diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,10 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.7.0...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.10.8.0...main) + +## [v1.10.8.0](https://github.com/freckle/freckle-app/compare/v1.10.7.0...v1.10.8.0) + +- Reduce logged caching errors to `WARN` and add `error.stack` to them +- Add `Freckle.App.Exception` with `annotatedExceptionMessage` helpers +- Use `withFrozenCallStack` on more exception utilities to reduce noise in call stacks ## [v1.10.7.0](https://github.com/freckle/freckle-app/compare/v1.10.6.0...v1.10.7.0) diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-app -version: 1.10.7.0 +version: 1.10.8.0 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -36,6 +36,7 @@ Freckle.App.Dotenv Freckle.App.Ecs Freckle.App.Env + Freckle.App.Exception Freckle.App.Exception.MonadThrow Freckle.App.Exception.MonadUnliftIO Freckle.App.Exception.Types @@ -138,6 +139,7 @@ lens >=4.19.2, memcache >=0.3.0.1, monad-control >=1.0.3.1, + monad-logger-aeson >=0.3.0.2, monad-validate >=1.2.0.1, mtl >=2.2.2, network-uri >=2.6.4.1, @@ -268,6 +270,7 @@ monad-validate >=1.2.0.1, nonempty-containers >=0.3.4.4, postgresql-simple >=0.6.4, + text >=1.2.4.1, vector >=0.12.3.1, wai >=3.2.3, wai-extra >=3.1.8 diff --git a/library/Freckle/App/Exception.hs b/library/Freckle/App/Exception.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Exception.hs @@ -0,0 +1,53 @@ +module Freckle.App.Exception + ( -- * Re-export of our current preferred implementation module + + -- | Currently 'MonadUnliftIO'-based + module Freckle.App.Exception.MonadUnliftIO + + -- * Helpers that are agnostic to either implementation + , annotatedExceptionMessage + , annotatedExceptionMessageFrom + ) where + +import Prelude + +import Control.Exception.Annotated (annotatedExceptionCallStack) +import qualified Control.Exception.Annotated as AnnotatedException +import Control.Monad.Logger.Aeson (Message (..), (.=)) +import Data.Aeson (object) +import Freckle.App.Exception.MonadUnliftIO +import GHC.Exception (prettyCallStack) + +-- | Construct a log 'Message' for any @'AnnotatedException' exception@ +-- +-- Produces a log message that works with Datadog /Standard Attributes/. +-- +-- +-- +-- @ +-- Exception +-- error.message: {displayException on underlying exception} +-- error.stack: {prettyCallStack from the annotation, if available} +-- @ +-- +-- You are expected to call this with a @TypeApplication@, for example: +-- +-- @ +-- 'catch' myAction $ 'logError' . 'annotatedExceptionMessage' @MyException +-- @ +annotatedExceptionMessage :: Exception ex => AnnotatedException ex -> Message +annotatedExceptionMessage = annotatedExceptionMessageFrom $ const "Exception" + +-- | Like 'annotatedExceptionMessage', but use the supplied function to +-- construct an initial 'Message' that it will augment. +annotatedExceptionMessageFrom + :: Exception ex => (ex -> Message) -> AnnotatedException ex -> Message +annotatedExceptionMessageFrom f ann = case f ex of + msg :# series -> msg :# series <> ["error" .= errorObject] + where + ex = AnnotatedException.exception ann + errorObject = + object + [ "message" .= displayException ex + , "stack" .= (prettyCallStack <$> annotatedExceptionCallStack ann) + ] diff --git a/library/Freckle/App/Exception/MonadThrow.hs b/library/Freckle/App/Exception/MonadThrow.hs --- a/library/Freckle/App/Exception/MonadThrow.hs +++ b/library/Freckle/App/Exception/MonadThrow.hs @@ -37,17 +37,17 @@ -- 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 +throwM e = withFrozenCallStack $ Annotated.throw e throwString :: forall m a. (MonadThrow m, HasCallStack) => String -> m a -throwString = throwM . userError +throwString s = withFrozenCallStack $ throwM $ userError s fromJustNoteM :: forall m a. (MonadThrow m, HasCallStack) => String -> Maybe a -> m a -fromJustNoteM err = maybe (throwString err) pure +fromJustNoteM err = withFrozenCallStack $ maybe (throwString err) pure impossible :: forall m a. (MonadThrow m, HasCallStack) => m a -impossible = throwString "Impossible" +impossible = withFrozenCallStack $ throwString "Impossible" catch :: forall e m a @@ -55,7 +55,7 @@ => m a -> (e -> m a) -> m a -catch = withFrozenCallStack Annotated.catch +catch action handler = withFrozenCallStack $ Annotated.catch action handler catchJust :: forall e b m a @@ -91,7 +91,7 @@ -> 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 +try action = withFrozenCallStack $ Annotated.try action tryJust :: forall e b m a @@ -114,5 +114,5 @@ -> m a -- ^ Action that only throws 'AnnotatedException', -- where the annotations include a call stack -checkpointCallStack = - withFrozenCallStack Annotated.checkpointCallStack +checkpointCallStack action = + withFrozenCallStack $ Annotated.checkpointCallStack action diff --git a/library/Freckle/App/Exception/MonadUnliftIO.hs b/library/Freckle/App/Exception/MonadUnliftIO.hs --- a/library/Freckle/App/Exception/MonadUnliftIO.hs +++ b/library/Freckle/App/Exception/MonadUnliftIO.hs @@ -38,17 +38,17 @@ -- 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 +throwM e = withFrozenCallStack $ Annotated.throw e throwString :: forall m a. (MonadIO m, HasCallStack) => String -> m a -throwString = throwM . userError +throwString s = withFrozenCallStack $ throwM $ userError s fromJustNoteM :: forall m a. (MonadIO m, HasCallStack) => String -> Maybe a -> m a -fromJustNoteM err = maybe (throwString err) pure +fromJustNoteM err = withFrozenCallStack $ maybe (throwString err) pure impossible :: forall m a. (MonadIO m, HasCallStack) => m a -impossible = throwString "Impossible" +impossible = withFrozenCallStack $ throwString "Impossible" catch :: forall e m a @@ -56,7 +56,7 @@ => m a -> (e -> m a) -> m a -catch = withFrozenCallStack Annotated.catch +catch action handler = withFrozenCallStack $ Annotated.catch action handler catchJust :: forall e b m a @@ -115,5 +115,6 @@ -> m a -- ^ Action that only throws 'AnnotatedException', -- where the annotations include a call stack -checkpointCallStack = - withFrozenCallStack Annotated.checkpointCallStack +checkpointCallStack action = + withFrozenCallStack $ + Annotated.checkpointCallStack action diff --git a/library/Freckle/App/Memcached.hs b/library/Freckle/App/Memcached.hs --- a/library/Freckle/App/Memcached.hs +++ b/library/Freckle/App/Memcached.hs @@ -31,6 +31,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) +import Freckle.App.Exception (annotatedExceptionMessage) import Freckle.App.Memcached.CacheKey import Freckle.App.Memcached.CacheTTL import Freckle.App.Memcached.Client (HasMemcachedClient (..)) @@ -54,11 +55,26 @@ toCachable = encodeUtf8 fromCachable = Right . decodeUtf8With lenientDecode -data Cached a - = CacheFound a - | CacheNotFound - | CacheError Text +data CachingError + = CacheGetError SomeException + | CacheSetError SomeException + | CacheDeserializeError String + deriving stock (Show) +instance Exception CachingError where + displayException = \case + CacheGetError ex -> "Unable to get: " <> displayException ex + CacheSetError ex -> "Unable to set: " <> displayException ex + CacheDeserializeError err -> "Unable to deserialize: " <> err + +-- | Log any thrown 'CachingError's as warnings and return the given value +warnOnCachingError :: (MonadUnliftIO m, MonadLogger m) => a -> m a -> m a +warnOnCachingError val = + flip catch $ + (val <$) + . logWarnNS "caching" + . annotatedExceptionMessage @CachingError + -- | Memoize an action using Memcached and 'Cachable' caching :: ( MonadUnliftIO m @@ -67,6 +83,7 @@ , MonadReader env m , HasMemcachedClient env , Cachable a + , HasCallStack ) => CacheKey -> CacheTTL @@ -81,6 +98,7 @@ , MonadTracer m , MonadReader env m , HasMemcachedClient env + , HasCallStack ) => (ByteString -> Either String a) -> (a -> ByteString) @@ -89,22 +107,17 @@ -> m a -> m a cachingAs from to key ttl f = do - result <- - fmap (maybe CacheNotFound (either (CacheError . pack) CacheFound . from)) $ - handleCachingError Nothing "getting" $ - Memcached.get key - - case result of - CacheFound a -> pure a - CacheNotFound -> store - CacheError e -> do - logCachingError "deserializing" e - store + mCached <- warnOnCachingError Nothing $ traverse cacheDeserialize =<< cacheGet + maybe store pure mCached where store = do a <- f - a <$ handleCachingError () "setting" (Memcached.set key (to a) ttl) + a <$ warnOnCachingError () (cacheSet a) + cacheGet = flip catch (throwM . CacheGetError) $ Memcached.get key + cacheSet a = flip catch (throwM . CacheSetError) $ Memcached.set key (to a) ttl + cacheDeserialize = either (throwM . CacheDeserializeError) pure . from + -- | Like 'caching', but de/serializing the value as JSON cachingAsJSON :: ( MonadUnliftIO m @@ -114,6 +127,7 @@ , HasMemcachedClient env , FromJSON a , ToJSON a + , HasCallStack ) => CacheKey -> CacheTTL @@ -129,6 +143,7 @@ , MonadReader env m , HasMemcachedClient env , Serialise a + , HasCallStack ) => CacheKey -> CacheTTL @@ -138,21 +153,6 @@ cachingAs (first show . deserialiseOrFail . BSL.fromStrict) (BSL.toStrict . serialise) - -handleCachingError - :: (MonadUnliftIO m, MonadLogger m) => a -> Text -> m a -> m a -handleCachingError value action = flip catch handler - where - handler (ex :: SomeException) = do - logCachingError action $ pack $ displayException ex - pure value - -logCachingError :: MonadLogger m => Text -> Text -> m () -logCachingError action message = - logErrorNS "caching" $ - "Error " - <> action - :# ["action" .= action, "message" .= message] encodeStrict :: ToJSON a => a -> ByteString encodeStrict = BSL.toStrict . encode diff --git a/library/Freckle/App/Prelude.hs b/library/Freckle/App/Prelude.hs --- a/library/Freckle/App/Prelude.hs +++ b/library/Freckle/App/Prelude.hs @@ -135,7 +135,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import Data.Set (Set) -import Freckle.App.Exception.MonadUnliftIO +import Freckle.App.Exception import Data.Text (Text, pack, unpack) import Data.Time (NominalDiffTime, UTCTime, getCurrentTime) import Data.Vector (Vector) diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: freckle-app -version: 1.10.7.0 +version: 1.10.8.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app @@ -113,6 +113,7 @@ - lens - memcache - monad-control + - monad-logger-aeson - monad-validate - mtl - network-uri @@ -166,9 +167,10 @@ - lens - lens-aeson - memcache - - postgresql-simple - monad-validate - nonempty-containers + - postgresql-simple + - text - vector - wai - wai-extra diff --git a/tests/Freckle/App/MemcachedSpec.hs b/tests/Freckle/App/MemcachedSpec.hs --- a/tests/Freckle/App/MemcachedSpec.hs +++ b/tests/Freckle/App/MemcachedSpec.hs @@ -8,10 +8,11 @@ import Blammo.Logging.LogSettings import Blammo.Logging.Logger -import Control.Lens (lens) +import Control.Lens (lens, to, (^?)) import Data.Aeson (Value (..)) -import Data.Aeson.Compat as KeyMap +import Data.Aeson.Lens import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T import qualified Freckle.App.Env as Env import Freckle.App.Memcached import Freckle.App.Memcached.Client (MemcachedClient, withMemcachedClient) @@ -92,9 +93,18 @@ msgs <- getLoggedMessagesLenient let Just LoggedMessage {..} = NE.last <$> NE.nonEmpty msgs - loggedMessageText `shouldBe` "Error deserializing" - loggedMessageMeta - `shouldBe` KeyMap.fromList - [ ("action", String "deserializing") - , ("message", String "invalid: \"Broken\"") - ] + Object loggedMessageMeta ^? key "error" . key "message" . _String + `shouldBe` Just "Unable to deserialize: invalid: \"Broken\"" + + -- This assertion is far too brittle, but can be useful to un-comment if + -- you intend to work on this logic specifically + -- Object loggedMessageMeta ^? key "error" . key "stack" . _String . to T.lines + -- `shouldBe` Just + -- [ "CallStack (from HasCallStack):" + -- , " throwM, called at library/Freckle/App/Memcached.hs:121:30 in freckle-app-1.10.8.0-1ebuZKUCQVI9sAWTLATGfO:Freckle.App.Memcached" + -- , " cachingAs, called at library/Freckle/App/Memcached.hs:92:11 in freckle-app-1.10.8.0-1ebuZKUCQVI9sAWTLATGfO:Freckle.App.Memcached" + -- , " caching, called at tests/Freckle/App/MemcachedSpec.hs:87:15 in main:Freckle.App.MemcachedSpec" + -- ] + Object loggedMessageMeta + ^? key "error" . key "stack" . _String . to T.lines + `shouldSatisfy` maybe False (not . null)