is this how you sign? 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

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)

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

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

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

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

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)