try delete follower too

app/DB.hs

@@ -15,8 +15,10 @@ data DB
   = DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
-  , insertNote :: NoteEntry -> IO ObjectId
+  , insertNote :: NoteEntry -> IO (DB.Int64, Note)
   , insertFollower :: FollowerEntry -> IO DB.Int64
+  , deleteFollower :: FollowerEntry -> IO DB.Int64
+  , getFollowers :: IO [Follower]
   }
 
 -- * Data types
@@ -35,6 +37,13 @@ data FollowerEntry
   , actorId :: T.Text
   }
 
+data Follower
+  = Follower
+  { myid :: T.Text
+  , followId :: T.Text
+  , actorId :: T.Text
+  }
+
 -----------------------
 
 -- * Handler smart constructor
@@ -46,13 +55,17 @@ mkDB connstr details = do
   pure
     DB
       { getNotes =
-          DB.withPool pool (getNotesFromDb $ actorUrl details)
+          DB.withPool pool getNotesFromDb
       , getNote =
-          \noteid -> DB.withPool pool (getNoteFromDb noteid $ actorUrl details)
+          \noteid -> DB.withPool pool (getNoteFromDb noteid)
       , insertNote =
           \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
       , insertFollower =
           \follower -> DB.withPool pool (insertFollowerToDb follower)
+      , deleteFollower =
+          \follower -> DB.withPool pool (deleteFollowerFromDb follower)
+      , getFollowers =
+          DB.withPool pool (getFollowersFromDb $ actorUrl details)
       }
 
 -----------------------
@@ -110,18 +123,18 @@ migrateDown = \case
 
 -- * Database actions
 
-getNotesFromDb :: Url -> DB.SQLite [Note]
-getNotesFromDb url =
-  map decodeNoteRow <$> uncurry DB.runWith (getNotesSQL url)
+getNotesFromDb :: DB.SQLite [Note]
+getNotesFromDb =
+  map (snd . decodeNoteRow) <$> uncurry DB.runWith getNotesSQL
 
-getNoteFromDb :: DB.Int64 -> Url -> DB.SQLite (Maybe Note)
-getNoteFromDb noteid url = do
-  n <- map decodeNoteRow <$> uncurry DB.runWith (getNoteSQL noteid url)
+getNoteFromDb :: DB.Int64 -> DB.SQLite (Maybe Note)
+getNoteFromDb noteid = do
+  n <- map (snd . decodeNoteRow) <$> uncurry DB.runWith (getNoteSQL noteid)
   pure (listToMaybe n)
 
-insertNoteToDb :: Url -> NoteEntry -> DB.SQLite ObjectId
+insertNoteToDb :: Url -> NoteEntry -> DB.SQLite (DB.Int64, Note)
 insertNoteToDb actor note = do
-  [n] <- map decodeNoteIdRow <$> uncurry DB.runWith (insertNoteSQL actor note)
+  [n] <- map decodeNoteRow <$> uncurry DB.runWith (insertNoteSQL actor note)
   pure n
 
 insertFollowerToDb :: FollowerEntry -> DB.SQLite DB.Int64
@@ -129,13 +142,23 @@ insertFollowerToDb follower = do
   [n] <- map decodeIntRow <$> uncurry DB.runWith (insertFollowerSQL follower)
   pure n
 
+deleteFollowerFromDb :: FollowerEntry -> DB.SQLite DB.Int64
+deleteFollowerFromDb follower = do
+  [n] <- map decodeIntRow <$> uncurry DB.runWith (deleteFollowerSQL follower)
+  pure n
+
+getFollowersFromDb :: Url -> DB.SQLite [Follower]
+getFollowersFromDb url =
+  map decodeFollowerRow <$> uncurry DB.runWith (getFollowersSQL url)
+
 -- ** SQL
 
-getNotesSQL :: Url -> (DB.SQL, [DB.SQLData])
-getNotesSQL url =
+getNotesSQL :: (DB.SQL, [DB.SQLData])
+getNotesSQL =
   ( [r|
       SELECT
-        ? || '/notes/' || id,
+        id,
+        actor || '/notes/' || id,
         published,
         actor,
         content,
@@ -146,14 +169,15 @@ getNotesSQL url =
       WHERE inReplyTo IS NULL
       ORDER BY published DESC
     |]
-  , [DB.SQLText $ T.pack url]
+  , []
   )
 
-getNoteSQL :: DB.Int64 -> Url -> (DB.SQL, [DB.SQLData])
-getNoteSQL noteid url =
+getNoteSQL :: DB.Int64 -> (DB.SQL, [DB.SQLData])
+getNoteSQL noteid =
   ( [r|
       SELECT
-        ? || '/notes/' || id,
+        id as nid,
+        actor || '/notes/' || id,
         published,
         actor,
         content,
@@ -164,7 +188,7 @@ getNoteSQL noteid url =
       WHERE note.id = ?
       ORDER BY published DESC
     |]
-  , [DB.SQLText $ T.pack url, DB.SQLInteger noteid]
+  , [DB.SQLInteger noteid]
   )
 
 insertNoteSQL :: Url -> NoteEntry -> (DB.SQL, [DB.SQLData])
@@ -172,7 +196,16 @@ insertNoteSQL actor note =
   ( [r|
       INSERT INTO note(actor, inReplyTo, content, name, url)
       VALUES (?, ?, ?, ?, ?)
-      RETURNING cast(id as text)
+      RETURNING
+        id as nid,
+        actor || '/notes/' || id,
+        published,
+        actor,
+        content,
+        name,
+        inReplyTo,
+        url
+
     |]
   ,
     [ DB.SQLText (T.pack actor)
@@ -186,7 +219,7 @@ insertNoteSQL actor note =
 insertFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
 insertFollowerSQL follower =
   ( [r|
-      INSERT INTO note(follow_id, actor)
+      INSERT INTO follower(follow_id, actor)
       VALUES (?, ?)
       RETURNING id
     |]
@@ -196,13 +229,38 @@ insertFollowerSQL follower =
     ]
   )
 
+deleteFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
+deleteFollowerSQL follower =
+  ( [r|
+      DELETE FROM follower
+      WHERE followId = ? AND actor = ?
+      RETURNING followId
+    |]
+  ,
+    [ DB.SQLText follower.followId
+    , DB.SQLText follower.actorId
+    ]
+  )
+
+getFollowersSQL :: Url -> (DB.SQL, [DB.SQLData])
+getFollowersSQL url =
+  ( [r|
+      SELECT
+        ? || '/followers/' || id,
+        follow_id,
+        actor
+      FROM follower
+    |]
+  , [DB.SQLText $ T.pack url]
+  )
 -----------------------
 
 -- ** Decode row
 
-decodeNoteRow :: [DB.SQLData] -> Note
+decodeNoteRow :: [DB.SQLData] -> (DB.Int64, Note)
 decodeNoteRow = \case
-  [ DB.SQLText noteid
+  [ DB.SQLInteger noteid
+    , DB.SQLText noteidurl
     , DB.SQLText published
     , DB.SQLText actor
     , DB.SQLText content
@@ -212,9 +270,9 @@ decodeNoteRow = \case
     ] ->
       let
         emptyNote = emptyUserNote $ T.unpack actor
-      in
+      in (noteid,
         emptyNote
-          { id = Just $ ObjectId $ T.unpack noteid
+          { id = Just $ ObjectId $ T.unpack noteidurl
           , published = Just $ read (T.unpack published)
           , attributedTo = Just $ LLink $ Link $ T.unpack actor
           , inReplyTo = LLink . Link <$> inReplyTo
@@ -225,26 +283,34 @@ decodeNoteRow = \case
               emptyNote.otype
                 { likes =
                     emptyNote.otype.likes
-                      { id = Just $ ObjectId $ T.unpack noteid <> "/likes"
+                      { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
                       }
                 , shares =
                     emptyNote.otype.shares
-                      { id = Just $ ObjectId $ T.unpack noteid <> "/shares"
+                      { id = Just $ ObjectId $ T.unpack noteidurl <> "/shares"
                       }
                 }
-          }
+          })
   row -> error $ "Couldn't decode row as Note: " <> show row
 
-decodeNoteIdRow :: [DB.SQLData] -> ObjectId
-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
 
+decodeFollowerRow :: [DB.SQLData] -> Follower
+decodeFollowerRow = \case
+  [ DB.SQLText myid
+    , DB.SQLText follower_id
+    , DB.SQLText actor
+    ] ->
+    Follower
+      { myid = myid
+      , followId = follower_id
+      , actorId = actor
+      }
+  row -> error $ "Couldn't decode row as Follower: " <> show row
+
 nullableString :: DB.SQLData -> Maybe (Maybe String)
 nullableString = \case
   DB.SQLText text -> Just (Just $ T.unpack text)

app/Main.hs

@@ -12,6 +12,7 @@ import Database.Sqlite.Easy qualified as Sqlite
 import Network.Wai.Handler.Warp (Port, run)
 import Network.Wai.Middleware.HttpAuth (basicAuth)
 import Network.Wai.Middleware.RequestLogger qualified as Logger
+import Network.Wai.Middleware.RequestSizeLimit qualified as Limit
 import Network.Wai.Middleware.Routed qualified as Wai
 import Routes
 import System.Environment (getArgs, lookupEnv)
@@ -113,7 +114,11 @@ runServer port authMiddleware app = do
       , "(ctrl-c to quit)"
       ]
   auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware
-  run port (Logger.logStdoutDev $ auth app)
+  run port $
+    ( Logger.logStdoutDev
+    . Limit.requestSizeLimitMiddleware Limit.defaultRequestSizeLimitSettings
+    . auth
+    ) app
 
 matchAdmin :: [T.Text] -> Bool
 matchAdmin = any (== "admin")

app/Routes.hs

@@ -11,16 +11,8 @@ 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
-  )
+import Data.Text qualified as T
+import Control.Concurrent.Async qualified as Async
 
 routes :: DB -> FilePath -> [Twain.Middleware]
 routes db detailsFile =
@@ -102,7 +94,7 @@ routes db detailsFile =
       url <- Twain.param "url"
       details <- liftIO $ fetchUserDetails detailsFile
 
-      noteid <-
+      (noteid, note) <-
         liftIO $
           db.insertNote
             NoteEntry
@@ -112,7 +104,9 @@ routes db detailsFile =
               , url = if trim url == "" then Nothing else Just url
               }
 
-      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> noteid.unwrap))
+      liftIO $ sendFollowers details db (Fedi.ActivityCreate $ noteToCreate note)
+
+      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> show noteid))
   ]
 
 trim :: String -> String
@@ -144,7 +138,8 @@ handleInbox db detailsFile activity = do
                   { actorId = fromString actor.unwrap
                   , followId = fromString id''.unwrap
                   }
-                (result :: A.Value) <- sendRequest
+                (result :: A.Value) <- Fedi.sendPost
+                  details
                   (id''.unwrap <> "/inbox")
                   ( Fedi.makeAccept
                     follow
@@ -155,18 +150,40 @@ handleInbox db detailsFile activity = do
             else Twain.next
         Nothing ->
           Twain.next
+    Fedi.ActivityUndo
+      ( Fedi.Object
+        { otype = Fedi.TypeActivity
+          { atype = Fedi.TypeUndo
+            { object = 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
+                deletedId <- db.deleteFollower FollowerEntry
+                  { actorId = fromString actor.unwrap
+                  , followId = fromString id''.unwrap
+                  }
+                print ("deleted follower: " <> show deletedId)
+                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
+sendFollowers :: Fedi.UserDetails -> DB -> Fedi.AnyActivity -> IO ()
+sendFollowers details db message = do
+  followers <- db.getFollowers
+  Fedi.for_ followers \follower -> do
+    Async.async $ do
+      result <- Fedi.sendPost @A.Value details (T.unpack follower.actorId <> "/inbox") message
+      print (follower.actorId, A.encode result)

cabal.project

@@ -1 +1,3 @@
 packages: *.cabal
+
+constraints: cryptostore +use_crypton

fedi.cabal

@@ -17,10 +17,13 @@ library
   import: warnings
   exposed-modules:
     Fedi
+    Fedi.Requests
     Fedi.Helpers
     Fedi.Types
+    Fedi.Types.Helpers
     Fedi.UserDetails
     Fedi.Webfinger
+    Fedi.Crypto
 
     Fedi.Routes
     Fedi.Routes.Helpers
@@ -46,6 +49,13 @@ library
     , twain
     , mime-types
     , time
+    , wai
+    , exceptions
+    , req
+    , base64
+    , crypton
+    , crypton-x509
+    , cryptostore
 
   hs-source-dirs: src
   default-language: GHC2021
@@ -84,7 +94,6 @@ executable fedi
     , raw-strings-qq
     , securemem
     , lucid2
-    , req
 
   hs-source-dirs: app
   default-language: GHC2021

src/Fedi.hs

@@ -1,7 +1,10 @@
 module Fedi (module Export) where
 
+import Fedi.Crypto as Export
 import Fedi.Helpers as Export
 import Fedi.Routes as Export
 import Fedi.Types as Export
+import Fedi.Types.Helpers as Export
 import Fedi.UserDetails as Export
 import Fedi.Webfinger as Export
+import Fedi.Requests as Export

src/Fedi/Crypto.hs

@@ -0,0 +1,75 @@
+{-# language RecordWildCards #-}
+
+module Fedi.Crypto where
+
+import Crypto.Hash qualified as Crypto
+import Crypto.PubKey.RSA.PSS qualified as Crypto
+import Crypto.Store.X509 qualified as Crypto
+import Crypto.Store.PKCS8 qualified as Crypto
+import Data.X509 qualified as Crypto
+import Fedi.Helpers
+import Fedi.UserDetails
+import Data.ByteString.Base64 qualified as Base64
+import Data.Base64.Types qualified as Base64
+
+verifyPub :: ByteString -> ByteString -> ByteString -> Bool
+verifyPub pubkeypem sig message =
+  let
+    pubkey = case Crypto.readPubKeyFileFromMemory pubkeypem of
+      [Crypto.PubKeyRSA pubkey'] -> pubkey'
+      _ -> error "failed to read pubkey pem"
+  in
+    Crypto.verify (Crypto.defaultPSSParams Crypto.SHA256) pubkey message sig
+
+verifyDigest :: ByteString -> ByteString -> ByteString -> Bool
+verifyDigest pubkeypem sig digest' =
+  let
+    pubkey = case Crypto.readPubKeyFileFromMemory pubkeypem of
+      [Crypto.PubKeyRSA pubkey'] -> pubkey'
+      _ -> error "failed to read pubkey pem"
+    digest = Crypto.hash digest'
+  in
+    Crypto.verifyDigest (Crypto.defaultPSSParams Crypto.SHA256) pubkey digest sig
+
+sign :: UserDetails -> ByteString -> IO Signed
+sign details message = do
+  -- get private key
+  privkeypem <- Crypto.readKeyFile details.privatePem
+  let
+    privateKey = case privkeypem of
+      [Crypto.Unprotected (Crypto.PrivKeyRSA privkey)] -> privkey
+      _ -> error $ "error reading local private key from '" <> details.privatePem <> "'."
+
+  -- sign message
+  signedMessage <- either (error . show) id <$>
+    Crypto.sign Nothing (Crypto.defaultPSSParams Crypto.SHA256) privateKey message
+
+  -- sign digest
+  let
+    digest :: Crypto.Digest Crypto.SHA256
+    digest = Crypto.hash message
+
+  signedDigest <- either (error . show) id <$>
+    Crypto.signDigest Nothing (Crypto.defaultPSSParams Crypto.SHA256) privateKey digest
+
+  -- return
+  pure Signed{..}
+
+data Signed
+  = Signed
+    { signedMessage :: ByteString
+    , signedDigest :: ByteString
+    }
+  deriving Show
+
+ppSigned :: Signed -> String
+ppSigned signed =
+  unlines
+    [ "Signature"
+    , "{ signedMessage = " <> encodeBase64 signed.signedMessage
+    , ", signedDigest = " <> encodeBase64 signed.signedDigest
+    , "}"
+    ]
+
+encodeBase64 :: ByteString -> String
+encodeBase64 = show . Base64.extractBase64 . Base64.encodeBase64

src/Fedi/Helpers.hs

@@ -1,168 +1,17 @@
-module Fedi.Helpers where
+module Fedi.Helpers
+  ( module Export
+  )
+where
 
-import Data.Text qualified as T
-import Fedi.Types
 import Fedi.UserDetails
-
--- | An empty activitypub Object.
-emptyObject :: Object ()
-emptyObject =
-  Object
-    { id = Nothing
-    , otype = ()
-    , content = Nothing
-    , published = Nothing
-    , replies = Nothing
-    , attachment = Nothing
-    , attributedTo = Nothing
-    , tag = Nothing
-    , to = Nothing
-    , cc = Nothing
-    , inReplyTo = Nothing
-    , url = Nothing
-    , name = Nothing
-    , icon = Nothing
-    , image = Nothing
-    , preview = Nothing
-    , summary = Nothing
-    , updated = Nothing
-    , mediaType = Nothing
-    }
-
--- | Create an activitypub Actor.
-makeActor :: UserDetails -> Actor
-makeActor details =
-  let
-    actor = actorUrl details
-  in
-    ActorPerson $
-      emptyObject
-        { id = Just $ ObjectId actor
-        , otype =
-            TypePerson
-              { preferredUsername = details.username
-              , inbox = Link $ actor <> "/inbox"
-              , outbox = Link $ actor <> "/outbox"
-              , following = Link $ actor <> "/following"
-              , followers = Link $ actor <> "/followers"
-              , publicKey =
-                  PublicKey
-                    { pkid = actor <> "#main-key"
-                    , owner = actor
-                    , publicKeyPem = details.publicPem
-                    }
-              }
-        , url = Nothing -- details.url
-        , name = Just $ StringName details.name
-        , icon = Just $ makeImage details.icon
-        , image = Just $ makeImage details.image
-        , summary = Just $ T.pack details.summary
-        }
-
-makeCreateNote :: Note -> Create
-makeCreateNote note =
-  emptyObject
-    { id = (\oid -> ObjectId $ oid.unwrap <> "/create") <$> note.id
-    , otype =
-        TypeActivity
-          { actor = maybe (Link "") getAttributedTo note.attributedTo
-          , atype = TypeCreate note
-          , target = Nothing
-          , origin = Nothing
-          }
-    }
-
--- | Create an user's empty 'Note'.
-emptyUserNote :: Url -> Note
-emptyUserNote actor =
-  emptyObject
-    { otype = emptyTypeNote
-    , attributedTo = Just (LLink $ Link actor)
-    , to = Just [Link "https://www.w3.org/ns/activitystreams#Public"]
-    , cc = Just [Link $ actor <> "/followers"]
-    }
-
--- | An empty 'Note'.
-emptyTypeNote :: TypeNote
-emptyTypeNote =
-  TypeNote
-    { likes = emptyUnorderedCollection
-    , shares = emptyUnorderedCollection
-    , replies = emptyUnorderedCollection
-    , sensitive = False
-    }
-
--- | Create an activitypub Image.
-makeImage :: Url -> Image
-makeImage link =
-  emptyObject
-    { otype = TypeImage
-    , mediaType = Just ("image/png" :: MediaType)
-    , url = Just link
-    }
-
--- | An empty 'Collection'.
-emptyUnorderedCollection :: Collection a
-emptyUnorderedCollection =
-  emptyObject
-    { otype =
-        CollectionType
-          { ctype =
-              UnorderedCollectionType
-                { items = []
-                }
-          , first = Nothing
-          , last = Nothing
-          , current = Nothing
-          }
-    }
-
--- | An empty 'OrderedCollection'.
-emptyOrderedCollection :: OrderedCollection a
-emptyOrderedCollection =
-  emptyObject
-    { otype =
-        CollectionType
-          { ctype =
-              OrderedCollectionType
-                { orderedItems = []
-                }
-          , first = Nothing
-          , last = Nothing
-          , current = Nothing
-          }
-    }
-
--- | Create an empty 'OrderedCollectionPage'.
-emptyOrderedCollectionPage :: Url -> OrderedCollectionPage a
-emptyOrderedCollectionPage url =
-  emptyObject
-    { otype =
-        CollectionType
-          { ctype =
-              OrderedCollectionPageType
-                { partOf = url
-                , prev = Nothing
-                , next = Nothing
-                , porderedItems = []
-                }
-          , first = Nothing
-          , last = Nothing
-          , 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
-          }
-    }
+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.ByteString as Export (ByteString)
+import Data.Time as Export (UTCTime)
+import Data.Traversable as Export
+import GHC.Generics as Export (Generic)
+import Control.Monad as Export
+import Data.Functor as Export
+import Data.Function as Export

src/Fedi/Requests.hs

@@ -0,0 +1,45 @@
+{-# language DataKinds #-}
+
+module Fedi.Requests where
+
+import Data.Aeson qualified as A
+import Fedi.UserDetails
+import Fedi.Crypto
+import Network.HTTP.Req qualified as Req
+import Data.ByteString.Lazy qualified as BSL
+
+sendPost
+  :: (A.FromJSON output, A.ToJSON input)
+  => UserDetails
+  -> String
+  -> input
+  -> IO output
+sendPost details url payload = do
+  let encoded = BSL.toStrict $ A.encode payload
+  signed <- sign details encoded
+
+  Req.runReq Req.defaultHttpConfig do
+    r <-
+      Req.req
+        Req.POST
+        (Req.https $ fromString url)
+        (Req.ReqBodyBs encoded)
+        Req.jsonResponse
+        ( Req.header "ContentType" "application/activity+json"
+          <> Req.header "Digest" signed.signedDigest
+          <> Req.header "Signature" signed.signedMessage
+        )
+    pure $ Req.responseBody r
+
+sendGet :: (A.FromJSON a) => String -> IO a
+sendGet url = do
+  Req.runReq Req.defaultHttpConfig do
+    r <-
+      Req.req
+        Req.GET
+        (Req.https $ fromString url)
+        Req.NoReqBody
+        Req.jsonResponse
+        ( Req.header "ContentType" "application/activity+json"
+        )
+    pure $ Req.responseBody r

src/Fedi/Routes/Follow.hs

@@ -3,6 +3,7 @@ module Fedi.Routes.Follow where
 import Data.Aeson qualified as A
 import Fedi.Helpers
 import Fedi.Types
+import Fedi.Types.Helpers
 import Fedi.UserDetails
 import Fedi.Routes.Helpers
 import Web.Twain qualified as Twain

src/Fedi/Routes/Helpers.hs

@@ -1,8 +1,10 @@
 module Fedi.Routes.Helpers where
 
+import Data.Aeson qualified as A
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BSL
 import Web.Twain qualified as Twain
+import Control.Monad.Catch (throwM)
 
 jsonLD :: BSL.ByteString -> Twain.Response
 jsonLD =
@@ -19,3 +21,9 @@ checkContentTypeAccept request =
               && ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs)
            )
     Nothing -> False
+
+parseJson :: (A.FromJSON a) => BSL.ByteString -> Twain.ResponderM a
+parseJson body = do
+  case A.eitherDecode body of
+    Left msg -> throwM $ Twain.HttpError Twain.status400 msg
+    Right a -> pure a

src/Fedi/Routes/Inbox.hs

@@ -1,9 +1,20 @@
 module Fedi.Routes.Inbox where
 
+import Fedi.Requests
 import Fedi.Types
 import Fedi.UserDetails
+import Fedi.Routes.Helpers
+import Fedi.Helpers
 import Web.Twain qualified as Twain
 import Web.Twain.Types qualified as Twain
+import Data.Text qualified as T
+import Network.Wai qualified as Wai
+import Control.Monad.IO.Class (liftIO)
+import Text.ParserCombinators.ReadP qualified as P
+import Data.Text.Encoding qualified as T
+import Data.Text.Encoding.Base64 qualified as Base64
+import Data.ByteString.Lazy qualified as BSL
+import Fedi.Crypto
 
 -- * Inbox
 
@@ -13,7 +24,93 @@ matchInbox details =
 
 handleInbox :: (AnyActivity -> Twain.ResponderM Twain.Response) -> Twain.ResponderM b
 handleInbox handle = do
-  activity <- Twain.fromBody
-  -- sig <- Twain.header "Signature"
+  activity <- checkSignatureAndParseBody
   response <- handle activity
   Twain.send response
+
+-- | Check the signature of the sender and parse the body of the request.
+checkSignatureAndParseBody :: Twain.ResponderM AnyActivity
+checkSignatureAndParseBody = do
+  -- get info
+  request <- Twain.request
+  body <- liftIO (Wai.strictRequestBody request)
+  sigheader <- parseSignature <$> Twain.header "Signature"
+  digest <-
+    maybe (error "missing header Digest") T.encodeUtf8 <$> Twain.header "Digest"
+  (person :: Person) <- liftIO $ sendGet sigheader.keyId
+  let personPkid = person.otype.publicKey.pkid
+  let personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
+
+  -- check
+  liftIO $
+    checkSignature personPkid personPublicKey sigheader digest (BSL.toStrict body)
+
+  -- parse the body and return it
+  parseJson body
+
+checkSignature
+  :: Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> IO ()
+checkSignature personPkid personPublicKey sigheader digest body = do
+  -- check
+  unless (personPkid == sigheader.keyId) $
+    error "public key mismatch with signature."
+
+  unless (verifyPub personPublicKey sigheader.signature body) $
+    error "signature verification failed."
+
+  unless (verifyDigest personPublicKey digest body) $
+    error "digest verification failed."
+  -- todo: check date
+
+data SignatureHeader
+  = SignatureHeader
+    { -- | Where to get the public key for this actor
+      keyId :: Url
+    , -- | Which headers have been sent
+      headers :: [T.Text]
+    , -- | Contains the signature
+      signature :: ByteString
+    }
+
+data Component
+  = KeyId
+  | Headers
+  | Signature
+  deriving Eq
+
+parseSignature :: Maybe T.Text -> SignatureHeader
+parseSignature minput =
+  let
+    input = maybe (error "no signature.") T.unpack minput
+  in case P.readP_to_S parser input of
+    [(sig, "")] -> sig
+    _ -> error "error parsing signature."
+  where
+    lookup' a b =
+      fromMaybe (error "error parsing signature") $ lookup a b
+    parser = do
+      components <- component `P.sepBy` P.char ','
+      pure SignatureHeader
+        { keyId = lookup' KeyId components
+        , headers = T.split (==' ') . T.pack $ lookup' Headers components
+        , signature =
+          ( T.encodeUtf8
+          . Base64.decodeBase64Lenient
+          . T.pack
+          . lookup' Signature
+          ) components
+        }
+    component = P.choice
+      [ do
+        _ <- P.string "keyId="
+        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+        pure (KeyId, url)
+      , do
+        _ <- P.string "headers="
+        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+        pure (Headers, url)
+      , do
+        _ <- P.string "signature="
+        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+        pure (Signature, url)
+      ]

src/Fedi/Routes/Outbox.hs

@@ -3,6 +3,7 @@ module Fedi.Routes.Outbox where
 import Data.Aeson qualified as A
 import Fedi.Helpers
 import Fedi.Types
+import Fedi.Types.Helpers
 import Fedi.UserDetails
 import Fedi.Routes.Helpers
 import Web.Twain qualified as Twain

src/Fedi/Routes/User.hs

@@ -4,6 +4,7 @@ import Data.Aeson qualified as A
 import Fedi.Helpers
 import Fedi.UserDetails
 import Fedi.Webfinger
+import Fedi.Types.Helpers
 import Fedi.Routes.Helpers
 import Web.Twain qualified as Twain
 import Web.Twain.Types qualified as Twain

src/Fedi/Types.hs

@@ -322,6 +322,30 @@ instance A.FromJSON TypeFollow where
       object <- value A..: "object"
       pure TypeFollow {..}
 
+-- | Undo
+type Undo = Activity TypeUndo
+
+data TypeUndo
+  = TypeUndo
+  { object :: AnyActivity
+  }
+  deriving (Show, Eq)
+
+instance ToObject TypeUndo where
+  toObject undo =
+    [ "type" A..= ("Undo" :: String)
+    , "object" A..= undo.object
+    ]
+
+instance A.FromJSON TypeUndo where
+  parseJSON =
+    A.withObject "TypeUndo" \value -> do
+      typ :: String <- value A..: "type"
+      guard (typ == "Undo")
+      object <- value A..: "object"
+      pure TypeUndo {..}
+
+
 --
 type Like = Object (TypeActivity TypeLike)
 
@@ -342,6 +366,7 @@ instance A.FromJSON TypeLike where
 data AnyActivity
   = -- ActivityAnnounce Announce
     ActivityCreate Create
+  | ActivityUndo Undo
   | ActivityFollow Follow
   | --  | ActivityLike Like
     ActivityAccept Accept
@@ -352,6 +377,7 @@ instance A.ToJSON AnyActivity where
   toJSON = \case
     --    ActivityAnnounce obj -> A.toJSON obj
     ActivityCreate obj -> A.toJSON obj
+    ActivityUndo obj -> A.toJSON obj
     ActivityFollow obj -> A.toJSON obj
     --    ActivityLike obj -> A.toJSON obj
     ActivityAccept obj -> A.toJSON obj
@@ -363,6 +389,7 @@ instance A.FromJSON AnyActivity where
       typ :: String <- v A..: "type"
       case typ of
         "Create" -> ActivityCreate <$> A.parseJSON value
+        "Undo" -> ActivityUndo <$> A.parseJSON value
         "Follow" -> ActivityFollow <$> A.parseJSON value
         "Accept" -> ActivityAccept <$> A.parseJSON value
         "Reject" -> ActivityReject <$> A.parseJSON value

src/Fedi/Types/Helpers.hs

@@ -0,0 +1,168 @@
+module Fedi.Types.Helpers where
+
+import Data.Text qualified as T
+import Fedi.Types
+import Fedi.UserDetails
+
+-- | An empty activitypub Object.
+emptyObject :: Object ()
+emptyObject =
+  Object
+    { id = Nothing
+    , otype = ()
+    , content = Nothing
+    , published = Nothing
+    , replies = Nothing
+    , attachment = Nothing
+    , attributedTo = Nothing
+    , tag = Nothing
+    , to = Nothing
+    , cc = Nothing
+    , inReplyTo = Nothing
+    , url = Nothing
+    , name = Nothing
+    , icon = Nothing
+    , image = Nothing
+    , preview = Nothing
+    , summary = Nothing
+    , updated = Nothing
+    , mediaType = Nothing
+    }
+
+-- | Create an activitypub Actor.
+makeActor :: UserDetails -> Actor
+makeActor details =
+  let
+    actor = actorUrl details
+  in
+    ActorPerson $
+      emptyObject
+        { id = Just $ ObjectId actor
+        , otype =
+            TypePerson
+              { preferredUsername = details.username
+              , inbox = Link $ actor <> "/inbox"
+              , outbox = Link $ actor <> "/outbox"
+              , following = Link $ actor <> "/following"
+              , followers = Link $ actor <> "/followers"
+              , publicKey =
+                  PublicKey
+                    { pkid = actor <> "#main-key"
+                    , owner = actor
+                    , publicKeyPem = details.publicPem
+                    }
+              }
+        , url = Nothing -- details.url
+        , name = Just $ StringName details.name
+        , icon = Just $ makeImage details.icon
+        , image = Just $ makeImage details.image
+        , summary = Just $ T.pack details.summary
+        }
+
+makeCreateNote :: Note -> Create
+makeCreateNote note =
+  emptyObject
+    { id = (\oid -> ObjectId $ oid.unwrap <> "/create") <$> note.id
+    , otype =
+        TypeActivity
+          { actor = maybe (Link "") getAttributedTo note.attributedTo
+          , atype = TypeCreate note
+          , target = Nothing
+          , origin = Nothing
+          }
+    }
+
+-- | Create an user's empty 'Note'.
+emptyUserNote :: Url -> Note
+emptyUserNote actor =
+  emptyObject
+    { otype = emptyTypeNote
+    , attributedTo = Just (LLink $ Link actor)
+    , to = Just [Link "https://www.w3.org/ns/activitystreams#Public"]
+    , cc = Just [Link $ actor <> "/followers"]
+    }
+
+-- | An empty 'Note'.
+emptyTypeNote :: TypeNote
+emptyTypeNote =
+  TypeNote
+    { likes = emptyUnorderedCollection
+    , shares = emptyUnorderedCollection
+    , replies = emptyUnorderedCollection
+    , sensitive = False
+    }
+
+-- | Create an activitypub Image.
+makeImage :: Url -> Image
+makeImage link =
+  emptyObject
+    { otype = TypeImage
+    , mediaType = Just ("image/png" :: MediaType)
+    , url = Just link
+    }
+
+-- | An empty 'Collection'.
+emptyUnorderedCollection :: Collection a
+emptyUnorderedCollection =
+  emptyObject
+    { otype =
+        CollectionType
+          { ctype =
+              UnorderedCollectionType
+                { items = []
+                }
+          , first = Nothing
+          , last = Nothing
+          , current = Nothing
+          }
+    }
+
+-- | An empty 'OrderedCollection'.
+emptyOrderedCollection :: OrderedCollection a
+emptyOrderedCollection =
+  emptyObject
+    { otype =
+        CollectionType
+          { ctype =
+              OrderedCollectionType
+                { orderedItems = []
+                }
+          , first = Nothing
+          , last = Nothing
+          , current = Nothing
+          }
+    }
+
+-- | Create an empty 'OrderedCollectionPage'.
+emptyOrderedCollectionPage :: Url -> OrderedCollectionPage a
+emptyOrderedCollectionPage url =
+  emptyObject
+    { otype =
+        CollectionType
+          { ctype =
+              OrderedCollectionPageType
+                { partOf = url
+                , prev = Nothing
+                , next = Nothing
+                , porderedItems = []
+                }
+          , first = Nothing
+          , last = Nothing
+          , 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
+          }
+    }

src/Fedi/UserDetails.hs

@@ -8,7 +8,9 @@ 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.ByteString as Export (ByteString)
 import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
 import Data.Time as Export (UTCTime)
 import Data.Traversable as Export
 import GHC.Generics as Export (Generic)
@@ -23,6 +25,9 @@ newtype Pem = Pem T.Text
   deriving (Show, Eq)
   deriving (A.FromJSON) via T.Text
 
+pemToBS :: Pem -> ByteString
+pemToBS (Pem txt) = T.encodeUtf8 txt
+
 instance A.ToJSON Pem where
   toJSON (Pem pem) = A.String pem