When POSTing activities, set a Digest header using SHA-256

src/Network/HTTP/Digest.hs

@@ -0,0 +1,90 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | RFC 3230 defines an extension for HTTP, to support body digests, with
+-- support for partial content, choice of digest algorithm, delta encoding, and
+-- perhaps other improvements over the Content-MD5 header. This module's role
+-- in Vervis is to be responsible for the parts of HTTP instance digests that
+-- aren't specific to requests or to responses. HTTP client and server modules
+-- can then build on top of this module.
+--
+-- Vervis uses HTTP instance digests for HTTP-signing (and verifying) the
+-- SHA-256 hash of the request body, and this module handles only what's
+-- relevant to that, and isn't (yet) a full general-purpose HTTP instance
+-- digest implementation. For example,
+--
+--   * It doesn't support the Want-Digest header
+--   * It supports using a single hash algorithm; it's possible and easy to
+--     accept more than one, but it could be more efficient if this module
+--     intentionally supported that
+module Network.HTTP.Digest
+    ( hDigest
+    , hashHttpBody
+    , parseHttpBodyDigest
+    , formatHttpBodyDigest
+    )
+where
+
+import Prelude
+
+import Crypto.Hash
+import Data.ByteString (ByteString)
+import Network.HTTP.Types.Header
+
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+
+hDigest :: HeaderName
+hDigest = "Digest"
+
+hashHttpBody
+    :: HashAlgorithm a => a -> IO ByteString -> IO (Digest a, BL.ByteString)
+hashHttpBody _algo getChunk = go hashInit id
+    where
+    go context cons = do
+        b <- getChunk
+        if BC.null b
+            then return (hashFinalize context, BL.fromChunks $ cons [])
+            else go (hashUpdate context b) (cons . (b :))
+
+parseHttpBodyDigest
+    :: HashAlgorithm a
+    => a
+    -> ByteString
+    -> [Header]
+    -> Either String (Digest a)
+parseHttpBodyDigest _algo algoName headers = do
+    let digestHeaders = [ h | (n, h) <- headers, n == hDigest ]
+        digests = concatMap (BC.split ' ') digestHeaders
+        chosen =
+            [ d | (n, d) <- map (BC.break (== '=')) digests, n == algoName ]
+    beq <- case chosen of
+        [] -> Left "No digest found for the given algorithm"
+        [x] -> Right x
+        _ -> Left "Multiple digests found for the given algorithm"
+    b64 <- case BC.uncons beq of
+        Just ('=', x) -> Right x
+        _ -> Left "No digest value, '=' character not found"
+    b <- B64.decode b64
+    case digestFromByteString b of
+        Nothing -> Left "Digest length doesn't match the algorithm"
+        Just d -> Right d
+
+formatHttpBodyDigest
+    :: HashAlgorithm a => a -> ByteString -> Digest a -> ByteString
+formatHttpBodyDigest _algo algoName digest =
+    BC.concat [algoName, "=", B64.encode $ BA.convert digest]

src/Web/ActivityPub.hs

@@ -69,6 +69,7 @@ import Control.Monad (when, unless, (<=<), join)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Writer (Writer)
+import Crypto.Hash hiding (Context)
 import Data.Aeson
 import Data.Aeson.Encoding (pair)
 import Data.Aeson.Types (Parser, typeMismatch, listEncoding)
@@ -102,6 +103,7 @@ import qualified Network.HTTP.Signature as S
 
 import Crypto.PublicVerifKey
 import Network.FedURI
+import Network.HTTP.Digest
 
 import Data.Aeson.Local
 
@@ -631,6 +633,7 @@ instance Exception APPostError
 -- * Verify the URI scheme is _https:_ and authority part is present
 -- * Set _Content-Type_ request header
 -- * Set _ActivityPub-Actor_ request header
+-- * Set _Digest_ request header using SHA-256 hash
 -- * Compute HTTP signature and add _Signature_ request header
 -- * Perform the POST request
 -- * Verify the response status is 2xx
@@ -645,12 +648,15 @@ httpPostAP
     -> m (Either APPostError (Response ()))
 httpPostAP manager uri headers sign uActor value = liftIO $ do
     req <- requestFromURI $ toURI uri
-    let req' =
+    let body = encode value
+        digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
+        req' =
             setRequestCheckStatus $
             consHeader hContentType typeActivityStreams2LD $
             consHeader hActivityPubActor (encodeUtf8 uActor) $
+            consHeader hDigest digest $
             req { method      = "POST"
-                , requestBody = RequestBodyLBS $ encode value
+                , requestBody = RequestBodyLBS body
                 }
         sign' b =
             let (k, s) = sign b

vervis.cabal

@@ -85,6 +85,7 @@ library
                        Language.Haskell.TH.Quote.Local
                        Network.FedURI
                        Network.HTTP.Client.Conduit.ActivityPub
+                       Network.HTTP.Digest
                        Network.SSH.Local
                        Text.Blaze.Local
                        Text.Display