diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/boots-app.cabal b/boots-app.cabal --- a/boots-app.cabal +++ b/boots-app.cabal @@ -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 diff --git a/demo/Main.hs b/demo/Main.hs --- a/demo/Main.hs +++ b/demo/Main.hs @@ -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" diff --git a/src/Boots.hs b/src/Boots.hs --- a/src/Boots.hs +++ b/src/Boots.hs @@ -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, ..} 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 @@ -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) diff --git a/src/Boots/CLI.hs b/src/Boots/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Boots/CLI.hs @@ -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 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,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 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 @@ -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. diff --git a/src/Boots/Prelude.hs b/src/Boots/Prelude.hs --- a/src/Boots/Prelude.hs +++ b/src/Boots/Prelude.hs @@ -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) diff --git a/src/Boots/Random.hs b/src/Boots/Random.hs --- a/src/Boots/Random.hs +++ b/src/Boots/Random.hs @@ -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