boots-web 0.2 → 0.2.0.1

raw patch · 15 files changed

+138/−122 lines, 15 filesdep +servantdep −timedep ~basedep ~bootsdep ~boots-appPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: servant

Dependencies removed: time

Dependency ranges changed: base, boots, boots-app

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• boots-web.cabal +6/−6
• src/Boots/Endpoint/Class.hs +6/−3
• src/Boots/Endpoint/Health.hs +3/−4
• src/Boots/Endpoint/Info.hs +5/−3
• src/Boots/Endpoint/Logger.hs +4/−1
• src/Boots/Endpoint/Metrics.hs +1/−0
• src/Boots/Endpoint/Refresh.hs +4/−1
• src/Boots/Endpoint/Swagger.hs +0/−1
• src/Boots/Factory/Endpoint.hs +3/−2
• src/Boots/Factory/Error.hs +1/−2
• src/Boots/Factory/Random.hs +0/−1
• src/Boots/Factory/Trace.hs +0/−1
• src/Boots/Factory/Web.hs +57/−68
• src/Boots/Web.hs +44/−29

@@ -1,3 +1,7 @@+0.2.0.1 [2019.09.03]+-------------------+* Add bootWebEnv+ 0.2 [2019.08.28] ------------------- * First release.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d9adb6d374b0cb9dc52eda97c75b686f163de767b0da55ef021afd0a472624e6+-- hash: 5215c3f55eaffc3e9d440031424b85a0c65259a827643b5b9d2defb123c3dd30  name:           boots-web-version:        0.2+version:        0.2.0.1 synopsis:       Factory for quickly building a web application description:    A quick out-of-box factory using to build web application with many useful builtin components based on [boots](https://hackage.haskell.org/package/boots) and [servant](https://hackage.haskell.org/package/servant). category:       Library, Application, Servant, Swagger, Web@@ -45,9 +45,9 @@   ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures   build-depends:       aeson >=1.4.4 && <1.5-    , base >=4.10 && <5-    , boots >=0.2 && <0.3-    , boots-app >=0.2 && <0.3+    , base >=4.9 && <5+    , boots >=0.2.0.1 && <0.3+    , boots-app >=0.2.0.1 && <0.3     , bytestring >=0.10.8 && <0.11     , containers >=0.6.0 && <0.7     , ekg-core >=0.1.1 && <0.2@@ -55,11 +55,11 @@     , microlens >=0.4.10 && <0.5     , monad-logger >=0.3.30 && <0.4     , salak >=0.3.5 && <0.4+    , servant >=0.16.2 && <0.17     , servant-server >=0.16.2 && <0.17     , servant-swagger >=1.1.7.1 && <1.2     , swagger2 >=2.4 && <2.5     , text >=1.2.3 && <1.3-    , time >=1.8.0 && <1.10     , unordered-containers >=0.2.10 && <0.3     , vault >=0.3.1 && <0.4     , wai >=3.2.2 && <3.3

@@ -1,11 +1,14 @@ {-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-}-module Boots.Endpoint.Class where+module Boots.Endpoint.Class(+    registerEndpoint+  ) where  import           Boots import           Boots.Factory.Web@@ -20,7 +23,7 @@ instance HasServer api ctx   => HasServer (EndpointTag :> api) ctx where   type ServerT (EndpointTag :> api) m = ServerT api m-  route _ b = pathRouter "endpoints" . (route (Proxy @api) b)+  route _ b = pathRouter "endpoints" . route (Proxy @api) b   hoistServerWithContext _ = hoistServerWithContext (Proxy @api)  instance HasSwagger api => HasSwagger (EndpointTag :> api) where@@ -37,7 +40,7 @@   => Text -- ^ Endpoint name, used for path, @/endpoints/:name@.   -> Proxy context -- ^ Context proxy.   -> Proxy api -- ^ Api proxy.-  -> ServerT api (App env) -- ^ Api server.+  -> ServerT api (App (AppEnv env)) -- ^ Api server.   -> Factory n (WebEnv env context) () registerEndpoint name pc _ server = do   WebEnv{..} <- getEnv

@@ -1,13 +1,12 @@ {-# LANGUAGE DataKinds         #-}-{-# LANGUAGE DeriveAnyClass    #-}-{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections     #-} {-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeOperators     #-} -module Boots.Endpoint.Health where+module Boots.Endpoint.Health(+    endpointHealth+  ) where  import           Boots import           Boots.Endpoint.Class

@@ -6,7 +6,9 @@ {-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeOperators     #-} -module Boots.Endpoint.Info where+module Boots.Endpoint.Info(+    endpointInfo+  ) where  import           Boots import           Boots.Endpoint.Class@@ -35,10 +37,10 @@   => Proxy context   -> Factory n (WebEnv env context) () endpointInfo pc = do-  app <- asksEnv (view askApp)+  WebEnv{..} <- getEnv   registerEndpoint "info" pc (Proxy @EndpointInfo) $ liftIO $ do     rtsf <- getRTSFlags-    return (go rtsf app)+    return (go rtsf envs)   where     {-# INLINE go #-}     go RTSFlags{..} AppEnv{..}=

@@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE TypeApplications           #-} {-# LANGUAGE TypeOperators              #-}-module Boots.Endpoint.Logger where+module Boots.Endpoint.Logger(+    endpointLogger+  ) where  import           Boots import           Boots.Endpoint.Class

@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeOperators     #-}

@@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds         #-} {-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeOperators     #-}-module Boots.Endpoint.Refresh where+module Boots.Endpoint.Refresh(+   endpointRefresh+  ) where  import           Boots import           Boots.Endpoint.Class

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP               #-} {-# LANGUAGE DataKinds         #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeOperators     #-} module Boots.Endpoint.Swagger where 

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module:      Boots.Factory.Endpoint@@ -37,8 +38,8 @@   -> Factory n (WebEnv env context) () buildEndpoints pc _ = do   WebEnv{..} <- getEnv-  unless   (enabled endpoint) $ logInfo "Endpoint is disabled."-  tryBuild (enabled endpoint) $ do+  unless (enabled endpoint) $ logInfo "Endpoint is disabled."+  when   (enabled endpoint) $ do     endpointInfo    pc     endpointLogger  pc     endpointRefresh pc

@@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE TypeApplications    #-} -- | -- Module:      Boots.Factory.Error -- Copyright:   2019 Daniel YU@@ -53,7 +52,7 @@  {-# INLINE toLog #-} toLog :: HasLogger env => Request -> Status -> App env ()-toLog ~req Status{..} =+toLog req Status{..} =   let {-# INLINE g #-}       g (Just i) = " \"" <> toLogStr i <> "\""       g _        = " \"\""

@@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE TypeApplications    #-} -- | -- Module:      Boots.Factory.Random -- Copyright:   2019 Daniel YU

@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections     #-}-{-# LANGUAGE TypeApplications  #-} -- | -- Module:      Boots.Factory.Trace -- Copyright:   2019 Daniel YU

@@ -1,20 +1,20 @@-{-# LANGUAGE AllowAmbiguousTypes   #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}  module Boots.Factory.Web(     buildWeb-  , HasWeb+  , HasWeb(..)   -- ** Configuration   , HasWebConfig(..)   , WebConfig(..)@@ -36,7 +36,6 @@   , HasContextEntry(..)   , SetContextEntry(..)   , Context(..)-  , askContext   , logException   , whenException   , ToSchema@@ -108,17 +107,13 @@                => Proxy api -> Swagger               -- ^ A wrapper of `toSwagger`.   , middleware :: EnvMiddleware env -- ^ Modified middleware.-  , envs       :: env -- ^ Application environment.-  , context    :: env -> Context context -- ^ Function used to generate @context@ from @env.+  , envs       :: AppEnv env -- ^ Application environment.+  , context    :: AppEnv env -> Context context -- ^ Function used to generate @context@ from @env.   , config     :: WebConfig -- ^ Web configuration.   , endpoint   :: EndpointConfig -- ^ Endpoint configuration.   , store      :: Store -- ^ Metrics store.   } -{-# INLINE askEnv' #-}-askEnv' :: Lens' (WebEnv env context) env-askEnv' = lens envs (\x y -> x { envs = y})- -- | Environment values with `WebEnv`. instance HasWebConfig (WebEnv env context) where   askWebConfig = lens config (\x y -> x { config = y})@@ -126,31 +121,31 @@ instance HasMetrics (WebEnv env context) where   {-# INLINE askMetrics #-}   askMetrics = lens store (\x y -> x { store = y})-instance HasSalak env => HasSalak (WebEnv env context) where+instance HasApp (WebEnv env context) env where+  {-# INLINE askApp #-}+  askApp = lens envs (\x y -> x { envs = y})+instance HasSalak (WebEnv env context) where   {-# INLINE askSalak #-}-  askSalak = askEnv' . askSalak-instance HasLogger env => HasLogger (WebEnv env context) where+  askSalak = askApp @(WebEnv env context) @env . askSalak+instance HasLogger (WebEnv env context) where   {-# INLINE askLogger #-}-  askLogger = askEnv' . askLogger-instance HasRandom env => HasRandom (WebEnv env context) where+  askLogger = askApp @(WebEnv env context) @env . askLogger+instance HasRandom (WebEnv env context) where   {-# INLINE askRandom #-}-  askRandom = askEnv' . askRandom-instance HasApp env => HasApp (WebEnv env context) where-  {-# INLINE askApp #-}-  askApp = askEnv' . askApp-instance HasHealth env => HasHealth (WebEnv env context) where+  askRandom = askApp @(WebEnv env context) @env . askRandom+instance HasHealth (WebEnv env context) where   {-# INLINE askHealth #-}-  askHealth = askEnv' . askHealth+  askHealth = askApp @(WebEnv env context) @env . askHealth --- | Unified constraints for web environment.-type HasWeb context env =-  ( HasApp env-  , HasLogger env-  , HasHealth env-  , HasRandom env-  , HasSalak env-  , HasContextEntry context env)+class+  ( HasContextEntry context (AppEnv env)+  , SetContextEntry context (AppEnv env))+  => HasWeb context env | context -> env where+  askWeb :: Lens' (Context context) (AppEnv env)+  askWeb = lens getContextEntry (flip setContextEntry) +instance HasWeb (AppEnv env : as) env+ -- | Class type used to modify @context@ entries. class HasContextEntry context env => SetContextEntry context env where   setContextEntry :: env -> Context context -> Context context@@ -163,27 +158,21 @@   {-# INLINE setContextEntry #-}   setContextEntry env (_ :. as) = env :. as --- | Lens for modify @env@ in @context@.-{-# INLINE askContext #-}-askContext :: SetContextEntry context env => Lens' (Context context) env-askContext = lens getContextEntry (flip setContextEntry)--instance (SetContextEntry context env, HasSalak env) => HasSalak (Context context) where-  {-# INLINE askSalak #-}-  askSalak = askContext @context @env . askSalak-instance (SetContextEntry context env, HasLogger env) => HasLogger (Context context) where-  {-# INLINE askLogger #-}-  askLogger = askContext @context @env . askLogger-instance (SetContextEntry context env, HasRandom env) => HasRandom (Context context) where-  {-# INLINE askRandom #-}-  askRandom = askContext @context @env . askRandom+instance HasWeb context env => HasApp (Context context) env where+  askApp = askWeb @context @env+instance HasWeb context env => HasSalak (Context context) where+  askSalak = askWeb @context @env . askSalak+instance HasWeb context env => HasLogger (Context context) where+  askLogger = askWeb @context @env . askLogger+instance HasWeb context env => HasRandom (Context context) where+  askRandom = askWeb @context @env . askRandom  -- | Create a web environment. {-# INLINE newWebEnv #-} newWebEnv-  :: (HasContextEntry context env, HasLogger env)-  => env -- ^ Application environment.-  -> (env -> Context context) -- ^ Function used to generate @context@ from @env@.+  :: HasContextEntry context (AppEnv env)+  => AppEnv env -- ^ Application environment.+  -> (AppEnv env -> Context context) -- ^ Function used to generate @context@ from @env@.   -> WebConfig -- ^ Web configuration.   -> EndpointConfig -- ^ Endpoint configuration.   -> Store -- ^ Metrics store.@@ -192,11 +181,11 @@  -- | Get application environment @env@. {-# INLINE askEnv #-}-askEnv :: MonadMask n => Factory n (WebEnv env context) env+askEnv :: MonadMask n => Factory n (WebEnv env context) (AppEnv env) askEnv = envs <$> getEnv  -- | Modified wai `Middleware`, which support modify @env@.-type EnvMiddleware env = (env -> Application) -> env -> Application+type EnvMiddleware env = (AppEnv env -> Application) -> AppEnv env -> Application  -- | Register a modified middleware. {-# INLINE registerMiddleware #-}@@ -219,8 +208,8 @@ buildWeb _ _ = do   (WebEnv{..} :: WebEnv env context) <- getEnv   within envs $ do-    AppEnv{..}        <- asksEnv (view askApp)-    let serveWarp WebConfig{..} = runSettings+    let AppEnv{..} = envs+        serveWarp WebConfig{..} = runSettings           $ defaultSettings           & setPort (fromIntegral port)           & setOnExceptionResponse whenException@@ -264,14 +253,14 @@ -- | Serve web server with swagger. tryServeWithSwagger   :: forall env context api n-  . ( HasContextEntry context env+  . ( HasContextEntry context (AppEnv env)     , HasServer api context     , HasSwagger api     , MonadMask n)   => Bool -- ^ If do this action.   -> Proxy context -- ^ Context proxy.   -> Proxy api -- ^ Api proxy.-  -> ServerT api (App env) -- ^ Api server.+  -> ServerT api (App (AppEnv env)) -- ^ Api server.   -> Factory n (WebEnv env context) () tryServeWithSwagger b pc proxy server = do   trySwagger b    proxy@@ -283,23 +272,23 @@   => Bool -- ^ If do this action.   -> Proxy api -- ^ Api proxy.   -> Factory n (WebEnv env context) ()-trySwagger b api = tryBuild b $ modifyEnv $ \web -> web { serveA = serveA web . gop api }+trySwagger b api = when b $ modifyEnv $ \web -> web { serveA = serveA web . gop api }  -- | Try serve a web server. tryServe   :: forall env context api n-  . ( HasContextEntry context env+  . ( HasContextEntry context (AppEnv env)     , HasServer api context     , MonadMask n)   => Bool -- ^ If do this action.   -> Proxy context -- ^ Context proxy.   -> Proxy api -- ^ Api proxy.-  -> ServerT api (App env) -- ^ Api server.+  -> ServerT api (App (AppEnv env)) -- ^ Api server.   -> Factory n (WebEnv env context) ()-tryServe b pc proxy server = tryBuild b $+tryServe b pc proxy server = when b $   modifyEnv     $ \web -> web { serveW = \p c s -> serveW web (gop p proxy) c-    $ s :<|> hoistServerWithContext proxy pc (go . runAppT (getContextEntry c :: env)) server }+    $ s :<|> hoistServerWithContext proxy pc (go . runAppT (getContextEntry c :: AppEnv env)) server }   where     {-# INLINE go #-}     go :: IO a -> Servant.Handler a

@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications  #-} -- |@@ -22,6 +23,8 @@ module Boots.Web(   -- * Boot web     bootWeb+  , bootWebEnv+  , runContext   , module Boots.Factory.Web   -- * Metrics   , module Boots.Metrics@@ -45,7 +48,13 @@  import           Boots import           Data.Version           (Version)+import           Servant.API+import           Servant.Server +-- | Run context.+runContext :: HasContextEntry context env => Context context -> AppT env m () -> m ()+runContext = runAppT . getContextEntry+ -- | A out-of-box web application booter with many predefined components. bootWeb   :: forall api env context@@ -54,34 +63,40 @@     , HasWeb context env)   => String -- ^ Application name.   -> Version -- ^ Application version.-  -> (AppEnv -> env) -- ^ Function which generates @env@ using `AppEnv`.-  -> (env -> Context context) -- ^ Function which generates @context@ using @env@.-  -> (Proxy context -> Proxy env -> Factory IO (WebEnv env context) ()) -- ^ Customized `Factory`.+  -> Factory IO (AppEnv ()) env -- ^ Function which generates @env@ using `AppEnv`.+  -> Factory IO (AppEnv env) (AppEnv env -> Context context) -- ^ Function which generates @context@ using @env@.+  -> Factory IO (WebEnv env context) () -- ^ Customized `Factory`.   -> Proxy api -- ^ Api proxy.-  -> ServerT api (App env) -- ^ Servant api server.+  -> ServerT api (App (AppEnv env)) -- ^ Servant api server.   -> IO ()-bootWeb appName ver fenv fcxt buildCustom api server = boot $ do-  app  <- buildApp appName ver-  within app $ do-    conf  <- require "application"-    ec    <- require "endpoints"-    store <- liftIO newStore-    logInfo $ "Start Service [" <> toLogStr (name app) <> "] ..."-    let-      c = newWebEnv-         (fenv app)-         fcxt-         conf-         ec-         store :: WebEnv env context-      pe = Proxy @env-      pc = Proxy @context-    within c $ do-      tryServeWithSwagger True  pc api server-      buildError     pc pe-      buildCustom    pc pe-      buildWebLogger pc pe-      buildTrace     pc pe-      buildRandom    pc pe-      buildEndpoints pc pe-      buildWeb       pc pe+bootWeb appName ver fenv fcxt buildCustom api server = bootApp appName ver fenv $ do+  conf  <- require "application"+  ec    <- require "endpoints"+  store <- liftIO newStore+  cxt   <- fcxt+  env   <- getEnv+  let+    c = newWebEnv env cxt conf ec store :: WebEnv env context+    pe = Proxy @env+    pc = Proxy @context+  within c $ do+    tryServeWithSwagger True  pc api server+    buildError     pc pe+    buildCustom+    buildWebLogger pc pe+    buildTrace     pc pe+    buildRandom    pc pe+    buildEndpoints pc pe+    buildWeb       pc pe++-- | A out-of-box web application booter with many predefined components. A more generic version use `bootWeb`+bootWebEnv+  :: String+  -> Version+  -> Factory IO (AppEnv ()) env+  -> Factory IO (WebEnv env '[AppEnv env]) ()+  -> IO ()+bootWebEnv name ver makeExt mid+  = bootWeb name ver makeExt (return (:. EmptyContext)) mid (Proxy @EmptyAPI) emptyServer++