From de1d38504454ae836cd002789629dbce4094851a Mon Sep 17 00:00:00 2001 From: me Date: Tue, 17 Dec 2024 10:46:59 +0200 Subject: [PATCH] follows and inbox --- app/Routes.hs | 71 ++++++++++++++++++++++++++++++++++++++--- fedi.cabal | 1 + src/Fedi/Helpers.hs | 15 +++++++++ src/Fedi/Routes.hs | 34 ++++++++++++++++++++ src/Fedi/Types.hs | 56 ++++++++++++++++---------------- src/Fedi/UserDetails.hs | 4 +-- 6 files changed, 147 insertions(+), 34 deletions(-) diff --git a/app/Routes.hs b/app/Routes.hs index 6084ab4..9b43bda 100644 --- a/app/Routes.hs +++ b/app/Routes.hs @@ -11,6 +11,16 @@ import Html import Lucid qualified as H import System.IO.Unsafe (unsafePerformIO) import Web.Twain qualified as Twain +import Network.HTTP.Req + ( runReq + , defaultHttpConfig + , req + , POST(POST) + , ReqBodyJson(ReqBodyJson) + , jsonResponse + , responseBody + , https + ) routes :: DB -> FilePath -> [Twain.Middleware] routes db detailsFile = @@ -43,12 +53,8 @@ routes db detailsFile = Fedi.handleCreateNote details notes , -- Match inbox Twain.get (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do - let - handle activity = do - liftIO (print activity) - pure $ Fedi.jsonLD $ A.encode activity + Fedi.handleInbox (handleInbox db detailsFile) - Fedi.handleInbox handle , -- Match Create object Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do details <- liftIO $ fetchUserDetails detailsFile @@ -70,10 +76,20 @@ routes db detailsFile = Nothing -> Twain.next Just thenote -> Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote] + + , -- Followers + Twain.get (Fedi.matchFollowers $ unsafePerformIO $ fetchUserDetails detailsFile) do + details <- liftIO $ fetchUserDetails detailsFile + Fedi.handleFollowers details + , -- Following + Twain.get (Fedi.matchFollowing $ unsafePerformIO $ fetchUserDetails detailsFile) do + details <- liftIO $ fetchUserDetails detailsFile + Fedi.handleFollowing details , -- Match webfinger Twain.get Fedi.matchWebfinger do details <- liftIO $ fetchUserDetails detailsFile Fedi.handleWebfinger details + -------------------------------------------------------------------------------------------- , -- Admin page Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do details <- liftIO $ fetchUserDetails detailsFile @@ -109,3 +125,48 @@ fetchUserDetails detailsFile = noteToCreate :: Fedi.Note -> Fedi.Create noteToCreate note = Fedi.makeCreateNote note + +handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response +handleInbox db detailsFile activity = do + details <- liftIO $ fetchUserDetails detailsFile + 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 + liftIO do + insertId <- db.insertFollower FollowerEntry + { actorId = fromString actor.unwrap + , followId = fromString id''.unwrap + } + (result :: A.Value) <- sendRequest + (id''.unwrap <> "/inbox") + ( Fedi.makeAccept + follow + (Fedi.actorUrl details <> "/accepts/follows/" <> show insertId) + ) + print result + pure $ Fedi.jsonLD "{}" + else Twain.next + Nothing -> + Twain.next + _ -> do + liftIO (print activity) + Twain.next + +sendRequest :: (A.ToJSON input, A.FromJSON output) => Fedi.Url -> input -> IO output +sendRequest url payload = do + runReq defaultHttpConfig do + r <- + req + POST + (https $ fromString url) + (ReqBodyJson payload) + jsonResponse + mempty + pure $ responseBody r diff --git a/fedi.cabal b/fedi.cabal index 9798bbd..96b7b47 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -77,6 +77,7 @@ executable fedi , raw-strings-qq , securemem , lucid2 + , req hs-source-dirs: app default-language: GHC2021 diff --git a/src/Fedi/Helpers.hs b/src/Fedi/Helpers.hs index 7c3fd66..643a7fe 100644 --- a/src/Fedi/Helpers.hs +++ b/src/Fedi/Helpers.hs @@ -151,3 +151,18 @@ emptyOrderedCollectionPage url = , current = Nothing } } + +makeAccept :: Follow -> Url -> Accept +makeAccept theirFollow myfollowId = + emptyObject + { id = Just $ ObjectId myfollowId + , otype = + TypeActivity + { actor = theirFollow.otype.actor + , atype = TypeAccept + { object = ActivityFollow theirFollow + } + , target = Nothing + , origin = Nothing + } + } diff --git a/src/Fedi/Routes.hs b/src/Fedi/Routes.hs index 8290807..caa315e 100644 --- a/src/Fedi/Routes.hs +++ b/src/Fedi/Routes.hs @@ -175,6 +175,40 @@ handleInbox handle = do response <- handle activity Twain.send response +-- * Followers + +matchFollowers :: UserDetails -> Twain.PathPattern +matchFollowers details = + fromString ("/" <> details.username <> "/followers") + +handleFollowers :: UserDetails -> Twain.ResponderM b +handleFollowers details = do + let + collection :: Collection () + collection = + emptyUnorderedCollection + { id = Just $ ObjectId $ actorUrl details <> "/followers" + , summary = Just $ fromString $ details.username <> "'s followers" + } + Twain.send $ jsonLD (A.encode collection) + +-- * Following + +matchFollowing :: UserDetails -> Twain.PathPattern +matchFollowing details = + fromString ("/" <> details.username <> "/following") + +handleFollowing :: UserDetails -> Twain.ResponderM b +handleFollowing details = do + let + collection :: Collection () + collection = + emptyUnorderedCollection + { id = Just $ ObjectId $ actorUrl details <> "/following" + , summary = Just $ fromString $ details.username <> " is following" + } + Twain.send $ jsonLD (A.encode collection) + -- * Other stuff checkContentTypeAccept :: Twain.Request -> Bool diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index 217bf01..f65ed18 100644 --- a/src/Fedi/Types.hs +++ b/src/Fedi/Types.hs @@ -37,7 +37,7 @@ data Object typ mediaType :: Maybe MediaType -- , duration :: Maybe String } - deriving (Show) + deriving (Show, Eq) class ToObject a where toObject :: a -> [A.Pair] @@ -101,13 +101,13 @@ newtype ObjectId = ObjectId {unwrap :: String} deriving (Show, Eq, A.FromJSON, A.ToJSON) via String newtype Link = Link {unwrap :: Url} - deriving (Show, A.FromJSON, A.ToJSON) via Url + deriving (Show, Eq, A.FromJSON, A.ToJSON) via Url data LinkOrObject a = LLink Link | OObject (Object a) | CCollection [LinkOrObject a] - deriving (Show) + deriving (Show, Eq) instance (A.FromJSON a) => A.FromJSON (LinkOrObject a) where parseJSON = \case @@ -130,7 +130,7 @@ instance (ToObject o) => A.ToJSON (LinkOrObject o) where data AnyMedia = ImageMedia Image - deriving (Show) + deriving (Show, Eq) instance A.ToJSON AnyMedia where toJSON = \case @@ -142,7 +142,7 @@ instance A.FromJSON AnyMedia where type Image = Object TypeImage -data TypeImage = TypeImage deriving (Show) +data TypeImage = TypeImage deriving (Show, Eq) instance ToObject TypeImage where toObject TypeImage = @@ -158,7 +158,7 @@ instance A.FromJSON TypeImage where data Name = StringName String | ObjectName (LinkOrObject Actor) - deriving (Show) + deriving (Show, Eq) instance A.ToJSON Name where toJSON = \case @@ -184,7 +184,7 @@ data TypeNote , replies :: Collection Note , sensitive :: Bool } - deriving (Show) + deriving (Show, Eq) instance ToObject TypeNote where toObject note = @@ -209,16 +209,16 @@ data TypeTag = TypeTag { href :: Url } - deriving (Show) + deriving (Show, Eq) type Preview = Object TypePreview data TypePreview = TypePreview - deriving (Show) + deriving (Show, Eq) type Share = Object TypeShare -data TypeShare = TypeShare deriving (Show) +data TypeShare = TypeShare deriving (Show, Eq) instance ToObject TypeShare where toObject TypeShare = @@ -230,7 +230,7 @@ instance A.FromJSON TypeShare where A.withObject "TypeShare" \value -> do typ :: String <- value A..: "type" guard (typ == "Share") - pure TypeShare {..} + pure TypeShare -- * Activities @@ -248,7 +248,7 @@ data TypeActivity t -- , result :: Maybe String -- , instrument :: Maybe String } - deriving (Show) + deriving (Show, Eq) instance (ToObject t) => ToObject (TypeActivity t) where toObject activity = @@ -284,7 +284,7 @@ data TypeCreate = TypeCreate { object :: Note } - deriving (Show) + deriving (Show, Eq) instance ToObject TypeCreate where toObject create = @@ -304,9 +304,9 @@ type Follow = Object (TypeActivity TypeFollow) data TypeFollow = TypeFollow - { object :: Actor + { object :: LinkOrObject Actor } - deriving (Show) + deriving (Show, Eq) instance ToObject TypeFollow where toObject follow = @@ -325,7 +325,7 @@ instance A.FromJSON TypeFollow where -- type Like = Object (TypeActivity TypeLike) -data TypeLike = TypeLike deriving (Show) +data TypeLike = TypeLike deriving (Show, Eq) instance ToObject TypeLike where toObject TypeLike = @@ -337,7 +337,7 @@ instance A.FromJSON TypeLike where A.withObject "TypeLike" \value -> do typ :: String <- value A..: "type" guard (typ == "Like") - pure TypeLike {..} + pure TypeLike data AnyActivity = -- ActivityAnnounce Announce @@ -346,7 +346,7 @@ data AnyActivity | -- | ActivityLike Like ActivityAccept Accept | ActivityReject Reject - deriving (Show) + deriving (Show, Eq) instance A.ToJSON AnyActivity where toJSON = \case @@ -376,7 +376,7 @@ data TypeAccept = TypeAccept { object :: AnyActivity } - deriving (Show) + deriving (Show, Eq) instance ToObject TypeAccept where toObject obj = @@ -398,7 +398,7 @@ data TypeReject = TypeReject { object :: AnyActivity } - deriving (Show) + deriving (Show, Eq) instance ToObject TypeReject where toObject obj = @@ -418,7 +418,9 @@ instance A.FromJSON TypeReject where -- | An Actor is an object that has one of the following types. -- -data Actor = ActorPerson Person deriving (Show) +data Actor + = ActorPerson Person + deriving (Show, Eq) instance A.FromJSON Actor where parseJSON = @@ -457,7 +459,7 @@ data TypePerson , following :: Link , followers :: Link } - deriving (Show) + deriving (Show, Eq) instance ToObject TypePerson where toObject person = @@ -476,7 +478,7 @@ data PublicKey , owner :: Url , publicKeyPem :: Pem } - deriving (Show) + deriving (Show, Eq) instance A.ToJSON PublicKey where toJSON pk = @@ -513,7 +515,7 @@ data CollectionType t , last :: Maybe Url , current :: Maybe Url } - deriving (Show) + deriving (Show, Eq) instance (ToObject t) => ToObject (CollectionType t) where toObject collection = @@ -539,7 +541,7 @@ data Unordered e = UnorderedCollectionType { items :: [e] } - deriving (Show) + deriving (Show, Eq) instance (A.ToJSON e) => ToObject (Unordered e) where toObject collection = @@ -560,7 +562,7 @@ data Ordered e = OrderedCollectionType { orderedItems :: [e] } - deriving (Show) + deriving (Show, Eq) instance (A.ToJSON e) => ToObject (Ordered e) where toObject collection = @@ -584,7 +586,7 @@ data OrderedPage e , next :: Maybe Url , porderedItems :: [e] } - deriving (Show) + deriving (Show, Eq) instance (A.ToJSON e) => ToObject (OrderedPage e) where toObject page = diff --git a/src/Fedi/UserDetails.hs b/src/Fedi/UserDetails.hs index b62b7b4..9c74808 100644 --- a/src/Fedi/UserDetails.hs +++ b/src/Fedi/UserDetails.hs @@ -20,7 +20,7 @@ type Domain = String type Username = String newtype Pem = Pem T.Text - deriving (Show) + deriving (Show, Eq) deriving (A.FromJSON) via T.Text instance A.ToJSON Pem where @@ -37,7 +37,7 @@ data UserDetails , publicPem :: Pem , privatePem :: FilePath } - deriving (Show, Generic, A.FromJSON) + deriving (Show, Eq, Generic, A.FromJSON) actorUrl :: UserDetails -> Url actorUrl details =