boots-app 0.1.0.2 → 0.1.0.3

raw patch · 6 files changed

+93/−28 lines, 6 filesdep +menshendep +vaultdep ~basedep ~salakPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: menshen, vault

Dependency ranges changed: base, salak

API changes (from Hackage documentation)

Files

• boots-app.cabal +11/−5
• src/Boots.hs +2/−0
• src/Boots/App/Internal.hs +2/−0
• src/Boots/Factory/Application.hs +18/−11
• src/Boots/Factory/Logger.hs +30/−12
• src/Boots/Factory/Vault.hs +30/−0

@@ -1,6 +1,6 @@ cabal-version: 1.12 name: boots-app-version: 0.1.0.2+version: 0.1.0.3 license: MIT license-file: LICENSE copyright: 2019 Daniel YU@@ -22,6 +22,7 @@         Boots.Factory.Salak         Boots.Factory.Application         Boots.Factory.Logger+        Boots.Factory.Vault     hs-source-dirs: src     other-modules:         Boots.App.Internal@@ -36,14 +37,16 @@         data-default >=0.7.1.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.3 && <0.4,+        salak >=0.3.3.1 && <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+        unliftio-core >=0.1.2.0 && <0.2,+        vault >=0.3.1.3 && <0.4  test-suite spec     type: exitcode-stdio-1.0@@ -56,6 +59,7 @@         Boots.Factory.Application         Boots.Factory.Logger         Boots.Factory.Salak+        Boots.Factory.Vault         Paths_boots_app     default-language: Haskell2010     default-extensions: FlexibleInstances MultiParamTypeClasses@@ -69,11 +73,13 @@         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.3 && <0.4,+        salak >=0.3.3.1 && <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+        unliftio-core >=0.1.2.0 && <0.2,+        vault >=0.3.1.3 && <0.4

@@ -4,6 +4,7 @@   , module Boots.Factory.Salak   , module Boots.Factory.Application   , module Boots.Factory.Logger+  , module Boots.Factory.Vault   ) where  import           Boots.App@@ -11,3 +12,4 @@ import           Boots.Factory.Application import           Boots.Factory.Logger import           Boots.Factory.Salak+import           Boots.Factory.Vault

@@ -17,6 +17,7 @@ import           Control.Monad.Catch import           Control.Monad.IO.Unlift import           Control.Monad.Reader+import           Data.Menshen  -- | Application monad transformation. newtype AppT cxt m a = AppT { unAppT :: ReaderT cxt m a }@@ -40,5 +41,6 @@     withRunInIO $ \run ->     inner (run . runAppT r) +instance MonadThrow m => HasValid (AppT cxt m) where  

@@ -9,8 +9,10 @@ import           Boots.Factory import           Boots.Factory.Logger import           Boots.Factory.Salak+import           Boots.Factory.Vault import           Control.Concurrent.MVar import           Data.Maybe+import           Data.Proxy import           Data.String import           Data.Text               (Text) import           Data.Version            (Version)@@ -21,35 +23,40 @@ import           Salak import           System.Random.SplitMix -class HasApp env where-  askApp :: Lens' env AppEnv+class HasApp cxt env where+  askApp :: Lens' env (AppEnv cxt) -instance HasApp AppEnv where+instance HasApp cxt (AppEnv cxt) where   askApp = id -instance HasSalak AppEnv where+instance HasSalak (AppEnv cxt) where   askSourcePack = lens configure (\x y -> x {configure = y}) -instance HasLogger AppEnv where+instance HasLogger (AppEnv cxt) where   askLogger = lens logF (\x y -> x {logF = y}) -data AppEnv = AppEnv+instance HasVault cxt (AppEnv cxt) where+  askVault = lens vaultF (\x y -> x {vaultF = y})++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   } -buildApp :: (MonadIO m, MonadCatch m) => String -> Version -> Factory m () AppEnv+buildApp :: (HasLogger cxt, MonadIO m, MonadCatch m) => String -> Version -> Factory m () (AppEnv cxt) buildApp confName version = do   configure  <- buildSalak confName   within configure $ do     name       <- fromMaybe (fromString confName) <$> require "application.name"     randSeed   <- offer $ liftIO $ initSMGen >>= newMVar     instanceId <- offer $ liftIO $ hex64 <$> random64 randSeed-    logF       <- buildLogger (name <> "," <> instanceId)+    vaultF     <- liftIO $ newVaultRef+    logF       <- buildLogger vaultF (name <> "," <> instanceId)     return AppEnv{..}  random64 :: MVar SMGen -> IO Word64@@ -63,7 +70,7 @@ rand64 :: (IsString a, MonadIO m) => MVar SMGen -> m a rand64 = liftIO . fmap hex64 . random64 -buildRandom :: (IsString a, MonadIO m, HasApp env) => Factory m env a-buildRandom = do-  AppEnv{..} <- asks (view askApp)+buildRandom :: forall cxt env a m. (IsString a, MonadIO m, HasApp cxt env) => Proxy cxt -> Factory m env a+buildRandom _ = do+  (AppEnv{..} :: AppEnv cxt) <- asks (view askApp)   offer $ rand64 randSeed

@@ -2,6 +2,7 @@     HasLogger(..)   , LogConfig(..)   , LogFunc+  , traceVault   , addTrace   , buildLogger   -- ** Log Functions@@ -19,10 +20,12 @@ import           Boots.App.Internal import           Boots.Factory import           Boots.Factory.Salak+import           Boots.Factory.Vault 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           Data.Word import           Lens.Micro import           Lens.Micro.Extras@@ -94,6 +97,7 @@   { logfunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()   , logend  :: IO ()   , logLvl  :: Writable LogLevel+  , logKey  :: L.Key Text   }  newLogger :: Text -> LogConfig -> IO LogFunc@@ -103,24 +107,38 @@       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)+  (l,logend) <- newTimedFastLogger tc ft+  logLvl     <- toWritable level+  logKey     <- L.newKey+  let logfunc = toLogger logLvl ln l+  return (LogFunc{..})   where-    toLogger lvl xn f Loc{..} _ ll s = do-      lc <- getWritable lvl+    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 <> xn <> toLogStr loc_module <> locate <> " - " <> s <> "\n"+        in toLogStr t <> " " <> toStr ll <> ln <> 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) }+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 +-- | 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  buildLogger-  :: (MonadIO m, MonadCatch m, HasSalak env)-  => Text -> Factory m env LogFunc-buildLogger name = do-  lc <- require "logging"+  :: (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)

@@ -0,0 +1,30 @@+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++class HasVault cxt env where+  askVault :: Lens' env (VaultRef cxt)++instance HasVault cxt (VaultRef cxt) where+  askVault = id++modifyVault :: (HasVault cxt env, MonadIO n) => (L.Vault -> cxt -> cxt) -> Factory n env ()+modifyVault f = asks (view askVault) >>= modifyVaultRef f++modifyVaultRef :: MonadIO n => (L.Vault -> env -> env) -> VaultRef env -> n ()+modifyVaultRef f ref = liftIO $ modifyMVar_ ref $ \g -> return $ \v -> g v . f v++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