diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +0.2 [2019.08.28] +------------------- +* First release. +* Builtin configuration. +* Builtin logger. +* Builtin health check. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. + diff --git a/boots-app.cabal b/boots-app.cabal --- a/boots-app.cabal +++ b/boots-app.cabal @@ -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 diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -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) + diff --git a/src/Boots.hs b/src/Boots.hs --- a/src/Boots.hs +++ b/src/Boots.hs @@ -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 + + + diff --git a/src/Boots/App.hs b/src/Boots/App.hs --- a/src/Boots/App.hs +++ b/src/Boots/App.hs @@ -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 #-} diff --git a/src/Boots/App/Internal.hs b/src/Boots/App/Internal.hs --- a/src/Boots/App/Internal.hs +++ b/src/Boots/App/Internal.hs @@ -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) diff --git a/src/Boots/Factory/Application.hs b/src/Boots/Factory/Application.hs --- a/src/Boots/Factory/Application.hs +++ b/src/Boots/Factory/Application.hs @@ -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 #-} diff --git a/src/Boots/Factory/Logger.hs b/src/Boots/Factory/Logger.hs --- a/src/Boots/Factory/Logger.hs +++ b/src/Boots/Factory/Logger.hs @@ -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 + "" + "" + "" + 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) diff --git a/src/Boots/Factory/Salak.hs b/src/Boots/Factory/Salak.hs --- a/src/Boots/Factory/Salak.hs +++ b/src/Boots/Factory/Salak.hs @@ -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 diff --git a/src/Boots/Factory/Vault.hs b/src/Boots/Factory/Vault.hs deleted file mode 100644 --- a/src/Boots/Factory/Vault.hs +++ /dev/null @@ -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 diff --git a/src/Boots/Health.hs b/src/Boots/Health.hs new file mode 100644 --- /dev/null +++ b/src/Boots/Health.hs @@ -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) diff --git a/src/Boots/Prelude.hs b/src/Boots/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Boots/Prelude.hs @@ -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 () diff --git a/src/Boots/Random.hs b/src/Boots/Random.hs new file mode 100644 --- /dev/null +++ b/src/Boots/Random.hs @@ -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 #-} diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - - -main = putStrLn "No tests"