boots-cloud (empty) → 0.2
raw patch · 8 files changed
+428/−0 lines, 8 filesdep +aesondep +basedep +boots
Dependencies added: aeson, base, boots, boots-app, boots-web, bytestring, http-client, salak, servant, servant-client, text, unordered-containers
Files
- CHANGELOG.md +4/−0
- LICENSE +21/−0
- README.md +15/−0
- boots-cloud.cabal +49/−0
- src/Boots/Cloud.hs +20/−0
- src/Boots/Factory/Client.hs +46/−0
- src/Boots/Factory/Consul.hs +56/−0
- src/Network/Consul.hs +217/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.2 [2019.08.28]+-------------------+* First release.+* Only Httpclient and consul.
+ 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-cloud++[](https://hackage.haskell.org/package/boots-cloud)+[](https://travis-ci.org/leptonyu/boots)+[](https://github.com/leptonyu/boots/blob/master/boots-cloud/LICENSE)+++Factory for quickly building a microservice.++### 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-cloud.cabal view
@@ -0,0 +1,49 @@+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: dd3b3d8a814864a3ded34bf754c84e4fa60b995aa9b54cabe066738f0570ea46++name: boots-cloud+version: 0.2+synopsis: Factory for quickly building a microservice+description: A quick out-of-box factory using to build microservices with many useful builtin components based on [boots-web](https://hackage.haskell.org/package/boots-web).+category: Library, Application, Servant, Swagger, Web, Microservice, Consul+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.Cloud+ other-modules:+ Network.Consul+ Boots.Factory.Consul+ Boots.Factory.Client+ 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+ , boots-web >=0.2 && <0.3+ , bytestring >=0.10.8 && <0.11+ , http-client >=0.6.4 && <0.7+ , salak >=0.3.5 && <0.4+ , servant >=0.16.2 && <0.17+ , servant-client >=0.16 && <0.17+ , text >=1.2.3 && <1.3+ , unordered-containers >=0.2.10 && <0.3+ default-language: Haskell2010
+ src/Boots/Cloud.hs view
@@ -0,0 +1,20 @@+-- |+-- Module: Boots.Cloud+-- Copyright: 2019 Daniel YU+-- License: MIT+-- Maintainer: leptonyu@gmail.com+-- Stability: experimental+-- Portability: portable+--+-- A quick out-of-box factory using to build microservices with many useful builtin components based on [boots-web](https://hackage.haskell.org/package/boots-web).+--+module Boots.Cloud(+ -- * Service management+ module Boots.Factory.Consul+ -- * Client+ , module Boots.Factory.Client+ ) where+++import Boots.Factory.Client+import Boots.Factory.Consul
+ src/Boots/Factory/Client.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+module Boots.Factory.Client(+ ManagerSettings+ , Manager+ , newManager+ , managerConnCount+ , managerRawConnection+ , managerTlsConnection+ , managerResponseTimeout+ , managerRetryableException+ , managerWrapException+ , managerIdleConnectionCount+ , managerModifyRequest+ , managerModifyResponse+ , managerLogException+ ) where++import Boots+import Network.HTTP.Client hiding (Proxy)+import Salak++instance Default ManagerSettings where+ def = defaultManagerSettings++instance FromProp m ResponseTimeout where+ fromProp = responseTimeoutMicro <$> fromProp++instance FromProp m ManagerSettings where+ fromProp = do+ connCount <- "max-conns" .?: managerConnCount+ timeout <- "timeout" .?: managerResponseTimeout+ idleCount <- "idle-conns" .?: managerIdleConnectionCount+ return def+ { managerConnCount = connCount+ , managerResponseTimeout = timeout+ , managerIdleConnectionCount = idleCount+ }++managerLogException :: HasLogger env => env -> ManagerSettings -> ManagerSettings+managerLogException env ms = ms { managerWrapException = go }+ where+ go req ma = do+ runAppT env $ logInfo $ "Request: " <> toLogStr (show req)+ managerWrapException ms req ma
+ src/Boots/Factory/Consul.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+module Boots.Factory.Consul(+ buildConsul+ ) where++import Boots+import Boots.Factory.Client ()+import Boots.Web+import Control.Monad (void)+import qualified Data.HashMap.Strict as HM+import Data.Version (showVersion)+import Network.Consul++-- | Register consule service.+buildConsul+ :: (MonadMask n, MonadIO n, HasSalak env, HasApp env, HasLogger env)+ => Factory n (WebEnv env context) ()+buildConsul = tryBuildByKey False "consul.enabled" $ do+ AppEnv{..} <- asksEnv (view askApp)+ WebConfig{..} <- view askWebConfig <$> getEnv+ mst <- require "consul.client"+ cc@ConsulConfig{..} <- require "consul"+ let+ ConsulApi{..} = consulApi cc mst+ met2 = HM.insert "version" (fromString $ showVersion version) meta+ open = registerService+ $ newServer+ $ HttpServer name instanceId (Just hostname) (Just port) tags met2+ $ ServiceCheck name instanceId interval dcsa+ $ "http://" <> hostname <> ":" <> show port <>"/endpoints/health"+ close _ = void+ $ deregisterService instanceId+ delay $ logInfo "Service deregistered from consul."+ _ <- produce open close+ logInfo "Service registered to consul."+++++++++++++++++++
+ src/Network/Consul.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+module Network.Consul where++import Boots+import Boots.Web+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.HashMap.Strict as HM+import Data.Text (Text, toLower)+import Data.Word+import GHC.Generics+import Network.HTTP.Client (newManager)+import Network.HTTP.Client.Internal hiding (Proxy)+import Salak+import Servant.API+import Servant.Client++data ServiceKind+ = KindNil+ | KindConnectProxy+ | KindMeshGateway+ deriving (Eq, Show, Generic, ToSchema, FromJSON, ToJSON)++newtype ServiceConnect = ServiceConnect+ { enabled :: Bool+ } deriving (Eq, Show, Generic, ToSchema, FromJSON, ToJSON)++data ServiceCheck = ServiceCheck+ { cname :: !Text+ , cid :: !Text+ , cinternal :: !String+ , cdcsa :: !String+ , chttp :: !String+ } deriving (Eq, Show, Generic, ToSchema)++instance ToJSON ServiceCheck where+ toJSON ServiceCheck{..} = object+ [ "ID" .= cid+ , "Name" .= cname+ , "Interval" .= cinternal+ , "DeregisterCriticalServiceAfter" .= cdcsa+ , "HTTP" .= chttp+ ]+instance FromJSON ServiceCheck where+ parseJSON = withObject "ServiceCheck" $ \v -> ServiceCheck+ <$> v .: "Name"+ <*> v .: "ID"+ <*> v .: "Interval"+ <*> v .: "DeregisterCriticalServiceAfter"+ <*> v .:? "HTTP" .!= ""++data ServiceWeight = ServiceWeight+ {++ } deriving (Eq, Show, Generic, ToSchema, FromJSON, ToJSON)++data ServiceDef = ServiceDef+ { sname :: !Text+ , sid :: !Text+ , stags :: ![Text]+ , saddr :: !(Maybe String)+ , saddrmap :: !(HM.HashMap String String)+ , smeta :: !(HM.HashMap Text Text)+ , sport :: !(Maybe Word16)+ , skind :: !ServiceKind+ , sconnect :: !(Maybe ServiceConnect)+ , scheck :: !(Maybe ServiceCheck)+ , schecks :: ![ServiceCheck]+ , stagoverride :: !Bool+ , sweights :: !(Maybe ServiceWeight)+ } deriving (Eq, Show, Generic, ToSchema)++data HttpServer = HttpServer+ { sname :: !Text+ , sid :: !Text+ , saddr :: !(Maybe String)+ , sport :: !(Maybe Word16)+ , stags :: ![Text]+ , smeta :: !(HM.HashMap Text Text)+ , chk :: !ServiceCheck+ }++newServer :: HttpServer -> ServiceDef+newServer HttpServer{..} = ServiceDef+ { saddrmap = HM.empty+ , skind = KindNil+ , sconnect = Nothing+ , scheck = Just chk+ , schecks = []+ , sweights = Nothing+ , stagoverride = False+ ,..}++instance ToJSON ServiceDef where+ toJSON ServiceDef{..} = object+ [ "ID" .= sid+ , "Name" .= sname+ , "Address" .= saddr+ , "Port" .= sport+ , "Tags" .= toJSON stags+ , "Meta" .= toJSON smeta+ , "Check" .= toJSON scheck+ ]++instance FromJSON ServiceDef where+ parseJSON = withObject "ServiceDef" $ \v -> ServiceDef+ <$> v .: "Name"+ <*> v .:? "ID" .!= ""+ <*> v .:? "Tags" .!= []+ <*> v .: "Address"+ <*> return HM.empty+ <*> v .:? "Meta" .!= HM.empty+ <*> v .: "Port"+ <*> return KindNil+ <*> return Nothing+ <*> return Nothing+ <*> return []+ <*> v .:? "EnableTagOverride" .!= True+ <*> return Nothing++type ConsulEndpoint = "v1" :> "agent" :> AgentEndpoint++type AgentEndpoint+ = "services" :> Get '[JSON] (HM.HashMap Text ServiceDef)+ :<|> "service" :> Capture "serviceId" Text :> Get '[JSON] ServiceDef+ :<|> "service" :> "register" :> ReqBody '[JSON] ServiceDef :> Put '[JSON] NoContent+ :<|> "service" :> "deregister" :> Capture "serviceId" Text :> Put '[JSON] NoContent+ :<|> "service" :> "maintenance" :> Capture "serviceId" Text :> Put '[JSON] NoContent+ :<|> "health" :> "service" :> HealthEndpoint++type HealthEndpoint+ = "name" :> Capture "serviceName" Text :> Get '[JSON] ServiceDef+ :<|> "id" :> Capture "serviceId" Text :> Get '[JSON] ServiceDef++data ConsulApi m = ConsulApi+ { getServices :: m (HM.HashMap Text ServiceDef)+ , getService :: Text -> m ServiceDef+ , registerService :: ServiceDef -> m NoContent+ , deregisterService :: Text -> m NoContent+ , maintenanceService :: Text -> m NoContent+ , checkHealthByName :: Text -> m ServiceDef+ , checkHealthById :: Text -> m ServiceDef+ }++consulApi+ :: (MonadThrow m, MonadIO m)+ => ConsulConfig -> ManagerSettings -> ConsulApi m+consulApi cc hc =+ let getServices+ :<|> getService+ :<|> registerService+ :<|> deregisterService+ :<|> maintenanceService+ :<|> checkHealthByName+ :<|> checkHealthById = hoistClient api (runConsul cc hc) (client api)+ in ConsulApi{..}++api :: Proxy ConsulEndpoint+api = Proxy++runConsul+ :: (MonadThrow m, MonadIO m)+ => ConsulConfig -> ManagerSettings -> ClientM a -> m a+runConsul ConsulConfig{..} mg cma = do+ let mgn = case token of+ Just t -> mg { managerModifyRequest = \req -> return req { requestHeaders = ("X-Consul-Token", t) : requestHeaders req }}+ _ -> mg+ liftIO $ do+ m <- newManager mgn+ v <- runClientM cma (ClientEnv m url Nothing)+ case v of+ Left e -> throwM e+ Right a -> return a++-- consulServer :: ConsulConfig -> Proxy m -> ManagerSettings -> _+-- consulServer cc pm hc = hoistClient api (runConsul cc pm hc) (client api)++data ConsulConfig = ConsulConfig+ { meta :: HM.HashMap Text Text+ , tags :: [Text]+ , token :: Maybe ByteString+ , interval :: String+ , dcsa :: String+ , url :: BaseUrl+ }++instance FromProp m ConsulConfig where+ fromProp = ConsulConfig+ <$> "meta"+ <*> "tags"+ <*> "token"+ <*> "interval" .?= "10s"+ <*> "deregister-critical-service-after" .?= "30m"+ <*> (BaseUrl+ <$> "schema" .?= Http+ <*> "host" .?= "127.0.0.1"+ <*> "port" .?= 8500+ <*> "path" .?= "")++instance FromProp m Scheme where+ fromProp = readEnum (go.toLower)+ where+ {-# INLINE go #-}+ go "http" = Right Http+ go "https" = Right Https+ go _ = Left "unkown schema"++