packages feed

freckle-app 1.10.7.0 → 1.10.8.0

raw patch · 9 files changed

+134/−59 lines, 9 filesdep +monad-logger-aeson

Dependencies added: monad-logger-aeson

Files

CHANGELOG.md view
@@ -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)
freckle-app.cabal view
@@ -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
+ library/Freckle/App/Exception.hs view
@@ -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/.+--+-- <https://docs.datadoghq.com/standard-attributes/?search=error.>+--+-- @+-- 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)+      ]
library/Freckle/App/Exception/MonadThrow.hs view
@@ -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
library/Freckle/App/Exception/MonadUnliftIO.hs view
@@ -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
library/Freckle/App/Memcached.hs view
@@ -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
library/Freckle/App/Prelude.hs view
@@ -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)
package.yaml view
@@ -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
tests/Freckle/App/MemcachedSpec.hs view
@@ -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)