Catch sig generation error when sending signed HTTP POST
This commit is contained in:
parent
97594dc945
commit
6e721797e9
1 changed files with 26 additions and 17 deletions
|
@ -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,9 +454,8 @@ httpPostAP
|
|||
-> (ByteString -> (KeyId, Signature))
|
||||
-> Text
|
||||
-> a
|
||||
-> m (Either HttpException (Response ()))
|
||||
httpPostAP manager uri headers sign uActor value =
|
||||
liftIO $ try $ do
|
||||
-> m (Either APPostError (Response ()))
|
||||
httpPostAP manager uri headers sign uActor value = liftIO $ do
|
||||
req <- requestFromURI $ toURI uri
|
||||
let req' =
|
||||
setRequestCheckStatus $
|
||||
|
@ -460,8 +467,10 @@ httpPostAP manager uri headers sign uActor value =
|
|||
sign' b =
|
||||
let (k, s) = sign b
|
||||
in (Nothing, k, s)
|
||||
req'' <- signRequest headers sign' Nothing req'
|
||||
httpNoBody req'' manager
|
||||
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 }
|
||||
|
||||
|
|
Loading…
Reference in a new issue