diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 9481fba..e04732f 100644 --- a/src/Web/ActivityPub.hs +++ b/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 diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index 68ab564..1fb5326 100644 --- a/src/Yesod/ActivityPub.hs +++ b/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