freckle-app 1.1.0.0 → 1.2.0.0
raw patch · 16 files changed
+218/−620 lines, 16 filesdep +Blammodep −ansi-terminaldep −data-defaultdep −fast-loggerdep ~Globdep ~MonadRandomdep ~aeson
Dependencies added: Blammo
Dependencies removed: ansi-terminal, data-default, fast-logger, iproute, network, rio, yesod
Dependency ranges changed: Glob, MonadRandom, aeson, base, bugsnag, bytestring, case-insensitive, conduit, containers, datadog, directory, dlist, doctest, ekg-core, exceptions, filepath, hashable, http-client, http-types, lens, lens-aeson, load-env, memcache, network-uri, persistent, persistent-postgresql, postgresql-simple, primitive, process, safe, semigroupoids, template-haskell, text, time, transformers, typed-process, unliftio, unordered-containers, vector, wai, wai-extra, yaml, yesod-core
Files
- CHANGELOG.md +30/−1
- freckle-app.cabal +59/−67
- library/Freckle/App.hs +21/−27
- library/Freckle/App/Database.hs +7/−4
- library/Freckle/App/Datadog.hs +1/−3
- library/Freckle/App/Env.hs +1/−1
- library/Freckle/App/Ghci.hs +2/−2
- library/Freckle/App/Logging.hs +0/−198
- library/Freckle/App/Memcached.hs +5/−2
- library/Freckle/App/RIO.hs +0/−71
- library/Freckle/App/Test.hs +30/−15
- library/Freckle/App/Test/Logging.hs +12/−1
- library/Freckle/App/Wai.hs +6/−127
- library/Freckle/App/Yesod.hs +5/−53
- package.yaml +3/−9
- tests/Freckle/App/MemcachedSpec.hs +36/−39
CHANGELOG.md view
@@ -1,4 +1,33 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.1.0.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.2.0.0...main)++## [v1.2.0.0](https://github.com/freckle/freckle-app/compare/v1.1.0.0...v1.2.0.0)++- Remove `Freckle.App.Logging`, integrate with [blammo][] instead.++ This will require the following end-user changes:++ - Remove `HasLogging` instance and add `HasLogger`++ This will require storing a `Logger` on your runtime `App` type, instead of+ a `LogLevel` (et al) in your static `AppSettings` type. (Or move to+ `runSimpleLoggingT`.)++ - Replace WAI middleware with [Blammo integration][blammo-wai]++ - Replace Yesod functions with [Blammo integration][blammo-yesod]++ And changes to environment variable values:++ - If using `LOG_OUTPUT=std(out|err)`, use `LOG_DESTINATION=std(out|err)` (note+ that `stdout` is the default)+ - If using `LOG_OUTPUT=file`, use `LOG_DESTINATION=@fancy.log` (yes, that's+ this option did)+ - If using `LOG_FORMAT=terminal`, use `LOG_FORMAT=tty` (note that this is the+ defualt)++[blammo]: https://hackage.haskell.org/package/Blammo+[blammo-wai]: https://github.com/freckle/blammo/#integration-with-wai+[blammo-yesode]: https://github.com/freckle/blammo/#integration-with-yesod ## [v1.1.0.0](https://github.com/freckle/freckle-app/compare/v1.0.4.0...v1.1.0.0)
freckle-app.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-app-version: 1.1.0.0+version: 1.2.0.0 license: MIT license-file: LICENSE maintainer: Freckle Education@@ -37,14 +37,12 @@ Freckle.App.Http Freckle.App.Http.Paginate Freckle.App.Http.Retry- Freckle.App.Logging Freckle.App.Memcached Freckle.App.Memcached.CacheKey Freckle.App.Memcached.CacheTTL Freckle.App.Memcached.Client Freckle.App.Memcached.Servers Freckle.App.Prelude- Freckle.App.RIO Freckle.App.Scientist Freckle.App.Test Freckle.App.Test.DocTest@@ -70,69 +68,64 @@ TypeApplications TypeFamilies build-depends:- Glob >=0.9.3,- MonadRandom >=0.5.1.1,- aeson >=1.3.1.1,- ansi-terminal >=0.8.2,- base >=4.11.1.0 && <5,- bugsnag >=1.0.0.1,- bytestring >=0.10.8.2,- case-insensitive >=1.2.0.11,- conduit >=1.3.1,- containers >=0.5.11.0,- data-default >=0.7.1.1,- datadog >=0.2.3.0,- dlist >=0.8.0.5,- doctest >=0.16.0.1,- ekg-core >=0.1.1.6,+ Blammo >=1.0.0.1,+ Glob >=0.10.1,+ MonadRandom >=0.5.2,+ aeson >=1.5.2.0,+ base >=4.13.0.0 && <5,+ bugsnag >=1.0.0.0,+ bytestring >=0.10.10.1,+ case-insensitive >=1.2.1.0,+ conduit >=1.3.4,+ containers >=0.6.2.1,+ datadog >=0.2.5.0,+ dlist >=0.8.0.8,+ doctest >=0.16.3,+ ekg-core >=0.1.1.7, envparse >=0.4.1, errors >=2.3.0,- exceptions >=0.10.0,- fast-logger >=2.4.11,- filepath >=1.4.2,- hashable >=1.2.7.0,+ exceptions >=0.10.4,+ filepath >=1.4.2.1,+ hashable >=1.3.0.0, hspec >=2.8.1, hspec-core >=2.8.1, hspec-expectations-lifted >=0.10.0, hspec-junit-formatter >=1.1.0.1,- http-client >=0.5.14,+ http-client >=0.6.4.1, http-conduit >=2.3.5, http-link-header >=1.0.3.1,- http-types >=0.12.2,+ http-types >=0.12.3, immortal >=0.3,- iproute >=1.7.7,- lens >=4.16.1,- load-env >=0.2.0.2,- memcache >=0.2.0.1,+ lens >=4.18.1,+ load-env >=0.2.1.0,+ memcache >=0.3.0.1, monad-control >=1.0.2.3, monad-logger >=0.3.31, mtl >=2.2.2,- network >=2.6.3.6,- network-uri >=2.6.1.0,- persistent >=2.8.2,- persistent-postgresql >=2.8.2.0,- postgresql-simple >=0.5.4.0,- primitive >=0.6.3.0,+ network-uri >=2.6.3.0,+ persistent >=2.10.5.3,+ persistent-postgresql >=2.10.1.2,+ postgresql-simple >=0.6.4,+ primitive >=0.7.0.1, resource-pool >=0.2.3.2, retry >=0.8.1.0,- rio >=0.1.7.0,- safe >=0.3.17,+ safe >=0.3.19, scientist >=0.0.0.0,- semigroupoids >=5.2.2,- template-haskell >=2.13.0.0,- text >=1.2.3.1,- time >=1.8.0.2,- transformers >=0.5.5.0,+ semigroupoids >=5.3.4,+ template-haskell >=2.15.0.0,+ text >=1.2.4.0,+ time >=1.9.3,+ transformers >=0.5.6.2, transformers-base >=0.4.5.2,- typed-process >=0.2.3.0,- unliftio >=0.2.9.0,- unordered-containers >=0.2.9.0,- vector >=0.12.0.2,- wai >=3.2.1.2,- wai-extra >=3.0.24.3,- yaml >=0.8.32,- yesod >=1.6.0,- yesod-core >=1.6.9+ typed-process >=0.2.6.0,+ unliftio >=0.2.13.1,+ unliftio-core >=0.1.2.0,+ unordered-containers >=0.2.10.0,+ vector >=0.12.1.2,+ wai >=3.2.2.1,+ wai-extra >=3.0.32,+ yaml >=0.11.5.0,+ yesod-core >=1.6.18.8 test-suite doctest type: exitcode-stdio-1.0@@ -150,7 +143,7 @@ TypeApplications TypeFamilies build-depends:- base >=4.11.1.0 && <5,+ base >=4.13.0.0 && <5, freckle-app -any test-suite gittest@@ -173,14 +166,14 @@ TypeApplications TypeFamilies build-depends:- base >=4.11.1.0 && <5,- directory >=1.3.1.5,+ base >=4.13.0.0 && <5,+ directory >=1.3.6.0, freckle-app -any, hspec >=2.8.1,- process >=1.6.3.0,+ process >=1.6.9.0, temporary >=1.3,- text >=1.2.3.1,- time >=1.8.0.2+ text >=1.2.4.0,+ time >=1.9.3 if flag(test-git) @@ -212,18 +205,17 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends:- aeson >=1.3.1.1,- base >=4.11.1.0 && <5,- bytestring >=0.10.8.2,+ aeson >=1.5.2.0,+ base >=4.13.0.0 && <5,+ bytestring >=0.10.10.1, errors >=2.3.0, freckle-app -any, hspec >=2.8.1,- http-types >=0.12.2,- lens >=4.16.1,- lens-aeson >=1.0.2,- memcache >=0.2.0.1,+ http-types >=0.12.3,+ lens >=4.18.1,+ lens-aeson >=1.1,+ memcache >=0.3.0.1, mtl >=2.2.2,- postgresql-simple >=0.5.4.0,- unliftio-core >=0.1.2.0,- wai >=3.2.1.2,- wai-extra >=3.0.24.3+ postgresql-simple >=0.6.4,+ wai >=3.2.2.1,+ wai-extra >=3.0.32
library/Freckle/App.hs view
@@ -10,19 +10,17 @@ -- -- > data App = App -- > { appDryRun :: Bool--- > , appLogLevel :: LogLevel+-- > , appLogger :: Logger -- > } -- -- This type can be as complex or simple as you want. It might hold a separate -- @Config@ attribute or may keep everything as one level of properties. It -- could even hold an @'IORef'@ if you need mutable application state. ----- The only requirements are some notion of a @'LogLevel'@:+-- The only requirements are 'HasLogger': ----- > instance HasLogging App where--- > getLogLevel = appLogLevel--- > getLogFormat _ = FormatTerminal--- > getLogLocation _ = LogStdout+-- > instance HasLogger App where+-- > loggerL = lens appLogger $ \x y -> x { appLogger = y } -- -- and a way to build a value: --@@ -30,11 +28,12 @@ -- -- It's likely you'll want to use @"Freckle.App.Env"@ to load your @App@: --+-- > import qualified Blammo.Logger.LogSettings.Env as LoggerEnv -- > import qualified Freckle.App.Env as Env -- > -- > loadApp = Env.parse id $ App -- > <$> Env.switch "DRY_RUN" mempty--- > <*> Env.flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- > <*> LoggerEnv.parser -- -- Though not required, a type synonym can make things throughout your -- application a bit more readable:@@ -49,7 +48,7 @@ -- > isDryRun <- asks appDryRun -- > -- > if isDryRun--- > then $logWarn "Skipping due to dry-run"+-- > then logWarn "Skipping due to dry-run" -- > else liftIO $ fireTheMissles -- -- These actions can be (composed of course, or) invoked by a @main@ that@@ -70,7 +69,7 @@ -- -- > data Config = Config -- > { configDbPoolSize :: Int--- > , configLogLevel :: LogLevel+-- > , configLogSettings :: LogSettings -- > } -- -- So you can isolate Env-related concerns@@ -78,19 +77,21 @@ -- > loadConfig :: IO Config -- > loadConfig = Env.parse id $ Config -- > <$> Env.var Env.auto "PGPOOLSIZE" (Env.def 1)--- > <*> Env.flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty+-- > <*> LoggerEnv.parser -- -- from the runtime application state: -- -- > data App = App -- > { appConfig :: Config+-- > , appLogger :: Logger -- > , appSqlPool :: SqlPool -- > } -- >--- > instance HasLogging App where--- > getLogLevel = configLogLevel . appConfig--- > getLogFormat _ = FormatTerminal--- > getLogLocation _ = LogStdout+-- > instance HasLogger App where+-- > loggerL = appLogger $ \x y -> x { appLogger = y }+-- >+-- > instance HasSqlPool App where+-- > getSqlPool = appSqlPool -- -- The @"Freckle.App.Database"@ module provides @'makePostgresPool'@ for -- building a Pool given this (limited) config data:@@ -98,11 +99,9 @@ -- > loadApp :: IO App -- > loadApp = do -- > appConfig{..} <- loadConfig--- > appSqlPool <- makePostgresPool configDbPoolSize+-- > appLogger <- newLogger configLoggerSettings+-- > appSqlPool <- runLoggerLoggingT appLogger $ makePostgresPool configDbPoolSize -- > pure App{..}--- >--- > instance HasSqlPool App where--- > getSqlPool = appSqlPool -- -- /Note/: the actual database connection parameters (host, user, etc) are -- (currently) parsed from conventional environment variables by the underlying@@ -145,15 +144,11 @@ -- Second, we'll probably want a conventional @withApp@ function so that we can -- truncate tables as part of spec setup: ----- > import Freckle.App (runApp) -- > import Freckle.App.Test hiding (withApp) -- > import Test.Hspec -- > -- > withApp :: SpecWith App -> Spec--- > withApp = before $ do--- > app <- loadApp--- > runSqlPool truncateTables $ appSqlPool app--- > pure app+-- > withApp = withAppSql truncateTables loadApp -- -- And now you can write specs that also use the database: --@@ -175,15 +170,14 @@ import Prelude -import Control.Monad.Logger as X+import Blammo.Logging as X import Control.Monad.Reader as X import Freckle.App.Database as X-import Freckle.App.Logging as X import System.IO (BufferMode(..), hSetBuffering, stderr, stdout) -runApp :: HasLogging app => app -> ReaderT app (LoggingT IO) a -> IO a+runApp :: HasLogger app => app -> ReaderT app (LoggingT IO) a -> IO a runApp app action = do -- Ensure output is streamed if in a Docker container hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering- runAppLoggerT app $ runReaderT action app+ runLoggerLoggingT app $ runReaderT action app
library/Freckle/App/Database.hs view
@@ -22,8 +22,8 @@ import Freckle.App.Prelude +import Blammo.Logging import qualified Control.Immortal as Immortal-import Control.Monad.Logger import Control.Monad.Reader import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8@@ -46,6 +46,7 @@ import qualified Prelude as Unsafe (read) import System.Process.Typed (proc, readProcessStdout_) import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception (displayException) import UnliftIO.IORef type SqlPool = Pool SqlBackend@@ -199,10 +200,10 @@ => PostgresConnectionConf -> m (IORef AuroraIamToken) spawnIamTokenRefreshThread conf = do- logInfoN "Spawning thread to refresh IAM auth token"+ logInfo "Spawning thread to refresh IAM auth token" tokenIORef <- newIORef =<< createAuroraIamToken conf void $ Immortal.create $ \_ -> Immortal.onFinish onFinishCallback $ do- logDebugN "Refreshing IAM auth token"+ logDebug "Refreshing IAM auth token" refreshIamToken conf tokenIORef threadDelay oneMinuteInMicroseconds pure tokenIORef@@ -211,7 +212,9 @@ onFinishCallback = \case Left ex ->- logErrorN $ pack $ "Error refreshing IAM auth token: " <> show ex+ logError+ $ "Error refreshing IAM auth token"+ :# ["exception" .= displayException ex] Right () -> pure () refreshIamToken
library/Freckle/App/Datadog.hs view
@@ -3,9 +3,7 @@ -- | Datadog access for your @App@ module Freckle.App.Datadog- (- -- * Reader environment interface- HasDogStatsClient(..)+ ( HasDogStatsClient(..) , HasDogStatsTags(..) , StatsClient , Tag
library/Freckle/App/Env.hs view
@@ -51,7 +51,7 @@ -- If the variable is present and non-empty in the environment, the active value -- is returned, otherwise the default is used. ----- >>> import Control.Monad.Logger+-- >>> import Blammo.Logging (LogLevel(..)) -- -- >>> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty `parsePure` [("DEBUG", "1")] -- Right LevelDebug
library/Freckle/App/Ghci.hs view
@@ -7,7 +7,7 @@ import Freckle.App.Prelude -import Control.Monad.Logger (runNoLoggingT)+import Blammo.Logging.Simple import Database.Persist.Postgresql (runSqlPool) import Database.Persist.Sql (SqlBackend) import Freckle.App.Database (makePostgresPool)@@ -20,7 +20,7 @@ -- | Run a db action runDB' :: ReaderT SqlBackend IO b -> IO b runDB' f = do- pool <- runNoLoggingT makePostgresPool+ pool <- runSimpleLoggingT makePostgresPool runSqlPool f pool loadEnvTest :: IO ()
− library/Freckle/App/Logging.hs
@@ -1,198 +0,0 @@-{-# LANGUAGE TupleSections #-}--module Freckle.App.Logging- (- -- * Logging settings- HasLogging(..)- , getLogDefaultANSI- , getLogBehaviors- , LogLevel- , LogFormat(..)- , LogLocation(..)-- -- ** Loading- , parseEnvLogFormat- , parseEnvLogLevel- , parseEnvLogLocation-- -- * 'MonadLogger'-style running- , runAppLoggerT-- -- * Formats, for use from other Logging libraries- , formatJsonLogStr- , formatJsonNoLoc- , formatJson- , formatTerminal- ) where--import Freckle.App.Prelude--import Control.Monad.Logger-import Data.Aeson (ToJSON, encode, object, (.=))-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import qualified Data.ByteString.Lazy as BSL-import qualified Freckle.App.Env as Env-import System.Console.ANSI- ( Color(Blue, Magenta, Red, Yellow)- , ColorIntensity(Dull)- , ConsoleLayer(Foreground)- , SGR(Reset, SetColor)- , hSupportsANSI- , setSGRCode- )-import System.IO (stderr, stdout)--data LogFormat- = FormatJSON- -- ^ Emit @{"level": "{level}", "message": "{message}"}@- | FormatTerminal- -- ^ Emit @[{level}] @{message}@, possibly colorized--data LogLocation- = LogStdout- | LogStderr- | LogFile FilePath---- | Class for getting Logging settings from your @app@ type-class HasLogging a where- getLogLevel :: a -> LogLevel-- getLogFormat :: a -> LogFormat-- getLogLocation :: a -> LogLocation---- | Provide a pure decision for colorizing output------ This is useful in a context where actively checking for ANSI terminal support--- is either not possible or too expensive. Given that we support 'LogFile', and--- so are unlikely to be redirecting terminal output to a file, it is relatively--- safe to use this determination.----getLogDefaultANSI :: HasLogging a => a -> Bool-getLogDefaultANSI app = case (getLogLocation app, getLogFormat app) of- (LogStdout, FormatTerminal) -> True- (LogStdout, FormatJSON) -> False- (LogStderr, FormatTerminal) -> True- (LogStderr, FormatJSON) -> False- (LogFile _, FormatTerminal) -> False- (LogFile _, FormatJSON) -> False--getLogBehaviors :: HasLogging a => a -> IO (ByteString -> IO (), Bool)-getLogBehaviors app = case getLogLocation app of- LogStdout -> (BS8.hPutStr stdout, ) <$> hSupportsANSI stdout- LogStderr -> (BS8.hPutStr stderr, ) <$> hSupportsANSI stderr- LogFile path -> pure (BS8.appendFile path, False)--parseEnvLogLevel :: Env.Parser Env.Error LogLevel-parseEnvLogLevel = Env.var parse "LOG_LEVEL" $ Env.def LevelWarn- where- parse = Env.eitherReader $ \case- "warn" -> Right LevelWarn- "error" -> Right LevelError- "debug" -> Right LevelDebug- "info" -> Right LevelInfo- level -> Left $ "unexpected log level: " <> level--parseEnvLogFormat :: Env.Parser Env.Error LogFormat-parseEnvLogFormat = Env.var parse "LOG_FORMAT" $ Env.def FormatTerminal- where- parse = Env.eitherReader $ \case- "json" -> Right FormatJSON- "terminal" -> Right FormatTerminal- format -> Left $ "unexpected format: " <> format--parseEnvLogLocation :: Env.Parser Env.Error LogLocation-parseEnvLogLocation = Env.var parse "LOG_LOCATION" $ Env.def LogStdout- where- parse = Env.eitherReader $ \case- "stdout" -> Right LogStdout- "stderr" -> Right LogStderr- "file" -> Right $ LogFile "fancy.log"- file -> Right $ LogFile file--runAppLoggerT :: HasLogging a => a -> LoggingT IO b -> IO b-runAppLoggerT app f = do- (putLogLine, isANSI) <- getLogBehaviors app-- let- logger = case getLogFormat app of- FormatJSON -> jsonLogger putLogLine- FormatTerminal -> ansiLogger putLogLine isANSI-- flip runLoggingT logger- $ filterLogger (\_ level -> level >= getLogLevel app) f- where- jsonLogger putLogLine loc src level str =- putLogLine $ formatJsonLogStr loc src level str-- ansiLogger putLogLine isANSI loc src level str =- putLogLine $ formatTerminal isANSI loc src level str--formatJsonLogStr :: Loc -> LogSource -> LogLevel -> LogStr -> ByteString-formatJsonLogStr loc src level =- formatJson (Just loc) (Just src) level . decodeUtf8 . fromLogStr--formatJsonNoLoc :: ToJSON a => LogLevel -> a -> ByteString-formatJsonNoLoc = formatJson Nothing Nothing--formatJson- :: ToJSON a => Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString-formatJson loc src level msg = (<> "\n") $ BSL.toStrict $ encode $ object- [ "loc" .= (locJson <$> loc)- , "src" .= src- , "level" .= levelText level- , "message" .= msg- ]- where- locJson Loc {..} = object- [ "filename" .= loc_filename- , "package" .= loc_package- , "module" .= loc_module- , "start" .= loc_start- , "end" .= loc_end- ]--formatTerminal- :: ToLogStr a- => Bool -- ^ Supports escapes?- -> Loc- -> LogSource- -> LogLevel- -> a- -> ByteString-formatTerminal isANSI loc src level str = mconcat- [ esc $ style level- , BS.snoc levelStr labelEnd- , esc Reset- , BS.intercalate (BS.singleton labelEnd) logStr- , esc Reset- ]- where- labelEnd = fromIntegral $ fromEnum ']'-- (levelStr, logStr) =- let formatted = fromLogStr $ defaultLogStr loc src level $ toLogStr str- in- case BS.split labelEnd formatted of- [] -> ("", [formatted])- (x : xs) -> (x, xs)-- esc x = if isANSI then BS8.pack $ setSGRCode [x] else ""--style :: LogLevel -> SGR-style = \case- LevelDebug -> SetColor Foreground Dull Magenta- LevelInfo -> SetColor Foreground Dull Blue- LevelWarn -> SetColor Foreground Dull Yellow- LevelError -> SetColor Foreground Dull Red- LevelOther _ -> Reset--levelText :: LogLevel -> Text-levelText = \case- LevelDebug -> "Debug"- LevelInfo -> "Info"- LevelWarn -> "Warn"- LevelError -> "Error"- LevelOther x -> x
library/Freckle/App/Memcached.hs view
@@ -23,7 +23,7 @@ import Freckle.App.Prelude -import Control.Monad.Logger (MonadLogger, logErrorN)+import Blammo.Logging import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL@@ -119,7 +119,10 @@ logCachingError :: MonadLogger m => Text -> Text -> m () logCachingError action message =- logErrorN $ "[Caching] error " <> action <> ": " <> message+ logErrorNS "caching"+ $ "Error "+ <> action+ :# ["action" .= action, "message" .= message] encodeStrict :: ToJSON a => a -> ByteString encodeStrict = BSL.toStrict . encode
− library/Freckle/App/RIO.hs
@@ -1,71 +0,0 @@--- | Compatibility between "Freckle.App" and "RIO"------ "Freckle.App" was created before "RIO" existed. We need to decide if we're--- going to move to using "RIO" without "Freckle.App" (and port the things--- we've added to be "RIO"-based), or not.------ As part of that decisions, some Apps are using "RIO". These should still be--- able to make use of "Freckle.App", by using this module.----module Freckle.App.RIO- ( toAppLogLevel- , fromAppLogLevel- , makeLogFunc- ) where--import Freckle.App.Prelude--import Control.Monad.Logger (Loc(..), LogLevel(..))-import Freckle.App.Logging-import GHC.Exception (CallStack, SrcLoc(..), getCallStack)-import qualified RIO--toAppLogLevel :: RIO.LogLevel -> LogLevel-toAppLogLevel = \case- RIO.LevelDebug -> LevelDebug- RIO.LevelInfo -> LevelInfo- RIO.LevelWarn -> LevelWarn- RIO.LevelError -> LevelError- RIO.LevelOther x -> LevelOther x--fromAppLogLevel :: LogLevel -> RIO.LogLevel-fromAppLogLevel = \case- LevelDebug -> RIO.LevelDebug- LevelInfo -> RIO.LevelInfo- LevelWarn -> RIO.LevelWarn- LevelError -> RIO.LevelError- LevelOther x -> RIO.LevelOther x--makeLogFunc :: HasLogging a => a -> IO RIO.LogFunc-makeLogFunc app = do- (putLogLine, isANSI) <- getLogBehaviors app-- pure $ RIO.mkLogFunc $ \cs src rioLevel builder -> do- let- level = toAppLogLevel rioLevel- msg = RIO.utf8BuilderToText builder-- when (level >= getLogLevel app) $ putLogLine $ case getLogFormat app of- FormatJSON -> formatJson (Just $ callStackToLoc cs) (Just src) level msg- FormatTerminal -> formatTerminal isANSI (callStackToLoc cs) src level msg--callStackToLoc :: CallStack -> Loc-callStackToLoc cs = fromMaybe unknownLoc $ do- (_, SrcLoc {..}) <- listToMaybe $ getCallStack cs-- pure $ Loc- { loc_filename = srcLocFile- , loc_package = srcLocPackage- , loc_module = srcLocModule- , loc_start = (srcLocStartLine, srcLocStartCol)- , loc_end = (srcLocEndLine, srcLocEndCol)- }--unknownLoc :: Loc-unknownLoc = Loc- { loc_filename = "<unknown>"- , loc_package = "<unknown>"- , loc_module = "unknown"- , loc_start = (0, 0)- , loc_end = (0, 0)- }
library/Freckle/App/Test.hs view
@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} module Freckle.App.Test- ( AppExample+ ( AppExample(..) , withApp , withAppSql , runAppTest@@ -13,16 +13,18 @@ import Freckle.App.Prelude +import Blammo.Logging import Control.Monad.Base import Control.Monad.Catch import qualified Control.Monad.Fail as Fail-import Control.Monad.Logger+import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Control.Monad.Primitive import Control.Monad.Random (MonadRandom(..)) import Control.Monad.Reader import Control.Monad.Trans.Control import Data.Pool as X import Database.Persist.Sql (SqlPersistT, runSqlPool)+import Freckle.App (runApp) import Freckle.App.Database as X import LoadEnv import Test.Hspec as X@@ -31,7 +33,15 @@ import Test.Hspec.Expectations.Lifted as X -- | An Hspec example over some @App@ value-newtype AppExample app a = AppExample (NoLoggingT (ReaderT app IO) a)+--+-- To disable logging in tests, you can either:+--+-- - Export @LOG_LEVEL=error@, if this would be quiet enough, or+-- - Export @LOG_DESTINATION=@/dev/null@ to fully silence+--+newtype AppExample app a = AppExample+ { unAppExample :: ReaderT app (LoggingT IO) a+ } deriving newtype ( Applicative , Functor@@ -42,11 +52,21 @@ , MonadIO , MonadReader app , MonadThrow- , MonadUnliftIO , MonadLogger , Fail.MonadFail ) +-- We could derive this in newer versions of unliftio-core, but defining it by+-- hand supports a few resolvers back, without CPP. This is just a copy of the+-- ReaderT instance,+--+-- https://hackage.haskell.org/package/unliftio-core-0.2.0.1/docs/src/Control.Monad.IO.Unlift.html#line-64+--+instance MonadUnliftIO (AppExample app) where+ {-# INLINE withRunInIO #-}+ withRunInIO inner =+ AppExample $ withRunInIO $ \run -> inner (run . unAppExample)+ instance MonadRandom (AppExample app) where getRandomR = liftIO . getRandomR getRandom = liftIO getRandom@@ -57,11 +77,11 @@ type PrimState (AppExample app) = PrimState IO primitive = liftIO . primitive -instance Example (AppExample app a) where+instance HasLogger app => Example (AppExample app a) where type Arg (AppExample app a) = app evaluateExample (AppExample ex) params action = evaluateExample- (action $ \app -> void $ runReaderT (runNoLoggingT ex) app)+ (action $ \app -> void $ runLoggerLoggingT app $ runReaderT ex app) params ($ ()) @@ -73,7 +93,8 @@ -- @ -- -- Reads @.env.test@, then @.env@, then loads the application. Examples within--- this spec can use 'runAppTest' (and 'runDB', if the app 'HasSqlPool').+-- this spec can use 'runAppTest' if the app 'HasLogger' (and 'runDB', if the+-- app 'HasSqlPool'). -- withApp :: IO app -> SpecWith app -> Spec withApp load = beforeAll (loadEnvTest *> load)@@ -92,13 +113,7 @@ loadEnvTest = loadEnvFrom ".env.test" >> loadEnv -- | Run an action with the test @App@------ Like @'runApp'@, but without exception handling or logging----runAppTest :: ReaderT app (LoggingT IO) a -> AppExample app a+runAppTest :: HasLogger app => ReaderT app (LoggingT IO) a -> AppExample app a runAppTest action = do app <- ask-- liftIO $ runStderrLoggingT $ filterLogger (\_ _ -> False) $ runReaderT- action- app+ liftIO $ runApp app action
library/Freckle/App/Test/Logging.hs view
@@ -4,6 +4,8 @@ ( MonadLogger , LoggingT , runCapturedLoggingT+ , logLineToJSON+ , logLineToByteString , logLineToText ) where @@ -11,6 +13,9 @@ import Control.Concurrent.Chan import Control.Monad.Logger+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL import Data.DList (DList) import qualified Data.DList as DList import UnliftIO.Async@@ -42,5 +47,11 @@ doneMessage :: Text doneMessage = "%DONE%" +logLineToJSON :: FromJSON a => LogLine -> Maybe a+logLineToJSON = decode . BSL.fromStrict . logLineToByteString++logLineToByteString :: LogLine -> ByteString+logLineToByteString (_, _, _, str) = fromLogStr str+ logLineToText :: LogLine -> Text-logLineToText (_, _, _, str) = decodeUtf8 $ fromLogStr str+logLineToText = decodeUtf8 . logLineToByteString
library/Freckle/App/Wai.hs view
@@ -1,7 +1,6 @@ -- | Integration of "Freckle.App" tooling with "Network.Wai" module Freckle.App.Wai- ( makeLoggingMiddleware- , makeRequestMetricsMiddleware+ ( makeRequestMetricsMiddleware , noCacheMiddleware , corsMiddleware , denyFrameEmbeddingMiddleware@@ -9,142 +8,19 @@ import Freckle.App.Prelude hiding (decodeUtf8) -import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader (runReaderT)-import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Data.ByteString.Builder (toLazyByteString)-import qualified Data.ByteString.Char8 as BS8-import qualified Data.ByteString.Lazy as BSL import qualified Data.CaseInsensitive as CI-import Data.Default (def)-import Data.IP (fromHostAddress, fromHostAddress6)-import Data.String (fromString) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags) import qualified Freckle.App.Datadog as Datadog-import Freckle.App.Logging-import Network.HTTP.Types (QueryItem, ResponseHeaders)-import Network.HTTP.Types.Status (Status, status200, statusCode)-import Network.Socket+import Network.HTTP.Types (ResponseHeaders)+import Network.HTTP.Types.Status (status200, statusCode) import Network.Wai import Network.Wai.Middleware.AddHeaders (addHeaders)-import Network.Wai.Middleware.RequestLogger- ( Destination(Logger)- , OutputFormat(..)- , OutputFormatterWithDetails- , destination- , mkRequestLogger- , outputFormat- )-import System.Log.FastLogger (LoggerSet, toLogStr) -makeLoggingMiddleware- :: HasLogging app- => app- -> (Request -> [(Text, Text)])- -> LoggerSet- -> IO Middleware-makeLoggingMiddleware app getTags ls = case getLogFormat app of- FormatJSON ->- makeWith- $ CustomOutputFormatWithDetails- $ suppressByStatus (getLogLevel app)- $ jsonOutputFormatter getTags- FormatTerminal -> makeWith $ Detailed $ getLogDefaultANSI app- where- makeWith format =- mkRequestLogger def { outputFormat = format, destination = Logger ls }--suppressByStatus- :: LogLevel -> OutputFormatterWithDetails -> OutputFormatterWithDetails-suppressByStatus minLevel f date req status responseSize duration reqBody response- | statusLevel status >= minLevel- = f date req status responseSize duration reqBody response- | otherwise- = ""--jsonOutputFormatter- :: (Request -> [(Text, Text)]) -> OutputFormatterWithDetails-jsonOutputFormatter getTags date req status responseSize duration _reqBody response- = toLogStr- $ formatJsonNoLoc (statusLevel status)- $ object- $ [ "time" .= decodeUtf8 date- , "method" .= decodeUtf8 (requestMethod req)- , "path" .= decodeUtf8 (rawPathInfo req)- , "query_string" .= map queryItemToJSON (queryString req)- , "status" .= statusCode status- , "duration_ms" .= (duration * 1000)- , "request_size" .= requestBodyLengthToJSON (requestBodyLength req)- , "response_size" .= responseSize- , "response_body" .= do- guard $ statusCode status >= 400- Just $ maybeDecodeToValue $ toLazyByteString response- , "client_ip" .= (decodeUtf8 <$> clientIp)- ]- <> map (uncurry (.=) . first (fromString . unpack)) (getTags req)- where clientIp = requestRealIp req <|> Just (sockAddrToIp $ remoteHost req)--statusLevel :: Status -> LogLevel-statusLevel status = case statusCode status of- 404 -> LevelInfo -- Special case- code | code >= 500 -> LevelError- code | code >= 400 -> LevelWarn- code | code >= 300 -> LevelInfo- _ -> LevelDebug--decodeUtf8 :: ByteString -> Text-decodeUtf8 = decodeUtf8With lenientDecode--requestBodyLengthToJSON :: RequestBodyLength -> Value-requestBodyLengthToJSON ChunkedBody = String "Unknown"-requestBodyLengthToJSON (KnownLength l) = toJSON l--queryItemToJSON :: QueryItem -> Value-queryItemToJSON (name, mValue) =- toJSON (decodeUtf8 name, decodeUtf8 <$> mValue)---- Try to decode as a 'Value'. Otherwise make a JSON string.-maybeDecodeToValue :: BSL.ByteString -> Value-maybeDecodeToValue str =- fromMaybe (toJSON . decodeUtf8With lenientDecode . BSL.toStrict $ str)- . decode @Value- $ str---- Copied from bugnag-haskell--requestRealIp :: Request -> Maybe ByteString-requestRealIp request =- requestForwardedFor request <|> lookup "X-Real-IP" (requestHeaders request)--requestForwardedFor :: Request -> Maybe ByteString-requestForwardedFor request =- readForwardedFor =<< lookup "X-Forwarded-For" (requestHeaders request)---- |------ >>> readForwardedFor ""--- Nothing------ >>> readForwardedFor "123.123.123"--- Just "123.123.123"------ >>> readForwardedFor "123.123.123, 45.45.45"--- Just "123.123.123"----readForwardedFor :: ByteString -> Maybe ByteString-readForwardedFor bs- | BS8.null bs = Nothing- | otherwise = Just $ fst $ BS8.break (== ',') bs--sockAddrToIp :: SockAddr -> ByteString-sockAddrToIp (SockAddrInet _ h) = BS8.pack $ show $ fromHostAddress h-sockAddrToIp (SockAddrInet6 _ _ h _) = BS8.pack $ show $ fromHostAddress6 h-sockAddrToIp _ = "<socket>"- makeRequestMetricsMiddleware :: (HasDogStatsClient env, HasDogStatsTags env) => env@@ -224,3 +100,6 @@ exposedHeaders = ["Set-Cookie", "Content-Disposition", "Link"] <> extraExposedHeaders++decodeUtf8 :: ByteString -> Text+decodeUtf8 = decodeUtf8With lenientDecode
library/Freckle/App/Yesod.hs view
@@ -1,67 +1,19 @@ -- | Integration of "Freckle.App" tooling with "Yesod" module Freckle.App.Yesod- ( makeLogger- , messageLoggerSource-- -- * Functions for use as 'yesodMiddleware'- , respondQueryCanceled+ ( respondQueryCanceled , respondQueryCanceledHeaders ) where import Freckle.App.Prelude -import Control.Monad.Logger+import Blammo.Logging import Database.PostgreSQL.Simple (SqlError(..)) import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags) import qualified Freckle.App.Datadog as Datadog-import Freckle.App.GlobalCache-import Freckle.App.Logging import Network.HTTP.Types (ResponseHeaders, status503) import qualified Network.Wai as W-import System.IO.Unsafe (unsafePerformIO)-import System.Log.FastLogger- ( LoggerSet- , defaultBufSize- , newFileLoggerSet- , newStderrLoggerSet- , newStdoutLoggerSet- )-import UnliftIO.Exception (handleJust)-import Yesod.Core.Handler (sendWaiResponse)-import Yesod.Core.Types (HandlerFor, Logger, loggerPutStr)-import Yesod.Default.Config2 (makeYesodLogger)--loggerSetVar :: GlobalCache LoggerSet-loggerSetVar = unsafePerformIO newGlobalCache-{-# NOINLINE loggerSetVar #-}-{-# ANN loggerSetVar ("HLint: ignore Avoid restricted function" :: String) #-}--makeLogger :: HasLogging a => a -> IO Logger-makeLogger app = makeYesodLogger- =<< globallyCache loggerSetVar (newLoggerSet defaultBufSize)- where- newLoggerSet = case getLogLocation app of- LogStdout -> newStdoutLoggerSet- LogStderr -> newStderrLoggerSet- LogFile f -> flip newFileLoggerSet f--messageLoggerSource- :: HasLogging a- => a- -> Logger- -> Loc- -> LogSource- -> LogLevel- -> LogStr- -> IO ()-messageLoggerSource app logger loc src level str =- when (level >= getLogLevel app)- $ loggerPutStr logger- $ toLogStr- $ case getLogFormat app of- FormatJSON -> formatJsonLogStr loc src level str- FormatTerminal ->- formatTerminal (getLogDefaultANSI app) loc src level str+import UnliftIO.Exception (displayException, handleJust)+import Yesod.Core.Handler (HandlerFor, sendWaiResponse) -- | Catch 'SqlError' when queries are canceled due to timeout and respond 503 --@@ -80,7 +32,7 @@ -> HandlerFor site res -> HandlerFor site res respondQueryCanceledHeaders headers = handleJust queryCanceled $ \ex -> do- logErrorN $ pack $ show ex+ logError $ "Query canceled" :# ["exception" .= displayException ex] Datadog.increment "query_canceled" [] sendWaiResponse $ W.responseLBS status503 headers "Query canceled"
package.yaml view
@@ -1,6 +1,6 @@ --- name: freckle-app-version: 1.1.0.0+version: 1.2.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -52,16 +52,15 @@ library: source-dirs: library dependencies:+ - Blammo - Glob - MonadRandom - aeson- - ansi-terminal - bugsnag - bytestring - case-insensitive - conduit - containers- - data-default - datadog - dlist - doctest@@ -69,7 +68,6 @@ - envparse - errors - exceptions- - fast-logger - filepath - hashable - hspec >= 2.8.1@@ -81,14 +79,12 @@ - http-link-header - http-types - immortal- - iproute - lens - load-env - memcache - monad-control - monad-logger >= 0.3.31 - mtl- - network - network-uri - persistent - persistent-postgresql@@ -96,7 +92,6 @@ - primitive - resource-pool - retry >= 0.8.1.0- - rio - safe - scientist - semigroupoids@@ -107,13 +102,13 @@ - transformers-base - typed-process - unliftio+ - unliftio-core - unordered-containers - vector - wai - wai-extra - yaml - yesod-core- - yesod tests: spec:@@ -132,7 +127,6 @@ - memcache - mtl - postgresql-simple- - unliftio-core - wai - wai-extra
tests/Freckle/App/MemcachedSpec.hs view
@@ -1,19 +1,23 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module Freckle.App.MemcachedSpec ( spec ) where import Freckle.App.Prelude -import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import Control.Lens ((^?!)) import Control.Monad.Reader+import Data.Aeson+import Data.Aeson.Lens import qualified Data.List.NonEmpty as NE import qualified Freckle.App.Env as Env import Freckle.App.Memcached import Freckle.App.Memcached.Client (MemcachedClient, newMemcachedClient) import qualified Freckle.App.Memcached.Client as Memcached import Freckle.App.Memcached.Servers+import Freckle.App.Test import Freckle.App.Test.Logging-import Test.Hspec data ExampleValue = A@@ -33,63 +37,56 @@ "C" -> Right C x -> Left $ "invalid: " <> show x -newtype TestAppT m a = TestAppT- { unTestAppT :: ReaderT MemcachedClient (LoggingT m) a- }- deriving newtype- ( Functor- , Applicative- , Monad- , MonadReader MemcachedClient- , MonadIO- , MonadLogger- )---- We could derive this in newer versions of unliftio-core, but defining it by--- hand supports a few resolvers back, without CPP. This is just a copy of the--- ReaderT instance,------ https://hackage.haskell.org/package/unliftio-core-0.2.0.1/docs/src/Control.Monad.IO.Unlift.html#line-64----instance MonadUnliftIO m => MonadUnliftIO (TestAppT m) where- {-# INLINE withRunInIO #-}- withRunInIO inner = TestAppT $ withRunInIO $ \run -> inner (run . unTestAppT)+runTestAppT+ :: MonadUnliftIO m => AppExample MemcachedClient a -> m (a, [Maybe Value])+runTestAppT f = liftIO $ do+ mc <- loadClient+ -- NB. we could use `withApp` and not need to call this runner ourselves+ -- within a plain-`IO` example -- except that we want to use+ -- `runCapturedLoggingT` and assert on the logged messages. We should add+ -- Blammo.Logging.Test to support this use-case.+ fmap (second $ map logLineToJSON) $ runCapturedLoggingT $ runReaderT+ (unAppExample f)+ mc -runTestAppT :: MonadUnliftIO m => TestAppT m a -> m (a, [Text])-runTestAppT f = do- servers <- liftIO $ Env.parse id $ Env.var+loadClient :: IO MemcachedClient+loadClient = do+ servers <- Env.parse id $ Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def defaultMemcachedServers)- mc <- newMemcachedClient servers- fmap (second $ map logLineToText) $ runCapturedLoggingT $ runReaderT- (unTestAppT f)- mc+ newMemcachedClient servers spec :: Spec spec = do describe "caching" $ do it "caches the given action by key using Cachable" $ example $ do void $ runTestAppT $ do- key <- cacheKeyThrow "A"+ k <- cacheKeyThrow "A" - val <- caching key (cacheTTL 5) $ pure A- mbs <- Memcached.get key+ val <- caching k (cacheTTL 5) $ pure A+ mbs <- Memcached.get k liftIO $ val `shouldBe` A liftIO $ mbs `shouldBe` Just "A" it "logs, but doesn't fail, on deserialization errors" $ example $ do (_, msgs) <- runTestAppT $ do- key <- cacheKeyThrow "B"+ k <- cacheKeyThrow "B" - val0 <- caching key (cacheTTL 5) $ pure B -- set- val1 <- caching key (cacheTTL 5) $ pure B -- get will fail- mbs <- Memcached.get key+ val0 <- caching k (cacheTTL 5) $ pure B -- set+ val1 <- caching k (cacheTTL 5) $ pure B -- get will fail+ mbs <- Memcached.get k liftIO $ val0 `shouldBe` B liftIO $ val1 `shouldBe` B liftIO $ mbs `shouldBe` Just "Broken" - fmap NE.last (NE.nonEmpty msgs)- `shouldBe` Just "[Caching] error deserializing: invalid: \"Broken\""+ let Just val = NE.last =<< NE.nonEmpty msgs+ val ^?! key "text" . _String `shouldBe` "Error deserializing"+ val ^?! key "meta" . key "action" . _String `shouldBe` "deserializing"+ val+ ^?! key "meta"+ . key "message"+ . _String+ `shouldBe` "invalid: \"Broken\""