Update activity POSTing code to use the new forwarding mechanism

It's not documented yet, but basically I replaced the custom input string with
an HTTPSig based one.

src/Web/ActivityPub.hs

@@ -88,13 +88,14 @@ import Data.Traversable
 import Data.Vector (Vector)
 import Network.HTTP.Client hiding (Proxy, proxy)
 import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
-import Network.HTTP.Client.Signature (signRequest)
 import Network.HTTP.Simple (JSONException)
 import Network.HTTP.Types.Header (HeaderName, hContentType)
 import Network.URI
 import Yesod.Core.Content (ContentType)
 import Yesod.Core.Handler (ProvidedRep, provideRepType)
 
+import Network.HTTP.Client.Signature
+
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as BC
@@ -630,14 +631,14 @@ data APPostError
 
 instance Exception APPostError
 
-hActivityPubSignature :: HeaderName
-hActivityPubSignature = "ActivityPub-Signature"
+hActivityPubForwarder :: HeaderName
+hActivityPubForwarder = "ActivityPub-Forwarder"
 
-hActivityPubFwdSignature :: HeaderName
-hActivityPubFwdSignature = "ActivityPub-Forwarded-Signature"
+hForwardingSignature :: HeaderName
+hForwardingSignature = "Forwarding-Signature"
 
-hActivityPubFwdKeyId :: HeaderName
-hActivityPubFwdKeyId = "ActivityPub-Forwarded-KeyId"
+hForwardedSignature :: HeaderName
+hForwardedSignature = "Forwarded-Signature"
 
 -- | Perform an HTTP POST request to submit an ActivityPub object.
 --
@@ -645,8 +646,10 @@ hActivityPubFwdKeyId = "ActivityPub-Forwarded-KeyId"
 -- * 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
+-- * If recipient is given, set _ActivityPub-Forwarder_ header and compute
+--   _Forwarding-Signature_ header
+-- * If forwarded signature is given, set set _ActivityPub-Forwarder_ and
+--   _Forwarded-Signature_ headers
 -- * Compute HTTP signature and add _Signature_ request header
 -- * Perform the POST request
 -- * Verify the response status is 2xx
@@ -658,42 +661,38 @@ httpPostAP
     -> S.KeyId
     -> (ByteString -> S.Signature)
     -> Text
-    -> Maybe (Either FedURI (S.KeyId, ByteString))
+    -> Maybe (Either FedURI ByteString)
     -> a
     -> m (Either APPostError (Response ()))
-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
-        req' =
-            setRequestCheckStatus $
-            consHeader hContentType typeActivityStreams2LD $
-            consHeader hActivityPubActor (encodeUtf8 uActor) $
-            consHeader hDigest digest $
-            consSigHeaders digest $
-            req { method      = "POST"
-                , requestBody = RequestBodyLBS body
-                }
-        sign' b =
-            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)
+httpPostAP manager uri headers keyid sign uSender mfwd value =
+    liftIO $ runExceptT $ do
+        req <- requestFromURI $ toURI uri
+        let body = encode value
+            digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
+            req' =
+                setRequestCheckStatus $
+                consHeader hContentType typeActivityStreams2LD $
+                consHeader hActivityPubActor (encodeUtf8 uSender) $
+                consHeader hDigest digest $
+                req { method      = "POST"
+                    , requestBody = RequestBodyLBS body
+                    }
+        req'' <- tryExceptT APPostErrorSig $ signRequest headers Nothing keyid sign Nothing req'
+        req''' <-
+            case mfwd of
+                Nothing -> return req''
+                Just (Left uRecip) ->
+                    tryExceptT APPostErrorSig $
+                        signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign Nothing $ consHeader hActivityPubForwarder (encodeUtf8 $ renderFedURI uRecip) req''
+                Just (Right sig) ->
+                    return $
+                        consHeader hForwardedSignature sig $
+                        consHeader hActivityPubForwarder (encodeUtf8 uSender)
+                            req''
+        tryExceptT APPostErrorHTTP $ 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
+    tryExceptT adapt action = ExceptT $ first adapt <$> try action
 
 -- | Result of GETing the keyId URI and processing the JSON document.
 data Fetched = Fetched

src/Yesod/ActivityPub.hs

@@ -46,12 +46,12 @@ postActivity
        , YesodActivityPub site
        )
     => FedURI
-    -> Maybe (Either FedURI (KeyId, ByteString))
+    -> Maybe (Either FedURI ByteString)
     -> Doc Activity
     -> m (Either APPostError (Response ()))
-postActivity inbox mrecip doc@(Doc hAct activity) = do
+postActivity inbox mfwd doc@(Doc hAct activity) = do
     manager <- asksSite getHttpManager
     headers <- asksSite sitePostSignedHeaders
     (keyid, sign) <- siteGetHttpSign
     let sender = renderFedURI $ l2f hAct (activityActor activity)
-    httpPostAP manager inbox headers keyid sign sender mrecip doc
+    httpPostAP manager inbox headers keyid sign sender mfwd doc