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,9 +454,8 @@ 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
     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'
+    ereq <- try $ signRequest headers sign' Nothing req'
-        httpNoBody req'' manager
+    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 }