app/DB.hs

@@ -15,10 +15,8 @@ data DB
   = DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
-  , insertNote :: NoteEntry -> IO (DB.Int64, Note)
+  , insertNote :: NoteEntry -> IO ObjectId
   , insertFollower :: FollowerEntry -> IO DB.Int64
-  , deleteFollower :: FollowerEntry -> IO DB.Int64
-  , getFollowers :: IO [Follower]
   }
 
 -- * Data types
@@ -37,13 +35,6 @@ data FollowerEntry
   , actorId :: T.Text
   }
 
-data Follower
-  = Follower
-  { myid :: T.Text
-  , followId :: T.Text
-  , actorId :: T.Text
-  }
-
 -----------------------
 
 -- * Handler smart constructor
@@ -55,17 +46,13 @@ mkDB connstr details = do
   pure
     DB
       { getNotes =
-          DB.withPool pool getNotesFromDb
+          DB.withPool pool (getNotesFromDb $ actorUrl details)
       , getNote =
-          \noteid -> DB.withPool pool (getNoteFromDb noteid)
+          \noteid -> DB.withPool pool (getNoteFromDb noteid $ actorUrl details)
       , 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)
       }
 
 -----------------------
@@ -123,18 +110,18 @@ migrateDown = \case
 
 -- * Database actions
 
-getNotesFromDb :: DB.SQLite [Note]
+getNotesFromDb :: Url -> DB.SQLite [Note]
-getNotesFromDb =
+getNotesFromDb url =
-  map (snd . decodeNoteRow) <$> uncurry DB.runWith getNotesSQL
+  map decodeNoteRow <$> uncurry DB.runWith (getNotesSQL url)
 
-getNoteFromDb :: DB.Int64 -> DB.SQLite (Maybe Note)
+getNoteFromDb :: DB.Int64 -> Url -> DB.SQLite (Maybe Note)
-getNoteFromDb noteid = do
+getNoteFromDb noteid url = do
-  n <- map (snd . decodeNoteRow) <$> uncurry DB.runWith (getNoteSQL noteid)
+  n <- map decodeNoteRow <$> uncurry DB.runWith (getNoteSQL noteid url)
   pure (listToMaybe n)
 
-insertNoteToDb :: Url -> NoteEntry -> DB.SQLite (DB.Int64, Note)
+insertNoteToDb :: Url -> NoteEntry -> DB.SQLite ObjectId
 insertNoteToDb actor note = do
-  [n] <- map decodeNoteRow <$> uncurry DB.runWith (insertNoteSQL actor note)
+  [n] <- map decodeNoteIdRow <$> uncurry DB.runWith (insertNoteSQL actor note)
   pure n
 
 insertFollowerToDb :: FollowerEntry -> DB.SQLite DB.Int64
@@ -142,23 +129,13 @@ 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 :: (DB.SQL, [DB.SQLData])
+getNotesSQL :: Url -> (DB.SQL, [DB.SQLData])
-getNotesSQL =
+getNotesSQL url =
   ( [r|
       SELECT
-        id,
+        ? || '/notes/' || id,
-        actor || '/notes/' || id,
         published,
         actor,
         content,
@@ -169,15 +146,14 @@ getNotesSQL =
       WHERE inReplyTo IS NULL
       ORDER BY published DESC
     |]
-  , []
+  , [DB.SQLText $ T.pack url]
   )
 
-getNoteSQL :: DB.Int64 -> (DB.SQL, [DB.SQLData])
+getNoteSQL :: DB.Int64 -> Url -> (DB.SQL, [DB.SQLData])
-getNoteSQL noteid =
+getNoteSQL noteid url =
   ( [r|
       SELECT
-        id as nid,
+        ? || '/notes/' || id,
-        actor || '/notes/' || id,
         published,
         actor,
         content,
@@ -188,7 +164,7 @@ getNoteSQL noteid =
       WHERE note.id = ?
       ORDER BY published DESC
     |]
-  , [DB.SQLInteger noteid]
+  , [DB.SQLText $ T.pack url, DB.SQLInteger noteid]
   )
 
 insertNoteSQL :: Url -> NoteEntry -> (DB.SQL, [DB.SQLData])
@@ -196,16 +172,7 @@ insertNoteSQL actor note =
   ( [r|
       INSERT INTO note(actor, inReplyTo, content, name, url)
       VALUES (?, ?, ?, ?, ?)
-      RETURNING
+      RETURNING cast(id as text)
-        id as nid,
-        actor || '/notes/' || id,
-        published,
-        actor,
-        content,
-        name,
-        inReplyTo,
-        url
-
     |]
   ,
     [ DB.SQLText (T.pack actor)
@@ -219,7 +186,7 @@ insertNoteSQL actor note =
 insertFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
 insertFollowerSQL follower =
   ( [r|
-      INSERT INTO follower(follow_id, actor)
+      INSERT INTO note(follow_id, actor)
       VALUES (?, ?)
       RETURNING id
     |]
@@ -229,38 +196,13 @@ 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] -> (DB.Int64, Note)
+decodeNoteRow :: [DB.SQLData] -> Note
 decodeNoteRow = \case
-  [ DB.SQLInteger noteid
+  [ DB.SQLText noteid
-    , DB.SQLText noteidurl
     , DB.SQLText published
     , DB.SQLText actor
     , DB.SQLText content
@@ -270,9 +212,9 @@ decodeNoteRow = \case
     ] ->
       let
         emptyNote = emptyUserNote $ T.unpack actor
-      in (noteid,
+      in
         emptyNote
-          { id = Just $ ObjectId $ T.unpack noteidurl
+          { id = Just $ ObjectId $ T.unpack noteid
           , published = Just $ read (T.unpack published)
           , attributedTo = Just $ LLink $ Link $ T.unpack actor
           , inReplyTo = LLink . Link <$> inReplyTo
@@ -283,34 +225,26 @@ decodeNoteRow = \case
               emptyNote.otype
                 { likes =
                     emptyNote.otype.likes
-                      { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
+                      { id = Just $ ObjectId $ T.unpack noteid <> "/likes"
                       }
                 , shares =
                     emptyNote.otype.shares
-                      { id = Just $ ObjectId $ T.unpack noteidurl <> "/shares"
+                      { id = Just $ ObjectId $ T.unpack noteid <> "/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,7 +12,6 @@ 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)
@@ -114,11 +113,7 @@ runServer port authMiddleware app = do
       , "(ctrl-c to quit)"
       ]
   auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware
-  run port $
+  run port (Logger.logStdoutDev $ auth app)
-    ( Logger.logStdoutDev
-    . Limit.requestSizeLimitMiddleware Limit.defaultRequestSizeLimitSettings
-    . auth
-    ) app
 
 matchAdmin :: [T.Text] -> Bool
 matchAdmin = any (== "admin")

app/Routes.hs

@@ -11,8 +11,16 @@ import Html
 import Lucid qualified as H
 import System.IO.Unsafe (unsafePerformIO)
 import Web.Twain qualified as Twain
-import Data.Text qualified as T
+import Network.HTTP.Req
-import Control.Concurrent.Async qualified as Async
+  ( runReq
+  , defaultHttpConfig
+  , req
+  , POST(POST)
+  , ReqBodyJson(ReqBodyJson)
+  , jsonResponse
+  , responseBody
+  , https
+  )
 
 routes :: DB -> FilePath -> [Twain.Middleware]
 routes db detailsFile =
@@ -94,7 +102,7 @@ routes db detailsFile =
       url <- Twain.param "url"
       details <- liftIO $ fetchUserDetails detailsFile
 
-      (noteid, note) <-
+      noteid <-
         liftIO $
           db.insertNote
             NoteEntry
@@ -104,9 +112,7 @@ routes db detailsFile =
               , url = if trim url == "" then Nothing else Just url
               }
 
-      liftIO $ sendFollowers details db (Fedi.ActivityCreate $ noteToCreate note)
+      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> noteid.unwrap))
-
-      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> show noteid))
   ]
 
 trim :: String -> String
@@ -138,8 +144,7 @@ handleInbox db detailsFile activity = do
                   { actorId = fromString actor.unwrap
                   , followId = fromString id''.unwrap
                   }
-                (result :: A.Value) <- Fedi.sendPost
+                (result :: A.Value) <- sendRequest
-                  details
                   (id''.unwrap <> "/inbox")
                   ( Fedi.makeAccept
                     follow
@@ -150,40 +155,18 @@ 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
 
-sendFollowers :: Fedi.UserDetails -> DB -> Fedi.AnyActivity -> IO ()
+sendRequest :: (A.ToJSON input, A.FromJSON output) => Fedi.Url -> input -> IO output
-sendFollowers details db message = do
+sendRequest url payload = do
-  followers <- db.getFollowers
+  runReq defaultHttpConfig do
-  Fedi.for_ followers \follower -> do
+    r <-
-    Async.async $ do
+      req
-      result <- Fedi.sendPost @A.Value details (T.unpack follower.actorId <> "/inbox") message
+        POST
-      print (follower.actorId, A.encode result)
+        (https $ fromString url)
+        (ReqBodyJson payload)
+        jsonResponse
+        mempty
+    pure $ responseBody r

cabal.project

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

fedi.cabal

@@ -17,13 +17,10 @@ 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
@@ -49,13 +46,6 @@ library
     , twain
     , mime-types
     , time
-    , wai
-    , exceptions
-    , req
-    , base64
-    , crypton
-    , crypton-x509
-    , cryptostore
 
   hs-source-dirs: src
   default-language: GHC2021
@@ -94,6 +84,7 @@ executable fedi
     , raw-strings-qq
     , securemem
     , lucid2
+    , req
 
   hs-source-dirs: app
   default-language: GHC2021

src/Fedi.hs

@@ -1,10 +1,7 @@
 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

@@ -1,75 +0,0 @@
-{-# 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,17 +1,168 @@
-module Fedi.Helpers
+module Fedi.Helpers where
-  ( module Export
-  )
-where
 
+import Data.Text qualified as T
+import Fedi.Types
 import Fedi.UserDetails
-import Data.Foldable as Export
+
-import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
+-- | An empty activitypub Object.
-import Data.String as Export (fromString)
+emptyObject :: Object ()
-import Data.Text as Export (Text)
+emptyObject =
-import Data.ByteString as Export (ByteString)
+  Object
-import Data.Time as Export (UTCTime)
+    { id = Nothing
-import Data.Traversable as Export
+    , otype = ()
-import GHC.Generics as Export (Generic)
+    , content = Nothing
-import Control.Monad as Export
+    , published = Nothing
-import Data.Functor as Export
+    , replies = Nothing
-import Data.Function as Export
+    , 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/Requests.hs

@@ -1,45 +0,0 @@
-{-# 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,7 +3,6 @@ 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,10 +1,8 @@
 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 =
@@ -21,9 +19,3 @@ 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,20 +1,9 @@
 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
 
@@ -24,93 +13,7 @@ matchInbox details =
 
 handleInbox :: (AnyActivity -> Twain.ResponderM Twain.Response) -> Twain.ResponderM b
 handleInbox handle = do
-  activity <- checkSignatureAndParseBody
+  activity <- Twain.fromBody
+  -- sig <- Twain.header "Signature"
   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,7 +3,6 @@ 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,7 +4,6 @@ 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,30 +322,6 @@ 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)
 
@@ -366,7 +342,6 @@ instance A.FromJSON TypeLike where
 data AnyActivity
   = -- ActivityAnnounce Announce
     ActivityCreate Create
-  | ActivityUndo Undo
   | ActivityFollow Follow
   | --  | ActivityLike Like
     ActivityAccept Accept
@@ -377,7 +352,6 @@ 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
@@ -389,7 +363,6 @@ 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

@@ -1,168 +0,0 @@
-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,9 +8,7 @@ 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)
@@ -25,9 +23,6 @@ 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