From 4e922ea4685e1089f40955f2c6587365e6ac7b34 Mon Sep 17 00:00:00 2001 From: me Date: Tue, 5 Nov 2024 12:16:29 +0200 Subject: [PATCH] try adding followers and message signatures --- app/DB.hs | 109 +++++++++++++++------- app/Main.hs | 7 +- app/Routes.hs | 39 +++----- cabal.project | 2 + fedi.cabal | 11 ++- src/Fedi.hs | 3 + src/Fedi/Crypto.hs | 75 +++++++++++++++ src/Fedi/Helpers.hs | 181 +++---------------------------------- src/Fedi/Requests.hs | 45 +++++++++ src/Fedi/Routes/Follow.hs | 1 + src/Fedi/Routes/Helpers.hs | 8 ++ src/Fedi/Routes/Inbox.hs | 101 ++++++++++++++++++++- src/Fedi/Routes/Outbox.hs | 1 + src/Fedi/Routes/User.hs | 1 + src/Fedi/Types/Helpers.hs | 168 ++++++++++++++++++++++++++++++++++ src/Fedi/UserDetails.hs | 5 + 16 files changed, 531 insertions(+), 226 deletions(-) create mode 100644 src/Fedi/Crypto.hs create mode 100644 src/Fedi/Requests.hs create mode 100644 src/Fedi/Types/Helpers.hs diff --git a/app/DB.hs b/app/DB.hs index c98bdd4..671a483 100644 --- a/app/DB.hs +++ b/app/DB.hs @@ -15,8 +15,9 @@ 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 + , getFollowers :: IO [Follower] } -- * Data types @@ -35,6 +36,13 @@ data FollowerEntry , actorId :: T.Text } +data Follower + = Follower + { myid :: T.Text + , followId :: T.Text + , actorId :: T.Text + } + ----------------------- -- * Handler smart constructor @@ -46,13 +54,15 @@ 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) + , getFollowers = + DB.withPool pool (getFollowersFromDb $ actorUrl details) } ----------------------- @@ -110,18 +120,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 +139,18 @@ insertFollowerToDb follower = do [n] <- map decodeIntRow <$> uncurry DB.runWith (insertFollowerSQL 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 +161,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 +180,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 +188,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) @@ -196,13 +221,25 @@ insertFollowerSQL follower = ] ) +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 +249,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 +262,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) diff --git a/app/Main.hs b/app/Main.hs index c00b36a..3e87c31 100644 --- a/app/Main.hs +++ b/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") diff --git a/app/Routes.hs b/app/Routes.hs index 9b43bda..1c6b6fb 100644 --- a/app/Routes.hs +++ b/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 @@ -159,14 +154,10 @@ handleInbox db detailsFile activity = 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) diff --git a/cabal.project b/cabal.project index 0d7f076..9792e01 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,3 @@ packages: *.cabal + +constraints: cryptostore +use_crypton diff --git a/fedi.cabal b/fedi.cabal index 8998f3f..c907fc6 100644 --- a/fedi.cabal +++ b/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 diff --git a/src/Fedi.hs b/src/Fedi.hs index 4d42414..82c63b4 100644 --- a/src/Fedi.hs +++ b/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 diff --git a/src/Fedi/Crypto.hs b/src/Fedi/Crypto.hs new file mode 100644 index 0000000..e2c3105 --- /dev/null +++ b/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 diff --git a/src/Fedi/Helpers.hs b/src/Fedi/Helpers.hs index 643a7fe..1d42913 100644 --- a/src/Fedi/Helpers.hs +++ b/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 diff --git a/src/Fedi/Requests.hs b/src/Fedi/Requests.hs new file mode 100644 index 0000000..d8e38bf --- /dev/null +++ b/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 diff --git a/src/Fedi/Routes/Follow.hs b/src/Fedi/Routes/Follow.hs index 25712cf..7ef2311 100644 --- a/src/Fedi/Routes/Follow.hs +++ b/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 diff --git a/src/Fedi/Routes/Helpers.hs b/src/Fedi/Routes/Helpers.hs index 9defc39..1222597 100644 --- a/src/Fedi/Routes/Helpers.hs +++ b/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 diff --git a/src/Fedi/Routes/Inbox.hs b/src/Fedi/Routes/Inbox.hs index 252eb1c..095ecf6 100644 --- a/src/Fedi/Routes/Inbox.hs +++ b/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) + ] diff --git a/src/Fedi/Routes/Outbox.hs b/src/Fedi/Routes/Outbox.hs index 9710374..c597af9 100644 --- a/src/Fedi/Routes/Outbox.hs +++ b/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 diff --git a/src/Fedi/Routes/User.hs b/src/Fedi/Routes/User.hs index c76d503..012477e 100644 --- a/src/Fedi/Routes/User.hs +++ b/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 diff --git a/src/Fedi/Types/Helpers.hs b/src/Fedi/Types/Helpers.hs new file mode 100644 index 0000000..e75dda6 --- /dev/null +++ b/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 + } + } diff --git a/src/Fedi/UserDetails.hs b/src/Fedi/UserDetails.hs index 9c74808..c82b435 100644 --- a/src/Fedi/UserDetails.hs +++ b/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