boots-app 0.2 → 0.2.0.1

raw patch · 11 files changed

+146/−40 lines, 11 filesdep +megaparsecdep +optparse-applicativedep −menshendep ~basedep ~bootsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: megaparsec, optparse-applicative

Dependencies removed: menshen

Dependency ranges changed: base, boots

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +1/−1
• boots-app.cabal +8/−6
• demo/Main.hs +3/−2
• src/Boots.hs +26/−3
• src/Boots/App/Internal.hs +0/−3
• src/Boots/CLI.hs +63/−0
• src/Boots/Factory/Application.hs +28/−16
• src/Boots/Factory/Logger.hs +5/−6
• src/Boots/Prelude.hs +5/−0
• src/Boots/Random.hs +1/−3

@@ -1,3 +1,9 @@+0.2.0.1 [2019.09.03]+-------------------+* Support GHC 8.8.1+* Modify `AppEnv`+* Add CLI tools+ 0.2 [2019.08.28] ------------------- * First release.

@@ -2,7 +2,7 @@  [![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)+[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/leptonyu/boots/blob/master/boots-app/LICENSE) ![Hackage-Deps](https://img.shields.io/hackage-deps/v/boots-app)  Factory for quickly building an application.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 17a4d40b136abc11c3baf4e094e0f6fcb297ed9c32d14854ddafe7b1a5f5a78f+-- hash: 63d3fc4730694b81fb3859e265d6d472522edcbd9802d46bc6f2972199aa2ce4  name:           boots-app-version:        0.2+version:        0.2.0.1 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@@ -26,6 +26,7 @@   exposed-modules:       Boots   other-modules:+      Boots.CLI       Boots.App       Boots.Health       Boots.Prelude@@ -40,14 +41,15 @@   default-extensions: RecordWildCards ScopedTypeVariables   ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures   build-depends:-      base >=4.10 && <5-    , boots >=0.2 && <0.3+      base >=4.9 && <5+    , boots >=0.2.0.1 && <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+    , megaparsec >=7.0.5 && <7.1     , microlens >=0.4.10 && <0.5     , mtl >=2.2.2 && <2.3+    , optparse-applicative >=0.14.3 && <0.16     , salak >=0.3.5 && <0.4     , salak-yaml >=0.3.5 && <0.4     , splitmix >=0.0.3 && <0.1@@ -65,7 +67,7 @@   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+      base >=4.9 && <5     , boots-app     , time >=1.8.0 && <1.10   default-language: Haskell2010

@@ -8,8 +8,9 @@ import           Paths_boots_app (version)  main :: IO ()-main = running () (buildApp "demo" Paths_boots_app.version) $-  \e -> runAppT e $ do+main = bootApp "demo" Paths_boots_app.version (return ()) $ do+  env <- getEnv+  return $ runAppT env $ do     count <- fromMaybe 1 <$> require "count"     t0 <- liftIO getCurrentTime     replicateM_ count $ logInfo "hello"

@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- Module:      Boots -- Copyright:   2019 Daniel YU@@ -16,8 +18,10 @@ -- 5. Define standard application values, such that @name@, @version@. -- module Boots(+  -- * Environment+    bootApp   -- * Monad App-    module Boots.App+  , module Boots.App   -- * Factory Instances   , module Boots.Factory.Application   , module Boots.Factory.Salak@@ -25,12 +29,15 @@   -- * Components   , module Boots.Health   , module Boots.Random+  -- * CLI+  , module Boots.CLI   -- * Reexport   , module Control.Monad.Factory   , module Boots.Prelude   ) where  import           Boots.App+import           Boots.CLI import           Boots.Factory.Application import           Boots.Factory.Logger import           Boots.Factory.Salak@@ -38,6 +45,22 @@ import           Boots.Prelude import           Boots.Random import           Control.Monad.Factory--+import           Data.Version              (Version) +-- | An out-of-box application booter, with builtin components. Also supports a default commandline handling.+bootApp+  :: String -- ^ name+  -> Version -- ^ version+  -> Factory IO (AppEnv ()) env -- ^ Generate env+  -> Factory IO (AppEnv env) (IO ()) -- ^ Application body.+  -> IO ()+bootApp n ver fext fac = runCLI ver+  $ \cli -> boot+  $ buildApp n ver cli () >>> go >>> fac+  where+    {-# INLINE go #-}+    go = do+      ext1       <- fext+      AppEnv{..} <- getEnv+      logInfo $ "Start Service [" <> toLogStr name <> "] ..."+      return AppEnv{ext = ext1, ..}

@@ -22,7 +22,6 @@ import           Control.Monad.Catch import           Control.Monad.IO.Unlift import           Control.Monad.Reader-import           Data.Menshen import           Unsafe.Coerce           (unsafeCoerce)  -- | Application monad transformation.@@ -52,6 +51,4 @@     AppT $ ReaderT $ \r ->     withRunInIO $ \run ->     inner (run . runAppT r)--instance MonadThrow m => HasValid (AppT env m) 

@@ -0,0 +1,63 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+module Boots.CLI(+    CLI(..)+  , interruptCli+  , runCLI+  ) where++import           Boots.Prelude+import           Control.Exception    (Exception, catch)+import           Control.Monad.Catch  (MonadThrow (..))+import           Data.List            (intercalate)+import           Data.Text            (Text)+import           Data.Version         (Version, showVersion)+import           Data.Void+import           Options.Applicative+import           Salak+import qualified Text.Megaparsec      as M+import qualified Text.Megaparsec.Char as M+#if __GLASGOW_HASKELL__ < 804+import           Data.Semigroup+#endif++-- | Options parsed from arguments.+data CLI = CLI+  { cliV :: Bool+  , cOpt :: [(Text, Text)]+  }++data CliInterrupt = CliInterrupt deriving Show++instance Exception CliInterrupt++-- | Normal interrupt cli.+interruptCli :: MonadThrow m => m a+interruptCli = throwM CliInterrupt++cli :: Parser CLI+cli = CLI+  <$> switch (long "version" <> short 'V' <> help "Print version information")+  <*> many (argument (eitherReader go) (metavar "KEY=VAL..."))+  where+    go = mapLeft M.errorBundlePretty . M.parse kv "" . fromString+    kv :: P (Text, Text)+    kv = do+      k <- key+      _ <- M.char '='+      v <- val+      return (fromString $ intercalate "." k, fromString v)+    key = ((:) <$> M.lowerChar <*> M.many (M.choice [ M.lowerChar, M.digitChar, M.char '-'])) `M.sepBy` M.char '.'+    val = M.some M.printChar++type P = M.Parsec Void Text++-- | Run cli.+runCLI :: Version -> (ParseCommandLine -> IO ()) -> IO ()+runCLI v f = (execParser go >>= g2) `catch` ge+  where+    go = info (cli <**> helper) fullDesc+    ge CliInterrupt   = return ()+    g2 CLI{..} = if cliV+      then putStrLn $ showVersion v+      else f $ \_ -> return cOpt

@@ -1,13 +1,14 @@-{-# LANGUAGE DuplicateRecordFields  #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE TupleSections         #-} module Boots.Factory.Application(   -- ** Application     HasApp(..)   , AppEnv(..)+  , askExt   , buildApp   ) where @@ -26,27 +27,27 @@ import           Salak.Yaml  -- | Environment values with `AppEnv`.-class HasApp env where-  askApp :: Lens' env AppEnv+class HasApp env ext where+  askApp :: Lens' env (AppEnv ext) -instance HasApp AppEnv where+instance HasApp (AppEnv ext) ext where   askApp = id   {-# INLINE askApp #-}-instance HasLogger AppEnv where+instance HasLogger (AppEnv ext) where   askLogger = lens logFunc (\x y -> x {logFunc = y})   {-# INLINE askLogger #-}-instance HasSalak AppEnv where+instance HasSalak (AppEnv ext) where   askSalak = lens configure (\x y -> x {configure = y})   {-# INLINE askSalak #-}-instance HasRandom AppEnv where+instance HasRandom (AppEnv ext) where   askRandom = lens randSeed (\x y -> x {randSeed = y})   {-# INLINE askRandom #-}-instance HasHealth AppEnv where+instance HasHealth (AppEnv ext) where   askHealth = lens health (\x y -> x {health = y})   {-# INLINE askHealth #-}  -- | Application environment.-data AppEnv = AppEnv+data AppEnv ext = AppEnv   { name       :: Text      -- ^ Service name.   , instanceId :: Text      -- ^ Service instance id.   , version    :: Version   -- ^ Service version.@@ -54,8 +55,12 @@   , configure  :: Salak     -- ^ Configuration function.   , randSeed   :: RD        -- ^ Random seed.   , health     :: IO Health -- ^ Health check.+  , ext        :: ext   } +askExt :: Lens' (AppEnv ext) ext+askExt = lens ext (\x y -> x {ext = y})+ -- | Application configuration used for customizing `AppEnv`. data AppConfig = AppConfig   { appName         :: Maybe Text@@ -71,14 +76,21 @@     <*> "random.type" .?= RDMVar  -- | Factory used to build `AppEnv`.-buildApp :: (MonadIO m, MonadMask m) => String -> Version -> Factory m () AppEnv-buildApp confName version = do+buildApp+  :: (MonadIO m, MonadMask m)+  => String+  -> Version+  -> ParseCommandLine+  -> ext+  -> Factory m () (AppEnv ext)+buildApp confName version mcli ext = do   mv        <- liftIO $ newIORef []   -- Initialize salak   configure <- liftIO $ runSalak def       { configName = confName       , loggerF = \c s -> modifyIORef' mv ((c,s):)       , loadExt = loadByExt YAML+      , commandLine = mcli       } askSourcePack   -- Read application name   within configure $ do

@@ -4,7 +4,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings      #-} {-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE TypeApplications       #-} module Boots.Factory.Logger(   -- ** Logger     HasLogger(..)@@ -100,7 +99,7 @@   }  instance Default LogConfig where-  def = LogConfig 4096 Nothing 10485760 256 (return LevelInfo) True+  def = LogConfig 4096 Nothing 10485760 256 (return LevelInfo) False  instance MonadIO m => FromProp m LogConfig where   fromProp = LogConfig@@ -182,7 +181,7 @@  {-# INLINE runLog #-} runLog :: (LogStr -> IO ()) -> Writable LogLevel -> LogEvent -> IO ()-runLog !lf !logLvl !LogEvent{..} = do+runLog !lf !logLvl LogEvent{..} = do   lc <- getWritable logLvl   when (lc <= llevel) $ makeLog lloc >>= lf   where@@ -224,7 +223,7 @@   void $ forkIO $ loop rc (runLog lf ll)   return     ( writeChan rc-    , (modifyIORef' b (\_ -> False) >> (catch leftc lfail)) `finally` le+    , (modifyIORef' b (const False) >> catch leftc lfail) `finally` le     )  -- | Create a new `LogFunc`.@@ -240,7 +239,7 @@     {-# INLINE logFail #-}     logFail = readMVar logFailM     {-# INLINE lfail #-}-    lfail   = \(_::SomeException) -> modifyMVar_ logFailM (return . (+1))+    lfail (_::SomeException) = modifyMVar_ logFailM (return . (+1))     {-# INLINE lname #-}     lname = " [" <> toLogStr name <> "] "   (execLog,logend) <- if asyncMode@@ -248,7 +247,7 @@     else return (\e -> runLog logf logLvl e `catch` lfail, close)   let     {-# INLINE logfunc #-}-    logfunc ~lloc ~llevel ~llog = execLog LogEvent {..}+    logfunc lloc llevel llog = execLog LogEvent {..}   return LogFunc{..}  -- | Add additional trace info into log.

@@ -2,6 +2,7 @@ module Boots.Prelude(     rightToMaybe   , whenJust+  , mapLeft   , when   , unless   , IsString(..)@@ -32,3 +33,7 @@ whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f () whenJust (Just a) f = f a whenJust _        _ = pure ()++mapLeft :: (a -> c) -> Either a b -> Either c b+mapLeft _ (Right a) = Right a+mapLeft f (Left  a) = Left (f a)

@@ -1,9 +1,7 @@ {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE OverloadedStrings      #-} {-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE TupleSections          #-} module Boots.Random(     RD(..)   , HasRandom(..)@@ -32,7 +30,7 @@ import           System.Random.SplitMix  -- | Random value generator.-data RD = RD { unRD :: forall a. (SMGen -> (a, SMGen)) -> IO a }+newtype RD = RD { unRD :: forall a. (SMGen -> (a, SMGen)) -> IO a }  -- | Seed container type. data RDType = RDIORef | RDMVar