Use annotated-exception

CHANGELOG.md

@@ -1,4 +1,15 @@
-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.4.0...main)
+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.5.0...main)
+
+## [v1.10.5.0](https://github.com/freckle/freckle-app/compare/v1.10.4.0...v1.10.5.0)
+
+- Add `Freckle.App.Exception...` modules with exception utilities based on the
+  `annotated-exception` package.
+
+- The Prelude module is expanded to reexport from `Freckle.App.Exception.MonadUnliftIO`
+  the following: `throwM`, `throwString`, `fromJustNoteM`, `catch`, `catchJust`,
+  `catches`, `try`, `tryJust`, `impossible`, `ExceptionHandler`, `Exception`,
+  `SomeException`. These should be used in place of their relevant counterparts from
+  packages `base`, `exceptions`, `safe-exceptions`, or `unliftio`.
 
 - Add `Freckle.App.Random`
 

freckle-app.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.18
 -- see: https://github.com/sol/hpack
 
 name:           freckle-app
-version:        1.10.4.0
+version:        1.10.5.0
 synopsis:       Haskell application toolkit used at Freckle
 description:    Please see README.md
 category:       Utils
@@ -39,6 +39,9 @@ library
       Freckle.App.Dotenv
       Freckle.App.Ecs
       Freckle.App.Env
+      Freckle.App.Exception.MonadThrow
+      Freckle.App.Exception.MonadUnliftIO
+      Freckle.App.Exception.Types
       Freckle.App.Ghci
       Freckle.App.GlobalCache
       Freckle.App.Http
@@ -108,6 +111,7 @@ library
     , Glob
     , MonadRandom
     , aeson
+    , annotated-exception
     , aws-xray-client-persistent
     , aws-xray-client-wai
     , base
@@ -294,7 +298,6 @@ test-suite spec
     , monad-validate
     , nonempty-containers
     , postgresql-simple
-    , unliftio
     , vector
     , wai
     , wai-extra

library/Freckle/App/Async.hs

@@ -14,7 +14,6 @@ import qualified Data.Aeson.Compat as KeyMap
 import UnliftIO.Async (Async)
 import qualified UnliftIO.Async as UnliftIO
 import UnliftIO.Concurrent (threadDelay)
-import UnliftIO.Exception (SomeException, displayException)
 
 -- | 'UnliftIO.Async.async' but passing the thread context along
 async :: (MonadMask m, MonadUnliftIO m) => m a -> m (Async a)

library/Freckle/App/Bugsnag.hs

@@ -33,10 +33,10 @@ import Database.PostgreSQL.Simple (SqlError (..))
 import Database.PostgreSQL.Simple.Errors
 import Freckle.App.Async (async)
 import qualified Freckle.App.Env as Env
+import qualified Freckle.App.Exception.MonadUnliftIO as Exception
 import Network.Bugsnag hiding (notifyBugsnag, notifyBugsnagWith)
 import qualified Network.Bugsnag as Bugsnag
 import Network.HTTP.Client (HttpException (..), host, method)
-import qualified UnliftIO.Exception as Exception
 import Yesod.Core.Lens
 import Yesod.Core.Types (HandlerData)
 

library/Freckle/App/Csv.hs

@@ -64,7 +64,6 @@ import Data.Sequence.NonEmpty (NESeq)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Vector as V
-import UnliftIO.Exception (handle)
 
 -- | Treat CSV header line as 1
 --
@@ -142,10 +141,10 @@ runCsvConduit
    . MonadUnliftIO m
   => ConduitT () Void (ValidateT (Seq (CsvException err)) (ResourceT m)) r
   -> m (Either (Seq (CsvException err)) r)
-runCsvConduit = handle nonUtf8 . runResourceT . runValidateT . runConduit
+runCsvConduit = flip catch nonUtf8 . runResourceT . runValidateT . runConduit
  where
-  nonUtf8 :: Conduit.TextException -> m (Either (Seq (CsvException err)) r)
-  nonUtf8 = const $ pure $ Left $ pure CsvUnknownFileEncoding
+  nonUtf8 (_ :: Conduit.TextException) =
+    pure $ Left $ pure CsvUnknownFileEncoding
 
 -- | Stream in 'ByteString's and parse records in constant space
 decodeCsv

library/Freckle/App/Database.hs

@@ -71,7 +71,6 @@ import qualified Freckle.App.Stats as Stats
 import OpenTelemetry.Instrumentation.Persistent
 import System.Process.Typed (proc, readProcessStdout_)
 import UnliftIO.Concurrent (threadDelay)
-import UnliftIO.Exception (displayException)
 import UnliftIO.IORef
 import Yesod.Core.Types (HandlerData (..), RunHandlerEnv (..))
 

library/Freckle/App/Ecs.hs

@@ -13,7 +13,6 @@ import Data.Aeson
 import Data.List.Extra (dropPrefix)
 import Freckle.App.Http
 import System.Environment (lookupEnv)
-import UnliftIO.Exception (Exception (..))
 
 data EcsMetadata = EcsMetadata
   { emContainerMetadata :: EcsContainerMetadata

library/Freckle/App/Exception/MonadThrow.hs

@@ -0,0 +1,115 @@
+module Freckle.App.Exception.MonadThrow
+  ( throwM
+  , throwString
+  , fromJustNoteM
+  , impossible
+  , catch
+  , catchJust
+  , catches
+  , try
+  , tryJust
+  , checkpointCallStack
+
+    -- * Miscellany
+  , MonadThrow
+  , MonadCatch
+  , MonadMask
+  , module Freckle.App.Exception.Types
+  ) where
+
+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.Functor (fmap, (<$>))
+import Data.Maybe (Maybe, 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. (Exception e, MonadThrow m, HasCallStack) => e -> m a
+throwM = Annotated.throw
+
+throwString :: forall m a. (MonadThrow m, HasCallStack) => String -> m a
+throwString = throwM . userError
+
+fromJustNoteM
+  :: forall m a. (MonadThrow m, HasCallStack) => String -> Maybe a -> m a
+fromJustNoteM err = maybe (throwString err) pure
+
+impossible :: forall m a. (MonadThrow m, HasCallStack) => m a
+impossible = throwString "Impossible"
+
+catch
+  :: forall e m a
+   . (Exception e, MonadCatch m, HasCallStack)
+  => m a
+  -> (e -> m a)
+  -> m a
+catch = withFrozenCallStack Annotated.catch
+
+catchJust
+  :: forall e b m a
+   . (Exception e, MonadCatch m, HasCallStack)
+  => (e -> Maybe b)
+  -> m a
+  -> (b -> m a)
+  -> m a
+catchJust test action handler =
+  withFrozenCallStack $ Annotated.catch action $ \e ->
+    maybe (Control.Monad.Catch.throwM e) handler (test e)
+
+catches
+  :: forall m a
+   . (MonadCatch m, HasCallStack)
+  => m a
+  -- ^ Action to run
+  -> [ExceptionHandler m a]
+  -- ^ Recovery actions to run if the first action throws an exception
+  --   with a type of either @e@ or @'AnnotatedException' e@
+  -> m a
+catches action handlers =
+  withFrozenCallStack $
+    Annotated.catches
+      action
+      (fmap (\case (ExceptionHandler f) -> Annotated.Handler f) handlers)
+
+try
+  :: forall e m a
+   . (Exception e, MonadCatch m, HasCallStack)
+  => m a
+  -- ^ Action to run
+  -> m (Either e a)
+  -- ^ Returns 'Left' if the action throws an exception with a type
+  --   of either @e@ or @'AnnotatedException' e@
+try = withFrozenCallStack Annotated.try
+
+tryJust
+  :: forall e b m a
+   . (Exception e, MonadCatch m, HasCallStack)
+  => (e -> Maybe b)
+  -> m a
+  -- ^ Action to run
+  -> m (Either b a)
+tryJust test action =
+  withFrozenCallStack $ Annotated.catch (Right <$> action) $ \e ->
+    maybe (Control.Monad.Catch.throwM e) (pure . Left) (test e)
+
+-- | When dealing with a library that does not use 'AnnotatedException',
+--   apply this function to augment its exceptions with call stacks.
+checkpointCallStack
+  :: forall m a
+   . (MonadCatch m, HasCallStack)
+  => m a
+  -- ^ Action that might throw whatever types of exceptions
+  -> m a
+  -- ^ Action that only throws 'AnnotatedException',
+  --   where the annotations include a call stack
+checkpointCallStack =
+  withFrozenCallStack Annotated.checkpointCallStack

library/Freckle/App/Exception/MonadUnliftIO.hs

@@ -0,0 +1,116 @@
+module Freckle.App.Exception.MonadUnliftIO
+  ( throwM
+  , throwString
+  , fromJustNoteM
+  , impossible
+  , catch
+  , catchJust
+  , catches
+  , try
+  , tryJust
+  , checkpointCallStack
+
+    -- * Miscellany
+  , IO
+  , MonadIO
+  , MonadUnliftIO
+  , module Freckle.App.Exception.Types
+  ) where
+
+import Freckle.App.Exception.Types
+
+import Control.Applicative (pure)
+import Data.Either (Either (..))
+import Data.Function (($), (.))
+import Data.Functor (fmap, (<$>))
+import Data.Maybe (Maybe, maybe)
+import Data.String (String)
+import GHC.IO.Exception (userError)
+import GHC.Stack (withFrozenCallStack)
+import System.IO (IO)
+import UnliftIO (MonadIO, MonadUnliftIO)
+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. (Exception e, MonadIO m, HasCallStack) => e -> m a
+throwM = Annotated.throw
+
+throwString :: forall m a. (MonadIO m, HasCallStack) => String -> m a
+throwString = throwM . userError
+
+fromJustNoteM
+  :: forall m a. (MonadIO m, HasCallStack) => String -> Maybe a -> m a
+fromJustNoteM err = maybe (throwString err) pure
+
+impossible :: forall m a. (MonadIO m, HasCallStack) => m a
+impossible = throwString "Impossible"
+
+catch
+  :: forall e m a
+   . (Exception e, MonadUnliftIO m, HasCallStack)
+  => m a
+  -> (e -> m a)
+  -> m a
+catch = withFrozenCallStack Annotated.catch
+
+catchJust
+  :: forall e b m a
+   . (Exception e, MonadUnliftIO m, HasCallStack)
+  => (e -> Maybe b)
+  -> m a
+  -> (b -> m a)
+  -> m a
+catchJust test action handler =
+  withFrozenCallStack $ Annotated.catch action $ \e ->
+    maybe (UnliftIO.Exception.throwIO e) handler (test e)
+
+catches
+  :: forall m a
+   . (MonadUnliftIO m, HasCallStack)
+  => m a
+  -- ^ Action to run
+  -> [ExceptionHandler m a]
+  -- ^ Recovery actions to run if the first action throws an exception
+  --   with a type of either @e@ or @'AnnotatedException' e@
+  -> m a
+catches action handlers =
+  withFrozenCallStack $
+    Annotated.catches
+      action
+      (fmap (\case (ExceptionHandler f) -> Annotated.Handler f) handlers)
+
+try
+  :: forall e m a
+   . (Exception e, MonadUnliftIO m, HasCallStack)
+  => m a
+  -- ^ Action to run
+  -> m (Either e a)
+  -- ^ Returns 'Left' if the action throws an exception with a type
+  --   of either @e@ or @'AnnotatedException' e@
+try = withFrozenCallStack Annotated.try
+
+tryJust
+  :: forall e b m a
+   . (Exception e, MonadUnliftIO m, HasCallStack)
+  => (e -> Maybe b)
+  -> m a
+  -- ^ Action to run
+  -> m (Either b a)
+tryJust test action =
+  withFrozenCallStack $ Annotated.catch (Right <$> action) $ \e ->
+    maybe (UnliftIO.Exception.throwIO e) (pure . Left) (test e)
+
+-- | When dealing with a library that does not use 'AnnotatedException',
+--   apply this function to augment its exceptions with call stacks.
+checkpointCallStack
+  :: forall m a
+   . (MonadUnliftIO m, HasCallStack)
+  => m a
+  -- ^ Action that might throw whatever types of exceptions
+  -> m a
+  -- ^ Action that only throws 'AnnotatedException',
+  --   where the annotations include a call stack
+checkpointCallStack =
+  withFrozenCallStack Annotated.checkpointCallStack

library/Freckle/App/Exception/Types.hs

@@ -0,0 +1,15 @@
+module Freckle.App.Exception.Types
+  ( ExceptionHandler (..)
+  , AnnotatedException (..)
+  , Exception (..)
+  , SomeException (..)
+  , HasCallStack
+  ) where
+
+import Control.Exception (Exception (..), SomeException (..))
+import Control.Exception.Annotated (AnnotatedException (..))
+import GHC.Stack (HasCallStack)
+
+-- Renamed just so that it can go into Freckle.App.Prelude and have a less generic name than 'Handler'
+data ExceptionHandler m a
+  = forall e. Exception e => ExceptionHandler (e -> m a)

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
     --
@@ -137,7 +137,6 @@ import Network.HTTP.Types.Status
   , statusIsServerError
   , statusIsSuccessful
   )
-import UnliftIO.Exception (Exception (..), throwIO)
 
 data HttpDecodeError = HttpDecodeError
   { hdeBody :: ByteString
@@ -213,8 +212,10 @@ addBearerAuthorizationHeader = addRequestHeader hAuthorization . ("Bearer " <>)
 -- error response bodies too, you'll want to use 'setRequestCheckStatus' so that
 -- you see status-code exceptions before 'HttpDecodeError's.
 getResponseBodyUnsafe
-  :: (MonadIO m, Exception e) => Response (Either e a) -> m a
-getResponseBodyUnsafe = either throwIO pure . getResponseBody
+  :: (MonadIO m, Exception e, HasCallStack)
+  => Response (Either e a)
+  -> m a
+getResponseBodyUnsafe = either throwM pure . getResponseBody
 
 httpExceptionIsInformational :: HttpException -> Bool
 httpExceptionIsInformational = filterStatusException statusIsInformational