add catchJust

CHANGELOG.md

@@ -6,8 +6,8 @@
   `annotated-exception` package.
 
 - The Prelude module is expanded to reexport from `Freckle.App.Exception.MonadUnliftIO`
-  the following: `throwM`, `throwString`, `fromJustNoteM`, `catch`, `catches`, `try`,
-  `impossible`, `ExceptionHandler`, `Exception`, `SomeException`.
+  the following: `throwM`, `throwString`, `fromJustNoteM`, `catch`, `catchJust`,
+  `catches`, `try`, `impossible`, `ExceptionHandler`, `Exception`, `SomeException`.
   These should be used in place of their relevant counterparts from packages
   `base`, `exceptions`, `safe-exceptions`, or `unliftio`.
 

library/Freckle/App/Exception/MonadThrow.hs

@@ -4,6 +4,7 @@ module Freckle.App.Exception.MonadThrow
   , fromJustNoteM
   , impossible
   , catch
+  , catchJust
   , catches
   , try
   , checkpointCallStack
@@ -20,19 +21,22 @@ import Freckle.App.Exception.Types
 import Control.Applicative (pure)
 import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 import Data.Either (Either (..))
-import Data.Function ((.))
+import Data.Function (($), (.))
 import Data.Functor (fmap)
-import Data.Maybe (Maybe, maybe)
+import Data.Maybe (Maybe, fromMaybe, maybe)
 import Data.String (String)
 import GHC.IO.Exception (userError)
+import GHC.Stack (withFrozenCallStack)
 
 import qualified Control.Exception.Annotated as Annotated
+import qualified Control.Monad.Catch
 
 -- Throws an exception, wrapped in 'AnnotatedException' which includes a call stack
-throwM :: forall e m a  . HasCallStack => MonadThrow m => Exception e => e -> m a
+throwM
+  :: forall e m a. HasCallStack => MonadThrow m => Exception e => e -> m a
 throwM = Annotated.throw
 
-throwString :: forall m a  . HasCallStack => MonadThrow m => String -> m a
+throwString :: forall m a. HasCallStack => MonadThrow m => String -> m a
 throwString = throwM . userError
 
 fromJustNoteM :: (HasCallStack, MonadThrow m) => String -> Maybe a -> m a
@@ -44,6 +48,12 @@ impossible = throwString "Impossible"
 catch :: (HasCallStack, Exception e, MonadCatch m) => m a -> (e -> m a) -> m a
 catch = Annotated.catch
 
+catchJust
+  :: (HasCallStack, Exception e, MonadCatch m) => m a -> (e -> Maybe (m a)) -> m a
+catchJust action f =
+  withFrozenCallStack Annotated.catch action $ \e ->
+    fromMaybe (Control.Monad.Catch.throwM e) (f e)
+
 catches
   :: (HasCallStack, MonadCatch m)
   => m a

library/Freckle/App/Exception/MonadUnliftIO.hs

@@ -4,6 +4,7 @@ module Freckle.App.Exception.MonadUnliftIO
   , fromJustNoteM
   , impossible
   , catch
+  , catchJust
   , catches
   , try
   , checkpointCallStack
@@ -19,21 +20,23 @@ import Freckle.App.Exception.Types
 
 import Control.Applicative (pure)
 import Data.Either (Either (..))
-import Data.Function ((.))
+import Data.Function (($), (.))
 import Data.Functor (fmap)
+import Data.Maybe (Maybe, fromMaybe, maybe)
 import Data.String (String)
+import GHC.IO.Exception (userError)
+import GHC.Stack (withFrozenCallStack)
 import System.IO (IO)
-import Data.Maybe (Maybe, maybe)
 import UnliftIO (MonadIO, MonadUnliftIO)
-import GHC.IO.Exception (userError)
+import qualified UnliftIO.Exception
 
 import qualified Control.Exception.Annotated.UnliftIO as Annotated
 
 -- Throws an exception, wrapped in 'AnnotatedException' which includes a call stack
-throwM :: forall e m a  . HasCallStack => MonadIO m => Exception e => e -> m a
+throwM :: forall e m a. HasCallStack => MonadIO m => Exception e => e -> m a
 throwM = Annotated.throw
 
-throwString :: forall m a  . HasCallStack => MonadIO m => String -> m a
+throwString :: forall m a. HasCallStack => MonadIO m => String -> m a
 throwString = throwM . userError
 
 fromJustNoteM :: (HasCallStack, MonadIO m) => String -> Maybe a -> m a
@@ -42,9 +45,24 @@ fromJustNoteM err = maybe (throwString err) pure
 impossible :: (HasCallStack, MonadIO m) => m a
 impossible = throwString "Impossible"
 
-catch :: forall e m a. (MonadUnliftIO m, Exception e, HasCallStack) => m a -> (e -> m a) -> m a
+catch
+  :: forall e m a
+   . (MonadUnliftIO m, Exception e, HasCallStack)
+  => m a
+  -> (e -> m a)
+  -> m a
 catch = Annotated.catch
 
+catchJust
+  :: forall e m a
+   . (HasCallStack, Exception e, MonadUnliftIO m)
+  => m a
+  -> (e -> Maybe (m a))
+  -> m a
+catchJust action f =
+  withFrozenCallStack Annotated.catch action $ \e ->
+    fromMaybe (UnliftIO.Exception.throwIO e) (f e)
+
 catches
   :: forall m a
    . MonadUnliftIO m

library/Freckle/App/Http.hs

@@ -92,7 +92,7 @@ module Freckle.App.Http
     -- error-handling specific to exceptions caused by 4XX responses:
     --
     -- @
-    -- 'handleJust' (guarded 'httpExceptionIsClientError') handle4XXError $ do
+    -- flip 'catchJust' (guard 'httpExceptionIsClientError' *> handle4XXError) $ do
     --   resp <- 'httpJson' $ 'setRequestCheckStatus' $ parseRequest_ "http://..."
     --   body <- 'getResponseBodyUnsafe' resp
     --

library/Freckle/App/Prelude.hs

@@ -93,6 +93,7 @@ module Freckle.App.Prelude
   , throwString
   , fromJustNoteM
   , catch
+  , catchJust
   , catches
   , try
   , impossible

library/Freckle/App/Yesod.hs

@@ -27,12 +27,11 @@ respondQueryCanceledHeaders
   => ResponseHeaders
   -> HandlerFor site res
   -> HandlerFor site res
-respondQueryCanceledHeaders headers = flip catch handler
+respondQueryCanceledHeaders headers = flip catchJust handler
  where
-  handler ex =
-    if sqlState ex == "57014"
-      then do
-        logError $ "Query canceled" :# ["exception" .= displayException ex]
-        Stats.increment "query_canceled"
-        sendWaiResponse $ W.responseLBS status503 headers "Query canceled"
-      else throwM ex
+  handler ex = do
+    guard (sqlState ex == "57014")
+    Just $ do
+      logError $ "Query canceled" :# ["exception" .= displayException ex]
+      Stats.increment "query_canceled"
+      sendWaiResponse $ W.responseLBS status503 headers "Query canceled"