fix digest generation maybe?

fedi.cabal

@@ -57,6 +57,7 @@ library
     , req
     , modern-uri
     , base64
+    , memory
     , crypton
     , crypton-x509
     , cryptostore

src/Fedi/Crypto.hs

@@ -3,6 +3,7 @@
 module Fedi.Crypto where
 
 import Crypto.Hash qualified as Crypto
+import Data.ByteArray qualified as BA
 import Crypto.PubKey.RSA.PSS qualified as Crypto
 import Crypto.Store.X509 qualified as Crypto
 import Crypto.Store.PKCS8 qualified as Crypto
@@ -21,16 +22,6 @@ verifyPub pubkeypem sig message = do
       _ -> throw "failed to read pubkey pem"
   pure $ Crypto.verify (Crypto.defaultPSSParams Crypto.SHA256) pubkey message sig
 
-verifyDigest :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool
-verifyDigest pubkeypem sig digest' = do
-  pubkey <-
-    case Crypto.readPubKeyFileFromMemory pubkeypem of
-      [Crypto.PubKeyRSA pubkey'] -> pure pubkey'
-      _ -> throw "failed to read pubkey pem"
-  let
-    digest = Crypto.hash digest'
-  pure $ Crypto.verifyDigest (Crypto.defaultPSSParams Crypto.SHA256) pubkey digest sig
-
 sign :: UserDetails -> ByteString -> IO Signed
 sign details message = do
   -- get private key
@@ -43,21 +34,12 @@ sign details message = do
   signedMessage <- either (throw . show) pure =<<
     Crypto.sign Nothing (Crypto.defaultPSSParams Crypto.SHA256) privateKey message
 
-  -- sign digest
-  let
-    digest :: Crypto.Digest Crypto.SHA256
-    digest = Crypto.hash message
-
-  signedDigest <- either (throw . show) pure =<<
-    Crypto.signDigest Nothing (Crypto.defaultPSSParams Crypto.SHA256) privateKey digest
-
   -- return
   pure Signed{..}
 
-data Signed
+newtype Signed
   = Signed
     { signedMessage :: ByteString
-    , signedDigest :: ByteString
     }
   deriving Show
 
@@ -66,7 +48,6 @@ ppSigned signed =
   unlines
     [ "Signature"
     , "{ signedMessage = " <> encodeBase64String signed.signedMessage
-    , ", signedDigest = " <> encodeBase64String signed.signedDigest
     , "}"
     ]
 
@@ -79,6 +60,6 @@ encodeBase64String = T.unpack . Base64.extractBase64 . Base64.encodeBase64
 decodeBase64 :: ByteString -> ByteString
 decodeBase64 = Base64.decodeBase64Lenient
 
-makeDigest :: ByteString -> String
+makeDigest :: ByteString -> ByteString
 makeDigest message =
-  show (Crypto.hash message :: Crypto.Digest Crypto.SHA256)
+   BA.convert (Crypto.hash message :: Crypto.Digest Crypto.SHA256)

src/Fedi/Signature/Check.hs

@@ -48,7 +48,7 @@ checkSignatureAndParseBody = do
 checkSignature
   :: MonadThrow m
   => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> m ()
-checkSignature personPkid personPublicKey sigheader digest body = do
+checkSignature personPkid personPublicKey sigheader _digest body = do
   -- check
   unless (personPkid == sigheader.keyId) $
     throw "public key mismatch with signature."
@@ -57,9 +57,10 @@ checkSignature personPkid personPublicKey sigheader digest body = do
   unless pub $
     throw "signature verification failed."
 
-  dig <- verifyDigest personPublicKey digest body
+  -- dig <- verifyDigest personPublicKey digest body
-  unless dig $
+  -- unless dig $
-    throw "digest verification failed."
+  --   throw "digest verification failed."
+
   -- todo: check date
 
 parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader

src/Fedi/Signature/Sign.hs

@@ -23,7 +23,7 @@ signSignature details host requestTarget body = do
     <&> Time.formatTime Time.defaultTimeLocale Time.rfc822DateFormat
 
   let
-    digest = encodeBase64 $ fromString $ makeDigest body
+    digest = "SHA-256=" <> encodeBase64 (makeDigest body)
     keyId = actorUrl details <> "#main-key"
     headers = ["(request-target)", "host", "date", "digest"]
     components = []
@@ -44,5 +44,5 @@ makeSignatureString host requestTarget date digest =
     [ "(request-target): " <> fromString requestTarget
     , "host: " <> fromString host
     , "date: " <> fromString date
-    , "digest: SHA-256=" <> digest
+    , "digest: " <> digest
     ]

src/Fedi/Types.hs

@@ -48,7 +48,10 @@ instance (ToObject a) => A.ToJSON (Object a) where
 instance (ToObject a) => ToObject (Object a) where
   toObject object =
     [ "@context"
-        A..= ("https://www.w3.org/ns/activitystreams" :: String)
+        A..=
+        [ ("https://www.w3.org/ns/activitystreams" :: String)
+        , ("https://w3id.org/security/v1" :: String)
+        ]
     ]
       <> toObject object.otype
       <> [ assignment