verify signatures

fedi.cabal

@@ -61,6 +61,8 @@ library
     , crypton
     , crypton-x509
     , cryptostore
+    , case-insensitive
+    , http-types
 
   hs-source-dirs: src
   default-language: GHC2021

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

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 <-

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)
       ]