Catch sig generation error when sending signed HTTP POST

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 ()))
+    -> m (Either APPostError (Response ()))
-httpPostAP manager uri headers sign uActor value =
+httpPostAP manager uri headers sign uActor value = liftIO $ do
-    liftIO $ try $ do
+    req <- requestFromURI $ toURI uri
-        req <- requestFromURI $ toURI uri
+    let req' =
-        let req' =
+            setRequestCheckStatus $
-                setRequestCheckStatus $
+            consHeader hContentType typeActivityStreams2LD $
-                consHeader hContentType typeActivityStreams2LD $
+            consHeader hActivityPubActor (encodeUtf8 uActor) $
-                consHeader hActivityPubActor (encodeUtf8 uActor) $
+            req { method      = "POST"
-                req { method      = "POST"
+                , requestBody = RequestBodyLBS $ encode value
-                    , requestBody = RequestBodyLBS $ encode value
+                }
-                    }
+        sign' b =
-            sign' b =
+            let (k, s) = sign b
-                let (k, s) = sign b
+            in  (Nothing, k, s)
-                in  (Nothing, k, s)
+    ereq <- try $ signRequest headers sign' Nothing req'
-        req'' <- signRequest headers sign' Nothing req'
+    case ereq of
-        httpNoBody req'' manager
+        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 }