When receiving activity to inbox, verify the body digest

This patch does a small simple change, however at the cost of the request body
not being available for display in the latest activity list, unless processing
succeeds. I'll fix this situation in a separate patch.

src/Vervis/Foundation.hs

@@ -24,6 +24,7 @@ import Control.Monad.STM (atomically)
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Crypto.Error (CryptoFailable (..))
+import Crypto.Hash.Algorithms
 import Data.Char
 import Data.Either (isRight)
 import Data.HashMap.Strict (HashMap)
@@ -35,9 +36,10 @@ import Data.Time.Units (Second, Minute, Day)
 import Database.Persist.Postgresql
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Graphics.SVGFonts.ReadFont (PreparedFont)
-import Network.HTTP.Client
+import Network.HTTP.Client (Manager, HasHttpManager (..))
 import Network.HTTP.Types.Header (hHost)
 import Network.URI (URI, uriAuthority, uriFragment, uriRegName, parseURI)
+import Network.Wai
 import Text.Shakespeare.Text (textFile)
 import Text.Hamlet          (hamletFile)
 --import Text.Jasmine         (minifym)
@@ -57,7 +59,8 @@ import qualified Yesod.Core.Unsafe as Unsafe
 import qualified Data.Text as T
 --import qualified Data.Text.Encoding as TE
 
-import Network.HTTP.Signature hiding (Algorithm (..))
+import Network.HTTP.Digest
+import Network.HTTP.Signature hiding (Algorithm (..), requestHeaders)
 import Yesod.Auth.Unverified
 import Yesod.Auth.Unverified.Creds
 import Yesod.HttpSignature (YesodHttpSig (..))
@@ -647,8 +650,8 @@ data ActorDetail = ActorDetail
     }
 
 instance YesodHttpSig App where
-    data HttpSigVerResult App = HttpSigVerResult (Either String ActorDetail)
+    data HttpSigVerResult App = HttpSigVerResult (Either String (ActorDetail, BL.ByteString))
-    httpSigVerRequiredHeaders = const [hRequestTarget, hHost]
+    httpSigVerRequiredHeaders = const [hRequestTarget, hHost, hDigest]
     httpSigVerWantedHeaders = const [hActivityPubActor]
     httpSigVerSeconds =
         fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
@@ -658,6 +661,7 @@ instance YesodHttpSig App where
     httpVerifySig (Verification malgo (KeyId keyid) input (Signature signature)) = fmap HttpSigVerResult $ runExceptT $ do
         (host, luKey) <- f2l <$> parseKeyId keyid
         checkHost host
+        body <- verifyBodyDigest
         mluActorHeader <- getActorHeader host
         manager <- getsYesod appHttpManager
         (inboxOrVkid, vkd) <- do
@@ -736,11 +740,14 @@ instance YesodHttpSig App where
                                 return (iid, rsid)
                             else errSig2
 
-        return ActorDetail
+        return
-            { actorDetailId       = l2f host $ vkdActorId vkd
+            ( ActorDetail
-            , actorDetailInstance = iid
+                { actorDetailId       = l2f host $ vkdActorId vkd
-            , actorDetailSharer   = rsid
+                , actorDetailInstance = iid
-            }
+                , actorDetailSharer   = rsid
+                }
+            , body
+            )
         where
         parseKeyId k =
             case parseFedURI =<< (first displayException . decodeUtf8') k of
@@ -756,6 +763,16 @@ instance YesodHttpSig App where
                 throwE "Received HTTP signed request from the instance's host"
             where
             isAsciiLetter c = isAsciiLower c || isAsciiUpper c
+        verifyBodyDigest = do
+            req <- waiRequest
+            let headers = requestHeaders req
+            digest <- case parseHttpBodyDigest SHA256 "SHA-256" headers of
+                Left s -> throwE $ "Parsing digest header failed: " ++ s
+                Right d -> return d
+            (digest', body) <- liftIO $ hashHttpBody SHA256 (requestBody req)
+            unless (digest == digest') $
+                throwE "Body digest verification failed"
+            return body
         getActorHeader host = do
             bs <- lookupHeaders hActivityPubActor
             case bs of

src/Vervis/Handler/Inbox.hs

@@ -138,21 +138,24 @@ postSharerInboxR shrRecip = do
     federation <- getsYesod $ appFederation . appSettings
     unless federation badMethod
     contentTypes <- lookupHeaders "Content-Type"
-    body <- requireJsonBody
     now <- liftIO getCurrentTime
-    result <- go now contentTypes body
+    result <- go now contentTypes
-    recordActivity now result contentTypes body
+    recordActivity now result contentTypes
     case result of
         Left _ -> sendResponseStatus badRequest400 ()
         Right _ -> return ()
     where
-    go now ctypes (WithValue raw (Doc hActivity activity)) = runExceptT $ do
+    go now ctypes = runExceptT $ do
         verifyContentType
         HttpSigVerResult result <-
             ExceptT $
                 first (T.pack . displayException) <$>
                     verifyRequestSignature now
-        ActorDetail uSender iid _raid <- ExceptT $ pure $ first T.pack result
+        (ActorDetail uSender iid _raid, body) <- ExceptT $ pure $ first T.pack result
+        WithValue raw (Doc hActivity activity) <-
+            case eitherDecode' body of
+                Left s -> throwE $ "Parsing activity failed: " <> T.pack s
+                Right wv -> return wv
         let (hSender, luSender) = f2l uSender
         unless (hSender == hActivity) $
             throwE $ T.concat
@@ -165,7 +168,7 @@ postSharerInboxR shrRecip = do
                 , renderFedURI $ l2f hActivity $ activityActor activity
                 , "> != Signature key's actor <", renderFedURI uSender, ">"
                 ]
-        handleSharerInbox now shrRecip iid raw activity
+        (raw,) <$> handleSharerInbox now shrRecip iid raw activity
         where
         verifyContentType =
             case ctypes of
@@ -183,12 +186,14 @@ postSharerInboxR shrRecip = do
             typeAS2 =
                 "application/ld+json; \
                 \profile=\"https://www.w3.org/ns/activitystreams\""
-    recordActivity now result contentTypes body = do
+    recordActivity now result contentTypes = do
         acts <- getsYesod appActivities
         liftIO $ atomically $ modifyTVar' acts $ \ vec ->
-            let msg = either id id result
+            let (msg, body) =
-                formattedBody = encodePretty $ wvRaw body
+                    case result of
-                item = ActivityReport now msg contentTypes formattedBody
+                        Left t -> (t, "{?}")
+                        Right (o, t) -> (t, encodePretty o)
+                item = ActivityReport now msg contentTypes body
                 vec' = item `V.cons` vec
             in  if V.length vec' > 10
                     then V.init vec'