Return keyid and digest after inbox verification, for use in forwarding

src/Vervis/Foundation.hs

@@ -24,7 +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 Crypto.Hash
 import Data.Char
 import Data.Either (isRight)
 import Data.HashMap.Strict (HashMap)
@@ -663,8 +663,17 @@ data ActorDetail = ActorDetail
     , actorDetailSharer   :: RemoteActorId
     }
 
+data ActivityDetail = ActivityDetail
+    { _actdAuthorURI :: FedURI
+    , _actdInstance  :: InstanceId
+    , _actdAuthorId  :: RemoteActorId
+    , _actdRawBody   :: BL.ByteString
+    , _actdSignKey   :: KeyId
+    , _actdDigest    :: Digest SHA256
+    }
+
 instance YesodHttpSig App where
-    data HttpSigVerResult App = HttpSigVerResult (Either String (ActorDetail, BL.ByteString))
+    data HttpSigVerResult App = HttpSigVerResult (Either String ActivityDetail)
     httpSigVerRequiredHeaders = const [hRequestTarget, hHost, hDigest]
     httpSigVerWantedHeaders = const [hActivityPubActor]
     httpSigVerSeconds =
@@ -675,7 +684,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
+        (body, digest) <- verifyBodyDigest
         mluActorHeader <- getActorHeader host
         manager <- getsYesod appHttpManager
         (inboxOrVkid, vkd) <- do
@@ -754,14 +763,14 @@ instance YesodHttpSig App where
                                 return (iid, rsid)
                             else errSig2
 
-        return
-            ( ActorDetail
-                { actorDetailId       = l2f host $ vkdActorId vkd
-                , actorDetailInstance = iid
-                , actorDetailSharer   = rsid
-                }
-            , body
-            )
+        return ActivityDetail
+            { _actdAuthorURI = l2f host $ vkdActorId vkd
+            , _actdInstance  = iid
+            , _actdAuthorId  = rsid
+            , _actdRawBody   = body
+            , _actdSignKey   = KeyId keyid
+            , _actdDigest    = digest
+            }
         where
         parseKeyId k =
             case parseFedURI =<< (first displayException . decodeUtf8') k of
@@ -786,7 +795,7 @@ instance YesodHttpSig App where
             (digest', body) <- liftIO $ hashHttpBody SHA256 (requestBody req)
             unless (digest == digest') $
                 throwE "Body digest verification failed"
-            return body
+            return (body, digest)
         getActorHeader host = do
             bs <- lookupHeaders hActivityPubActor
             case bs of

src/Vervis/Handler/Inbox.hs

@@ -152,7 +152,7 @@ postSharerInboxR shrRecip = do
             ExceptT $
                 first (T.pack . displayException) <$>
                     verifyRequestSignature now
-        (ActorDetail uSender iid _raid, body) <- ExceptT $ pure $ first T.pack result
+        ActivityDetail uSender iid _raid body _keyid _digest <- ExceptT $ pure $ first T.pack result
         WithValue raw (Doc hActivity activity) <-
             case eitherDecode' body of
                 Left s -> throwE $ "Parsing activity failed: " <> T.pack s