basic object parsing

app/DB.hs

@@ -16,6 +16,7 @@ data DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
   , insertNote :: NoteEntry -> IO ObjectId
+  , insertFollower :: FollowerEntry -> IO DB.Int64
   }
 
 -- * Data types
@@ -28,6 +29,12 @@ data NoteEntry
   , url :: Maybe Url
   }
 
+data FollowerEntry
+  = FollowerEntry
+  { followId :: T.Text
+  , actorId :: T.Text
+  }
+
 -----------------------
 
 -- * Handler smart constructor
@@ -44,6 +51,8 @@ mkDB connstr details = do
           \noteid -> DB.withPool pool (getNoteFromDb noteid $ actorUrl details)
       , insertNote =
           \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
+      , insertFollower =
+          \follower -> DB.withPool pool (insertFollowerToDb follower)
       }
 
 -----------------------
@@ -56,6 +65,7 @@ runMigrations = DB.migrate migrations migrateUp migrateDown
 migrations :: [DB.MigrationName]
 migrations =
   [ "note"
+  , "follower"
   ]
 
 migrateUp :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
@@ -73,15 +83,27 @@ migrateUp = \case
           url text
         )
       |]
-
+    pure ()
+  "follower" -> do
+    [] <-
+      DB.run
+        [r| create table follower(
+          id integer primary key autoincrement,
+          follow_id text not null unique,
+          actor text not null unique
+        )
+      |]
     pure ()
   name -> error $ "unexpected migration: " <> show name
 
 migrateDown :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
 migrateDown = \case
-  "notes" -> do
+  "note" -> do
     [] <- DB.run "DROP TABLE note"
     pure ()
+  "follower" -> do
+    [] <- DB.run "DROP TABLE follower"
+    pure ()
   name -> error $ "unexpected migration: " <> show name
 
 -----------------------
@@ -102,6 +124,11 @@ insertNoteToDb actor note = do
   [n] <- map decodeNoteIdRow <$> uncurry DB.runWith (insertNoteSQL actor note)
   pure n
 
+insertFollowerToDb :: FollowerEntry -> DB.SQLite DB.Int64
+insertFollowerToDb follower = do
+  [n] <- map decodeIntRow <$> uncurry DB.runWith (insertFollowerSQL follower)
+  pure n
+
 -- ** SQL
 
 getNotesSQL :: Url -> (DB.SQL, [DB.SQLData])
@@ -156,6 +183,19 @@ insertNoteSQL actor note =
     ]
   )
 
+insertFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
+insertFollowerSQL follower =
+  ( [r|
+      INSERT INTO note(follow_id, actor)
+      VALUES (?, ?)
+      RETURNING id
+    |]
+  ,
+    [ DB.SQLText follower.followId
+    , DB.SQLText follower.actorId
+    ]
+  )
+
 -----------------------
 
 -- ** Decode row
@@ -200,6 +240,11 @@ decodeNoteIdRow = \case
   [DB.SQLText noteid] -> ObjectId $ T.unpack noteid
   row -> error $ "Couldn't decode row as NoteId: " <> show row
 
+decodeIntRow :: [DB.SQLData] -> DB.Int64
+decodeIntRow = \case
+  [DB.SQLInteger fid] -> fid
+  row -> error $ "Couldn't decode row as NoteId: " <> show row
+
 nullableString :: DB.SQLData -> Maybe (Maybe String)
 nullableString = \case
   DB.SQLText text -> Just (Just $ T.unpack text)

app/Routes.hs

@@ -14,7 +14,12 @@ import Web.Twain qualified as Twain
 
 routes :: DB -> FilePath -> [Twain.Middleware]
 routes db detailsFile =
-  [ -- Match actor
+  [ Twain.get "/" do
+      details <- liftIO $ fetchUserDetails detailsFile
+      Twain.send $
+        Twain.redirect302 $
+          fromString ("/" <> details.username)
+  , -- Match actor
     Twain.get (Fedi.matchUser $ unsafePerformIO $ fetchUserDetails detailsFile) do
       request <- Twain.request
       if Fedi.checkContentTypeAccept request
@@ -35,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
 
@@ -180,7 +182,7 @@ checkContentTypeAccept request =
   case lookup Twain.hAccept request.requestHeaders of
     Just bs ->
       ("application/activity+json" `BS.isInfixOf` bs)
-        || ( ("application/activity+json" `BS.isInfixOf` bs)
+        || ( ("application/ld+json" `BS.isInfixOf` bs)
               && ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs)
            )
     Nothing -> False

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,12 +292,36 @@ instance ToObject TypeCreate where
     , "object" A..= create.object
     ]
 
--- type Follow = Object (TypeActivity TypeFollow)
+instance A.FromJSON TypeCreate where
--- data TypeFollow = TypeFollow deriving Show
+  parseJSON =
--- instance ToObject TypeFollow where
+    A.withObject "TypeCreate" \value -> do
---   toObject TypeFollow =
+      typ :: String <- value A..: "type"
---     [ "type" A..= ("Follow" :: String)
+      guard (typ == "Create")
---     ]
+      object <- value A..: "object"
+      pure TypeCreate {..}
+
+type Follow = Object (TypeActivity TypeFollow)
+
+data TypeFollow
+  = TypeFollow
+  { object :: Actor
+  }
+  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)
 
@@ -233,20 +332,87 @@ 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
+  | ActivityFollow Follow
-  --  | ActivityLike Like
+  | --  | ActivityLike Like
+    ActivityAccept Accept
+  | ActivityReject Reject
   deriving (Show)
 
 instance A.ToJSON AnyActivity where
   toJSON = \case
     --    ActivityAnnounce obj -> A.toJSON obj
     ActivityCreate obj -> A.toJSON obj
-
+    ActivityFollow obj -> A.toJSON obj
---    ActivityFollow 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)
+
+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)
+
+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
 
@@ -254,6 +420,10 @@ instance A.ToJSON AnyActivity 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
@@ -265,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
@@ -303,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))
@@ -335,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]
@@ -348,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]
@@ -361,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
@@ -379,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