boots-app (empty) → 0.1

raw patch · 10 files changed

+402/−0 lines, 10 filesdep +basedep +bootsdep +data-default

Dependencies added: base, boots, data-default, exceptions, fast-logger, hspec, microlens, monad-logger, mtl, salak, salak-yaml, splitmix, text, unliftio-core

Files

• LICENSE +21/−0
• README.md +1/−0
• boots-app.cabal +79/−0
• src/Boots.hs +13/−0
• src/Boots/App.hs +24/−0
• src/Boots/App/Internal.hs +44/−0
• src/Boots/Factory/Application.hs +71/−0
• src/Boots/Factory/Logger.hs +117/−0
• src/Boots/Factory/Salak.hs +28/−0
• test/Spec.hs +4/−0

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Daniel YU++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,1 @@+# Boots-app

@@ -0,0 +1,79 @@+cabal-version: 1.12+name: boots-app+version: 0.1+license: MIT+license-file: LICENSE+copyright: 2019 Daniel YU+maintainer: leptonyu@gmail.com+author: Daniel YU+homepage: https://github.com/leptonyu/boots#readme+synopsis: Startup factories using IoC monad+description:+    Provide basic factories base on boots.+category: Library, Application+build-type: Simple+extra-source-files:+    README.md++library+    exposed-modules:+        Boots+        Boots.App+        Boots.Factory.Salak+        Boots.Factory.Application+        Boots.Factory.Logger+    hs-source-dirs: src+    other-modules:+        Boots.App.Internal+    default-language: Haskell2010+    default-extensions: FlexibleInstances MultiParamTypeClasses+                        GeneralizedNewtypeDeriving OverloadedStrings RecordWildCards+                        FlexibleContexts RankNTypes ScopedTypeVariables+    ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures+    build-depends:+        base >=4.10 && <5,+        boots ==0.1.*,+        data-default >=0.7.1.1 && <0.8,+        exceptions >=0.10.2 && <0.11,+        fast-logger >=2.4.16 && <2.5,+        microlens >=0.4.10 && <0.5,+        monad-logger >=0.3.30 && <0.4,+        mtl >=2.2.2 && <2.3,+        salak >=0.3.3 && <0.4,+        salak-yaml >=0.3.3 && <0.4,+        splitmix >=0.0.3 && <0.1,+        text >=1.2.3.1 && <1.3,+        unliftio-core >=0.1.2.0 && <0.2++test-suite spec+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    hs-source-dirs: test src+    other-modules:+        Boots+        Boots.App+        Boots.App.Internal+        Boots.Factory.Application+        Boots.Factory.Logger+        Boots.Factory.Salak+        Paths_boots_app+    default-language: Haskell2010+    default-extensions: FlexibleInstances MultiParamTypeClasses+                        GeneralizedNewtypeDeriving OverloadedStrings RecordWildCards+                        FlexibleContexts RankNTypes ScopedTypeVariables+    ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures+    build-depends:+        base >=4.10 && <5,+        boots ==0.1.*,+        data-default >=0.7.1.1 && <0.8,+        exceptions >=0.10.2 && <0.11,+        fast-logger >=2.4.16 && <2.5,+        hspec ==2.*,+        microlens >=0.4.10 && <0.5,+        monad-logger >=0.3.30 && <0.4,+        mtl >=2.2.2 && <2.3,+        salak >=0.3.3 && <0.4,+        salak-yaml >=0.3.3 && <0.4,+        splitmix >=0.0.3 && <0.1,+        text >=1.2.3.1 && <1.3,+        unliftio-core >=0.1.2.0 && <0.2

@@ -0,0 +1,13 @@+module Boots(+    module Boots.Factory+  , module Boots.App+  , module Boots.Factory.Salak+  , module Boots.Factory.Application+  , module Boots.Factory.Logger+  ) where++import           Boots.App+import           Boots.Factory+import           Boots.Factory.Application+import           Boots.Factory.Logger+import           Boots.Factory.Salak

@@ -0,0 +1,24 @@+module Boots.App(+    natA+  , delayA+  , bracketA+  , module Boots.App.Internal+  ) where++import           Boots.App.Internal+import           Boots.Factory++natA :: Monad m => Factory (AppT env m) env component -> Factory m env component+natA fenc = do+  env <- ask+  natTrans (runAppT env) lift fenc++delayA :: MonadCatch m => AppT env m () -> Factory m env ()+delayA app = do+  env <- ask+  delay $ runAppT env app++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)

@@ -0,0 +1,44 @@+-- |+-- Module:      Boots.App.Internal+-- Copyright:   2019 Daniel YU+-- License:     BSD3+-- Maintainer:  leptonyu@gmail.com+-- Stability:   experimental+-- Portability: portable+--+-- This module defines a generic application monad transformation.+--+module Boots.App.Internal(+    AppT+  , App+  , runAppT+  ) where++import           Control.Monad.Catch+import           Control.Monad.IO.Unlift+import           Control.Monad.Reader++-- | 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)++-- | Simple IO monad.+type App cxt = AppT cxt IO++-- | Run application monad transformation.+runAppT :: cxt -> AppT cxt m a -> m a+runAppT cxt ma = runReaderT (unAppT ma) cxt++instance MonadUnliftIO m => MonadUnliftIO (AppT cxt m) where+  {-# INLINE askUnliftIO #-}+  askUnliftIO = AppT $ ReaderT $ \r ->+                withUnliftIO $ \u ->+                return (UnliftIO (unliftIO u . runAppT r))+  {-# INLINE withRunInIO #-}+  withRunInIO inner =+    AppT $ ReaderT $ \r ->+    withRunInIO $ \run ->+    inner (run . runAppT r)+++

@@ -0,0 +1,71 @@+module Boots.Factory.Application(+    HasApp(..)+  , AppEnv(..)+  , buildApp+  , rand64+  , buildRandom+  ) where++import           Boots.Factory+import           Boots.Factory.Logger+import           Boots.Factory.Salak+import           Control.Concurrent.MVar+import           Data.Maybe+import           Data.String             (fromString)+import           Data.Text               (Text)+import           Data.Version            (Version)+import           Data.Word+import           Lens.Micro+import           Lens.Micro.Extras+import           Numeric                 (showHex)+import           Salak+import           System.Random.SplitMix++class HasApp env where+  askApp :: Lens' env AppEnv++instance HasApp AppEnv where+  askApp = id++instance HasSalak AppEnv where+  askSourcePack = lens configure (\x y -> x {configure = y})++instance HasLogger AppEnv where+  askLogger = lens logF (\x y -> x {logF = y})++data AppEnv = AppEnv+  { name       :: Text    -- ^ Service name.+  , instanceId :: Text    -- ^ Instance id.+  , version    :: Version -- ^ Service version.+  , tags       :: [Text]  -- ^ Service tags.+  , randSeed   :: MVar SMGen -- ^ Random seed+  , configure  :: Salak+  , logF       :: LogFunc+  }++buildApp :: (MonadIO m, MonadCatch m) => String -> Version -> Factory m () AppEnv+buildApp confName version = do+  configure  <- buildSalak confName+  within configure $ do+    name       <- fromMaybe (fromString confName) <$> require "application.name"+    logF       <- buildLogger name+    tags       <- require "application.tags"+    randSeed   <- offer $ liftIO $ initSMGen >>= newMVar+    instanceId <- offer $ liftIO $ hex64 <$> random64 randSeed+    return AppEnv{..}++random64 :: MVar SMGen -> IO Word64+random64 ref = modifyMVar ref (return . go . nextWord64)+  where+    go (a,b) = (b,a)++hex64 :: Word64 -> Text+hex64 i = fromString $ let x = showHex i "" in replicate (16 - length x) '0' ++ x++rand64 :: MonadIO m => MVar SMGen -> m Text+rand64 = liftIO . fmap hex64 . random64++buildRandom :: (MonadIO m, HasApp env) => Factory m env Text+buildRandom = do+  AppEnv{..} <- asks (view askApp)+  offer $ rand64 randSeed

@@ -0,0 +1,117 @@+module Boots.Factory.Logger(+    HasLogger(..)+  , LogConfig(..)+  , LogFunc+  , addTrace+  , buildLogger+  , MonadLogger(..)+  ) where++import           Boots.App.Internal+import           Boots.Factory+import           Boots.Factory.Salak+import           Control.Monad+import           Control.Monad.Logger.CallStack+import           Data.Default+import           Data.Text                      (Text, toLower, unpack)+import           Data.Word+import           Lens.Micro+import           Lens.Micro.Extras+import           Salak+import           System.Log.FastLogger++-- | 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 })++instance HasLogger LogFunc where+  askLogger = id++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)++instance (MonadIO m, HasLogger cxt) => MonadLogger (AppT cxt m) where+  monadLoggerLog a b c d = do+    LogFunc{..} <- asks (view askLogger)+    liftIO $ logfunc a b c (toLogStr d)++instance (MonadIO m, HasLogger cxt) => MonadLoggerIO (Factory m cxt) where+  askLoggerIO = logfunc <$> asks (view askLogger)++instance (MonadIO m, HasLogger cxt) => MonadLoggerIO (AppT cxt m) where+  askLoggerIO = logfunc <$> asks (view askLogger)++instance Monad m => 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 toStr #-}+toStr :: LogLevel -> LogStr+toStr LevelDebug     = "DEBUG"+toStr LevelInfo      = " INFO"+toStr LevelWarn      = " WARN"+toStr LevelError     = "ERROR"+toStr (LevelOther l) = toLogStr l++-- | Logger config.+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.+  }+instance Default LogConfig where+  def = LogConfig 4096 Nothing 10485760 256 (return LevelInfo)++instance MonadIO m => FromProp m LogConfig where+  fromProp = LogConfig+    <$> "buffer-size" .?: bufferSize+    <*> "file"        .?: file+    <*> "max-size"    .?: maxSize+    <*> "max-history" .?: rotateHistory+    <*> "level"       .?: level++data LogFunc = LogFunc+  { logfunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()+  , logend  :: IO ()+  , logLvl  :: Writable LogLevel+  }++newLogger :: Text -> LogConfig -> IO LogFunc+newLogger name LogConfig{..} = do+  tc            <- newTimeCache "%Y-%m-%d %T"+  let ln = " [" <> toLogStr name <> "] "+      ft = case file of+        Just f -> LogFile (FileLogSpec f (toInteger maxSize) (fromIntegral rotateHistory)) $ fromIntegral bufferSize+        _      -> LogStdout $ fromIntegral bufferSize+  (l,close) <- newTimedFastLogger tc ft+  lvl       <- toWritable level+  return (LogFunc (toLogger lvl ln l) close lvl)+  where+    toLogger lvl xn f Loc{..} _ ll s = do+      lc <- getWritable lvl+      when (lc <= ll) $ f $ \t ->+        let locate = if ll /= LevelError then "" else " @" <> toLogStr loc_filename <> toLogStr (show loc_start)+        in toLogStr t <> " " <> toStr ll <> xn <> toLogStr loc_module <> locate <> " - " <> s <> "\n"++-- | Add additional trace info into log.+addTrace :: Text -> LogFunc -> LogFunc+addTrace trace lf = lf { logfunc = \a b c d -> let p = "[" <> toLogStr trace <> "] " in logfunc lf a b c (p <> d) }+++buildLogger+  :: (MonadIO m, MonadCatch m, HasSalak env)+  => Text -> Factory m env LogFunc+buildLogger name = do+  lc <- require "logging"+  bracket (liftIO $ newLogger name lc) (\LogFunc{..} -> liftIO logend)

@@ -0,0 +1,28 @@+module Boots.Factory.Salak(+    HasSalak(..)+  , buildSalak+  -- ** Configuration Functions+  , MonadSalak(..)+  ) where++import           Boots.App.Internal+import           Boots.Factory+import           Lens.Micro+import           Lens.Micro.Extras+import           Salak+import           Salak.Yaml++class HasSalak env where+  askSourcePack :: Lens' env SourcePack++instance HasSalak SourcePack where+  askSourcePack = id++instance (HasSalak env, Monad m) => MonadSalak (Factory m env) where+  askSalak = asks (view askSourcePack)++instance (HasSalak env, Monad m) => MonadSalak (AppT env m) where+  askSalak = asks (view askSourcePack)++buildSalak :: (MonadIO m, MonadCatch m) => String -> Factory m () Salak+buildSalak name = offer $ runSalakWithYaml name askSalak

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