legion-discovery 0.2.2.2 → 0.3.0.0
raw patch · 4 files changed
+79/−22 lines, 4 files
Files
- README.md +22/−3
- legion-discovery.cabal +1/−1
- src/Network/Legion/Discovery.hs +51/−17
- src/Network/Legion/Discovery/HttpError.hs +5/−1
README.md view
@@ -11,7 +11,7 @@ also experimental. - [API](#api)- - [`POST /v1/ping/:serviceId/:version`](#post-v1pingserviceidversion)+ - [`POST /v1/ping`](#post-v1ping) - [`GET /v1/services/:serviceId`](#get-v1servicesserviceid) - [`GET /v1/services/:serviceId/:versionRange`](#get-v1servicesserviceidversionrange) - [`GET /v1/graph`](#get-v1graph)@@ -21,18 +21,31 @@ ## API -### `POST /v1/ping/:serviceId/:version`+### `POST /v1/ping` -Register a service. Registration expires in 30 seconds.+Register a service. The service name and version are obtained via the+`User-Agent` header field. Registration expires in 30 seconds. - Request - Content-Type: [`application/vnd.legion-discovery.ping-request+json`](#applicationvndlegion-discoveryping-requestjson)+ - Headers:+ - `User-Agent`: The `User-Agent` request header is+ mandatory, and must conform to the grammar specified in+ [RFC-2616](https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.43)+ and, further, must provide the product version that RFC-2616+ describes as optional. - Response `204 No Content`: indicates a successful registration. ### `GET /v1/services/:serviceId` Returns all current instances of a service, regardless of version. +- Request+ - Headers:+ - `User-Agent`: The `User-Agent` request header is+ mandatory, and must conform to the grammar specified in+ [RFC-2616](https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.43)+ - Response `200 Ok` - Content-Type: [`application/vnd.legion-discovery.instance-list+json`](#applicationvndlegion-discoveryinstance-listjson) @@ -43,6 +56,12 @@ version range syntax is the same as what cabal understands (e.g. `>= 0.1 && < 0.2`). You are really going to want to make sure and url encode this segment of the url.++- Request+ - Headers:+ - `User-Agent`: The `User-Agent` request header is+ mandatory, and must conform to the grammar specified in+ [RFC-2616](https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.43) - Response `200 Ok` - Content-Type: [`application/vnd.legion-discovery.instance-list+json`](#applicationvndlegion-discoveryinstance-listjson)
legion-discovery.cabal view
@@ -1,5 +1,5 @@ name: legion-discovery-version: 0.2.2.2+version: 0.3.0.0 synopsis: A discovery service based on Legion. description: A simple service discovery service based on Legion,
src/Network/Legion/Discovery.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-} module Network.Legion.Discovery ( main ) where@@ -9,8 +10,11 @@ import Canteven.HTTP (requestLogging, logExceptionsAndContinue, DecodeResult(Unsupported, BadEntity, Ok), FromEntity, decodeEntity) import Canteven.Log.MonadLog (getCantevenOutput)-import Control.Monad (void)+import Control.Exception (throwIO)+import Control.Monad (void, (<=<)) import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (MonadLoggerIO, logInfo)+import Control.Monad.Trans.Class (lift) import Data.Aeson (encode, object, (.=), FromJSON, parseJSON, Value(Object), (.:), eitherDecode) import Data.ByteString (ByteString, hGetContents)@@ -25,7 +29,7 @@ import Data.Text (pack, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time (getCurrentTime)-import Data.Version (showVersion)+import Data.Version (showVersion, Version) import Distribution.Text (simpleParse) import Distribution.Version (VersionRange, anyVersion) import Network.HTTP.Types (badRequest400, unsupportedMediaType415,@@ -41,7 +45,7 @@ unServiceId, State, Client(Client), cName, cVersion) import Network.Legion.Discovery.Config (servicePort, ekgPort) import Network.Legion.Discovery.Graphviz (toDotGraph)-import Network.Legion.Discovery.HttpError (HttpError)+import Network.Legion.Discovery.HttpError (HttpError(Critical, Transient)) import Network.Legion.Discovery.LIO (runLIO, LIO) import Network.Legion.Discovery.UserAgent (UserAgent(UAProduct), Product( Product), productName, productVersion, parseUserAgent)@@ -51,7 +55,8 @@ import Web.Scotty.Format.Trans (respondTo, format, ResponseFormat) import Web.Scotty.Resource.Trans (resource, get, post) import Web.Scotty.Trans (scottyT, middleware, ScottyT, param, setHeader,- raw, status, text, ActionT, ScottyError, body, header)+ raw, status, text, ActionT, ScottyError, body, header, defaultHandler,+ raise) import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit.List as CL import qualified Data.Map as Map@@ -75,28 +80,38 @@ $ requestLogging logging . setServer "legion-discovery" . logExceptionsAndContinue logging+ defaultHandler handleEx webService legion +{- | Handle 'HttpError' errors. -}+handleEx :: (MonadLoggerIO m, ScottyError e) => HttpError -> ActionT e m ()+handleEx e@(Critical _) =+ liftIO (throwIO e)+handleEx (Transient statusCode msg) = do+ lift . $(logInfo)+ $ "Transient error: " <> msg+ status statusCode+ text (TL.fromStrict msg)++ {- | The web service endpoint definitions. -} webService :: Runtime Input Output -> ScottyT HttpError LIO () webService runtime = do- resource "/v1/ping/:serviceId/:version" $- post $- simpleParse <$> param "version" >>= \case- Nothing -> do- status badRequest400- text "Invalid version."- Just ver -> do- serviceId <- ServiceId <$> param "serviceId"- now <- Time <$> liftIO getCurrentTime- withEntity (\ PingRequest {serviceAddress} -> do- let req = Ping now serviceId ver serviceAddress+ resource "/v1/ping" $+ post . withStrictClients $ \clients -> do+ now <- Time <$> liftIO getCurrentTime+ withEntity (\ PingRequest {serviceAddress} -> do+ sequence_ [ makeRequest runtime (toKey serviceId) req >>= \case- PingResponse -> status noContent204+ PingResponse -> return () InstanceList _ -> fail "Invalid runtime response." ServiceResponse _ -> fail "Invalid runtime response."- )+ | (serviceId, ver) <- clients+ , let req = Ping now serviceId ver serviceAddress+ ]+ status noContent204+ ) resource "/v1/services" $ get $ do now <- Time <$> liftIO getCurrentTime@@ -169,6 +184,25 @@ serviceId <- ServiceId <$> param "serviceId" queryResource serviceId range where+ {- | Like 'withClients', but do not allow missing client versions. -}+ withStrictClients :: (Monad m)+ => ([(ServiceId, Version)] -> ActionT HttpError m ())+ -> ActionT HttpError m ()+ withStrictClients f =+ withClients $ f <=< mapM toStrict+ where+ toStrict :: (Monad m)+ => Client+ -> ActionT HttpError m (ServiceId, Version)+ toStrict Client {cName, cVersion = Just version} =+ return (cName, version)+ toStrict Client {cName, cVersion = Nothing} =+ raise (Transient badRequest400 (+ "Missing version for client product: "+ <> unServiceId cName+ <> ". Please fix your User-Agent header."+ ))+ {- | Parse the list of clients from the User-Agent header and return the resulting 'ActionT', or else return an 'ActionT' that returns
src/Network/Legion/Discovery/HttpError.hs view
@@ -3,9 +3,10 @@ response types. -} module Network.Legion.Discovery.HttpError (- HttpError,+ HttpError(..), ) where +import Control.Exception (Exception) import Data.Text (Text, pack) import Data.Text.Lazy (fromStrict) import Network.HTTP.Types (Status)@@ -14,6 +15,9 @@ data HttpError = Transient Status Text | Critical Text+ deriving (Show)++instance Exception HttpError instance ScottyError HttpError where stringError = Critical . pack