diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index d40b7be..9dde4cc 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -43,6 +43,7 @@ module Web.ActivityPub , provideAP , APGetError (..) , httpGetAP + , APPostError (..) , httpPostAP , Fetched (..) , fetchAPID @@ -79,7 +80,7 @@ import Data.Time.Clock (UTCTime) import Network.HTTP.Client hiding (Proxy, proxy) import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Client.Signature (signRequest) -import Network.HTTP.Signature (KeyId, Signature) +import Network.HTTP.Signature (KeyId, Signature, HttpSigGenError) import Network.HTTP.Simple (JSONException) import Network.HTTP.Types.Header (HeaderName, hContentType) import Network.URI @@ -430,6 +431,13 @@ httpGetAP manager uri = else Left $ APGetErrorContentType $ "Non-AP Content-Type: " <> decodeUtf8 b _ -> Left $ APGetErrorContentType "Multiple Content-Type" +data APPostError + = APPostErrorSig HttpSigGenError + | APPostErrorHTTP HttpException + deriving Show + +instance Exception APPostError + -- | Perform an HTTP POST request to submit an ActivityPub object. -- -- * Verify the URI scheme is _https:_ and authority part is present @@ -446,22 +454,23 @@ httpPostAP -> (ByteString -> (KeyId, Signature)) -> Text -> a - -> m (Either HttpException (Response ())) -httpPostAP manager uri headers sign uActor value = - liftIO $ try $ do - req <- requestFromURI $ toURI uri - let req' = - setRequestCheckStatus $ - consHeader hContentType typeActivityStreams2LD $ - consHeader hActivityPubActor (encodeUtf8 uActor) $ - req { method = "POST" - , requestBody = RequestBodyLBS $ encode value - } - sign' b = - let (k, s) = sign b - in (Nothing, k, s) - req'' <- signRequest headers sign' Nothing req' - httpNoBody req'' manager + -> m (Either APPostError (Response ())) +httpPostAP manager uri headers sign uActor value = liftIO $ do + req <- requestFromURI $ toURI uri + let req' = + setRequestCheckStatus $ + consHeader hContentType typeActivityStreams2LD $ + consHeader hActivityPubActor (encodeUtf8 uActor) $ + req { method = "POST" + , requestBody = RequestBodyLBS $ encode value + } + sign' b = + let (k, s) = sign b + in (Nothing, k, 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 }