diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 7f67728..6243712 100644 --- a/src/Vervis/Federation.hs +++ b/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) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 27aa850..9481fba 100644 --- a/src/Web/ActivityPub.hs +++ b/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