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.
This commit is contained in:
parent
1fcec035f0
commit
951364036f
2 changed files with 43 additions and 44 deletions
|
@ -88,13 +88,14 @@ import Data.Traversable
|
||||||
import Data.Vector (Vector)
|
import Data.Vector (Vector)
|
||||||
import Network.HTTP.Client hiding (Proxy, proxy)
|
import Network.HTTP.Client hiding (Proxy, proxy)
|
||||||
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
||||||
import Network.HTTP.Client.Signature (signRequest)
|
|
||||||
import Network.HTTP.Simple (JSONException)
|
import Network.HTTP.Simple (JSONException)
|
||||||
import Network.HTTP.Types.Header (HeaderName, hContentType)
|
import Network.HTTP.Types.Header (HeaderName, hContentType)
|
||||||
import Network.URI
|
import Network.URI
|
||||||
import Yesod.Core.Content (ContentType)
|
import Yesod.Core.Content (ContentType)
|
||||||
import Yesod.Core.Handler (ProvidedRep, provideRepType)
|
import Yesod.Core.Handler (ProvidedRep, provideRepType)
|
||||||
|
|
||||||
|
import Network.HTTP.Client.Signature
|
||||||
|
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Base64 as B64
|
import qualified Data.ByteString.Base64 as B64
|
||||||
import qualified Data.ByteString.Char8 as BC
|
import qualified Data.ByteString.Char8 as BC
|
||||||
|
@ -630,14 +631,14 @@ data APPostError
|
||||||
|
|
||||||
instance Exception APPostError
|
instance Exception APPostError
|
||||||
|
|
||||||
hActivityPubSignature :: HeaderName
|
hActivityPubForwarder :: HeaderName
|
||||||
hActivityPubSignature = "ActivityPub-Signature"
|
hActivityPubForwarder = "ActivityPub-Forwarder"
|
||||||
|
|
||||||
hActivityPubFwdSignature :: HeaderName
|
hForwardingSignature :: HeaderName
|
||||||
hActivityPubFwdSignature = "ActivityPub-Forwarded-Signature"
|
hForwardingSignature = "Forwarding-Signature"
|
||||||
|
|
||||||
hActivityPubFwdKeyId :: HeaderName
|
hForwardedSignature :: HeaderName
|
||||||
hActivityPubFwdKeyId = "ActivityPub-Forwarded-KeyId"
|
hForwardedSignature = "Forwarded-Signature"
|
||||||
|
|
||||||
-- | Perform an HTTP POST request to submit an ActivityPub object.
|
-- | Perform an HTTP POST request to submit an ActivityPub object.
|
||||||
--
|
--
|
||||||
|
@ -645,8 +646,10 @@ hActivityPubFwdKeyId = "ActivityPub-Forwarded-KeyId"
|
||||||
-- * Set _Content-Type_ request header
|
-- * Set _Content-Type_ request header
|
||||||
-- * Set _ActivityPub-Actor_ request header
|
-- * Set _ActivityPub-Actor_ request header
|
||||||
-- * Set _Digest_ request header using SHA-256 hash
|
-- * Set _Digest_ request header using SHA-256 hash
|
||||||
-- * If recipient is given, compute and set _ActivityPub-Signature_ header
|
-- * If recipient is given, set _ActivityPub-Forwarder_ header and compute
|
||||||
-- * If forwarded key ID and digest are given, set headers for them
|
-- _Forwarding-Signature_ header
|
||||||
|
-- * If forwarded signature is given, set set _ActivityPub-Forwarder_ and
|
||||||
|
-- _Forwarded-Signature_ headers
|
||||||
-- * Compute HTTP signature and add _Signature_ request header
|
-- * Compute HTTP signature and add _Signature_ request header
|
||||||
-- * Perform the POST request
|
-- * Perform the POST request
|
||||||
-- * Verify the response status is 2xx
|
-- * Verify the response status is 2xx
|
||||||
|
@ -658,42 +661,38 @@ httpPostAP
|
||||||
-> S.KeyId
|
-> S.KeyId
|
||||||
-> (ByteString -> S.Signature)
|
-> (ByteString -> S.Signature)
|
||||||
-> Text
|
-> Text
|
||||||
-> Maybe (Either FedURI (S.KeyId, ByteString))
|
-> Maybe (Either FedURI ByteString)
|
||||||
-> a
|
-> a
|
||||||
-> m (Either APPostError (Response ()))
|
-> m (Either APPostError (Response ()))
|
||||||
httpPostAP manager uri headers keyid sign uActor mrecip value = liftIO $ do
|
httpPostAP manager uri headers keyid sign uSender mfwd value =
|
||||||
|
liftIO $ runExceptT $ do
|
||||||
req <- requestFromURI $ toURI uri
|
req <- requestFromURI $ toURI uri
|
||||||
let body = encode value
|
let body = encode value
|
||||||
digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
|
digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
|
||||||
req' =
|
req' =
|
||||||
setRequestCheckStatus $
|
setRequestCheckStatus $
|
||||||
consHeader hContentType typeActivityStreams2LD $
|
consHeader hContentType typeActivityStreams2LD $
|
||||||
consHeader hActivityPubActor (encodeUtf8 uActor) $
|
consHeader hActivityPubActor (encodeUtf8 uSender) $
|
||||||
consHeader hDigest digest $
|
consHeader hDigest digest $
|
||||||
consSigHeaders digest $
|
|
||||||
req { method = "POST"
|
req { method = "POST"
|
||||||
, requestBody = RequestBodyLBS body
|
, requestBody = RequestBodyLBS body
|
||||||
}
|
}
|
||||||
sign' b =
|
req'' <- tryExceptT APPostErrorSig $ signRequest headers Nothing keyid sign Nothing req'
|
||||||
let s = sign b
|
req''' <-
|
||||||
in (Nothing, keyid, s)
|
case mfwd of
|
||||||
ereq <- try $ signRequest headers sign' Nothing req'
|
Nothing -> return req''
|
||||||
case ereq of
|
Just (Left uRecip) ->
|
||||||
Left sigErr -> return $ Left $ APPostErrorSig sigErr
|
tryExceptT APPostErrorSig $
|
||||||
Right req'' -> first APPostErrorHTTP <$> try (httpNoBody req'' manager)
|
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
|
where
|
||||||
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
||||||
unsig (S.Signature b) = b
|
tryExceptT adapt action = ExceptT $ first adapt <$> try action
|
||||||
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.
|
-- | Result of GETing the keyId URI and processing the JSON document.
|
||||||
data Fetched = Fetched
|
data Fetched = Fetched
|
||||||
|
|
|
@ -46,12 +46,12 @@ postActivity
|
||||||
, YesodActivityPub site
|
, YesodActivityPub site
|
||||||
)
|
)
|
||||||
=> FedURI
|
=> FedURI
|
||||||
-> Maybe (Either FedURI (KeyId, ByteString))
|
-> Maybe (Either FedURI ByteString)
|
||||||
-> Doc Activity
|
-> Doc Activity
|
||||||
-> m (Either APPostError (Response ()))
|
-> m (Either APPostError (Response ()))
|
||||||
postActivity inbox mrecip doc@(Doc hAct activity) = do
|
postActivity inbox mfwd doc@(Doc hAct activity) = do
|
||||||
manager <- asksSite getHttpManager
|
manager <- asksSite getHttpManager
|
||||||
headers <- asksSite sitePostSignedHeaders
|
headers <- asksSite sitePostSignedHeaders
|
||||||
(keyid, sign) <- siteGetHttpSign
|
(keyid, sign) <- siteGetHttpSign
|
||||||
let sender = renderFedURI $ l2f hAct (activityActor activity)
|
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
|
||||||
|
|
Loading…
Reference in a new issue