boots-app 0.1.1 → 0.2

raw patch · 15 files changed

+640/−288 lines, 15 filesdep +boots-appdep +timedep +unordered-containersdep −hspecdep −monad-loggerdep −vaultdep ~bootsnew-component:exe:demo-appPVP ok

version bump matches the API change (PVP)

Dependencies added: boots-app, time, unordered-containers

Dependencies removed: hspec, monad-logger, vault

Dependency ranges changed: boots

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +15/−1
• boots-app.cabal +23/−42
• demo/Main.hs +18/−0
• src/Boots.hs +34/−6
• src/Boots/App.hs +21/−17
• src/Boots/App/Internal.hs +18/−7
• src/Boots/Factory/Application.hs +72/−77
• src/Boots/Factory/Logger.hs +205/−92
• src/Boots/Factory/Salak.hs +25/−8
• src/Boots/Factory/Vault.hs +0/−34
• src/Boots/Health.hs +59/−0
• src/Boots/Prelude.hs +34/−0
• src/Boots/Random.hs +110/−0
• test/Spec.hs +0/−4

@@ -0,0 +1,6 @@+0.2 [2019.08.28]+-------------------+* First release.+* Builtin configuration.+* Builtin logger.+* Builtin health check.

@@ -1,1 +1,15 @@-# Boots-app+# boots-app++[![Hackage](https://img.shields.io/hackage/v/boots-app.svg?logo=haskell)](https://hackage.haskell.org/package/boots-app)+[![Build](https://img.shields.io/travis/leptonyu/boots.svg?logo=travis)](https://travis-ci.org/leptonyu/boots)+[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/leptonyu/boots-app/blob/master/LICENSE)+![Hackage-Deps](https://img.shields.io/hackage-deps/v/boots-app)++Factory for quickly building an application.++### Packages based on boots++- [![Hackage](https://img.shields.io/badge/boots-app-orange)](https://hackage.haskell.org/package/boots-app) Factory for quickly building an application.+- [![Hackage](https://img.shields.io/badge/boots-web-orange)](https://hackage.haskell.org/package/boots-web) Factory for quickly building a web application.+- [![Hackage](https://img.shields.io/badge/boots-cloud-orange)](https://hackage.haskell.org/package/boots-cloud) Factory for quickly building a microservice.+

@@ -4,13 +4,13 @@ -- -- see: https://github.com/sol/hpack ----- hash: 8bb4b2c3b8f36dc7b03817c490e5103d1f5d4b644c13203f0e148c3ac9b950ca+-- hash: 17a4d40b136abc11c3baf4e094e0f6fcb297ed9c32d14854ddafe7b1a5f5a78f  name:           boots-app-version:        0.1.1-synopsis:       Startup factories using IoC monad-description:    Provide basic factories base on boots.-category:       Library, Application+version:        0.2+synopsis:       Factory for quickly building an application+description:    A quick out-of-box factory using to build application with many useful builtin components based on [boots](https://hackage.haskell.org/package/boots).+category:       Library, Application, Configuration, Logger, Health, Random homepage:       https://github.com/leptonyu/boots#readme author:         Daniel YU maintainer:     leptonyu@gmail.com@@ -20,71 +20,52 @@ build-type:     Simple extra-source-files:     README.md+    CHANGELOG.md  library   exposed-modules:       Boots+  other-modules:       Boots.App-      Boots.Factory.Salak+      Boots.Health+      Boots.Prelude+      Boots.Random+      Boots.App.Internal       Boots.Factory.Application       Boots.Factory.Logger-      Boots.Factory.Vault-  other-modules:-      Boots.App.Internal+      Boots.Factory.Salak+      Paths_boots_app   hs-source-dirs:       src-  default-extensions: FlexibleInstances MultiParamTypeClasses GeneralizedNewtypeDeriving OverloadedStrings RecordWildCards FlexibleContexts RankNTypes ScopedTypeVariables FunctionalDependencies ConstraintKinds+  default-extensions: RecordWildCards ScopedTypeVariables   ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures   build-depends:       base >=4.10 && <5-    , boots >=0.1 && <0.2+    , boots >=0.2 && <0.3     , data-default >=0.7.1 && <0.8     , exceptions >=0.10.2 && <0.11     , fast-logger >=2.4.16 && <2.5     , menshen >=0.0.3 && <0.1     , microlens >=0.4.10 && <0.5-    , monad-logger >=0.3.30 && <0.4     , mtl >=2.2.2 && <2.3     , salak >=0.3.5 && <0.4     , salak-yaml >=0.3.5 && <0.4     , splitmix >=0.0.3 && <0.1     , text >=1.2.3 && <1.3     , unliftio-core >=0.1.2 && <0.2-    , vault >=0.3.1 && <0.4+    , unordered-containers >=0.2.10 && <0.3   default-language: Haskell2010 -test-suite spec-  type: exitcode-stdio-1.0-  main-is: Spec.hs+executable demo-app+  main-is: Main.hs   other-modules:-      Boots-      Boots.App-      Boots.App.Internal-      Boots.Factory.Application-      Boots.Factory.Logger-      Boots.Factory.Salak-      Boots.Factory.Vault       Paths_boots_app   hs-source-dirs:-      test-      src-  default-extensions: FlexibleInstances MultiParamTypeClasses GeneralizedNewtypeDeriving OverloadedStrings RecordWildCards FlexibleContexts RankNTypes ScopedTypeVariables FunctionalDependencies ConstraintKinds-  ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures+      demo+  default-extensions: RecordWildCards ScopedTypeVariables+  ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -rtsopts -threaded -with-rtsopts=-K1K   build-depends:       base >=4.10 && <5-    , boots >=0.1 && <0.2-    , data-default >=0.7.1 && <0.8-    , exceptions >=0.10.2 && <0.11-    , fast-logger >=2.4.16 && <2.5-    , hspec ==2.*-    , menshen >=0.0.3 && <0.1-    , microlens >=0.4.10 && <0.5-    , monad-logger >=0.3.30 && <0.4-    , mtl >=2.2.2 && <2.3-    , salak >=0.3.5 && <0.4-    , salak-yaml >=0.3.5 && <0.4-    , splitmix >=0.0.3 && <0.1-    , text >=1.2.3 && <1.3-    , unliftio-core >=0.1.2 && <0.2-    , vault >=0.3.1 && <0.4+    , boots-app+    , time >=1.8.0 && <1.10   default-language: Haskell2010

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import           Boots+import           Control.Monad+import           Data.Maybe+import           Data.Time+import           Paths_boots_app (version)++main :: IO ()+main = running () (buildApp "demo" Paths_boots_app.version) $+  \e -> runAppT e $ do+    count <- fromMaybe 1 <$> require "count"+    t0 <- liftIO getCurrentTime+    replicateM_ count $ logInfo "hello"+    t1 <- liftIO getCurrentTime+    liftIO $ print (diffUTCTime t1 t0)+

@@ -1,15 +1,43 @@+-- |+-- Module:      Boots+-- Copyright:   2019 Daniel YU+-- License:     MIT+-- Maintainer:  leptonyu@gmail.com+-- Stability:   experimental+-- Portability: portable+--+-- A quick out-of-box factory using to build application with many useful builtin components,+-- based on [boots](https://hackage.haskell.org/package/boots).+--+-- 1. Builtin configuration, use [salak](https://hackage.haskell.org/package/salak).+-- 2. Builtin logger functions, use [fast-logger](https://hackage.haskell.org/package/fast-logger) as backend.+-- 3. Builtin health check, support health check registration.+-- 4. Builtin random support, use [splitmix](https://hackage.haskell.org/package/splitmix) as backend.+-- 5. Define standard application values, such that @name@, @version@.+-- module Boots(-    module Boots.Factory-  , module Boots.App-  , module Boots.Factory.Salak+  -- * Monad App+    module Boots.App+  -- * Factory Instances   , module Boots.Factory.Application+  , module Boots.Factory.Salak   , module Boots.Factory.Logger-  , module Boots.Factory.Vault+  -- * Components+  , module Boots.Health+  , module Boots.Random+  -- * Reexport+  , module Control.Monad.Factory+  , module Boots.Prelude   ) where  import           Boots.App-import           Boots.Factory import           Boots.Factory.Application import           Boots.Factory.Logger import           Boots.Factory.Salak-import           Boots.Factory.Vault+import           Boots.Health+import           Boots.Prelude+import           Boots.Random+import           Control.Monad.Factory+++

@@ -1,27 +1,31 @@ module Boots.App(-    natA-  , delayA-  , bracketA-  , module Boots.App.Internal+    module Boots.App.Internal+  -- ** Utilities+  , natA+  , delay+  , produceA   ) where  import           Boots.App.Internal-import           Boots.Factory+import           Control.Monad.Factory -natA :: Monad m => Factory (AppT env m) env component -> Factory m env component+-- | Nature transform from `AppT` @env@ @m@ to @m@.+natA :: MonadMask m => Factory (AppT env m) env component -> Factory m env component natA fenc = do-  env <- ask+  env <- getEnv   natTrans (runAppT env) lift fenc {-# INLINE natA #-} -delayA :: MonadCatch m => AppT env m () -> Factory m env ()-delayA app = do-  env <- ask-  delay $ runAppT env app-{-# INLINE delayA #-}+-- | Add a delayed action into the factory.+delay :: MonadMask m => AppT env m () -> Factory m env ()+delay app = do+  env <- getEnv+  defer $ runAppT env app+{-# INLINE delay #-} -bracketA :: MonadCatch m => AppT env m res -> (res -> AppT env m ()) -> Factory m env res-bracketA open close = do-  env <- ask-  bracket (runAppT env open) (runAppT env . close)-{-# INLINE bracketA #-}+-- | Produce @res@ under environment @env@.+produceA :: MonadMask m => AppT env m res -> (res -> AppT env m ()) -> Factory m env res+produceA open close = do+  env <- getEnv+  produce (runAppT env open) (runAppT env . close)+{-# INLINE produceA #-}

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module:      Boots.App.Internal -- Copyright:   2019 Daniel YU@@ -12,26 +14,35 @@     AppT   , App   , runAppT+  , withAppT+  , MonadReader(..)+  , asks   ) where  import           Control.Monad.Catch import           Control.Monad.IO.Unlift import           Control.Monad.Reader import           Data.Menshen+import           Unsafe.Coerce           (unsafeCoerce)  -- | Application monad transformation.-newtype AppT cxt m a = AppT { unAppT :: ReaderT cxt m a }-  deriving (Functor, Applicative, Monad, MonadTrans, MonadReader cxt, MonadIO, MonadThrow, MonadCatch, MonadMask)+newtype AppT env m a = AppT { unAppT :: ReaderT env m a }+  deriving (Functor, Applicative, Monad, MonadTrans, MonadReader env, MonadIO, MonadThrow, MonadCatch, MonadMask)  -- | Simple IO monad.-type App cxt = AppT cxt IO+type App env = AppT env IO  -- | Run application monad transformation.-runAppT :: cxt -> AppT cxt m a -> m a-runAppT cxt ma = runReaderT (unAppT ma) cxt+runAppT :: env -> AppT env m a -> m a+runAppT env ma = runReaderT (unAppT ma) env {-# INLINE runAppT #-} -instance MonadUnliftIO m => MonadUnliftIO (AppT cxt m) where+-- | Execute a computation in a modified environment.+withAppT :: (env -> env) -> AppT env m a -> AppT env m a+withAppT = unsafeCoerce withReaderT+{-# INLINE withAppT #-}++instance MonadUnliftIO m => MonadUnliftIO (AppT env m) where   {-# INLINE askUnliftIO #-}   askUnliftIO = AppT $ ReaderT $ \r ->                 withUnliftIO $ \u ->@@ -42,5 +53,5 @@     withRunInIO $ \run ->     inner (run . runAppT r) -instance MonadThrow m => HasValid (AppT cxt m)+instance MonadThrow m => HasValid (AppT env m) 

@@ -1,106 +1,101 @@-{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE TupleSections          #-} module Boots.Factory.Application(+  -- ** Application     HasApp(..)   , AppEnv(..)   , buildApp-  , rand64-  , buildRandom-  , getRand   ) where -import           Boots.App.Internal-import           Boots.Factory import           Boots.Factory.Logger import           Boots.Factory.Salak-import           Boots.Factory.Vault-import           Control.Concurrent.MVar-import           Control.Monad.Logger.CallStack-import           Data.Default+import           Boots.Health+import           Boots.Prelude+import           Boots.Random+import           Control.Concurrent    (setNumCapabilities)+import           Control.Monad.Factory+import           Data.IORef import           Data.Maybe-import           Data.String-import           Data.Text                      (Text)-import           Data.Tuple-import           Data.Version                   (Version)-import           Data.Word-import           Lens.Micro-import           Lens.Micro.Extras-import           Numeric                        (showHex)+import           Data.Text             (Text)+import           Data.Version          (Version) import           Salak import           Salak.Yaml-import           System.Random.SplitMix -class HasApp cxt env | env -> cxt where-  askApp :: Lens' env (AppEnv cxt)+-- | Environment values with `AppEnv`.+class HasApp env where+  askApp :: Lens' env AppEnv -instance HasApp cxt (AppEnv cxt) where+instance HasApp AppEnv where   askApp = id   {-# INLINE askApp #-}--instance HasSalak (AppEnv cxt) where+instance HasLogger AppEnv where+  askLogger = lens logFunc (\x y -> x {logFunc = y})+  {-# INLINE askLogger #-}+instance HasSalak AppEnv where   askSalak = lens configure (\x y -> x {configure = y})   {-# INLINE askSalak #-}--instance HasLogger (AppEnv cxt) where-  askLogger = lens logF (\x y -> x {logF = y})-  {-# INLINE askLogger #-}+instance HasRandom AppEnv where+  askRandom = lens randSeed (\x y -> x {randSeed = y})+  {-# INLINE askRandom #-}+instance HasHealth AppEnv where+  askHealth = lens health (\x y -> x {health = y})+  {-# INLINE askHealth #-} -instance HasVault cxt (AppEnv cxt) where-  askVault = lens vaultF (\x y -> x {vaultF = y})-  {-# INLINE askVault #-}+-- | Application environment.+data AppEnv = AppEnv+  { name       :: Text      -- ^ Service name.+  , instanceId :: Text      -- ^ Service instance id.+  , version    :: Version   -- ^ Service version.+  , logFunc    :: LogFunc   -- ^ Logging function.+  , configure  :: Salak     -- ^ Configuration function.+  , randSeed   :: RD        -- ^ Random seed.+  , health     :: IO Health -- ^ Health check.+  } -data AppEnv cxt = AppEnv-  { name       :: Text    -- ^ Service name.-  , instanceId :: Text    -- ^ Instance id.-  , version    :: Version -- ^ Service version.-  , randSeed   :: MVar SMGen -- ^ Random seed-  , configure  :: Salak-  , logF       :: LogFunc-  , vaultF     :: VaultRef cxt+-- | Application configuration used for customizing `AppEnv`.+data AppConfig = AppConfig+  { appName         :: Maybe Text+  , numCapabilities :: Maybe Int+  , randomType      :: RDType   } -buildApp :: (HasLogger cxt, MonadIO m, MonadCatch m) => String -> Version -> Factory m () (AppEnv cxt)+instance FromProp m AppConfig where+  {-# INLINE fromProp #-}+  fromProp = AppConfig+    <$> "name"+    <*> "num-capabilities"+    <*> "random.type" .?= RDMVar++-- | Factory used to build `AppEnv`.+buildApp :: (MonadIO m, MonadMask m) => String -> Version -> Factory m () AppEnv buildApp confName version = do-  mv           <- liftIO $ newMVar []-  configure    <- liftIO $ runSalak def+  mv        <- liftIO $ newIORef []+  -- Initialize salak+  configure <- liftIO $ runSalak def       { configName = confName-      , loggerF = \c s -> modifyMVar_ mv $ return . ((c,s):)+      , loggerF = \c s -> modifyIORef' mv ((c,s):)       , loadExt = loadByExt YAML       } askSourcePack+  -- Read application name   within configure $ do-    name       <- fromMaybe (fromString confName) <$> require "application.name"-    randSeed   <- liftIO $ initSMGen >>= newMVar-    instanceId <- liftIO $ hex32 <$> random64 randSeed-    vaultF     <- liftIO newVaultRef-    logF       <- buildLogger vaultF (name <> "," <> instanceId)-    let lf c s = runLoggingT (logDebugCS c s :: LoggingT IO ()) (logfunc logF)-    liftIO $ swapMVar mv [] >>= sequence_ . reverse . fmap (uncurry lf)+    AppConfig{..} <- require "application"+    liftIO $ whenJust numCapabilities setNumCapabilities+    let name = fromMaybe (fromString confName) appName+    -- Generate instanceid+    randSeed   <- liftIO $ newRD randomType+    instanceId <- liftIO $ hex32 <$> unRD randSeed nextWord64+    -- Initialize logger+    logFunc    <- buildLogger (name <> "," <> instanceId)+    -- Consume logs from salak+    let+      health = emptyHealth+      lf c s = logCS c LevelTrace (toLogStr s) logFunc+    liftIO $ atomicModifyIORef' mv ([],) >>= sequence_ . reverse . fmap (uncurry lf)+    -- Config new logger to salak     setLogF lf     return AppEnv{..} -random64 :: MVar SMGen -> IO Word64-random64 ref = modifyMVar ref (return . swap . nextWord64)-{-# INLINE random64 #-}--hex64 :: IsString a => Word64 -> a-hex64 i = fromString $ let x = showHex i "" in replicate (16 - length x) '0' ++ x-{-# INLINE hex64 #-}--hex32 :: IsString a => Word64 -> a-hex32 i = fromString $ let x = showHex i "" in drop 8 $ replicate (16 - length x) '0' ++ x-{-# INLINE hex32 #-}--rand64 :: (IsString a, MonadIO m) => MVar SMGen -> m a-rand64 = liftIO . fmap hex64 . random64-{-# INLINE rand64 #-}--getRand :: (IsString a, HasApp cxt env, MonadIO m) => AppT env m a-getRand = do-  AppEnv{..} <- asks (view askApp)-  lift $ rand64 randSeed-{-# INLINE getRand #-}--buildRandom :: (IsString a, MonadIO m, HasApp cxt env) => Factory m env a-buildRandom = do-  AppEnv{..} <- asks (view askApp)-  offer $ rand64 randSeed-{-# INLINE buildRandom #-}

@@ -1,97 +1,106 @@+{-# LANGUAGE BangPatterns           #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE TypeApplications       #-} module Boots.Factory.Logger(+  -- ** Logger     HasLogger(..)   , LogConfig(..)   , LogFunc(..)-  , traceVault   , addTrace   , buildLogger-  -- ** Log Functions-  , MonadLogger(..)-  , MonadLoggerIO(..)-  , runLoggingT-  , logInfo+  -- *** Log Functions+  , logTrace   , logDebug-  , logError+  , logInfo   , logWarn-  , logOther+  , logError+  , logFatal+  , logCS   , LogLevel(..)+  -- *** Reexport log functions+  , levelFromStr+  , ToLogStr(..)+  , LogStr   ) where  import           Boots.App.Internal-import           Boots.Factory import           Boots.Factory.Salak-import           Boots.Factory.Vault+import           Boots.Prelude+import           Control.Concurrent      (forkIO)+import           Control.Concurrent.Chan+import           Control.Concurrent.MVar+import           Control.Exception       (SomeException, catch, finally, mask_) import           Control.Monad-import           Control.Monad.Logger.CallStack-import           Data.Default-import           Data.Text                      (Text, toLower, unpack)-import qualified Data.Vault.Lazy                as L+import           Control.Monad.Factory+import           Data.Int+import           Data.IORef+import           Data.Text               (Text, toLower, unpack) import           Data.Word-import           Lens.Micro-import           Lens.Micro.Extras+import           GHC.Stack import           Salak import           System.Log.FastLogger +-- | Log level.+data LogLevel+  = LevelTrace+  | LevelDebug+  | LevelInfo+  | LevelWarn+  | LevelError+  | LevelFatal+  deriving (Eq, Ord, Show)+ -- | Environment providing a logging function. class HasLogger env where   askLogger :: Lens' env LogFunc-  askLogLevel :: Lens' env (Writable LogLevel)-  askLogLevel = askLogger . lens logLvl (\x y -> x { logLvl = y })-  {-# INLINE askLogLevel #-}  instance HasLogger LogFunc where   askLogger = id   {-# INLINE askLogger #-} -instance (MonadIO m, HasLogger env) => MonadLogger (Factory m env) where-  monadLoggerLog a b c d = do-    LogFunc{..} <- asks (view askLogger)-    liftIO $ logfunc a b c (toLogStr d)-  {-# INLINE monadLoggerLog #-}--instance (MonadIO m, HasLogger env) => MonadLogger (AppT env m) where-  monadLoggerLog a b c d = do-    LogFunc{..} <- asks (view askLogger)-    liftIO $ logfunc a b c (toLogStr d)-  {-# INLINE monadLoggerLog #-}--instance (MonadIO m, HasLogger env) => MonadLoggerIO (Factory m env) where-  askLoggerIO = logfunc <$> asks (view askLogger)-  {-# INLINE askLoggerIO #-}--instance (MonadIO m, HasLogger env) => MonadLoggerIO (AppT env m) where-  askLoggerIO = logfunc <$> asks (view askLogger)-  {-# INLINE askLoggerIO #-}- instance FromProp m LogLevel where-  fromProp = readEnum (fromEnumProp.toLower)-    where-      fromEnumProp "debug" = Right   LevelDebug-      fromEnumProp "info"  = Right   LevelInfo-      fromEnumProp "warn"  = Right   LevelWarn-      fromEnumProp "error" = Right   LevelError-      fromEnumProp u       = Left $ "unknown level: " ++ unpack u-      {-# INLINE fromEnumProp #-}+  fromProp = readEnum levelFromStr   {-# INLINE fromProp #-} +-- | Parsing `LogLevel` from string.+{-# INLINE levelFromStr #-}+levelFromStr :: Text -> Either String LogLevel+levelFromStr = go . toLower+  where+    {-# INLINE go #-}+    go "trace" = Right   LevelTrace+    go "debug" = Right   LevelDebug+    go "info"  = Right   LevelInfo+    go "warn"  = Right   LevelWarn+    go "error" = Right   LevelError+    go "fatal" = Right   LevelFatal+    go u       = Left $ "unknown level: " ++ unpack u+ {-# INLINE toStr #-} toStr :: LogLevel -> LogStr-toStr LevelDebug     = "DEBUG"-toStr LevelInfo      = " INFO"-toStr LevelWarn      = " WARN"-toStr LevelError     = "ERROR"-toStr (LevelOther l) = toLogStr l+toStr LevelTrace = "TRACE"+toStr LevelDebug = "DEBUG"+toStr LevelInfo  = " INFO"+toStr LevelWarn  = " WARN"+toStr LevelError = "ERROR"+toStr LevelFatal = "FATAL" --- | Logger config.+-- | Logger configuation used to customizing `LogFunc`. data LogConfig = LogConfig   { bufferSize    :: !Word16         -- ^ Logger buffer size.   , file          :: !(Maybe FilePath) -- ^ Logger file path.   , maxSize       :: !Word32         -- ^ Max logger file size.   , rotateHistory :: !Word16         -- ^ Max number of logger files should be reserved.   , level         :: !(IO LogLevel)    -- ^ Log level to show.+  , asyncMode     :: !Bool   }+ instance Default LogConfig where-  def = LogConfig 4096 Nothing 10485760 256 (return LevelInfo)+  def = LogConfig 4096 Nothing 10485760 256 (return LevelInfo) True  instance MonadIO m => FromProp m LogConfig where   fromProp = LogConfig@@ -100,57 +109,161 @@     <*> "max-size"    .?: maxSize     <*> "max-history" .?: rotateHistory     <*> "level"       .?: level+    <*> "async"       .?: asyncMode   {-# INLINE fromProp #-} +-- | A `Monad` which has the ability to log messages.+class (MonadIO m, HasLogger e) => MonadLog e m | m -> e where+  askLog :: m LogFunc++instance (MonadIO m, HasLogger env) => MonadLog env (AppT env m) where+  askLog = asks (view askLogger)++instance (MonadIO m, MonadMask m, HasLogger env) => MonadLog env (Factory m env) where+  askLog = asksEnv (view askLogger)++-- | Logs a `LevelTrace` message.+logTrace :: (MonadLog e m, HasCallStack) => LogStr -> m ()+logTrace s = askLog >>= liftIO . logCS callStack LevelTrace s++-- | Logs a `LevelDebug` message.+logDebug :: (MonadLog e m, HasCallStack) => LogStr -> m ()+logDebug s = askLog >>= liftIO . logCS callStack LevelDebug s++-- | Logs a `LevelInfo` message.+logInfo :: (MonadLog e m, HasCallStack) => LogStr -> m ()+logInfo s = askLog >>= liftIO . logCS callStack LevelInfo s++-- | Logs a `LevelWarn` message.+logWarn :: (MonadLog e m, HasCallStack) => LogStr -> m ()+logWarn s = askLog >>= liftIO . logCS callStack LevelWarn s++-- | Logs a `LevelError` message.+logError :: (MonadLog e m, HasCallStack) => LogStr -> m ()+logError s = askLog >>= liftIO . logCS callStack LevelError s++-- | Logs a `LevelFatal` message.+logFatal :: (MonadLog e m, HasCallStack) => LogStr -> m ()+logFatal s = askLog >>= liftIO . logCS callStack LevelFatal s++-- | Logs a message with location given by `CallStack`.+{-# INLINE logCS #-}+logCS :: CallStack -> LogLevel -> LogStr -> LogFunc -> IO ()+logCS cs ll ls lf = logfunc lf (go $ getCallStack cs) ll ls+  where+    {-# INLINE go #-}+    go ((_,loc):_) = loc+    go _           = def++instance Default SrcLoc where+  def = SrcLoc+    "<unknown>"+    "<unknown>"+    "<unknown>"+    0 0 0 0++-- | A closable logging function.+-- Also supporting change log level and count failed logs. data LogFunc = LogFunc-  { logfunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()+  { logfunc :: SrcLoc -> LogLevel -> LogStr -> IO ()   , logend  :: IO ()   , logLvl  :: Writable LogLevel-  , logKey  :: L.Key Text+  , logFail :: IO Int64   } +-- | Log event.+data LogEvent = LogEvent+  { lloc   :: SrcLoc+  , llevel :: LogLevel+  , llog   :: LogStr+  , lname  :: LogStr+  , ltime  :: IO FormattedTime+  }++{-# INLINE runLog #-}+runLog :: (LogStr -> IO ()) -> Writable LogLevel -> LogEvent -> IO ()+runLog !lf !logLvl !LogEvent{..} = do+  lc <- getWritable logLvl+  when (lc <= llevel) $ makeLog lloc >>= lf+  where+    {-# INLINE makeLog #-}+    makeLog SrcLoc{..} = do+      t <- ltime+      let locate = if llevel <= LevelWarn+            then ""+            else " @" <> toLogStr srcLocFile <> toLogStr (show srcLocStartCol)+      return+        $ toLogStr t+        <> " "+        <> toStr llevel+        <> lname+        <> toLogStr srcLocModule+        <> locate+        <> " - "+        <> llog+        <> "\n"++{-# INLINE asyncLog #-}+asyncLog+  :: (LogStr -> IO ())+  -> Writable LogLevel+  -> (SomeException -> IO ())+  -> IO ()+  -> IO (LogEvent -> IO (), IO ())+asyncLog lf ll lfail le = do+  rc <- newChan -- First Channel+  b  <- newIORef True+  let+    loop rr ww = do+      xb <- readIORef b+      when xb $ do+        _ <- readChan rr >>= ww+        loop rr ww+    {-# INLINE leftc #-}+    leftc = mask_ (getChanContents rc >>= mapM_ (runLog lf ll))+  void $ forkIO $ loop rc (runLog lf ll)+  return+    ( writeChan rc+    , (modifyIORef' b (\_ -> False) >> (catch leftc lfail)) `finally` le+    )++-- | Create a new `LogFunc`. newLogger :: Text -> LogConfig -> IO LogFunc newLogger name LogConfig{..} = do-  tc            <- newTimeCache "%Y-%m-%d %T"-  let ln = " [" <> toLogStr name <> "] "-      ft = case file of+  (logf,close)  <- newFastLogger $ case file of         Just f -> LogFile (FileLogSpec f (toInteger maxSize) (fromIntegral rotateHistory)) $ fromIntegral bufferSize         _      -> LogStdout $ fromIntegral bufferSize-  (l,logend) <- newTimedFastLogger tc ft-  logLvl     <- toWritable level-  logKey     <- L.newKey-  let logfunc = toLogger logLvl ln l-  return (LogFunc{..})-  where-    toLogger logLvl ln f Loc{..} _ ll s = do-      lc <- getWritable logLvl-      when (lc <= ll) $ f $ \t ->-        let locate = if ll /= LevelError then "" else " @" <> toLogStr loc_filename <> toLogStr (show loc_start)-        in toLogStr t <> " " <> toStr ll <> ln <> toLogStr loc_module <> locate <> " - " <> s <> "\n"---- | Add additional trace info into log.-traceVault :: L.Vault -> LogFunc -> LogFunc-traceVault v LogFunc{..} = LogFunc { logfunc = \a b c d -> logfunc a b c (go d), .. }-  where-    go :: LogStr -> LogStr-    go d = maybe d (\p -> "[" <> toLogStr p <> "] " <> d) $ L.lookup logKey v-    {-# INLINE go #-}-{-# INLINE traceVault #-}+  ltime    <- newTimeCache "%Y-%m-%d %T"+  logLvl   <- toWritable level+  logFailM <- newMVar 0+  let+    {-# INLINE logFail #-}+    logFail = readMVar logFailM+    {-# INLINE lfail #-}+    lfail   = \(_::SomeException) -> modifyMVar_ logFailM (return . (+1))+    {-# INLINE lname #-}+    lname = " [" <> toLogStr name <> "] "+  (execLog,logend) <- if asyncMode+    then asyncLog logf logLvl lfail close+    else return (\e -> runLog logf logLvl e `catch` lfail, close)+  let+    {-# INLINE logfunc #-}+    logfunc ~lloc ~llevel ~llog = execLog LogEvent {..}+  return LogFunc{..}  -- | Add additional trace info into log.-addTrace :: Maybe Text -> LogFunc -> L.Vault -> L.Vault-addTrace (Just msg) LogFunc{..} v =-  let mt = L.lookup logKey v-  in case mt of-    Just m -> L.insert logKey (m <> "," <> msg) v-    _      -> L.insert logKey msg v-addTrace _ _ v = v {-# INLINE addTrace #-}+addTrace :: ToLogStr msg => msg -> LogFunc -> LogFunc+addTrace msg LogFunc{..} = LogFunc+  { logfunc = \a b c -> logfunc a b ("[" <> toLogStr msg <> "] " <> c)+  , ..} +-- | Factory which produces a `LogFunc`. buildLogger-  :: (MonadIO m, MonadCatch m, HasSalak env, HasLogger cxt)-  => VaultRef cxt -> Text -> Factory m env LogFunc-buildLogger vf name = do-  lc  <- require "logging"-  modifyVaultRef (over askLogger . traceVault) vf-  bracket (liftIO $ newLogger name lc) (\LogFunc{..} -> liftIO logend)+  :: ( MonadIO m+    , MonadMask m+    , HasSalak env)+  => Text -> Factory m env LogFunc+buildLogger name = do+  lc   <- require "logging"+  produce (liftIO $ newLogger name lc) (\LogFunc{..} -> liftIO logend)

@@ -1,17 +1,22 @@+{-# LANGUAGE TypeSynonymInstances #-} module Boots.Factory.Salak(+  -- ** Configuration     HasSalak(..)-  , buildSalak-  -- ** Configuration Functions   , MonadSalak(..)+  , buildSalak+  -- *** Utilities+  , tryBuildByKey   ) where  import           Boots.App.Internal-import           Boots.Factory-import           Lens.Micro-import           Lens.Micro.Extras+import           Boots.Prelude+import           Control.Monad.Factory+import           Data.Maybe+import           Data.Text             (Text) import           Salak import           Salak.Yaml +-- | Environment values with `Salak`. class HasSalak env where   askSalak :: Lens' env Salak @@ -19,13 +24,25 @@   askSalak = id   {-# INLINE askSalak #-} -instance (HasSalak env, Monad m) => MonadSalak (Factory m env) where-  askSourcePack = asks (view askSalak)+instance (HasSalak env, MonadMask m) => MonadSalak (Factory m env) where+  askSourcePack = asksEnv (view askSalak)   {-# INLINE askSourcePack #-}  instance (HasSalak env, Monad m) => MonadSalak (AppT env m) where   askSourcePack = asks (view askSalak)   {-# INLINE askSourcePack #-} +-- | Factory which loads configurations, and produces a configuration instance. buildSalak :: (MonadIO m, MonadCatch m) => String -> Factory m () Salak-buildSalak name = offer $ runSalakWithYaml name askSourcePack+buildSalak name = liftIO $ runSalakWithYaml name askSourcePack++-- | A helper function used for try to build a factory if configuration set true.+tryBuildByKey+  ::(MonadMask m, MonadIO m, HasSalak env)+  => Bool -- ^ Default value.+  -> Text -- ^ Configuration key.+  -> Factory m env () -- ^ Target factory.+  -> Factory m env () -- ^ Launch the target factory if configuration is setted to be true.+tryBuildByKey defBool key fac = do+  b <- fromMaybe defBool <$> require key+  when b fac

@@ -1,34 +0,0 @@-module Boots.Factory.Vault where--import           Boots.App.Internal-import           Boots.Factory-import           Control.Concurrent.MVar-import qualified Data.Vault.Lazy         as L-import           Lens.Micro-import           Lens.Micro.Extras--type VaultRef env = MVar (L.Vault -> env -> env)--newVaultRef :: IO (VaultRef env)-newVaultRef = newMVar $ const id-{-# INLINE newVaultRef #-}--class HasVault cxt env | env -> cxt where-  askVault :: Lens' env (VaultRef cxt)--instance HasVault cxt (VaultRef cxt) where-  askVault = id-  {-# INLINE askVault #-}--modifyVault :: (HasVault cxt env, MonadIO n) => (L.Vault -> cxt -> cxt) -> Factory n env ()-modifyVault f = asks (view askVault) >>= modifyVaultRef f-{-# INLINE modifyVault #-}--modifyVaultRef :: MonadIO n => (L.Vault -> env -> env) -> VaultRef env -> n ()-modifyVaultRef f ref = liftIO $ modifyMVar_ ref $ \g -> return $ \v -> g v . f v-{-# INLINE modifyVaultRef #-}--runVault :: (MonadIO m, HasVault env env) => env -> L.Vault -> AppT env m a -> m a-runVault env v ma = do-  f <- liftIO $ readMVar $ view askVault env-  runAppT (f v env) ma

@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections     #-}+module Boots.Health(+  -- ** Health Check+    Health(..)+  , HealthStatus(..)+  , HasHealth(..)+  , emptyHealth+  , registerHealth+  ) where++import           Boots.Prelude+import           Control.Exception     (SomeException, catch)+import           Control.Monad.Factory+import qualified Data.HashMap.Strict   as HM+import           Data.Text             (Text, pack)+import           GHC.Generics++-- | Health status.+data HealthStatus = UP | DOWN deriving (Eq, Show, Generic)++-- | Health detail.+data Health = Health+  { status  :: !HealthStatus+  , errMsg  :: !(Maybe Text)+  , details :: !(HM.HashMap Text Health)+  } deriving (Eq, Show, Generic)++-- | Default health detail.+{-# INLINE emptyHealth #-}+emptyHealth :: IO Health+emptyHealth = return (Health UP Nothing HM.empty)++-- | Environment values with health checker `IO Health`.+class HasHealth env where+  askHealth :: Lens' env (IO Health)++instance HasHealth (IO Health) where+  askHealth = id++type CheckHealth = (Text, IO HealthStatus)++insertHealth :: CheckHealth -> IO Health -> IO Health+insertHealth (na, ios) ior = do+  (err,s)          <- ((Nothing,) <$> ios) `catch` (\(e :: SomeException) -> return (Just (pack $ show e), DOWN))+  Health{..} <- ior+  return (Health (if s == DOWN then s else status) Nothing $ HM.insert na (Health s err HM.empty) details)++-- combineHealth :: [CheckHealth] -> IO Health -> IO Health+-- combineHealth = flip (foldr insertHealth)++-- | Register a health checker.+registerHealth+  :: (MonadMask n, HasHealth env)+  => Text -- ^ Component name.+  -> IO HealthStatus -- ^ Check action.+  -> Factory n env ()+registerHealth  name status = modifyEnv $ over askHealth $ insertHealth (name, status)

@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}+module Boots.Prelude(+    rightToMaybe+  , whenJust+  , when+  , unless+  , IsString(..)+  , view+  , over+  , Lens'+  , lens+  , (&)+  , Monoid(..)+  , Proxy(..)+  , Default(..)+  ) where++import           Control.Monad+import           Data.Default+import           Data.Proxy+import           Data.String+import           Lens.Micro+import           Lens.Micro.Extras+#if __GLASGOW_HASKELL__ < 804+import           Data.Semigroup    ()+#endif++rightToMaybe :: Either a b -> Maybe b+rightToMaybe (Left  _) = Nothing+rightToMaybe (Right b) = Just b++whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()+whenJust (Just a) f = f a+whenJust _        _ = pure ()

@@ -0,0 +1,110 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE TupleSections          #-}+module Boots.Random(+    RD(..)+  , HasRandom(..)+  , MonadRandom(..)+  , newRD+  , RDType(..)+  , makeRD+  , makeRD0+  , forkRD+  , hex32+  , hex64+  , nextWord64+  , splitSMGen+  ) where++import           Boots.App.Internal+import           Boots.Prelude+import           Control.Concurrent.MVar+import           Control.Monad.Factory+import           Data.IORef+import           Data.Text               (toLower, unpack)+import           Data.Tuple+import           Foreign+import           Numeric                 (showHex)+import           Salak+import           System.Random.SplitMix++-- | Random value generator.+data RD = RD { unRD :: forall a. (SMGen -> (a, SMGen)) -> IO a }++-- | Seed container type.+data RDType = RDIORef | RDMVar++instance FromProp m RDType where+  fromProp = readEnum (go . toLower)+    where+      {-# INLINE go #-}+      go "ioref" = Right RDIORef+      go "mvar"  = Right RDMVar+      go v       = Left $ "unknown <" <> unpack v <> ">"++-- | Environment values with `RD`.+class HasRandom env where+  askRandom :: Lens' env RD++instance HasRandom RD where+  askRandom = id+  {-# INLINE askRandom #-}++-- | Create a new random value generator.+{-# INLINE newRD #-}+newRD :: RDType -> IO RD+newRD RDIORef = initSMGen >>= newIORef >>= \ref -> return (RD $ \f -> atomicModifyIORef' ref (swap.f))+newRD _       = initSMGen >>= makeRD++-- | Create random value generator with a seed.+{-# INLINE makeRD #-}+makeRD :: SMGen -> IO RD+makeRD seed = newMVar seed >>= \ref -> return (RD $ \f -> modifyMVar ref (return . swap . f))++-- | Create a thread unsafe `RD`, which should be used only in single thread.+-- It is faster than `RD` generated by `newRD` and `makeRD`.+{-# INLINE makeRD0 #-}+makeRD0 :: SMGen -> (RD -> IO a) -> IO a+makeRD0 smg f = do+  let (seed, gamma) = unseedSMGen smg+  allocaArray 2 $ \ps -> do+    pokeArray ps [seed,gamma]+    f $ RD $ \func -> do+      [s0,g0] <- peekArray 2 ps+      let (a, smg2) = func $ seedSMGen s0 g0+          (s1,g1)   = unseedSMGen smg2+      pokeArray ps [s1,g1]+      return a++-- | Fork a new `RD` from old `RD`.+{-# INLINE forkRD #-}+forkRD :: RD -> IO RD+forkRD (RD f) = f splitSMGen >>= makeRD++class Monad m => MonadRandom env m | m -> env where+  nextW64   :: m Word64++-- | Convert `Word64` into 64 bit hex.+hex64 :: IsString a => Word64 -> a+hex64 i = fromString $ let x = showHex i "" in replicate (16 - length x) '0' ++ x+{-# INLINE hex64 #-}++-- | Convert `Word64` into 32 bit hex.+hex32 :: IsString a => Word64 -> a+hex32 i = fromString $ let x = showHex i "" in drop 8 $ replicate (16 - length x) '0' ++ x+{-# INLINE hex32 #-}++instance (HasRandom env, MonadMask n, MonadIO n) => MonadRandom env (Factory n env) where+  nextW64 = do+    vr <- asksEnv (view askRandom)+    liftIO $ unRD vr nextWord64+  {-# INLINE nextW64 #-}++instance (HasRandom env, MonadIO n) => MonadRandom env (AppT env n) where+  nextW64 = do+    vr <- asks (view askRandom)+    liftIO $ unRD vr nextWord64+  {-# INLINE nextW64 #-}

@@ -1,4 +0,0 @@-module Main where---main = putStrLn "No tests"