diff --git a/src/Network/HTTP/Digest.hs b/src/Network/HTTP/Digest.hs new file mode 100644 index 0000000..1d3551d --- /dev/null +++ b/src/Network/HTTP/Digest.hs @@ -0,0 +1,90 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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] diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 0160be1..27aa850 100644 --- a/src/Web/ActivityPub.hs +++ b/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 diff --git a/vervis.cabal b/vervis.cabal index f23a996..1e473cc 100644 --- a/vervis.cabal +++ 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