From 1b7ad4489169546901795bc92d28deebd4f0b377 Mon Sep 17 00:00:00 2001 From: me Date: Tue, 17 Dec 2024 10:46:59 +0200 Subject: [PATCH] is this how you sign? maybe --- fedi.cabal | 3 + src/Fedi/Crypto.hs | 19 +++++-- src/Fedi/Requests.hs | 43 ++++++++++++--- src/Fedi/Routes/Inbox.hs | 107 +----------------------------------- src/Fedi/Signature/Check.hs | 101 ++++++++++++++++++++++++++++++++++ src/Fedi/Signature/Sign.hs | 48 ++++++++++++++++ src/Fedi/Signature/Types.hs | 47 ++++++++++++++++ 7 files changed, 250 insertions(+), 118 deletions(-) create mode 100644 src/Fedi/Signature/Check.hs create mode 100644 src/Fedi/Signature/Sign.hs create mode 100644 src/Fedi/Signature/Types.hs diff --git a/fedi.cabal b/fedi.cabal index abc0b9b..368b68c 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -24,6 +24,9 @@ library Fedi.UserDetails Fedi.Webfinger Fedi.Crypto + Fedi.Signature.Types + Fedi.Signature.Check + Fedi.Signature.Sign Fedi.Routes Fedi.Routes.Helpers diff --git a/src/Fedi/Crypto.hs b/src/Fedi/Crypto.hs index a875677..254fa7e 100644 --- a/src/Fedi/Crypto.hs +++ b/src/Fedi/Crypto.hs @@ -11,6 +11,7 @@ import Fedi.Helpers import Fedi.UserDetails import Data.ByteString.Base64 qualified as Base64 import Data.Base64.Types qualified as Base64 +import Data.Text qualified as T verifyPub :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool verifyPub pubkeypem sig message = do @@ -64,10 +65,20 @@ ppSigned :: Signed -> String ppSigned signed = unlines [ "Signature" - , "{ signedMessage = " <> encodeBase64 signed.signedMessage - , ", signedDigest = " <> encodeBase64 signed.signedDigest + , "{ signedMessage = " <> encodeBase64String signed.signedMessage + , ", signedDigest = " <> encodeBase64String signed.signedDigest , "}" ] -encodeBase64 :: ByteString -> String -encodeBase64 = show . Base64.extractBase64 . Base64.encodeBase64 +encodeBase64 :: ByteString -> ByteString +encodeBase64 = Base64.extractBase64 . Base64.encodeBase64' + +encodeBase64String :: ByteString -> String +encodeBase64String = T.unpack . Base64.extractBase64 . Base64.encodeBase64 + +decodeBase64 :: ByteString -> ByteString +decodeBase64 = Base64.decodeBase64Lenient + +makeDigest :: ByteString -> String +makeDigest message = + show (Crypto.hash message :: Crypto.Digest Crypto.SHA256) diff --git a/src/Fedi/Requests.hs b/src/Fedi/Requests.hs index 320c21a..e8e83b9 100644 --- a/src/Fedi/Requests.hs +++ b/src/Fedi/Requests.hs @@ -2,13 +2,15 @@ module Fedi.Requests where +import Data.List (intercalate) import Data.Aeson qualified as A import Fedi.Helpers import Fedi.UserDetails -import Fedi.Crypto +import Fedi.Signature.Sign import Network.HTTP.Req qualified as Req import Data.ByteString.Lazy qualified as BSL import Text.URI qualified as URI +import Data.Text qualified as T sendPost :: (A.FromJSON output, A.ToJSON input) @@ -17,12 +19,10 @@ sendPost -> input -> IO output sendPost details url payload = do - let encoded = BSL.toStrict $ A.encode payload - signed <- sign details encoded uri <- URI.mkURI $ fromString url + let encoded = BSL.toStrict $ A.encode payload + httpSignature <- makeHttpSignature details uri encoded (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri) - print ("url", url') - Req.runReq Req.defaultHttpConfig do r <- Req.req @@ -31,12 +31,39 @@ sendPost details url payload = do (Req.ReqBodyBs encoded) Req.jsonResponse ( scheme - <> Req.header "ContentType" "application/activity+json" - <> Req.header "Digest" signed.signedDigest - <> Req.header "Signature" signed.signedMessage + <> sigHeaders httpSignature ) pure $ Req.responseBody r +makeHttpSignature :: UserDetails -> URI.URI -> ByteString -> IO HttpSignature +makeHttpSignature details uri encoded = do + host <- case uri.uriAuthority of + Right u -> pure $ T.unpack $ URI.unRText u.authHost + _ -> throw "no host in uri" + -- We may want to add the uri path and uri query, + -- but maybe later. + let + path = case uri.uriPath of + Just (_, list) -> + "/" <> intercalate "/" (map (T.unpack . URI.unRText) $ toList list) + Nothing -> "/" + signSignature details host ("post " <> path) encoded + + +sigHeaders :: HttpSignature -> Req.Option scheme +sigHeaders = + foldMap (uncurry Req.header) . makeSigHeaders + +makeSigHeaders :: HttpSignature -> [(ByteString, ByteString)] +makeSigHeaders httpSignature = + [ ("ContentType", "application/activity+json") + , ("Accept", "application/activity+json") + , ("Digest", httpSignature.digest) + , ("Host", fromString httpSignature.host) + , ("Date", fromString httpSignature.date) + , ("Signature", toSignature httpSignature.signatureHeader) + ] + sendGet :: (A.FromJSON a) => String -> IO a sendGet url = do uri <- URI.mkURI $ fromString url diff --git a/src/Fedi/Routes/Inbox.hs b/src/Fedi/Routes/Inbox.hs index 2140c99..b9180db 100644 --- a/src/Fedi/Routes/Inbox.hs +++ b/src/Fedi/Routes/Inbox.hs @@ -1,23 +1,13 @@ -{-# language RecordWildCards #-} module Fedi.Routes.Inbox where import Prelude hiding (error) -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 Control.Monad.Catch (catch, displayException, SomeException) -import Text.ParserCombinators.ReadP qualified as P -import Data.Text.Encoding qualified as T -import Data.ByteString.Base64 qualified as Base64 -import Data.ByteString.Lazy qualified as BSL -import Fedi.Crypto +import Fedi.Signature.Check -- * Inbox @@ -37,98 +27,3 @@ handleInbox handle = do Twain.send $ Twain.status Twain.status500 $ Twain.text "Internal Server Error 500" - --- | Check the signature of the sender and parse the body of the request. -checkSignatureAndParseBody :: Twain.ResponderM AnyActivity -checkSignatureAndParseBody = do - -- get info - request <- Twain.request - liftIO $ print ("headers", Twain.requestHeaders request) - body <- liftIO (Wai.strictRequestBody request) - sigheader <- parseSignature =<< Twain.header "Signature" - digest <- Twain.header "Digest" >>= - maybe (throw "missing header Digest") (pure . T.encodeUtf8) - (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 - :: MonadThrow m - => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> m () -checkSignature personPkid personPublicKey sigheader digest body = do - -- check - unless (personPkid == sigheader.keyId) $ - throw "public key mismatch with signature." - - pub <- verifyPub personPublicKey sigheader.signature body - unless pub $ - throw "signature verification failed." - - dig <- verifyDigest personPublicKey digest body - unless dig $ - throw "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 - , components :: [(Component, String)] - } - deriving Show - -data Component - = KeyId - | Headers - | Signature - | Other String - deriving (Eq, Show) - -parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader -parseSignature minput = do - input <- maybe (throw "no signature.") (pure . T.unpack) minput - case P.readP_to_S parser input of - [(sig, "")] -> pure sig - xs -> throw $ "error parsing signature: " <> show xs - where - lookup' a b = - maybe (fail "error parsing signature") pure $ lookup a b - parser = do - components <- component `P.sepBy` P.char ',' - keyId <- lookup' KeyId components - headers <- T.split (==' ') . T.pack <$> lookup' Headers components - signature <- - ( Base64.decodeBase64Lenient - . fromString - ) <$> lookup' Signature components - pure SignatureHeader{..} - 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) - , do - key <- P.munch1 (/= '=') - _ <- P.char '=' - value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"')) - pure (Other key, value) - ] diff --git a/src/Fedi/Signature/Check.hs b/src/Fedi/Signature/Check.hs new file mode 100644 index 0000000..28b6e05 --- /dev/null +++ b/src/Fedi/Signature/Check.hs @@ -0,0 +1,101 @@ +{-# language RecordWildCards #-} + +module Fedi.Signature.Check + ( module Fedi.Signature.Types + , module Fedi.Signature.Check + ) +where + +import Prelude hiding (error) +import Fedi.Types +import Fedi.UserDetails +import Fedi.Requests +import Fedi.Routes.Helpers +import Fedi.Helpers +import Web.Twain 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.ByteString.Lazy qualified as BSL +import Fedi.Crypto +import Fedi.Signature.Types + +-- * Check + +-- | Check the signature of the sender and parse the body of the request. +checkSignatureAndParseBody :: Twain.ResponderM AnyActivity +checkSignatureAndParseBody = do + -- get info + request <- Twain.request + liftIO $ print ("headers", Twain.requestHeaders request) + body <- liftIO (Wai.strictRequestBody request) + sigheader <- parseSignature =<< Twain.header "Signature" + digest <- Twain.header "Digest" >>= + maybe (throw "missing header Digest") (pure . T.encodeUtf8) + (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 + :: MonadThrow m + => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> m () +checkSignature personPkid personPublicKey sigheader digest body = do + -- check + unless (personPkid == sigheader.keyId) $ + throw "public key mismatch with signature." + + pub <- verifyPub personPublicKey sigheader.signature body + unless pub $ + throw "signature verification failed." + + dig <- verifyDigest personPublicKey digest body + unless dig $ + throw "digest verification failed." + -- todo: check date + +parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader +parseSignature minput = do + input <- maybe (throw "no signature.") (pure . T.unpack) minput + case P.readP_to_S parser input of + [(sig, "")] -> pure sig + xs -> throw $ "error parsing signature: " <> show xs + where + lookup' a b = + maybe (fail "error parsing signature") pure $ lookup a b + parser = do + components <- component `P.sepBy` P.char ',' + keyId <- lookup' KeyId components + headers <- T.split (==' ') . T.pack <$> lookup' Headers components + signature <- + ( decodeBase64 + . fromString + ) <$> lookup' Signature components + pure SignatureHeader{..} + 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) + , do + key <- P.munch1 (/= '=') + _ <- P.char '=' + value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"')) + pure (Other key, value) + ] diff --git a/src/Fedi/Signature/Sign.hs b/src/Fedi/Signature/Sign.hs new file mode 100644 index 0000000..2039ec4 --- /dev/null +++ b/src/Fedi/Signature/Sign.hs @@ -0,0 +1,48 @@ +{-# language RecordWildCards #-} + +module Fedi.Signature.Sign + ( module Fedi.Signature.Types + , module Fedi.Signature.Sign + ) +where + +import Prelude hiding (error) +import Fedi.UserDetails +import Fedi.Helpers +import Data.ByteString qualified as BS +import Fedi.Crypto +import Data.Time qualified as Time +import Fedi.Signature.Types + +-- * Sign + +signSignature + :: UserDetails -> String -> String -> ByteString -> IO HttpSignature +signSignature details host requestTarget body = do + date <- Time.getCurrentTime + <&> Time.formatTime Time.defaultTimeLocale Time.rfc822DateFormat + + let + digest = encodeBase64 $ fromString $ makeDigest body + keyId = actorUrl details <> "#main-key" + headers = ["(request-target)", "host", "date", "digest"] + components = [] + signatureString = makeSignatureString host requestTarget date digest + + signed <- sign details signatureString + + let + signature = encodeBase64 signed.signedMessage + signatureHeader = SignatureHeader{..} + + pure HttpSignature{..} + +makeSignatureString + :: String -> String -> String -> ByteString -> ByteString +makeSignatureString host requestTarget date digest = + BS.intercalate "\n" + [ "(request-target): " <> fromString requestTarget + , "host: " <> fromString host + , "date: " <> fromString date + , "digest: SHA-256=" <> digest + ] diff --git a/src/Fedi/Signature/Types.hs b/src/Fedi/Signature/Types.hs new file mode 100644 index 0000000..0ecbe5f --- /dev/null +++ b/src/Fedi/Signature/Types.hs @@ -0,0 +1,47 @@ +{-# language RecordWildCards #-} + +module Fedi.Signature.Types where + +import Prelude hiding (error) +import Fedi.UserDetails +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.ByteString qualified as BS + +data HttpSignature + = HttpSignature + { signatureHeader :: SignatureHeader + , date :: String + , host :: String + , digest :: ByteString + } + deriving Show + +toSignature :: SignatureHeader -> ByteString +toSignature sig = + BS.intercalate "," + [ "keyId=\"" <> fromString sig.keyId <> "\"" + , "headers=\"" <> BS.intercalate " " (map T.encodeUtf8 sig.headers) <> "\"" + , "signature=\"" <> sig.signature <> "\"" + , "algorithm=\"" <> "rsa-sha256" <> "\"" + ] + +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 + , components :: [(Component, String)] + } + deriving Show + +data Component + = KeyId + | Headers + | Signature + | Algorithm + | Other String + deriving (Eq, Show)