basic object parsing

2024-11-01 20:14:18 +02:00 · 2024-11-01 20:14:18 +02:00 · 9b3da936cf
commit 9b3da936cf
parent 5cd85715f1
5 changed files with 230 additions and 27 deletions
--- 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 ()
--- 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
--- 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

--- 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.
 -- <https://www.w3.org/TR/activitystreams-vocabulary/#object-types>
@ -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
 -- <https://www.w3.org/TR/activitystreams-vocabulary/#actor-types>
 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 {..}
--- 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