Following me should now work

app/DB.hs

@@ -27,9 +27,12 @@ data DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
   , insertNote :: NoteEntry -> IO (DB.Int64, Note)
-  , insertFollower ::
+  , -- | We use a callback so we can revert if the operation fails.
+    insertFollower ::
       forall a. Typeable a => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
-  , deleteFollower :: FollowerEntry -> IO (Maybe DB.Int64)
+  , -- | We use a callback so we can revert if the operation fails.
+    deleteFollower ::
+      forall a. Typeable a => FollowerEntry -> (Maybe DB.Int64 -> IO a) -> IO a
   , getFollowers :: IO [Follower]
   }
 
@@ -80,7 +83,9 @@ mkDB connstr details = do
             id' <- insertFollowerToDb follower
             liftIO $ handle id'
       , deleteFollower =
-          \follower -> DB.withPool pool (deleteFollowerFromDb follower)
+          \follower handle -> DB.withPool pool $ DB.transaction do
+            id' <- deleteFollowerFromDb follower
+            liftIO $ handle id'
       , getFollowers =
           DB.withPool pool (getFollowersFromDb $ actorUrl details)
       }

app/Routes.hs

@@ -12,6 +12,7 @@ import Web.Twain qualified as Twain
 import Data.Text qualified as T
 import Control.Concurrent.Async qualified as Async
 import Control.Logger.Simple qualified as Log
+import Routes.Inbox.Follow
 
 routes :: DB -> FilePath -> [Twain.Middleware]
 routes db detailsFile =
@@ -130,41 +131,10 @@ noteToCreate note = Fedi.makeCreateNote note
 handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response
 handleInbox db detailsFile activity = do
   details <- liftIO $ fetchUserDetails detailsFile
-  Log.logDebug (Fedi.pJson activity)
+  Log.logDebug $ "Inbox request: " <> Fedi.pJson activity
   case activity of
-    Fedi.ActivityFollow follow -> do
+    Fedi.ActivityFollow follow ->
-      let
+      handleInboxFollow details db activity follow
-        id' = follow.id
-        actor = follow.otype.actor
-        object = follow.otype.atype.object
-      case id' of
-        Just id'' -> do
-          if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
-            then do
-              let
-                followerEntry = ( FollowerEntry
-                    { actorId = fromString actor.unwrap
-                    , followId = fromString id''.unwrap
-                    }
-                  )
-                callback =
-                  ( \(insertId :: DB.Int64) -> do
-                    result <- Fedi.sendPost
-                      details
-                      (actor.unwrap <> "/inbox")
-                      ( Fedi.makeAccept
-                        follow
-                        (Fedi.actorUrl details <> "/accepts/follows/" <> show insertId)
-                      )
-                    Log.logDebug (Fedi.pShow result)
-                    pure $ Twain.text ""
-                  )
-              liftIO do
-                insertFollower db followerEntry callback
-                  <* Log.logInfo ("New follower: " <> Fedi.pShow followerEntry)
-            else Twain.next
-        Nothing ->
-          Twain.next
     Fedi.ActivityUndo
       ( Fedi.Object
         { otype = Fedi.TypeActivity
@@ -172,25 +142,8 @@ handleInbox db detailsFile activity = do
             { object = Fedi.ActivityFollow follow
             }
           }
-        }) -> do
+        }) ->
-      let
+      handleInboxUnfollow details db activity follow
-        id' = follow.id
-        actor = follow.otype.actor
-        object = follow.otype.atype.object
-      case id' of
-        Just id'' -> do
-          if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
-            then do
-              liftIO do
-                deletedId <- db.deleteFollower FollowerEntry
-                  { actorId = fromString actor.unwrap
-                  , followId = fromString id''.unwrap
-                  }
-                Log.logInfo ("deleted follower: " <> Fedi.pShow deletedId)
-                pure $ Twain.text ""
-            else Twain.next
-        Nothing ->
-          Twain.next
     _ -> do
       Log.logError $ "Unsupported activity: " <> Fedi.pShow activity
       Twain.next

app/Routes/Inbox/Accept.hs

@@ -0,0 +1,36 @@
+module Routes.Inbox.Accept where
+
+import DB
+import Fedi qualified as Fedi
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async qualified as Async
+import Control.Logger.Simple qualified as Log
+
+acceptRequest
+  :: Fedi.UserDetails
+   -> Fedi.Link
+   -> Fedi.AnyActivity
+   -> ((Int64 -> IO ()) -> IO a)
+   -> IO ()
+acceptRequest details actor activity operation = do
+  _ <- liftIO $ Async.async do
+    Log.logDebug "Waiting 10 seconds before accepting follow..."
+    threadDelay 10000000 -- 10 seconds
+    let
+      callback =
+        ( \(opid :: DB.Int64) -> do
+          result <- Fedi.sendPost
+            details
+            (actor.unwrap <> "/inbox")
+            ( Fedi.makeAccept Fedi.MkAccept
+              { Fedi.acceptId =
+                Fedi.actorUrl details <> "/accepts/requests/" <> show opid
+              , Fedi.acceptingActorUrl = Fedi.Link $ Fedi.actorUrl details
+              , Fedi.acceptedActivity = activity
+              }
+            )
+          Log.logDebug (Fedi.pShow result)
+        )
+    do
+      operation callback
+  pure ()

app/Routes/Inbox/Follow.hs

@@ -0,0 +1,79 @@
+module Routes.Inbox.Follow where
+
+import DB
+import Fedi qualified as Fedi
+import Web.Twain qualified as Twain
+import Control.Logger.Simple qualified as Log
+import Routes.Inbox.Accept
+
+handleInboxFollow
+  :: Fedi.UserDetails
+  -> DB
+  -> Fedi.AnyActivity
+  -> Fedi.Follow
+  -> Twain.ResponderM Twain.Response
+handleInboxFollow details db activity follow = do
+  let
+    id' = follow.id
+    actor = follow.otype.actor
+    object = follow.otype.atype.object
+  case id' of
+    Just id'' -> do
+      if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
+        then do
+          let
+            followerEntry =
+              ( FollowerEntry
+                { actorId = fromString actor.unwrap
+                , followId = fromString id''.unwrap
+                }
+              )
+            operation sendAccept = do
+              insertFollower db followerEntry sendAccept
+                <* Log.logInfo ("New follower: " <> Fedi.pShow followerEntry)
+
+          liftIO $ acceptRequest details actor activity operation
+
+          pure $ Twain.text ""
+
+        else Twain.next
+
+    Nothing ->
+      Twain.next
+
+handleInboxUnfollow
+  :: Fedi.UserDetails
+  -> DB
+  -> Fedi.AnyActivity
+  -> Fedi.Follow
+  -> Twain.ResponderM Twain.Response
+handleInboxUnfollow details db activity follow = do
+  let
+    id' = follow.id
+    actor = follow.otype.actor
+    object = follow.otype.atype.object
+  case id' of
+    Just id'' -> do
+      if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
+        then do
+          let
+            followerEntry =
+              ( FollowerEntry
+                { actorId = fromString actor.unwrap
+                , followId = fromString id''.unwrap
+                }
+              )
+            operation sendAccept = do
+              deleteFollower db followerEntry
+                (\deletedId' -> do
+                    let deletedId = Fedi.fromMaybe 0 deletedId'
+                    sendAccept deletedId
+                      <* Log.logInfo ("Deleted follower: " <> Fedi.pShow deletedId)
+                )
+
+          liftIO $ acceptRequest details actor activity operation
+
+          pure $ Twain.text ""
+        else Twain.next
+    Nothing ->
+      Twain.next

fedi.cabal

@@ -91,6 +91,8 @@ executable fedi
     Html
     Css
     Routes
+    Routes.Inbox.Follow
+    Routes.Inbox.Accept
   -- other-extensions:
   build-depends:
       aeson

src/Fedi/Requests.hs

@@ -21,13 +21,13 @@ sendPost
   -> IO ByteString
 sendPost details url payload = do
   uri <- URI.mkURI $ fromString url
-  Log.logDebug "To: " <> fromString url
+  Log.logDebug $ "Post To: " <> fromString url
-  Log.logDebug "Sending: " <> pJson payload
+  Log.logDebug $ "Post Sending: " <> pJson payload
 
   let encoded = BSL.toStrict $ A.encode payload
   httpSignature <- makeHttpSignature details uri encoded
-  Log.logDebug $ "http signature: " <> pShow httpSignature
+  Log.logDebug $ "Post http signature: " <> pShow httpSignature
-  Log.logDebug $ "http signature headers: " <> pShow (makeSigHeaders httpSignature)
+  Log.logDebug $ "Post http signature headers: " <> pShow (makeSigHeaders httpSignature)
   (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
   Req.runReq Req.defaultHttpConfig do
     response <-
@@ -43,7 +43,7 @@ sendPost details url payload = do
           Log.logDebug $ "Sending POST request: " <> pShow request
           pure request
         )
-    Log.logInfo $ "Response: " <> pShow response
+    Log.logInfo $ "Post Response: " <> pShow response
     pure $ Req.responseBody response
 
 makeHttpSignature :: UserDetails -> URI.URI -> ByteString -> IO HttpSignature
@@ -75,13 +75,13 @@ makeSigHeaders httpSignature =
   , ("Signature", toSignature httpSignature.signatureHeader)
   ]
 
-sendGet :: (A.FromJSON a) => String -> IO a
+sendGet :: (Show a, A.FromJSON a) => String -> IO a
 sendGet url = do
   uri <- URI.mkURI $ fromString url
   (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
 
   Req.runReq Req.defaultHttpConfig do
-    r <-
+    response <-
       Req.reqCb
         Req.GET
         url'
@@ -94,4 +94,5 @@ sendGet url = do
           Log.logDebug $ "Sending GET request: " <> pShow request
           pure request
         )
-    pure $ Req.responseBody r
+    Log.logInfo $ "Get Response: " <> pShow response
+    pure $ Req.responseBody response

src/Fedi/Types/Helpers.hs

@@ -152,15 +152,22 @@ emptyOrderedCollectionPage url =
           }
     }
 
-makeAccept :: Follow -> Url -> Accept
+data MkAccept
-makeAccept theirFollow myfollowId =
+  = MkAccept
+    { acceptId :: String
+    , acceptingActorUrl :: Link
+    , acceptedActivity :: AnyActivity
+    }
+
+makeAccept :: MkAccept -> Object (TypeActivity TypeAccept)
+makeAccept accept =
   emptyObject
-    { id = Just $ ObjectId myfollowId
+    { id = Just $ ObjectId accept.acceptId
     , otype =
         TypeActivity
-          { actor = theirFollow.otype.actor
+          { actor = accept.acceptingActorUrl
           , atype = TypeAccept
-            { object = ActivityFollow theirFollow
+            { object = accept.acceptedActivity
             }
           , target = Nothing
           , origin = Nothing