boots-web (empty) → 0.2
raw patch · 18 files changed
+1044/−0 lines, 18 filesdep +aesondep +basedep +boots
Dependencies added: aeson, base, boots, boots-app, bytestring, containers, ekg-core, http-types, microlens, monad-logger, salak, servant-server, servant-swagger, swagger2, text, time, unordered-containers, vault, wai, warp
Files
- CHANGELOG.md +12/−0
- LICENSE +21/−0
- README.md +15/−0
- boots-web.cabal +67/−0
- src/Boots/Endpoint/Class.hs +46/−0
- src/Boots/Endpoint/Health.hs +37/−0
- src/Boots/Endpoint/Info.hs +61/−0
- src/Boots/Endpoint/Logger.hs +33/−0
- src/Boots/Endpoint/Metrics.hs +64/−0
- src/Boots/Endpoint/Refresh.hs +34/−0
- src/Boots/Endpoint/Swagger.hs +31/−0
- src/Boots/Factory/Endpoint.hs +46/−0
- src/Boots/Factory/Error.hs +87/−0
- src/Boots/Factory/Random.hs +30/−0
- src/Boots/Factory/Trace.hs +49/−0
- src/Boots/Factory/Web.hs +312/−0
- src/Boots/Metrics.hs +12/−0
- src/Boots/Web.hs +87/−0
+ CHANGELOG.md view
@@ -0,0 +1,12 @@+0.2 [2019.08.28]+-------------------+* First release.+* Endpoints builtin+ * info+ * healthcheck+ * logger+ * metrics+ * refresh configuration+ * swagger+* Tracable log.+
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Daniel YU++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,15 @@+# boots-web++[](https://hackage.haskell.org/package/boots-web)+[](https://travis-ci.org/leptonyu/boots)+[](https://github.com/leptonyu/boots/blob/master/boots-web/LICENSE)+++Factory for quickly building a web application.++### Packages based on boots++- [](https://hackage.haskell.org/package/boots-app) Factory for quickly building an application.+- [](https://hackage.haskell.org/package/boots-web) Factory for quickly building a web application.+- [](https://hackage.haskell.org/package/boots-cloud) Factory for quickly building a microservice.+
+ boots-web.cabal view
@@ -0,0 +1,67 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: d9adb6d374b0cb9dc52eda97c75b686f163de767b0da55ef021afd0a472624e6++name: boots-web+version: 0.2+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+homepage: https://github.com/leptonyu/boots#readme+author: Daniel YU+maintainer: leptonyu@gmail.com+copyright: 2019 Daniel YU+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++library+ exposed-modules:+ Boots.Web+ Boots.Factory.Endpoint+ Boots.Factory.Error+ Boots.Factory.Random+ Boots.Factory.Trace+ other-modules:+ Boots.Factory.Web+ Boots.Metrics+ Boots.Endpoint.Class+ Boots.Endpoint.Health+ Boots.Endpoint.Info+ Boots.Endpoint.Logger+ Boots.Endpoint.Metrics+ Boots.Endpoint.Refresh+ Boots.Endpoint.Swagger+ hs-source-dirs:+ src+ default-extensions: RecordWildCards ScopedTypeVariables+ 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+ , bytestring >=0.10.8 && <0.11+ , containers >=0.6.0 && <0.7+ , ekg-core >=0.1.1 && <0.2+ , http-types >=0.12.3 && <0.13+ , microlens >=0.4.10 && <0.5+ , monad-logger >=0.3.30 && <0.4+ , salak >=0.3.5 && <0.4+ , 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+ , warp >=3.2.28 && <3.4+ default-language: Haskell2010
+ src/Boots/Endpoint/Class.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Boots.Endpoint.Class where++import Boots+import Boots.Factory.Web+import qualified Data.HashMap.Strict as HM+import qualified Data.Swagger as S+import Data.Text (Text)+import Servant+import Servant.Server.Internal++data EndpointTag++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)+ hoistServerWithContext _ = hoistServerWithContext (Proxy @api)++instance HasSwagger api => HasSwagger (EndpointTag :> api) where+ toSwagger _ = toSwagger (Proxy @api) & S.applyTags [S.Tag "endpoints" (Just "Endpoints API") Nothing]++-- | Register endpoint, use this function to create custom endpoints.+registerEndpoint+ :: forall context env api n+ . ( HasSwagger api+ , HasServer api context+ , HasWeb context env+ , MonadIO n+ , MonadMask n)+ => Text -- ^ Endpoint name, used for path, @/endpoints/:name@.+ -> Proxy context -- ^ Context proxy.+ -> Proxy api -- ^ Api proxy.+ -> ServerT api (App env) -- ^ Api server.+ -> Factory n (WebEnv env context) ()+registerEndpoint name pc _ server = do+ WebEnv{..} <- getEnv+ let ok = enabled endpoint && HM.lookup name (endpoints endpoint) /= Just False+ when ok $ logDebug $ "Endpoint " <> toLogStr name <> " actived."+ tryServeWithSwagger ok pc (Proxy @(EndpointTag :> api)) server
+ src/Boots/Endpoint/Health.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Boots.Endpoint.Health where++import Boots+import Boots.Endpoint.Class+import Boots.Factory.Web+import Data.Aeson+import Servant+++type EndpointHealth = "health" :> Get '[JSON] Health++instance ToJSON HealthStatus+instance ToJSON Health where+ toJSON = genericToJSON defaultOptions+ { omitNothingFields = True }+instance ToSchema HealthStatus+instance ToSchema Health++-- | Register health endpoint.+endpointHealth+ :: (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context+ -> Factory n (WebEnv env context) ()+endpointHealth pc = do+ health <- asksEnv (view askHealth)+ registerEndpoint "health" pc (Proxy @EndpointHealth) $ liftIO $ do+ h@Health{..} <- health+ if status == UP then return h else throwM err400 { errBody = encode h }
+ src/Boots/Endpoint/Info.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Boots.Endpoint.Info where++import Boots+import Boots.Endpoint.Class+import Boots.Factory.Web+import Control.Concurrent+import Data.Aeson+import Data.Text (Text)+import Data.Version (Version, showVersion)+import GHC.Generics+import GHC.RTS.Flags+import Servant+import System.Info++data Info = Info+ { name :: !Text+ , instanceId :: !Text+ , version :: !Version+ , profile :: !Bool+ } deriving (Show, Generic, ToSchema)++type EndpointInfo = "info" :> Get '[JSON] Info++-- | Register info endpoint.+endpointInfo+ :: (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context+ -> Factory n (WebEnv env context) ()+endpointInfo pc = do+ app <- asksEnv (view askApp)+ registerEndpoint "info" pc (Proxy @EndpointInfo) $ liftIO $ do+ rtsf <- getRTSFlags+ return (go rtsf app)+ where+ {-# INLINE go #-}+ go RTSFlags{..} AppEnv{..}=+ let ProfFlags{..} = profilingFlags+ in Info{profile = find doHeapProfile , ..}+ {-# INLINE find #-}+ find NoHeapProfiling = False+ find _ = True++instance ToJSON Info where+ toJSON Info{..} = object+ [ "application" .= name+ , "instanceId" .= instanceId+ , "version" .= version+ , "isMultithread" .= rtsSupportsBoundThreads+ , "isProfile" .= profile+ , "os" .= os+ , "arch" .= arch+ , "compiler" .= (compilerName <> "-" <> showVersion compilerVersion)+ ]
+ src/Boots/Endpoint/Logger.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+module Boots.Endpoint.Logger where++import Boots+import Boots.Endpoint.Class+import Boots.Factory.Web+import Data.Aeson+import GHC.Generics+import Salak+import Servant++type EndpointLogger = "logger" :> (Get '[JSON] LogInfo :<|> ReqBody '[JSON] LogInfo :> Put '[JSON] NoContent)++newtype LogInfo = LogInfo+ { level :: String+ } deriving (Show, Generic, ToJSON, FromJSON, ToSchema)++-- | Register logger endpoint.+endpointLogger+ :: (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context+ -> Factory n (WebEnv env context) ()+endpointLogger pc = do+ LogFunc{..} <- asksEnv (view askLogger)+ registerEndpoint "logger" pc (Proxy @EndpointLogger) (getLogInfo logLvl :<|> putLogInfo logLvl)+ where+ getLogInfo w = liftIO $ LogInfo . show <$> getWritable w+ putLogInfo w LogInfo{..} = liftIO $ setWritable (rightToMaybe $ levelFromStr $ fromString level) w >> return NoContent
+ src/Boots/Endpoint/Metrics.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+module Boots.Endpoint.Metrics(+ HasMetrics(..)+ , endpointMetrics+ ) where++import Boots+import Boots.Endpoint.Class+import Boots.Factory.Web+import Boots.Metrics+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M+import Data.Text (Text)+import Network.HTTP.Types+import Network.Wai+import Servant+import System.Metrics+import qualified System.Metrics.Counter as Counter+++type EndpointMetrics = "metrics" :> Get '[JSON] Metrics++type Metrics = M.Map Text Text++-- | Register metrics endpoint.+endpointMetrics+ :: (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context+ -> Factory n (WebEnv env context) ()+endpointMetrics pc = do+ store <- asksEnv (view askMetrics)+ LogFunc{..} <- asksEnv (view askLogger)+ liftIO $ do+ registerGcMetrics store+ registerCounter "log.failure" logFail store+ let newC n = liftIO $ createCounter n store+ requests <- newC "http.server.requests"+ req_fail <- newC "http.server.requests.failure"+ registerMiddleware+ $ \app env req resH -> app env req+ $ \res -> do+ Counter.inc requests+ when (statusCode (responseStatus res) >= 400) $ Counter.inc req_fail+ resH res+ registerEndpoint "metrics" pc (Proxy @EndpointMetrics) (liftIO $ go store)+ where+ {-# INLINE go #-}+ go s = do+ sample <- sampleAll s+ return+ $ M.fromList+ $ HM.toList+ $ HM.map g2 sample+ {-# INLINE showT #-}+ showT :: Show a => a -> Text+ showT = fromString . show+ {-# INLINE g2 #-}+ g2 (Counter i) = showT i+ g2 (Gauge i) = showT i+ g2 (Label x) = x+ g2 (Distribution i) = showT i
+ src/Boots/Endpoint/Refresh.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+module Boots.Endpoint.Refresh where++import Boots+import Boots.Endpoint.Class+import Boots.Factory.Web+import Data.Aeson+import GHC.Generics+import Salak+import Servant++type EndpointRefresh = "refresh" :> Post '[JSON] Refresh++data Refresh = Refresh+ { hasError :: !Bool+ , msgs :: ![String]+ } deriving (Eq, Show, Generic, ToJSON, ToSchema)++-- | Register refresh endpoint.+endpointRefresh+ :: (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context+ -> Factory n (WebEnv env context) ()+endpointRefresh pc = do+ reload <- askReload+ registerEndpoint "refresh" pc (Proxy @EndpointRefresh) (liftIO $ go <$> reload)+ where+ {-# INLINE go #-}+ go ReloadResult{..} = Refresh{..}
+ src/Boots/Endpoint/Swagger.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+module Boots.Endpoint.Swagger where++import qualified Data.Swagger as S+import Data.Text (Text, pack)+import Data.Version (Version, showVersion)+import Data.Word+import Lens.Micro+import Servant+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif++type EndpointSwagger = "endpoints" :> "swagger" :> Get '[JSON] S.Swagger++-- | Swagger modification+baseInfo+ :: String -- ^ Hostname+ -> Text -- ^ Server Name+ -> Version -- ^ Server version+ -> Word16 -- ^ Port+ -> S.Swagger -- ^ Old swagger+ -> S.Swagger+baseInfo hostName n v p s = s+ & S.info . S.title .~ (n <> " API Documents")+ & S.info . S.version .~ pack (showVersion v)+ & S.host ?~ S.Host hostName (Just $ fromIntegral p)
+ src/Boots/Factory/Endpoint.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: Boots.Factory.Endpoint+-- Copyright: 2019 Daniel YU+-- License: MIT+-- Maintainer: leptonyu@gmail.com+-- Stability: experimental+-- Portability: portable+--+-- This module provide supports for endpoints.+--+module Boots.Factory.Endpoint(+ buildEndpoints+ , registerEndpoint+ , endpointInfo+ , endpointLogger+ , endpointRefresh+ , endpointHealth+ , endpointMetrics+ ) where++import Boots+import Boots.Endpoint.Class+import Boots.Endpoint.Health+import Boots.Endpoint.Info+import Boots.Endpoint.Logger+import Boots.Endpoint.Metrics+import Boots.Endpoint.Refresh+import Boots.Factory.Web++-- | Register all endpoints provided by this package.+buildEndpoints+ :: forall context env n+ . (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context -- ^ Context proxy.+ -> Proxy env -- ^ Environment proxy.+ -> Factory n (WebEnv env context) ()+buildEndpoints pc _ = do+ WebEnv{..} <- getEnv+ unless (enabled endpoint) $ logInfo "Endpoint is disabled."+ tryBuild (enabled endpoint) $ do+ endpointInfo pc+ endpointLogger pc+ endpointRefresh pc+ endpointHealth pc+ endpointMetrics pc
+ src/Boots/Factory/Error.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module: Boots.Factory.Error+-- Copyright: 2019 Daniel YU+-- License: MIT+-- Maintainer: leptonyu@gmail.com+-- Stability: experimental+-- Portability: portable+--+-- This module provide supports for handling exception.+--+module Boots.Factory.Error(+ buildError+ , buildWebLogger+ , toMonadLogger+ , L.runLoggingT+ ) where++import Boots+import Boots.Factory.Web+import Control.Exception (catch)+import qualified Control.Monad.Logger as L+import GHC.Stack+import Network.HTTP.Types+import Network.Wai++-- | Catch exception, convert to Resonpose.+{-# INLINE buildError #-}+buildError+ :: forall context env n+ . (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context -> Proxy env -> Factory n (WebEnv env context) ()+buildError _ _ = tryBuildByKey True "web.error.enabled" $+ registerMiddleware $ \app env req resH -> app env req resH `catch`+ \e -> do+ runAppT env $ logException e+ resH (whenException e)++-- | Register logging requests.+{-# INLINE buildWebLogger #-}+buildWebLogger+ :: forall context env n+ . (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context -> Proxy env -> Factory n (WebEnv env context) ()+buildWebLogger _ _ = tryBuildByKey True "web.log.enabled" $+ registerMiddleware $ \app env req resH -> app env req+ $ \res -> do+ runAppT env $ toLog req (responseStatus res)+ resH res++{-# INLINE toLog #-}+toLog :: HasLogger env => Request -> Status -> App env ()+toLog ~req Status{..} =+ let {-# INLINE g #-}+ g (Just i) = " \"" <> toLogStr i <> "\""+ g _ = " \"\""+ lf = if statusCode < 400 then logInfo else logWarn+ in lf $ "\""+ <> toLogStr (requestMethod req)+ <> " "+ <> toLogStr (rawPathInfo req)+ <> toLogStr (rawQueryString req)+ <> " "+ <> toLogStr (show $ httpVersion req)+ <> "\""+ <> g (requestHeaderReferer req)+ <> g (requestHeaderHost req)+ <> g (requestHeaderUserAgent req)+ <> " "+ <> toLogStr statusCode++-- | Adapter to [monad-logger](https://hackage.haskell.org/package/monad-logger).+{-# INLINE toMonadLogger #-}+toMonadLogger :: ToLogStr msg => LogFunc -> L.Loc -> L.LogSource -> L.LogLevel -> msg -> IO ()+toMonadLogger LogFunc{..} L.Loc{..} _ ll = logfunc g1 (g2 ll) . toLogStr+ where+ {-# INLINE g1 #-}+ g1 = uncurry (uncurry (SrcLoc loc_package loc_module loc_filename) loc_start) loc_end+ {-# INLINE g2 #-}+ g2 L.LevelDebug = LevelDebug+ g2 L.LevelInfo = LevelInfo+ g2 L.LevelWarn = LevelWarn+ g2 L.LevelError = LevelError+ g2 (L.LevelOther _) = LevelTrace
+ src/Boots/Factory/Random.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module: Boots.Factory.Random+-- Copyright: 2019 Daniel YU+-- License: MIT+-- Maintainer: leptonyu@gmail.com+-- Stability: experimental+-- Portability: portable+--+-- This module provide supports for creating a thread unsafe random seed.+--+module Boots.Factory.Random(+ buildRandom+ ) where++import Boots+import Boots.Factory.Web++-- | Create a thread unsafe random seed per request.+buildRandom+ :: forall context env n+ . (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context -> Proxy env -> Factory n (WebEnv env context) ()+buildRandom _ _ = tryBuildByKey True "web.random.enabled" $+ registerMiddleware $ \app env req resH -> do+ seed <- unRD (view askRandom env) splitSMGen+ makeRD0 seed $ \rd -> app (over askRandom (const rd) env) req resH
+ src/Boots/Factory/Trace.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module: Boots.Factory.Trace+-- Copyright: 2019 Daniel YU+-- License: MIT+-- Maintainer: leptonyu@gmail.com+-- Stability: experimental+-- Portability: portable+--+-- This module provide supports for generating trace info.+--+module Boots.Factory.Trace(+ buildTrace+ ) where++import Boots+import Boots.Factory.Web+import Data.ByteString (ByteString)+import Network.HTTP.Types+import Network.Wai++{-# INLINE hTraceId #-}+hTraceId :: HeaderName+hTraceId = "X-B3-TraceId"++{-# INLINE hSpanId #-}+hSpanId :: HeaderName+hSpanId = "X-B3-SpanId"++-- | Generate trace info for each request.+buildTrace+ :: forall env context n+ . (HasWeb context env, MonadMask n, MonadIO n)+ => Proxy context -> Proxy env -> Factory n (WebEnv env context) ()+buildTrace _ _ = tryBuildByKey True "web.trace.enabled" $+ registerMiddleware $ \app env req resH -> do+ let x64 = runAppT env $ hex64 <$> nextW64 :: IO ByteString+ ids <- case lookup hTraceId (requestHeaders req) of+ Just tid -> (lookup hSpanId (requestHeaders req),tid,) <$> x64+ _ -> (Nothing,,) <$> x64 <*> x64+ app (over askLogger (addTrace $ go ids) env) req resH+ where+ {-# INLINE go #-}+ go :: (Maybe ByteString, ByteString, ByteString) -> LogStr+ go (Just pid, tid, sid) = toLogStr tid <> "," <> toLogStr sid <> "," <> toLogStr pid+ go (_, tid, sid) = toLogStr tid <> "," <> toLogStr sid <> ","
+ src/Boots/Factory/Web.hs view
@@ -0,0 +1,312 @@+{-# 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 #-}++module Boots.Factory.Web(+ buildWeb+ , HasWeb+ -- ** Configuration+ , HasWebConfig(..)+ , WebConfig(..)+ , EndpointConfig(..)+ -- ** Environment+ , WebEnv(..)+ , newWebEnv+ , askEnv+ -- ** Modified Middleware+ , EnvMiddleware+ , registerMiddleware+ -- ** Api serve+ , tryServe+ , trySwagger+ , tryServeWithSwagger+ -- ** Utilities+ , HasSwagger(..)+ , HasServer(..)+ , HasContextEntry(..)+ , SetContextEntry(..)+ , Context(..)+ , askContext+ , logException+ , whenException+ , ToSchema+ , Vault+ ) where++import Boots+import Boots.Endpoint.Swagger+import Boots.Metrics+import Control.Exception+ ( SomeException+ , fromException+ )+import qualified Data.HashMap.Strict as HM+import Data.Maybe+import Data.Swagger (Swagger)+import Data.Swagger.Schema (ToSchema)+import Data.Text (Text)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Encoding+import Data.Word+import Network.Wai+import Network.Wai.Handler.Warp+import Salak+import Servant+import Servant.Server.Internal.ServerError (responseServerError)+import Servant.Swagger++-- | Application Configuration.+data WebConfig = WebConfig+ { hostname :: !String -- ^ Applicatoin hostname, used in swagger.+ , port :: !Word16 -- ^ Application http port.+ } deriving (Eq, Show)++instance Default WebConfig where+ {-# INLINE def #-}+ def = WebConfig "localhost" 8888++instance FromProp m WebConfig where+ {-# INLINE fromProp #-}+ fromProp = WebConfig+ <$> "host" .?: hostname+ <*> "port" .?: port++-- | Environment values with `WebConfig`.+class HasWebConfig env where+ askWebConfig :: Lens' env WebConfig++instance HasWebConfig WebConfig where+ askWebConfig = id++-- | Endpoint configuration.+data EndpointConfig = EndpointConfig+ { enabled :: Bool+ , endpoints :: HM.HashMap Text Bool+ }++instance FromProp m EndpointConfig where+ fromProp = EndpointConfig+ <$> "enabled" .?= True+ <*> "enabled" .?= HM.empty++-- | Web environment, which defined all components to build a web application.+data WebEnv env context = WebEnv+ { serveW :: forall api. HasServer api context+ => Proxy api -> Context context -> Server api -> Application+ -- ^ A wrapper of `serveWithContext`.+ , serveA :: forall api. HasSwagger api+ => 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.+ , 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})++instance HasMetrics (WebEnv env context) where+ {-# INLINE askMetrics #-}+ askMetrics = lens store (\x y -> x { store = y})+instance HasSalak env => HasSalak (WebEnv env context) where+ {-# INLINE askSalak #-}+ askSalak = askEnv' . askSalak+instance HasLogger env => HasLogger (WebEnv env context) where+ {-# INLINE askLogger #-}+ askLogger = askEnv' . askLogger+instance HasRandom env => 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+ {-# INLINE askHealth #-}+ askHealth = askEnv' . askHealth++-- | Unified constraints for web environment.+type HasWeb context env =+ ( HasApp env+ , HasLogger env+ , HasHealth env+ , HasRandom env+ , HasSalak env+ , HasContextEntry context env)++-- | Class type used to modify @context@ entries.+class HasContextEntry context env => SetContextEntry context env where+ setContextEntry :: env -> Context context -> Context context++instance {-# OVERLAPPABLE #-} SetContextEntry as env => SetContextEntry (a : as) env where+ {-# INLINE setContextEntry #-}+ setContextEntry env (a :. as) = a :. setContextEntry env as++instance SetContextEntry (env : as) env where+ {-# 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++-- | 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@.+ -> WebConfig -- ^ Web configuration.+ -> EndpointConfig -- ^ Endpoint configuration.+ -> Store -- ^ Metrics store.+ -> WebEnv env context+newWebEnv = WebEnv serveWithContext toSwagger id++-- | Get application environment @env@.+{-# INLINE askEnv #-}+askEnv :: MonadMask n => Factory n (WebEnv env context) env+askEnv = envs <$> getEnv++-- | Modified wai `Middleware`, which support modify @env@.+type EnvMiddleware env = (env -> Application) -> env -> Application++-- | Register a modified middleware.+{-# INLINE registerMiddleware #-}+registerMiddleware+ :: MonadMask n+ => EnvMiddleware env+ -> Factory n (WebEnv env context) ()+registerMiddleware md = modifyEnv $ \web -> web { middleware = md . middleware web }++-- | Build a web application from `WebEnv`.+buildWeb+ :: forall context env n+ . ( MonadIO n+ , MonadMask n+ , HasWeb context env+ )+ => Proxy context -- ^ @context@ proxy.+ -> Proxy env -- ^ @env@ proxy.+ -> Factory n (WebEnv env context) (IO ()) -- ^ Factory which create an application from `WebEnv`.+buildWeb _ _ = do+ (WebEnv{..} :: WebEnv env context) <- getEnv+ within envs $ do+ AppEnv{..} <- asksEnv (view askApp)+ let serveWarp WebConfig{..} = runSettings+ $ defaultSettings+ & setPort (fromIntegral port)+ & setOnExceptionResponse whenException+ & setOnException (\_ -> runAppT envs . logException)+ let ok = enabled endpoint && HM.lookup "swagger" (endpoints endpoint) /= Just False+ when ok+ $ logInfo+ $ "Swagger enabled: http://"+ <> toLogStr (hostname config)+ <> ":"+ <> toLogStr (port config)+ <> "/endpoints/swagger"+ logInfo $ "Service started on port(s): " <> toLogStr (port config)+ delay $ logInfo "Service ended"+ return+ $ serveWarp config+ $ flip middleware envs+ $ \env1 -> if ok+ then serveW (Proxy @EndpointSwagger) (context env1)+ (return $ baseInfo (hostname config) name version (port config) $ serveA $ Proxy @EmptyAPI)+ else serveW (Proxy @EmptyAPI) (context env1) emptyServer++-- | Log exception.+{-# INLINE logException #-}+logException :: HasLogger env => SomeException -> App env ()+logException = logError . toLogStr . formatException++-- | Convert an exception into `Network.Wai.Response`.+{-# INLINE whenException #-}+whenException :: SomeException -> Network.Wai.Response+whenException e = responseServerError+ $ fromMaybe err400 { errBody = fromString $ show e} (fromException e :: Maybe ServerError)++-- | Format exception.+{-# INLINE formatException #-}+formatException :: SomeException -> Text+formatException e = case fromException e of+ Just ServerError{..} -> fromString errReasonPhrase <> " " <> toStrict (decodeUtf8 errBody)+ _ -> fromString $ show e++-- | Serve web server with swagger.+tryServeWithSwagger+ :: forall env context api n+ . ( HasContextEntry context 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.+ -> Factory n (WebEnv env context) ()+tryServeWithSwagger b pc proxy server = do+ trySwagger b proxy+ tryServe b pc proxy server++-- | Try serve a swagger definition.+trySwagger+ :: (MonadMask n, HasSwagger api)+ => 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 }++-- | Try serve a web server.+tryServe+ :: forall env context api n+ . ( HasContextEntry context 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.+ -> Factory n (WebEnv env context) ()+tryServe b pc proxy server = tryBuild b $+ modifyEnv+ $ \web -> web { serveW = \p c s -> serveW web (gop p proxy) c+ $ s :<|> hoistServerWithContext proxy pc (go . runAppT (getContextEntry c :: env)) server }+ where+ {-# INLINE go #-}+ go :: IO a -> Servant.Handler a+ go = liftIO++{-# INLINE gop #-}+gop :: forall a b. Proxy a -> Proxy b -> Proxy (a :<|> b)+gop _ _ = Proxy++
+ src/Boots/Metrics.hs view
@@ -0,0 +1,12 @@+module Boots.Metrics(+ HasMetrics(..)+ , Store+ , newStore+ ) where++import Boots+import System.Metrics++-- | Environment values with `Store`.+class HasMetrics env where+ askMetrics :: Lens' env Store
+ src/Boots/Web.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module: Boots.Web+-- Copyright: 2019 Daniel YU+-- License: MIT+-- Maintainer: leptonyu@gmail.com+-- Stability: experimental+-- Portability: portable+--+-- A quick out-of-box factory using to build web application with many useful builtin web components,+-- based on [boots-app](https://hackage.haskell.org/package/boots-app) and [servant](https://hackage.haskell.org/package/servant).+--+-- 1. Builtin metrics, use [ekg-core](https://hackage.haskell.org/package/ekg-core) as backend.+-- 2. Builtin tracing log, support B3-Tags.+-- 3. Builtin endpoints, info, healthcheck, logger, metrics, refresh configuration, swagger api.+-- 4. Builtin error management.+--+-- Hackage [boots-consul](https://hackage.haskell.org/package/boots-consul) provides consul support for building microservices.+--+module Boots.Web(+ -- * Boot web+ bootWeb+ , module Boots.Factory.Web+ -- * Metrics+ , module Boots.Metrics+ -- * Middleware+ -- ** Endpoint+ , module Boots.Factory.Endpoint+ -- ** Tracing+ , module Boots.Factory.Trace+ -- ** Other+ , module Boots.Factory.Error+ , module Boots.Factory.Random+ ) where++import Boots.Factory.Web+import Boots.Metrics++import Boots.Factory.Endpoint+import Boots.Factory.Error+import Boots.Factory.Random+import Boots.Factory.Trace++import Boots+import Data.Version (Version)++-- | A out-of-box web application booter with many predefined components.+bootWeb+ :: forall api env context+ . ( HasServer api context+ , HasSwagger api+ , 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`.+ -> Proxy api -- ^ Api proxy.+ -> ServerT api (App 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