From 7aee94928ea155be4798f1bade9e88d736c5de27 Mon Sep 17 00:00:00 2001 From: me Date: Fri, 8 Nov 2024 00:20:29 +0200 Subject: [PATCH] Following me should now work --- app/DB.hs | 11 ++++-- app/Routes.hs | 59 +++------------------------- app/Routes/Inbox/Accept.hs | 36 +++++++++++++++++ app/Routes/Inbox/Follow.hs | 79 ++++++++++++++++++++++++++++++++++++++ fedi.cabal | 2 + src/Fedi/Requests.hs | 17 ++++---- src/Fedi/Types/Helpers.hs | 17 +++++--- 7 files changed, 152 insertions(+), 69 deletions(-) create mode 100644 app/Routes/Inbox/Accept.hs create mode 100644 app/Routes/Inbox/Follow.hs diff --git a/app/DB.hs b/app/DB.hs index 49e58cd..9c72b7c 100644 --- a/app/DB.hs +++ b/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) } diff --git a/app/Routes.hs b/app/Routes.hs index 82a2b0a..c165cdb 100644 --- a/app/Routes.hs +++ b/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 - 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 - } - ) - 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.ActivityFollow follow -> + handleInboxFollow details db activity follow Fedi.ActivityUndo ( Fedi.Object { otype = Fedi.TypeActivity @@ -172,25 +142,8 @@ handleInbox db detailsFile activity = do { object = Fedi.ActivityFollow 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 - 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 + }) -> + handleInboxUnfollow details db activity follow _ -> do Log.logError $ "Unsupported activity: " <> Fedi.pShow activity Twain.next diff --git a/app/Routes/Inbox/Accept.hs b/app/Routes/Inbox/Accept.hs new file mode 100644 index 0000000..22e5e10 --- /dev/null +++ b/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 () diff --git a/app/Routes/Inbox/Follow.hs b/app/Routes/Inbox/Follow.hs new file mode 100644 index 0000000..e42438c --- /dev/null +++ b/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 diff --git a/fedi.cabal b/fedi.cabal index 3921133..8f6cd78 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -91,6 +91,8 @@ executable fedi Html Css Routes + Routes.Inbox.Follow + Routes.Inbox.Accept -- other-extensions: build-depends: aeson diff --git a/src/Fedi/Requests.hs b/src/Fedi/Requests.hs index 372a4b4..02b9f7e 100644 --- a/src/Fedi/Requests.hs +++ b/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 "Sending: " <> pJson payload + Log.logDebug $ "Post To: " <> fromString url + 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 $ "http signature headers: " <> pShow (makeSigHeaders httpSignature) + Log.logDebug $ "Post http signature: " <> pShow 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 diff --git a/src/Fedi/Types/Helpers.hs b/src/Fedi/Types/Helpers.hs index e75dda6..3427224 100644 --- a/src/Fedi/Types/Helpers.hs +++ b/src/Fedi/Types/Helpers.hs @@ -152,15 +152,22 @@ emptyOrderedCollectionPage url = } } -makeAccept :: Follow -> Url -> Accept -makeAccept theirFollow myfollowId = +data MkAccept + = 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