From 9017d953be1e017ae4030d7c37260776f670118e Mon Sep 17 00:00:00 2001 From: me Date: Thu, 7 Nov 2024 13:51:40 +0200 Subject: [PATCH] verify signatures --- fedi.cabal | 2 ++ src/Fedi/Crypto.hs | 2 +- src/Fedi/Requests.hs | 1 - src/Fedi/Signature/Check.hs | 65 ++++++++++++++++++++++++++++++------- 4 files changed, 57 insertions(+), 13 deletions(-) diff --git a/fedi.cabal b/fedi.cabal index ac2ef85..d2f8fcc 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -61,6 +61,8 @@ library , crypton , crypton-x509 , cryptostore + , case-insensitive + , http-types hs-source-dirs: src default-language: GHC2021 diff --git a/src/Fedi/Crypto.hs b/src/Fedi/Crypto.hs index a2ca4c5..bcd24b0 100644 --- a/src/Fedi/Crypto.hs +++ b/src/Fedi/Crypto.hs @@ -19,7 +19,7 @@ verifyPub pubkeypem sig message = do case Crypto.readPubKeyFileFromMemory pubkeypem of [Crypto.PubKeyRSA pubkey'] -> pure pubkey' _ -> throw "failed to read pubkey pem" - pure $ Crypto.verify (Just Crypto.SHA256) pubkey message sig + pure $ Crypto.verify (Just Crypto.SHA256) pubkey message (decodeBase64 sig) sign :: FilePath -> ByteString -> IO Signed sign privatePemFile message = do diff --git a/src/Fedi/Requests.hs b/src/Fedi/Requests.hs index e8e83b9..da47ec8 100644 --- a/src/Fedi/Requests.hs +++ b/src/Fedi/Requests.hs @@ -68,7 +68,6 @@ sendGet :: (A.FromJSON a) => String -> IO a sendGet url = do uri <- URI.mkURI $ fromString url (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri) - print ("url", url') Req.runReq Req.defaultHttpConfig do r <- diff --git a/src/Fedi/Signature/Check.hs b/src/Fedi/Signature/Check.hs index a8d2f26..ab829c2 100644 --- a/src/Fedi/Signature/Check.hs +++ b/src/Fedi/Signature/Check.hs @@ -1,4 +1,5 @@ {-# language RecordWildCards #-} +{-# language ViewPatterns #-} module Fedi.Signature.Check ( module Fedi.Signature.Types @@ -15,12 +16,15 @@ import Fedi.Helpers import Web.Twain qualified as Twain import Data.Text qualified as T import Network.Wai qualified as Wai +import Network.HTTP.Types.URI qualified as HTTP import Control.Monad.IO.Class (liftIO) import Text.ParserCombinators.ReadP qualified as P import Data.Text.Encoding qualified as T +import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL import Fedi.Crypto import Fedi.Signature.Types +import Data.CaseInsensitive qualified as CI -- * Check @@ -38,28 +42,62 @@ checkSignatureAndParseBody = do let personPkid = person.otype.publicKey.pkid let personPublicKey = pemToBS person.otype.publicKey.publicKeyPem + signatureString <- + makeSignatureString request sigheader.headers + -- check liftIO $ - checkSignature personPkid personPublicKey sigheader digest (BSL.toStrict body) + checkSignature personPkid personPublicKey sigheader signatureString digest (BSL.toStrict body) -- parse the body and return it parseJson body +makeSignatureString + :: forall m. MonadThrow m => Wai.Request -> [T.Text] -> m ByteString +makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do + let + requestHeaders = Wai.requestHeaders request + method = T.encodeUtf8 $ T.toLower $ T.decodeUtf8 $ Wai.requestMethod request + path = T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request) + <> HTTP.renderQuery True (Wai.queryString request) + requestTarget = method <> " " <> path + let + mylookup :: ByteString -> m ByteString + mylookup header + | header == "(request-target)" = + pure $ header <> ": " <> requestTarget + | header == "host" = do + let result = lookup (CI.mk header) requestHeaders + case result of + Nothing -> throw $ "Missing header '" <> show header <> "'." + Just value -> pure $ header <> ": " + <> if ":443" `BS.isSuffixOf` value + then BS.dropEnd (BS.length ":443") value + else value + | otherwise = do + let result = lookup (CI.mk header) requestHeaders + case result of + Nothing -> throw $ "Missing header '" <> show header <> "'." + Just value -> pure $ header <> ": " <> value + + BS.intercalate "\n" <$> traverse mylookup headers + checkSignature :: MonadThrow m - => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> m () -checkSignature personPkid personPublicKey sigheader _digest body = do + => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> ByteString -> m () +checkSignature personPkid personPublicKey sigheader signatureString digest body = do -- check unless (personPkid == sigheader.keyId) $ throw "public key mismatch with signature." - pub <- verifyPub personPublicKey sigheader.signature body + pub <- verifyPub personPublicKey sigheader.signature signatureString unless pub $ throw "signature verification failed." - -- dig <- verifyDigest personPublicKey digest body - -- unless dig $ - -- throw "digest verification failed." + let + mydigest = "SHA-256=" <> encodeBase64 (makeDigest body) + unless (mydigest == digest) $ + throw "digest verification failed." -- todo: check date @@ -80,6 +118,7 @@ parseSignature minput = do ( decodeBase64 . fromString ) <$> lookup' Signature components + P.eof pure SignatureHeader{..} component = P.choice [ do @@ -95,8 +134,12 @@ parseSignature minput = do 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) + _ <- P.string "algorithm=" + alg <- P.between (P.char '\"') (P.char '\"') (P.string "rsa-sha256") + pure (Algorithm, alg) + -- , do + -- key <- P.munch1 (/= '=') + -- _ <- P.char '=' + -- value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"')) + -- pure (Other key, value) ]