basic object parsing

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 ()

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

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
+  , Twain.get matchWebfinger do
-    --   handleInbox details undefined
-
-    Twain.get matchWebfinger do
       handleWebfinger details
   ]
 
@@ -164,14 +165,15 @@ handleOutbox details items = do
 
 -- * Inbox
 
--- matchInbox :: UserDetails -> Twain.PathPattern
+matchInbox :: UserDetails -> Twain.PathPattern
--- matchInbox details =
+matchInbox details =
---   fromString ("/" <> details.username <> "/inbox")
+  fromString ("/" <> details.username <> "/inbox")
---
+
--- handleInbox :: UserDetails -> (Activity -> Twain.ResponderM b) -> Twain.ResponderM b
+handleInbox :: (AnyActivity -> Twain.ResponderM Twain.Response) -> Twain.ResponderM b
--- handleInbox _details _handle = do
+handleInbox handle = do
---   let response = undefined
+  activity <- Twain.fromBody
---   Twain.send $ jsonLD response
+  response <- handle activity
+  Twain.send response
 
 -- * Other stuff
 

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
+  | --  | ActivityLike Like
-  | ActivityAccept Accept
+    ActivityAccept Accept
   | ActivityReject Reject
   deriving (Show)
 
@@ -256,35 +357,62 @@ instance A.ToJSON AnyActivity where
     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 {..}

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