From 77361d72f358afb40baa5908459a2eacda38aacb Mon Sep 17 00:00:00 2001 From: me Date: Tue, 17 Dec 2024 10:46:59 +0200 Subject: [PATCH] basic object parsing --- app/DB.hs | 2 - app/Routes.hs | 15 ++- src/Fedi/Routes.hs | 28 +++--- src/Fedi/Types.hs | 209 ++++++++++++++++++++++++++++++++++++++-- src/Fedi/UserDetails.hs | 3 +- 5 files changed, 230 insertions(+), 27 deletions(-) diff --git a/app/DB.hs b/app/DB.hs index e65964d..c98bdd4 100644 --- a/app/DB.hs +++ b/app/DB.hs @@ -84,7 +84,6 @@ migrateUp = \case ) |] pure () - "follower" -> do [] <- DB.run @@ -95,7 +94,6 @@ migrateUp = \case ) |] pure () - name -> error $ "unexpected migration: " <> show name migrateDown :: (HasCallStack) => DB.MigrationName -> DB.SQLite () diff --git a/app/Routes.hs b/app/Routes.hs index 0f7215d..6084ab4 100644 --- a/app/Routes.hs +++ b/app/Routes.hs @@ -19,7 +19,6 @@ routes db detailsFile = Twain.send $ Twain.redirect302 $ fromString ("/" <> details.username) - , -- Match actor Twain.get (Fedi.matchUser $ unsafePerformIO $ fetchUserDetails detailsFile) do request <- Twain.request @@ -41,6 +40,20 @@ routes db detailsFile = details <- liftIO $ fetchUserDetails detailsFile notes <- map noteToCreate <$> liftIO db.getNotes + 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 handle + , -- Match Create object + Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do + details <- liftIO $ fetchUserDetails detailsFile + notes <- map noteToCreate <$> liftIO db.getNotes + Fedi.handleCreateNote details notes , -- Match Note object Twain.get (Fedi.matchNote $ unsafePerformIO $ fetchUserDetails detailsFile) do diff --git a/src/Fedi/Routes.hs b/src/Fedi/Routes.hs index e105b1d..8290807 100644 --- a/src/Fedi/Routes.hs +++ b/src/Fedi/Routes.hs @@ -14,7 +14,11 @@ import Web.Twain.Types qualified as Twain routes :: UserDetails -> [Twain.Middleware] routes details = - [ Twain.get (matchUser details) do + [ Twain.get "/" do + Twain.send $ + Twain.redirect302 $ + fromString ("/" <> details.username) + , Twain.get (matchUser details) do handleUser details , Twain.get (matchOutbox details) do handleOutbox details [] @@ -22,10 +26,7 @@ routes details = handleCreateNote details [] , Twain.get (matchNote details) do handleNote details [] - , -- , Twain.post (matchInbox details) do - -- handleInbox details undefined - - Twain.get matchWebfinger do + , Twain.get matchWebfinger do handleWebfinger details ] @@ -164,14 +165,15 @@ handleOutbox details items = do -- * Inbox --- matchInbox :: UserDetails -> Twain.PathPattern --- matchInbox details = --- fromString ("/" <> details.username <> "/inbox") --- --- handleInbox :: UserDetails -> (Activity -> Twain.ResponderM b) -> Twain.ResponderM b --- handleInbox _details _handle = do --- let response = undefined --- Twain.send $ jsonLD response +matchInbox :: UserDetails -> Twain.PathPattern +matchInbox details = + fromString ("/" <> details.username <> "/inbox") + +handleInbox :: (AnyActivity -> Twain.ResponderM Twain.Response) -> Twain.ResponderM b +handleInbox handle = do + activity <- Twain.fromBody + response <- handle activity + Twain.send response -- * Other stuff diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index 6c639f4..217bf01 100644 --- a/src/Fedi/Types.hs +++ b/src/Fedi/Types.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE RecordWildCards #-} + module Fedi.Types where +import Control.Monad (guard) import Data.Aeson qualified as A import Data.Aeson.Types qualified as A import Data.Text qualified as T import Fedi.UserDetails +import Prelude hiding (id, last) -- | An Object is what everything is here. -- @@ -69,6 +73,30 @@ instance (ToObject a) => ToObject (Object a) where ] ] +instance (A.FromJSON a) => A.FromJSON (Object a) where + parseJSON object = do + otype <- A.parseJSON object + flip (A.withObject "Object") object $ \v -> do + id <- v A..:? "id" + content <- v A..:? "content" + published <- v A..:? "published" + replies <- v A..:? "replies" + attachment <- v A..:? "attachment" + attributedTo <- v A..:? "attributedTo" + tag <- pure Nothing -- v A..:? "tag" + to <- v A..:? "to" + cc <- v A..:? "cc" + inReplyTo <- v A..:? "inReplyTo" + url <- v A..:? "url" + name <- v A..:? "name" + icon <- v A..:? "icon" + image <- v A..:? "image" + preview <- pure Nothing -- v A..:? "preview" + summary <- v A..:? "summary" + updated <- v A..:? "updated" + mediaType <- v A..:? "mediaType" + pure $ Object {..} + newtype ObjectId = ObjectId {unwrap :: String} deriving (Show, Eq, A.FromJSON, A.ToJSON) via String @@ -81,10 +109,16 @@ data LinkOrObject a | CCollection [LinkOrObject a] deriving (Show) +instance (A.FromJSON a) => A.FromJSON (LinkOrObject a) where + parseJSON = \case + A.String str -> pure $ LLink (Link $ T.unpack str) + A.Array objs -> CCollection <$> traverse A.parseJSON (toList objs) + value -> OObject <$> A.parseJSON value + getAttributedTo :: LinkOrObject a -> Link getAttributedTo = \case LLink link -> link - OObject obj -> Link (maybe (ObjectId "") id obj.id).unwrap + OObject obj -> Link (fromMaybe (ObjectId "") obj.id).unwrap CCollection list -> maybe (Link "") getAttributedTo (listToMaybe list) @@ -102,6 +136,10 @@ instance A.ToJSON AnyMedia where toJSON = \case ImageMedia obj -> A.toJSON obj +instance A.FromJSON AnyMedia where + parseJSON value = + ImageMedia <$> A.parseJSON value + type Image = Object TypeImage data TypeImage = TypeImage deriving (Show) @@ -110,6 +148,13 @@ instance ToObject TypeImage where toObject TypeImage = ["type" A..= ("Image" :: String)] +instance A.FromJSON TypeImage where + parseJSON = + A.withObject "TypeImage" \value -> do + (i :: String) <- value A..: "type" + guard (i == "Image") + pure TypeImage + data Name = StringName String | ObjectName (LinkOrObject Actor) @@ -120,6 +165,11 @@ instance A.ToJSON Name where StringName str -> A.toJSON str ObjectName loo -> A.toJSON loo +instance A.FromJSON Name where + parseJSON = \case + A.String str -> pure $ StringName (T.unpack str) + value -> ObjectName <$> A.parseJSON value + type Content = T.Text type MediaType = String @@ -144,6 +194,15 @@ instance ToObject TypeNote where , "sensitive" A..= note.sensitive ] +instance A.FromJSON TypeNote where + parseJSON = + A.withObject "TypeNote" \value -> do + likes <- value A..: "likes" + shares <- value A..: "shares" + replies <- value A..: "replies" + sensitive <- value A..: "sensitive" + pure TypeNote {..} + type Tag = Object TypeTag data TypeTag @@ -166,6 +225,13 @@ instance ToObject TypeShare where [ "type" A..= ("Share" :: String) ] +instance A.FromJSON TypeShare where + parseJSON = + A.withObject "TypeShare" \value -> do + typ :: String <- value A..: "type" + guard (typ == "Share") + pure TypeShare {..} + -- * Activities -- | An Activity is a superset of an Object with one of the following types, @@ -196,6 +262,15 @@ instance (ToObject t) => ToObject (TypeActivity t) where ] <> toObject activity.atype +instance (A.FromJSON a) => A.FromJSON (TypeActivity a) where + parseJSON object = do + atype <- A.parseJSON object + flip (A.withObject "TypeActivity") object \value -> do + actor <- value A..: "actor" + target <- value A..: "target" + origin <- value A..: "origin" + pure TypeActivity {..} + -- type Announce = Object (TypeActivity TypeAnnounce) -- data TypeAnnounce = TypeAnnounce deriving Show -- instance ToObject TypeAnnounce where @@ -217,17 +292,36 @@ instance ToObject TypeCreate where , "object" A..= create.object ] +instance A.FromJSON TypeCreate where + parseJSON = + A.withObject "TypeCreate" \value -> do + typ :: String <- value A..: "type" + guard (typ == "Create") + object <- value A..: "object" + pure TypeCreate {..} + type Follow = Object (TypeActivity TypeFollow) + data TypeFollow = TypeFollow { object :: Actor } - deriving Show + deriving (Show) + instance ToObject TypeFollow where toObject follow = [ "type" A..= ("Follow" :: String) , "object" A..= follow.object ] + +instance A.FromJSON TypeFollow where + parseJSON = + A.withObject "TypeFollow" \value -> do + typ :: String <- value A..: "type" + guard (typ == "Follow") + object <- value A..: "object" + pure TypeFollow {..} + -- type Like = Object (TypeActivity TypeLike) @@ -238,12 +332,19 @@ instance ToObject TypeLike where [ "type" A..= ("Like" :: String) ] +instance A.FromJSON TypeLike where + parseJSON = + A.withObject "TypeLike" \value -> do + typ :: String <- value A..: "type" + guard (typ == "Like") + pure TypeLike {..} + data AnyActivity = -- ActivityAnnounce Announce ActivityCreate Create | ActivityFollow Follow - -- | ActivityLike Like - | ActivityAccept Accept + | -- | ActivityLike Like + ActivityAccept Accept | ActivityReject Reject deriving (Show) @@ -252,39 +353,66 @@ instance A.ToJSON AnyActivity where -- ActivityAnnounce obj -> A.toJSON obj ActivityCreate obj -> A.toJSON obj ActivityFollow obj -> A.toJSON obj --- ActivityLike obj -> A.toJSON obj + -- ActivityLike obj -> A.toJSON obj ActivityAccept obj -> A.toJSON obj ActivityReject obj -> A.toJSON obj +instance A.FromJSON AnyActivity where + parseJSON value = + flip (A.withObject "AnyActivity") value \v -> do + typ :: String <- v A..: "type" + case typ of + "Create" -> ActivityCreate <$> A.parseJSON value + "Follow" -> ActivityFollow <$> A.parseJSON value + "Accept" -> ActivityAccept <$> A.parseJSON value + "Reject" -> ActivityReject <$> A.parseJSON value + _ -> fail ("Parsing '" <> typ <> "' not yet implemented.") + -- * Accept Reject Add Remove type Accept = Object (TypeActivity TypeAccept) + data TypeAccept = TypeAccept { object :: AnyActivity } - deriving Show + deriving (Show) + instance ToObject TypeAccept where toObject obj = [ "type" A..= ("Accept" :: String) , "object" A..= obj.object ] +instance A.FromJSON TypeAccept where + parseJSON = + A.withObject "TypeAccept" \value -> do + typ :: String <- value A..: "type" + guard (typ == "Accept") + object <- value A..: "object" + pure TypeAccept {..} + type Reject = Object (TypeActivity TypeReject) + data TypeReject = TypeReject { object :: AnyActivity } - deriving Show + deriving (Show) + instance ToObject TypeReject where toObject obj = [ "type" A..= ("Reject" :: String) , "object" A..= obj.object ] - - - +instance A.FromJSON TypeReject where + parseJSON = + A.withObject "TypeReject" \value -> do + typ :: String <- value A..: "type" + guard (typ == "Reject") + object <- value A..: "object" + pure TypeReject {..} -- * Actors @@ -292,6 +420,10 @@ instance ToObject TypeReject where -- data Actor = ActorPerson Person deriving (Show) +instance A.FromJSON Actor where + parseJSON = + fmap ActorPerson . A.parseJSON + instance A.ToJSON Actor where toJSON = \case ActorPerson obj -> A.toJSON obj @@ -303,6 +435,19 @@ instance ToObject Actor where -- | A Person is an object that has the type 'Person'. type Person = Object TypePerson +instance A.FromJSON TypePerson where + parseJSON = + A.withObject "Person" \value -> do + typ :: String <- value A..: "type" + guard (typ == "Person") + preferredUsername <- value A..: "preferredUsername" + publicKey <- value A..: "publicKey" + inbox <- value A..: "inbox" + outbox <- value A..: "outbox" + following <- value A..: "following" + followers <- value A..: "followers" + pure TypePerson {..} + data TypePerson = TypePerson { preferredUsername :: String @@ -341,6 +486,14 @@ instance A.ToJSON PublicKey where , "publicKeyPem" A..= pk.publicKeyPem ] +instance A.FromJSON PublicKey where + parseJSON = + A.withObject "PublicKey" \value -> do + pkid <- value A..: "id" + owner <- value A..: "owner" + publicKeyPem <- value A..: "publicKeyPem" + pure PublicKey {..} + -- * Collections type Collection e = Object (CollectionType (Unordered e)) @@ -373,6 +526,15 @@ instance (ToObject t) => ToObject (CollectionType t) where ] ] +instance (A.FromJSON t) => A.FromJSON (CollectionType t) where + parseJSON value = do + ctype <- A.parseJSON value + flip (A.withObject "CollectionType") value \v -> do + first <- v A..:? "first" + last <- v A..:? "last" + current <- v A..:? "current" + pure CollectionType {..} + data Unordered e = UnorderedCollectionType { items :: [e] @@ -386,6 +548,14 @@ instance (A.ToJSON e) => ToObject (Unordered e) where , "items" A..= collection.items ] +instance (A.FromJSON e) => A.FromJSON (Unordered e) where + parseJSON = do + A.withObject "Unordered" \v -> do + typ :: String <- v A..: "type" + guard (typ == "Collection") + items <- fromMaybe [] <$> v A..:? "items" + pure UnorderedCollectionType {..} + data Ordered e = OrderedCollectionType { orderedItems :: [e] @@ -399,6 +569,14 @@ instance (A.ToJSON e) => ToObject (Ordered e) where , "orderedItems" A..= collection.orderedItems ] +instance (A.FromJSON e) => A.FromJSON (Ordered e) where + parseJSON = do + A.withObject "Ordered" \v -> do + typ :: String <- v A..: "type" + guard (typ == "OrderedCollection") + orderedItems <- fromMaybe [] <$> v A..:? "orderedItems" + pure OrderedCollectionType {..} + data OrderedPage e = OrderedCollectionPageType { partOf :: Url @@ -417,3 +595,14 @@ instance (A.ToJSON e) => ToObject (OrderedPage e) where , "prev" A..= page.prev , "next" A..= page.next ] + +instance (A.FromJSON e) => A.FromJSON (OrderedPage e) where + parseJSON = do + A.withObject "OrderedPage" \v -> do + typ :: String <- v A..: "type" + guard (typ == "OrderedCollectionPage") + partOf <- v A..: "partOf" + prev <- v A..:? "prev" + next <- v A..:? "next" + porderedItems <- fromMaybe [] <$> v A..:? "orderedItems" + pure OrderedCollectionPageType {..} diff --git a/src/Fedi/UserDetails.hs b/src/Fedi/UserDetails.hs index 3e2c2f7..b62b7b4 100644 --- a/src/Fedi/UserDetails.hs +++ b/src/Fedi/UserDetails.hs @@ -4,12 +4,13 @@ module Fedi.UserDetails ( ) where import Data.Aeson qualified as A -import Data.List as Export (find) +import Data.Foldable as Export import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList) import Data.String as Export (fromString) import Data.Text as Export (Text) import Data.Text qualified as T import Data.Time as Export (UTCTime) +import Data.Traversable as Export import GHC.Generics as Export (Generic) type Url = String