diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.2 [2019.08.28] +------------------- +* First release. +* Only Httpclient and consul. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# boots-cloud + +[![Hackage](https://img.shields.io/hackage/v/boots-cloud.svg?logo=haskell)](https://hackage.haskell.org/package/boots-cloud) +[![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/blob/master/boots-cloud/LICENSE) +![Hackage-Deps](https://img.shields.io/hackage-deps/v/boots-cloud) + +Factory for quickly building a microservice. + +### Packages based on boots + +- [![Hackage](https://img.shields.io/badge/boots-app-orange)](https://hackage.haskell.org/package/boots-app) Factory for quickly building an application. +- [![Hackage](https://img.shields.io/badge/boots-web-orange)](https://hackage.haskell.org/package/boots-web) Factory for quickly building a web application. +- [![Hackage](https://img.shields.io/badge/boots-cloud-orange)](https://hackage.haskell.org/package/boots-cloud) Factory for quickly building a microservice. + diff --git a/boots-cloud.cabal b/boots-cloud.cabal new file mode 100644 --- /dev/null +++ b/boots-cloud.cabal @@ -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 diff --git a/src/Boots/Cloud.hs b/src/Boots/Cloud.hs new file mode 100644 --- /dev/null +++ b/src/Boots/Cloud.hs @@ -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 diff --git a/src/Boots/Factory/Client.hs b/src/Boots/Factory/Client.hs new file mode 100644 --- /dev/null +++ b/src/Boots/Factory/Client.hs @@ -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 diff --git a/src/Boots/Factory/Consul.hs b/src/Boots/Factory/Consul.hs new file mode 100644 --- /dev/null +++ b/src/Boots/Factory/Consul.hs @@ -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." + + + + + + + + + + + + + + + + + + + diff --git a/src/Network/Consul.hs b/src/Network/Consul.hs new file mode 100644 --- /dev/null +++ b/src/Network/Consul.hs @@ -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" + +