boots-app 0.1.0.5 → 0.1.0.6
raw patch · 8 files changed
+60/−17 lines, 8 filesdep ~bootsdep ~salakdep ~salak-yaml
Dependency ranges changed: boots, salak, salak-yaml
Files
- boots-app.cabal +7/−7
- src/Boots.hs +0/−0
- src/Boots/App.hs +3/−0
- src/Boots/App/Internal.hs +2/−2
- src/Boots/Factory/Application.hs +28/−7
- src/Boots/Factory/Logger.hs +13/−1
- src/Boots/Factory/Salak.hs +3/−0
- src/Boots/Factory/Vault.hs +4/−0
boots-app.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: boots-app-version: 0.1.0.5+version: 0.1.0.6 license: MIT license-file: LICENSE copyright: 2019 Daniel YU@@ -34,7 +34,7 @@ ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: base >=4.10 && <5,- boots ==0.1.*,+ boots >=0.1.1 && <0.2, data-default >=0.7.1.1 && <0.8, exceptions >=0.10.2 && <0.11, fast-logger >=2.4.16 && <2.5,@@ -42,8 +42,8 @@ microlens >=0.4.10 && <0.5, monad-logger >=0.3.30 && <0.4, mtl >=2.2.2 && <2.3,- salak >=0.3.3.2 && <0.4,- salak-yaml >=0.3.3.2 && <0.4,+ salak >=0.3.5 && <0.4,+ salak-yaml >=0.3.5 && <0.4, splitmix >=0.0.3 && <0.1, text >=1.2.3.1 && <1.3, unliftio-core >=0.1.2.0 && <0.2,@@ -70,7 +70,7 @@ ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: base >=4.10 && <5,- boots ==0.1.*,+ boots >=0.1.1 && <0.2, data-default >=0.7.1.1 && <0.8, exceptions >=0.10.2 && <0.11, fast-logger >=2.4.16 && <2.5,@@ -79,8 +79,8 @@ microlens >=0.4.10 && <0.5, monad-logger >=0.3.30 && <0.4, mtl >=2.2.2 && <2.3,- salak >=0.3.3.2 && <0.4,- salak-yaml >=0.3.3.2 && <0.4,+ salak >=0.3.5 && <0.4,+ salak-yaml >=0.3.5 && <0.4, splitmix >=0.0.3 && <0.1, text >=1.2.3.1 && <1.3, unliftio-core >=0.1.2.0 && <0.2,
src/Boots.hs view
src/Boots/App.hs view
@@ -12,13 +12,16 @@ natA fenc = do env <- ask 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 #-} 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 #-}
src/Boots/App/Internal.hs view
@@ -29,6 +29,7 @@ -- | Run application monad transformation. runAppT :: cxt -> AppT cxt m a -> m a runAppT cxt ma = runReaderT (unAppT ma) cxt+{-# INLINE runAppT #-} instance MonadUnliftIO m => MonadUnliftIO (AppT cxt m) where {-# INLINE askUnliftIO #-}@@ -41,6 +42,5 @@ withRunInIO $ \run -> inner (run . runAppT r) -instance MonadThrow m => HasValid (AppT cxt m) where-+instance MonadThrow m => HasValid (AppT cxt m)
src/Boots/Factory/Application.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImplicitParams #-} module Boots.Factory.Application( HasApp(..) , AppEnv(..)@@ -13,15 +14,19 @@ import Boots.Factory.Salak import Boots.Factory.Vault import Control.Concurrent.MVar+import Control.Monad.Logger.CallStack+import Data.Default import Data.Maybe import Data.String-import Data.Text (Text)-import Data.Version (Version)+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 Numeric (showHex) import Salak+import Salak.Yaml import System.Random.SplitMix class HasApp cxt env | env -> cxt where@@ -29,15 +34,19 @@ instance HasApp cxt (AppEnv cxt) where askApp = id+ {-# INLINE askApp #-} instance HasSalak (AppEnv cxt) 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 HasVault cxt (AppEnv cxt) where askVault = lens vaultF (\x y -> x {vaultF = y})+ {-# INLINE askVault #-} data AppEnv cxt = AppEnv { name :: Text -- ^ Service name.@@ -51,35 +60,47 @@ buildApp :: (HasLogger cxt, MonadIO m, MonadCatch m) => String -> Version -> Factory m () (AppEnv cxt) buildApp confName version = do- configure <- buildSalak confName+ mv <- liftIO $ newMVar []+ configure <- liftIO $ runSalak def+ { configName = confName+ , loggerF = \c s -> modifyMVar_ mv $ return . ((c,s):)+ , loadExt = loadByExt YAML+ } askSourcePack 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)+ setLogF lf return AppEnv{..} random64 :: MVar SMGen -> IO Word64-random64 ref = modifyMVar ref (return . go . nextWord64)- where- go (a,b) = (b,a)+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 #-}
src/Boots/Factory/Logger.hs view
@@ -1,7 +1,7 @@ module Boots.Factory.Logger( HasLogger(..) , LogConfig(..)- , LogFunc+ , LogFunc(..) , traceVault , addTrace , buildLogger@@ -37,25 +37,31 @@ 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)@@ -65,6 +71,8 @@ fromEnumProp "warn" = Right LevelWarn fromEnumProp "error" = Right LevelError fromEnumProp u = Left $ "unknown level: " ++ unpack u+ {-# INLINE fromEnumProp #-}+ {-# INLINE fromProp #-} {-# INLINE toStr #-} toStr :: LogLevel -> LogStr@@ -92,6 +100,7 @@ <*> "max-size" .?: maxSize <*> "max-history" .?: rotateHistory <*> "level" .?: level+ {-# INLINE fromProp #-} data LogFunc = LogFunc { logfunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()@@ -125,6 +134,8 @@ where go :: LogStr -> LogStr go d = maybe d (\p -> "[" <> toLogStr p <> "] " <> d) $ L.lookup logKey v+ {-# INLINE go #-}+{-# INLINE traceVault #-} -- | Add additional trace info into log. addTrace :: Maybe Text -> LogFunc -> L.Vault -> L.Vault@@ -134,6 +145,7 @@ Just m -> L.insert logKey (m <> "," <> msg) v _ -> L.insert logKey msg v addTrace _ _ v = v+{-# INLINE addTrace #-} buildLogger :: (MonadIO m, MonadCatch m, HasSalak env, HasLogger cxt)
src/Boots/Factory/Salak.hs view
@@ -17,12 +17,15 @@ instance HasSalak Salak where askSalak = id+ {-# INLINE askSalak #-} instance (HasSalak env, Monad m) => MonadSalak (Factory m env) where askSourcePack = asks (view askSalak)+ {-# INLINE askSourcePack #-} instance (HasSalak env, Monad m) => MonadSalak (AppT env m) where askSourcePack = asks (view askSalak)+ {-# INLINE askSourcePack #-} buildSalak :: (MonadIO m, MonadCatch m) => String -> Factory m () Salak buildSalak name = offer $ runSalakWithYaml name askSourcePack
src/Boots/Factory/Vault.hs view
@@ -11,18 +11,22 @@ 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