fedi.cabal

@@ -24,9 +24,6 @@ library
     Fedi.UserDetails
     Fedi.Webfinger
     Fedi.Crypto
-    Fedi.Signature.Types
-    Fedi.Signature.Check
-    Fedi.Signature.Sign
 
     Fedi.Routes
     Fedi.Routes.Helpers
@@ -55,9 +52,7 @@ library
     , wai
     , exceptions
     , req
-    , modern-uri
     , base64
-    , memory
     , crypton
     , crypton-x509
     , cryptostore

src/Fedi/Crypto.hs

@@ -3,7 +3,6 @@
 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
@@ -12,7 +11,6 @@ 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
@@ -22,6 +20,16 @@ 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
@@ -34,12 +42,21 @@ 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{..}
 
-newtype Signed
+data Signed
   = Signed
     { signedMessage :: ByteString
+    , signedDigest :: ByteString
     }
   deriving Show
 
@@ -47,19 +64,10 @@ ppSigned :: Signed -> String
 ppSigned signed =
   unlines
     [ "Signature"
-    , "{ signedMessage = " <> encodeBase64String signed.signedMessage
+    , "{ signedMessage = " <> encodeBase64 signed.signedMessage
+    , ", signedDigest = " <> encodeBase64 signed.signedDigest
     , "}"
     ]
 
-encodeBase64 :: ByteString -> ByteString
+encodeBase64 :: ByteString -> String
-encodeBase64 = Base64.extractBase64 . Base64.encodeBase64'
+encodeBase64 = show . 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,15 +2,11 @@
 
 module Fedi.Requests where
 
-import Data.List (intercalate)
 import Data.Aeson qualified as A
-import Fedi.Helpers
 import Fedi.UserDetails
-import Fedi.Signature.Sign
+import Fedi.Crypto
 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)
@@ -19,65 +15,31 @@ sendPost
   -> input
   -> IO output
 sendPost details url payload = do
-  uri <- URI.mkURI $ fromString url
   let encoded = BSL.toStrict $ A.encode payload
-  httpSignature <- makeHttpSignature details uri encoded
+  signed <- sign details encoded
-  (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
+
   Req.runReq Req.defaultHttpConfig do
     r <-
       Req.req
         Req.POST
-        url'
+        (Req.https $ fromString url)
         (Req.ReqBodyBs encoded)
         Req.jsonResponse
-        ( scheme
+        ( Req.header "ContentType" "application/activity+json"
-          <> sigHeaders httpSignature
+          <> Req.header "Digest" signed.signedDigest
+          <> Req.header "Signature" signed.signedMessage
         )
     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
-        url'
+        (Req.https $ fromString url)
         Req.NoReqBody
         Req.jsonResponse
-        ( scheme
+        ( Req.header "ContentType" "application/activity+json"
-          <> Req.header "ContentType" "application/activity+json"
         )
     pure $ Req.responseBody r

src/Fedi/Routes/Inbox.hs

@@ -1,13 +1,23 @@
+{-# 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 Control.Monad.Catch (catch)
-import Fedi.Signature.Check
+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
 
 -- * Inbox
 
@@ -22,8 +32,94 @@ handleInbox handle = do
       activity <- checkSignatureAndParseBody
       response <- handle activity
       Twain.send response
-  handler `catch` \(e :: SomeException) -> do
+  handler `catch` \(Error e) -> do
-    liftIO $ putStrLn (displayException e)
+    liftIO $ print e
-    Twain.send $
+    Twain.send $ Twain.status Twain.status500 $ Twain.text (T.pack e)
-      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 $ 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)
+      ]

src/Fedi/Signature/Check.hs

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

@@ -1,48 +0,0 @@
-{-# 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

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