In httpPostAP, support the new signature headers

src/Vervis/Federation.hs

@@ -496,7 +496,7 @@ newtype FedError = FedError Text deriving Show
 instance Exception FedError
 
 getHttpSign
-    :: (MonadSite m, SiteEnv m ~ App) => m (ByteString -> (KeyId, Signature))
+    :: (MonadSite m, SiteEnv m ~ App) => m (KeyId, ByteString -> Signature)
 getHttpSign = do
     (akey1, akey2, new1) <- liftIO . readTVarIO =<< asksSite appActorKeys
     renderUrl <- askUrlRender
@@ -504,20 +504,20 @@ getHttpSign = do
             if new1
                 then (renderUrl ActorKey1R, akey1)
                 else (renderUrl ActorKey2R, akey2)
-    return $ \ b -> (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
+    return (KeyId $ encodeUtf8 keyID, actorKeySign akey)
 
 deliverHttp
     :: (MonadSite m, SiteEnv m ~ App)
-    => (ByteString -> (KeyId, Signature))
+    => (KeyId, ByteString -> Signature)
     -> Doc Activity
     -> Text
     -> LocalURI
     -> m (Either APPostError (Response ()))
-deliverHttp sign doc h luInbox = do
+deliverHttp (keyid, sign) doc h luInbox = do
     manager <- asksSite appHttpManager
     let inbox = l2f h luInbox
         headers = hRequestTarget :| [hHost, hDate, hActivityPubActor]
-    httpPostAP manager inbox headers sign docActor doc
+    httpPostAP manager inbox headers keyid sign docActor Nothing doc
     where
     docActor = renderFedURI $ l2f (docHost doc) (activityActor $ docValue doc)
 

src/Web/ActivityPub.hs

@@ -95,6 +95,8 @@ import Network.URI
 import Yesod.Core.Content (ContentType)
 import Yesod.Core.Handler (ProvidedRep, provideRepType)
 
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.HashMap.Strict as M (lookup)
 import qualified Data.Text as T (pack, unpack)
@@ -628,12 +630,23 @@ data APPostError
 
 instance Exception APPostError
 
+hActivityPubSignature :: HeaderName
+hActivityPubSignature = "ActivityPub-Signature"
+
+hActivityPubFwdSignature :: HeaderName
+hActivityPubFwdSignature = "ActivityPub-Forwarded-Signature"
+
+hActivityPubFwdKeyId :: HeaderName
+hActivityPubFwdKeyId = "ActivityPub-Forwarded-KeyId"
+
 -- | Perform an HTTP POST request to submit an ActivityPub object.
 --
 -- * 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
+-- * If recipient is given, compute and set _ActivityPub-Signature_ header
+-- * If forwarded key ID and digest are given, set headers for them
 -- * Compute HTTP signature and add _Signature_ request header
 -- * Perform the POST request
 -- * Verify the response status is 2xx
@@ -642,11 +655,13 @@ httpPostAP
     => Manager
     -> FedURI
     -> NonEmpty HeaderName
-    -> (ByteString -> (S.KeyId, S.Signature))
+    -> S.KeyId
+    -> (ByteString -> S.Signature)
     -> Text
+    -> Maybe (Either FedURI (S.KeyId, ByteString))
     -> a
     -> m (Either APPostError (Response ()))
-httpPostAP manager uri headers sign uActor value = liftIO $ do
+httpPostAP manager uri headers keyid sign uActor mrecip value = liftIO $ do
     req <- requestFromURI $ toURI uri
     let body = encode value
         digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
@@ -655,18 +670,30 @@ httpPostAP manager uri headers sign uActor value = liftIO $ do
             consHeader hContentType typeActivityStreams2LD $
             consHeader hActivityPubActor (encodeUtf8 uActor) $
             consHeader hDigest digest $
+            consSigHeaders digest $
             req { method      = "POST"
                 , requestBody = RequestBodyLBS body
                 }
         sign' b =
-            let (k, s) = sign b
-            in  (Nothing, k, s)
+            let s = sign b
+            in  (Nothing, keyid, s)
     ereq <- try $ signRequest headers sign' Nothing req'
     case ereq of
         Left sigErr -> return $ Left $ APPostErrorSig sigErr
         Right req'' -> first APPostErrorHTTP <$> try (httpNoBody req'' manager)
     where
     consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
+    unsig (S.Signature b) = b
+    consSigHeaders digest =
+        case mrecip of
+            Nothing -> id
+            Just (Left recip) ->
+                consHeader hActivityPubActor $
+                    B64.encode $ unsig $ sign $
+                        B.concat [digest, ".", encodeUtf8 $ renderFedURI recip]
+            Just (Right (S.KeyId fwdK, fwdD)) ->
+                consHeader hActivityPubFwdKeyId fwdK .
+                consHeader hActivityPubFwdSignature fwdD
 
 -- | Result of GETing the keyId URI and processing the JSON document.
 data Fetched = Fetched