fix digest generation maybe?

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
@@ -52,7 +55,9 @@ library
     , wai
     , exceptions
     , 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
@@ -11,6 +12,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
@@ -20,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
@@ -42,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
 
@@ -64,10 +47,19 @@ ppSigned :: Signed -> String
 ppSigned signed =
   unlines
     [ "Signature"
-    , "{ signedMessage = " <> encodeBase64 signed.signedMessage
-    , ", signedDigest = " <> encodeBase64 signed.signedDigest
+    , "{ signedMessage = " <> encodeBase64String signed.signedMessage
     , "}"
     ]
 
-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 -> ByteString
+makeDigest message =
+   BA.convert (Crypto.hash message :: Crypto.Digest Crypto.SHA256)

src/Fedi/Requests.hs

@@ -2,11 +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)
@@ -15,31 +19,65 @@ sendPost
   -> input
   -> IO output
 sendPost details url payload = do
+  uri <- URI.mkURI $ fromString url
   let encoded = BSL.toStrict $ A.encode payload
-  signed <- sign details encoded
-
+  httpSignature <- makeHttpSignature details uri encoded
+  (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
   Req.runReq Req.defaultHttpConfig do
     r <-
       Req.req
         Req.POST
-        (Req.https $ fromString url)
+        url'
         (Req.ReqBodyBs encoded)
         Req.jsonResponse
-        ( Req.header "ContentType" "application/activity+json"
-          <> Req.header "Digest" signed.signedDigest
-          <> Req.header "Signature" signed.signedMessage
+        ( scheme
+          <> 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
+  (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
+  print ("url", url')
+
   Req.runReq Req.defaultHttpConfig do
     r <-
       Req.req
         Req.GET
-        (Req.https $ fromString url)
+        url'
         Req.NoReqBody
         Req.jsonResponse
-        ( Req.header "ContentType" "application/activity+json"
+        ( scheme
+          <> Req.header "ContentType" "application/activity+json"
         )
     pure $ Req.responseBody r

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)
-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
+import Control.Monad.Catch (catch, displayException, SomeException)
+import Fedi.Signature.Check
 
 -- * Inbox
 
@@ -32,94 +22,8 @@ handleInbox handle = do
       activity <- checkSignatureAndParseBody
       response <- handle activity
       Twain.send response
-  handler `catch` \(Error e) -> do
-    liftIO $ print e
-    Twain.send $ Twain.status Twain.status500 $ Twain.text (T.pack e)
-
--- | 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 $ 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
-    }
-
-data Component
-  = KeyId
-  | Headers
-  | Signature
-  deriving Eq
-
-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
-    _ -> throw "error parsing signature."
-  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 <-
-        ( T.encodeUtf8
-        . Base64.decodeBase64Lenient
-        . T.pack
-        ) <$> 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)
-      ]
+  handler `catch` \(e :: SomeException) -> do
+    liftIO $ putStrLn (displayException e)
+    Twain.send $
+      Twain.status Twain.status500 $
+        Twain.text "Internal Server Error 500"

src/Fedi/Signature/Check.hs

@@ -0,0 +1,102 @@
+{-# 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)
+      ]

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 = "SHA-256=" <> encodeBase64 (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: " <> digest
+    ]

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)

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