use annotated-exception

CHANGELOG.md

@@ -1,4 +1,14 @@
-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.4.0...main)
+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.11.0.0...main)
+
+## [v1.11.0.0](https://github.com/freckle/freckle-app/compare/v1.10.4.0...v1.11.0.0)
+
+- Add `Freckle.App.Exception` with exception utilities based on the
+  `annotated-exception` package.
+
+- The Prelude module is expanded to reexport from `Freckle.App.Exception` the following:
+  `throw`, `throwIO`, `catch`, `catchIO`, `try`, `tryIO`, `StringException`, `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.11.0.0
 synopsis:       Haskell application toolkit used at Freckle
 description:    Please see README.md
 category:       Utils
@@ -39,6 +39,7 @@ library
       Freckle.App.Dotenv
       Freckle.App.Ecs
       Freckle.App.Env
+      Freckle.App.Exception
       Freckle.App.Ghci
       Freckle.App.GlobalCache
       Freckle.App.Http
@@ -108,6 +109,7 @@ library
     , Glob
     , MonadRandom
     , aeson
+    , annotated-exception
     , aws-xray-client-persistent
     , aws-xray-client-wai
     , base
@@ -294,7 +296,6 @@ test-suite spec
     , monad-validate
     , nonempty-containers
     , postgresql-simple
-    , unliftio
     , vector
     , wai
     , wai-extra

library/Freckle/App.hs

@@ -183,7 +183,6 @@ import Freckle.App.Prelude
 
 import Blammo.Logging
 import Control.Lens (view)
-import Control.Monad.Catch (MonadCatch, MonadThrow)
 import Control.Monad.IO.Unlift (MonadUnliftIO (..))
 import Control.Monad.Primitive (PrimMonad (..))
 import Control.Monad.Reader

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

@@ -23,7 +23,6 @@ module Freckle.App.Bugsnag
 import Freckle.App.Prelude
 
 import Control.Lens (Lens', view)
-import Control.Monad.Catch (MonadMask)
 import Control.Monad.Reader (runReaderT)
 import Data.Bugsnag
 import Data.Bugsnag.Settings
@@ -33,10 +32,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 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,11 @@ 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 = catchIO [nonUtf8] . runResourceT . runValidateT . runConduit
  where
-  nonUtf8 :: Conduit.TextException -> m (Either (Seq (CsvException err)) r)
-  nonUtf8 = const $ pure $ Left $ pure CsvUnknownFileEncoding
+  nonUtf8 :: ExceptionHandler m (Either (Seq (CsvException err)) r)
+  nonUtf8 = ExceptionHandler $ \(_ :: 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.hs

@@ -0,0 +1,185 @@
+-- |
+--
+-- == Which monadic constraints are you using?
+--
+-- In a 'MonadThrow'/'MonadCatch' setting, use 'throw', 'catch', and 'try'. These
+-- can be used in situations that don't necessarily involve 'IO'.
+--
+-- In a 'MonadIO'/'MonadUnliftIO' setting where 'IO' is definitely part of your
+-- monad stack, use the "...IO" family of functions: 'throwIO', 'catchIO', and 'tryIO'.
+--
+-- == Throwing
+--
+-- To throw an exception, use either 'throwIO' (in a 'MonadIO'/'MonadUnliftIO' setting)
+-- or 'throw' (in a 'MonadThrow' setting). This throws the exception wrapped in
+-- 'AnnotatedException', which includes a call stack.
+--
+-- If you're throwing an exception that is never intended to be caught (such as a "this
+-- should never happen" situation), you can use 'stringException' to conveniently construct
+-- the exception.
+--
+-- == Augmenting non-annotated exceptions
+--
+-- When dealing with a library that does not use 'AnnotatedException', wrap its actions
+-- in 'checkpointCallStack'/'checkpointCallStackIO' to augment its exceptions with call
+-- stacks.
+module Freckle.App.Exception
+  ( -- * Throw
+    throw
+  , throwIO
+  , StringException (..)
+  , Impossible (..)
+
+    -- * Catch
+  , catch
+  , catchIO
+  , ExceptionHandler (..)
+
+    -- * Try
+  , try
+  , tryIO
+
+    -- * Annotation
+  , checkpointCallStack
+  , checkpointCallStackIO
+
+    -- * Miscellany
+  , Exception (..)
+  , SomeException (..)
+  , AnnotatedException (..)
+  , HasCallStack
+  , MonadThrow
+  , MonadCatch
+  , MonadMask
+  , IO
+  , MonadIO
+  , MonadUnliftIO
+  ) where
+
+import Control.Exception.Annotated (AnnotatedException, Handler (..))
+import Control.Monad.Catch
+  ( Exception
+  , MonadCatch
+  , MonadMask
+  , MonadThrow
+  , SomeException (..)
+  )
+import Data.Either (Either (..))
+import Data.Function ((.))
+import Data.Functor (fmap)
+import Data.String (String)
+import GHC.Stack (HasCallStack)
+import System.IO (IO)
+import Text.Show (Show (showsPrec), showString, shows)
+import UnliftIO (MonadIO, MonadUnliftIO)
+
+import qualified Control.Exception.Annotated
+import qualified Control.Exception.Annotated.UnliftIO
+
+throw
+  :: forall e m a
+   . HasCallStack
+  => MonadThrow m
+  => Exception e
+  => e
+  -- ^ Exception to throw; see 'StringException' if you need an idea
+  -> m a
+throw = Control.Exception.Annotated.throw
+
+throwIO
+  :: forall e m a
+   . HasCallStack
+  => MonadIO m
+  => Exception e
+  => e
+  -- ^ Exception to throw; see 'StringException' if you need an idea
+  -> m a
+throwIO = Control.Exception.Annotated.UnliftIO.throw
+
+catch
+  :: (HasCallStack, MonadCatch m)
+  => [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
+  -- ^ Action to run
+  -> m a
+catch handlers action =
+  Control.Exception.Annotated.catches
+    action
+    (fmap (\case (ExceptionHandler f) -> Handler f) handlers)
+
+catchIO
+  :: forall m a
+   . MonadUnliftIO m
+  => HasCallStack
+  => [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
+  -- ^ Action to run
+  -> m a
+catchIO handlers action =
+  Control.Exception.Annotated.UnliftIO.catches
+    action
+    (fmap (\case (ExceptionHandler f) -> Handler f) handlers)
+
+try
+  :: Exception e
+  => MonadCatch m
+  => 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 = Control.Exception.Annotated.try
+
+tryIO
+  :: forall e m a
+   . Exception e
+  => MonadUnliftIO m
+  => 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@
+tryIO = Control.Exception.Annotated.UnliftIO.try
+
+checkpointCallStack
+  :: 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 =
+  Control.Exception.Annotated.checkpointCallStack
+
+checkpointCallStackIO
+  :: 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
+checkpointCallStackIO =
+  Control.Exception.Annotated.UnliftIO.checkpointCallStack
+
+-- | A convenient exception type with no particular meaning
+newtype StringException = StringException String
+  deriving anyclass (Exception)
+
+instance Show StringException where
+  showsPrec _ (StringException s) =
+    shows @String "Exception:\n\n" . showString s
+
+-- 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)
+
+data Impossible = Impossible
+  deriving stock (Show)
+  deriving anyclass (Exception)

library/Freckle/App/Http.hs

@@ -137,7 +137,6 @@ import Network.HTTP.Types.Status
   , statusIsServerError
   , statusIsSuccessful
   )
-import UnliftIO.Exception (Exception (..), throwIO)
 
 data HttpDecodeError = HttpDecodeError
   { hdeBody :: ByteString
@@ -213,7 +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
+  :: (MonadIO m, Exception e)
+  => HasCallStack
+  => Response (Either e a)
+  -> m a
 getResponseBodyUnsafe = either throwIO pure . getResponseBody
 
 httpExceptionIsInformational :: HttpException -> Bool

library/Freckle/App/Http/Retry.hs

@@ -12,7 +12,6 @@ import Network.HTTP.Client (Request (..))
 import Network.HTTP.Simple
 import Network.HTTP.Types.Status (status429)
 import Text.Read (readMaybe)
-import UnliftIO.Exception (Exception (..), throwIO)
 
 -- | Thrown if we exhaust our retries limit and still see a @429@
 --
@@ -78,7 +77,8 @@ suppressRetryStatusError req =
  where
   originalCheckResponse = checkResponse req
 
-checkRetriesExhausted :: MonadIO m => Int -> Response body -> m (Response body)
+checkRetriesExhausted
+  :: MonadIO m => HasCallStack => Int -> Response body -> m (Response body)
 checkRetriesExhausted retryLimit resp
   | getResponseStatus resp == status429 =
       throwIO $