legion-discovery 0.3.0.0 → 0.3.0.1
raw patch · 10 files changed
+697/−731 lines, 10 filesdep +http-api-datadep +mtldep +servant-serverdep −http-typesdep −scottydep −scotty-formatdep ~Cabaldep ~basedep ~binaryPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: http-api-data, mtl, servant-server
Dependencies removed: http-types, scotty, scotty-format, scotty-resource, transformers
Dependency ranges changed: Cabal, base, binary, bytestring, canteven-http, canteven-log, conduit, containers, data-default-class, legion-extra, monad-logger, time, wai-extra, warp
API changes (from Hackage documentation)
- Network.Legion.Discovery: instance Canteven.HTTP.FromEntity Network.Legion.Discovery.PingRequest
- Network.Legion.Discovery: instance Data.Aeson.Types.Class.FromJSON Network.Legion.Discovery.PingRequest
Files
- legion-discovery.cabal +34/−49
- src/Network/Legion/Discovery.hs +32/−357
- src/Network/Legion/Discovery/Api.hs +175/−0
- src/Network/Legion/Discovery/App.hs +0/−265
- src/Network/Legion/Discovery/Graphviz.hs +14/−10
- src/Network/Legion/Discovery/HttpError.hs +0/−26
- src/Network/Legion/Discovery/LIO.hs +0/−22
- src/Network/Legion/Discovery/LegionApp.hs +340/−0
- src/Network/Legion/Discovery/Server.hs +97/−0
- src/Network/Legion/Discovery/UserAgent.hs +5/−2
legion-discovery.cabal view
@@ -1,5 +1,5 @@ name: legion-discovery-version: 0.3.0.0+version: 0.3.0.1 synopsis: A discovery service based on Legion. description: A simple service discovery service based on Legion,@@ -16,84 +16,69 @@ copyright: 2016 Rick Owens category: value build-type: Simple-extra-source-files:- README.md+extra-source-files: README.md cabal-version: >=1.10 library- hs-source-dirs:- src+ hs-source-dirs: src exposed-modules: Network.Legion.Discovery other-modules:- Network.Legion.Discovery.App+ Network.Legion.Discovery.Api Network.Legion.Discovery.Config Network.Legion.Discovery.Graphviz- Network.Legion.Discovery.HttpError- Network.Legion.Discovery.LIO+ Network.Legion.Discovery.LegionApp+ Network.Legion.Discovery.Server Network.Legion.Discovery.UserAgent Paths_legion_discovery build-depends:- Cabal >= 1.22.5.0 && < 1.25,+ Cabal >= 1.24.0.0 && < 1.25, SHA >= 1.6.4.1 && < 1.7, aeson >= 0.11.2.1 && < 0.12, attoparsec >= 0.13.1.0 && < 0.14,- base >= 4.9 && < 4.10,- binary >= 0.7.5.0 && < 0.9,- bytestring >= 0.10.6.0 && < 0.11,- canteven-http >= 0.1.1.1 && < 0.2,- canteven-log >= 1.0.0.0 && < 2.1,- conduit >= 1.2.7 && < 1.3,- containers >= 0.5.6.2 && < 0.6,- data-default-class >= 0.0.1 && < 0.2,+ base >= 4.8 && < 4.10,+ binary >= 0.8.3.0 && < 0.9,+ bytestring >= 0.10.8.1 && < 0.11,+ canteven-http >= 0.1.1.2 && < 0.2,+ canteven-log >= 2.0.0.1 && < 2.1,+ conduit >= 1.2.8 && < 1.3,+ containers >= 0.5.7.1 && < 0.6,+ data-default-class >= 0.1.2.0 && < 0.2, ekg >= 0.4.0.11 && < 0.5, graphviz >= 2999.18.1.2 && < 2999.19,- http-types >= 0.9.1 && < 0.10,+ http-api-data >= 0.2.4 && < 0.3, legion >= 0.8 && < 0.9,- legion-extra >= 0.1.0.3 && < 0.2,- monad-logger >= 0.3.19 && < 0.4,- scotty >= 0.11.0 && < 0.12,- scotty-format >= 0.1.1 && < 0.2,- scotty-resource >= 0.1.1.0 && < 0.3,+ legion-extra >= 0.1.0.6 && < 0.2,+ monad-logger >= 0.3.20.1 && < 0.4,+ mtl >= 2.2.1 && < 2.3,+ servant-server >= 0.8.1 && < 0.9, text >= 1.2.2.1 && < 1.3,- time >= 1.5.0.1 && < 1.7,- transformers >= 0.4.2.0 && < 0.6,+ time >= 1.6.0.1 && < 1.7, wai >= 3.2.1.1 && < 3.3,- wai-extra >= 3.0.17 && < 3.1,- warp >= 3.2.8 && < 3.3+ wai-extra >= 3.0.19 && < 3.1,+ warp >= 3.2.9 && < 3.3 default-language: Haskell2010 executable legion-discovery- hs-source-dirs:- app- main-is:- legion-discovery.hs- ghc-options:- -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs: app+ main-is: legion-discovery.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base, legion-discovery- default-language:- Haskell2010+ default-language: Haskell2010 test-suite legion-discovery-test- type:- exitcode-stdio-1.0- hs-source-dirs:- test- main-is:- Spec.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs build-depends: base, legion-discovery- ghc-options:- -threaded -rtsopts -with-rtsopts=-N- default-language:- Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010 source-repository head- type:- git- location:- https://github.com/owensmurray/legion-discovery+ type: git+ location: https://github.com/owensmurray/legion-discovery
src/Network/Legion/Discovery.hs view
@@ -1,69 +1,30 @@ {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-} module Network.Legion.Discovery (- main+ main, ) where -import Canteven.HTTP (requestLogging, logExceptionsAndContinue,- DecodeResult(Unsupported, BadEntity, Ok), FromEntity, decodeEntity)+import Canteven.HTTP (requestLogging, logExceptionsAndContinue) import Canteven.Log.MonadLog (getCantevenOutput)-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)-import Data.Conduit ((=$=), runConduit)-import Data.GraphViz (graphvizWithHandle, GraphvizCommand(Dot),- GraphvizOutput(Svg))-import Data.GraphViz.Printing (renderDot, toDot)-import Data.GraphViz.Types.Canonical (DotGraph)-import Data.Map (Map)-import Data.Monoid ((<>))-import Data.String (IsString)-import Data.Text (pack, unpack)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Time (getCurrentTime)-import Data.Version (showVersion, Version)-import Distribution.Text (simpleParse)-import Distribution.Version (VersionRange, anyVersion)-import Network.HTTP.Types (badRequest400, unsupportedMediaType415,- noContent204)-import Network.Legion (forkLegionary, Runtime, makeRequest,- search, SearchTag(SearchTag), IndexRecord, irKey, PartitionKey,- newMemoryPersistence, Persistence)+import Control.Monad (void)+import Control.Monad.Logger (runLoggingT)+import Data.Proxy (Proxy(Proxy))+import Data.Version (showVersion)+import Network.Legion (forkLegionary, newMemoryPersistence, Persistence) import Network.Legion.Config (parseArgs)-import Network.Legion.Discovery.App (Input(GetRange, Ping, GetService,- GetRequests), Output(InstanceList, PingResponse, ServiceResponse),- ServiceId(ServiceId), toKey, Time(Time), unServiceAddr, version,- ServiceAddr(ServiceAddr), InstanceInfo, Service, instances, name,- 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(Critical, Transient))-import Network.Legion.Discovery.LIO (runLIO, LIO)-import Network.Legion.Discovery.UserAgent (UserAgent(UAProduct), Product(- Product), productName, productVersion, parseUserAgent)+import Network.Legion.Discovery.Api(DiscoveryApi)+import Network.Legion.Discovery.LegionApp (Input, Output, State)+import Network.Legion.Discovery.Server (discoveryServer) import Network.Wai (Middleware, modifyResponse) import Network.Wai.Middleware.AddHeaders (addHeaders) import Network.Wai.Middleware.StripHeaders (stripHeader)-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, defaultHandler,- raise)-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Conduit.List as CL-import qualified Data.Map as Map+import Servant (serve)+import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TLE import qualified Network.Legion.Discovery.Config as C+import qualified Network.Wai.Handler.Warp as Warp import qualified Paths_legion_discovery as P import qualified System.Remote.Monitoring as Ekg @@ -71,322 +32,36 @@ main = do (settings, startupMode, config) <- parseArgs logging <- getCantevenOutput (C.logging config)- void $ Ekg.forkServer "localhost" (ekgPort config)+ void $ Ekg.forkServer "localhost" (C.ekgPort config) persist <- newMemoryPersistence :: IO (Persistence Input Output State)- runLIO logging $ do- legion <- forkLegionary persist settings startupMode- scottyT (servicePort config) (runLIO logging) $ do- middleware- $ 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" $- post . withStrictClients $ \clients -> do- now <- Time <$> liftIO getCurrentTime- withEntity (\ PingRequest {serviceAddress} -> do- sequence_ [- makeRequest runtime (toKey serviceId) req >>= \case- 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- list <- runConduit (- search runtime (SearchTag "" Nothing)- =$= CL.mapMaybeM (fillServiceInfo now)- =$= CL.consume- )- respondTo $- format serviceListCT $ do- setHeader "content-type" serviceListCT- raw . encode $ object [- unServiceId (name service) .= encodeInstances (instances service)- | service <- list- ]- let- getGraph :: (MonadIO m, ScottyError e) => ActionT e m (DotGraph TL.Text)- getGraph = - toDotGraph <$> runConduit (- search runtime (SearchTag "" Nothing)- =$= CL.mapMaybeM fillClientInfo- =$= CL.consume- )-- renderSvg :: (MonadIO m, ScottyError e)- => DotGraph TL.Text- -> ResponseFormat e m ()- renderSvg graph = format svgCT $ do- setHeader "content-type" svgCT- bytes <- liftIO $ graphvizWithHandle Dot graph Svg hGetContents- raw (LBS.fromStrict bytes)-- renderGraphviz :: (MonadIO m, ScottyError e)- => DotGraph TL.Text- -> ResponseFormat e m ()- renderGraphviz graph = format graphvizCT $ do- setHeader "content-type" graphvizCT- text (renderDot (toDot graph))-- resource "/v1/graph" $- get $ do- graph <- getGraph- respondTo $ do- renderSvg graph- renderGraphviz graph- let- queryResource :: (MonadIO m, ScottyError e)- => ServiceId- -> VersionRange- -> ActionT e m ()- queryResource serviceId range = - withClients $ \clients -> do- now <- Time <$> liftIO getCurrentTime- respondInstances =<<- getInstances- runtime- (toKey serviceId)- (GetRange clients serviceId now range)- resource "/v1/services/:serviceId" $- get $ do- serviceId <- ServiceId <$> param "serviceId"- queryResource serviceId anyVersion- resource "/v1/services/:serviceId/:versionRange" $- get $- simpleParse <$> param "versionRange" >>= \case- Nothing -> do- status badRequest400- text "Invalid version range."- Just range -> do- 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- a @400 Bad Request@ if the User-Agent header is missing or invalid.- -}- withClients :: (Monad m, ScottyError e)- => ([Client] -> ActionT e m ())- -> ActionT e m ()- withClients f =- fmap parseUserAgent <$> headerBS "user-agent" >>= \case- Nothing -> do- status badRequest400- text "Missing User-Agent."- Just (Left err) -> do- status badRequest400- text $ "Invalid User-Agent: " <> TL.pack err- Just (Right uas) ->- let- clients = [- Client {- cName = ServiceId (decodeUtf8 name),- cVersion = version- }- | UAProduct Product {productName, productVersion} <- uas- , let- vstring = unpack . decodeUtf8 <$> productVersion- (name, version) = case simpleParse =<< vstring of- Nothing -> (- productName <> maybe "" ("/" <>) productVersion,- Nothing- )- Just v -> (productName, Just v)- ]- in f clients--- {- | Get the service info for the serivce listing. -}- fillServiceInfo :: (MonadIO m, ScottyError e)- => Time- -> IndexRecord- -> ActionT e m (Maybe Service)- fillServiceInfo now ir = getService runtime (irKey ir) (GetService now)-- {- | Get the client info for a service. -}- fillClientInfo :: (MonadIO m, ScottyError e)- => IndexRecord- -> ActionT e m (Maybe Service)- fillClientInfo ir = getService runtime (irKey ir) GetRequests-- {- | Send a response containing the service instance list. -}- respondInstances :: (Monad m, ScottyError e)- => Map ServiceAddr InstanceInfo- -> ActionT e m ()- respondInstances is = do- setHeader "content-type" instanceListCT- (raw . encode . encodeInstances) is-- {- | Encode instances into a JSON object -}- encodeInstances :: Map ServiceAddr InstanceInfo -> Value- encodeInstances instances = object [- unServiceAddr addr .= object [- "version" .= showVersion (version info)- ]- | (addr, info) <- Map.toList instances- ]--{- | Send a legion request that returns an InstanceList response. -}-getInstances :: (MonadIO io)- => Runtime Input Output- -> PartitionKey- -> Input- -> io (Map ServiceAddr InstanceInfo)-getInstances runtime key input =- makeRequest runtime key input >>= \case- InstanceList instances -> return instances- PingResponse -> fail "Invalid runtime response."- ServiceResponse _ -> fail "Invalid runtime response."---{- | Send a legion request that returns a 'ServiceResposne' response. -}-getService :: (MonadIO io)- => Runtime Input Output- -> PartitionKey- -> Input- -> io (Maybe Service)-getService runtime key input =- makeRequest runtime key input >>= \case- ServiceResponse service -> return service- PingResponse -> fail "Invalid runtime response."- InstanceList _ -> fail "Invalid runtime response."+ legion <- (`runLoggingT` logging)+ $ forkLegionary persist settings startupMode+ Warp.run+ (C.servicePort config)+ (+ requestLogging logging+ . setServer "legion-discovery"+ . logExceptionsAndContinue logging+ . serve (Proxy :: Proxy DiscoveryApi)+ . discoveryServer+ $ legion+ ) {- | Set the server header. -} setServer :: String -> Middleware setServer serviceName = addServerHeader . stripServerHeader where- {- |- Strip the server header- -}+ {- | Strip the server header. -} stripServerHeader :: Middleware stripServerHeader = modifyResponse (stripHeader "Server") - {- |- Add our own server header.- -}+ {- | Add our own server header. -} addServerHeader :: Middleware addServerHeader = addHeaders [("Server", serverValue)] - {- |- The value of the @Server:@ header.- -}+ {- | The value of the @Server:@ header. -} serverValue =- TE.encodeUtf8 (pack (serviceName ++ "/" ++ showVersion P.version))---{- | The service instance list content type. -}-instanceListCT :: (IsString a) => a-instanceListCT = "application/vnd.legion-discovery.instance-list+json"---{- | The known service list content type. -}-serviceListCT :: (IsString a) => a-serviceListCT = "application/vnd.legion-discovery.service-list+json"---{- | The content type of unrendered dot graphs. -}-graphvizCT :: (IsString a) => a-graphvizCT = "text/vnd.graphviz"---{- | The content type of svg data. -}-svgCT :: (IsString a) => a-svgCT = "image/svg+xml"---{- | Scotty shorthand for getting and decoding an entity. -}-withEntity :: (FromEntity a, MonadIO m, ScottyError e)- => (a -> ActionT e m ())- -> ActionT e m ()-withEntity f =- decodeEntity <$> headerLBS "content-type" <*> body >>= \case- Unsupported -> status unsupportedMediaType415- BadEntity why -> do- status badRequest400- text (TL.pack why)- Ok b -> f b---{- | Get a header as a 'Date.ByteString.Lazy.ByteString'. -}-headerLBS :: (ScottyError e, Monad m)- => TL.Text- -> ActionT e m (Maybe LBS.ByteString)-headerLBS headerName = fmap TLE.encodeUtf8 <$> header headerName---{- | Decode a ping request entity. -}-newtype PingRequest = PingRequest {- serviceAddress :: ServiceAddr- }-instance FromJSON PingRequest where- parseJSON (Object o) =- PingRequest . ServiceAddr <$> o .: "serviceAddress"- parseJSON v = fail- $ "Can't parse PingRequest from: " ++ show v-instance FromEntity PingRequest where- decodeEntity (Just PingRequestCT) bytes =- case eitherDecode bytes of- Left err -> BadEntity err- Right req -> Ok req- decodeEntity _ _ = Unsupported---{- | The content type for ping requests. -}-pattern PingRequestCT :: (IsString a, Eq a) => a-pattern PingRequestCT = "application/vnd.legion-discovery.ping-request+json"---{- |- Like 'Web.Scotty.Trans.header', except returns a 'ByteString' instead of- 'TL.Text'.--}-headerBS :: (Monad m, ScottyError e)- => TL.Text- -> ActionT e m (Maybe ByteString)-headerBS name = fmap (encodeUtf8 . TL.toStrict) <$> header name+ TE.encodeUtf8 (T.pack (serviceName ++ "/" ++ showVersion P.version))
+ src/Network/Legion/Discovery/Api.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{- | The descovery api specification. -}+module Network.Legion.Discovery.Api (+ -- * Api types+ DiscoveryApi,+ V1Api,+ PingApi,+ InstancesApi,+ GraphApi,++ -- * "Real" data types.+ ClientList(..),+ InstanceList(..),+ Range(..),+ PingRequest(..),+ Graph(..),+) where++import Data.Aeson (FromJSON, parseJSON, Value(Object), (.:), eitherDecode,+ encode, object, (.=))+import Data.ByteString (hGetContents)+import Data.GraphViz (graphvizWithHandle, GraphvizCommand(Dot),+ GraphvizOutput(Svg))+import Data.GraphViz.Printing (renderDot, toDot)+import Data.GraphViz.Types.Canonical (DotGraph)+import Data.Map (Map)+import Data.Monoid ((<>))+import Data.Proxy (Proxy(Proxy))+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Data.Version (showVersion)+import Distribution.Text (simpleParse)+import Distribution.Version (VersionRange)+import Network.Legion.Discovery.LegionApp (ServiceAddr(ServiceAddr),+ Client(Client), cName, cVersion, EntityName(EntityName), Client,+ unServiceAddr, version, InstanceInfo)+import Network.Legion.Discovery.UserAgent (parseUserAgent,+ UserAgent(UAProduct), Product(Product), productName, productVersion)+import Servant ((:>), (:<|>), Get, Accept, contentType, ReqBody, Capture,+ Header, MimeUnrender, mimeUnrender, MimeRender, mimeRender, NoContent,+ JSON)+import System.IO.Unsafe (unsafePerformIO)+import Web.HttpApiData (FromHttpApiData, parseUrlPiece, parseHeader)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import qualified Servant as S+++type DiscoveryApi =+ "v1" :> V1Api+++type V1Api =+ Header "User-Agent" ClientList :> (+ "ping" :> PingApi :<|>+ "services" :> (+ Capture "serviceName" EntityName :> (+ InstancesApi :<|>+ Capture "versionRange" Range :> InstancesApi+ )+ )+ ) :<|>+ "graph" :> GraphApi+++{- | The "graph" endpoint. -}+type GraphApi = Get '[SvgCT, DotCT] Graph+++{- | The "ping" endpoint. -}+type PingApi = ReqBody '[PingRequestCT] PingRequest :> PostNoContent+++{- | Shorthand for a post returning no contents. -}+type PostNoContent = S.PostNoContent '[StupidArbitraryPlaceholder] NoContent+++{- | see: https://github.com/haskell-servant/servant/issues/498 -}+type StupidArbitraryPlaceholder = JSON+++{- | Api segment that returns a list of instances. -}+type InstancesApi = Get '[InstanceListCT] InstanceList+++{- | The type of graph data. -}+newtype Graph = Graph (DotGraph TL.Text)+instance MimeRender DotCT Graph where+ mimeRender Proxy (Graph graph) = + TLE.encodeUtf8 . renderDot . toDot $ graph+instance MimeRender SvgCT Graph where+ mimeRender Proxy (Graph graph) = unsafePerformIO $ do+ bytes <- graphvizWithHandle Dot graph Svg hGetContents+ return (BSL.fromStrict bytes)+++newtype Range = Range VersionRange+instance FromHttpApiData Range where+ parseUrlPiece r = case simpleParse (T.unpack r) of+ Nothing -> Left . T.pack $ ("Invalid version range: " ++ show r)+ Just vr -> Right (Range vr)+++data InstanceListCT+instance Accept InstanceListCT where+ contentType Proxy = "application/vnd.legion-discovery.instance-list+json"+++data PingRequestCT+instance Accept PingRequestCT where+ contentType Proxy = "application/vnd.legion-discovery.ping-request+json"+++data DotCT+instance Accept DotCT where+ contentType Proxy = "text/vnd.graphviz"+++data SvgCT+instance Accept SvgCT where+ contentType Proxy = "image/svg+xml"+++newtype ClientList = ClientList [Client]+instance FromHttpApiData ClientList where+ parseUrlPiece = parseHeader . encodeUtf8+ parseHeader bytes = do+ agents <- parseUserAgent bytes+ return $ ClientList [+ Client {+ cName = EntityName (decodeUtf8 name),+ cVersion = version+ }+ | UAProduct Product {productName, productVersion} <- agents+ , let+ vstring = T.unpack . decodeUtf8 <$> productVersion+ (name, version) = case simpleParse =<< vstring of+ Nothing -> (+ productName <> maybe "" ("/" <>) productVersion,+ Nothing+ )+ Just v -> (productName, Just v)+ ]+++newtype InstanceList = InstanceList (Map ServiceAddr InstanceInfo)+instance MimeRender InstanceListCT InstanceList where+ mimeRender Proxy (InstanceList instances) = + encode $ object [+ unServiceAddr addr .= object [+ "version" .= showVersion (version info)+ ]+ | (addr, info) <- Map.toList instances+ ]+++{- | Decode a ping request entity. -}+newtype PingRequest = PingRequest {+ serviceAddress :: ServiceAddr+ }+instance FromJSON PingRequest where+ parseJSON (Object o) =+ PingRequest . ServiceAddr <$> o .: "serviceAddress"+ parseJSON v = fail+ $ "Can't parse PingRequest from: " ++ show v+instance MimeUnrender PingRequestCT PingRequest where+ mimeUnrender Proxy = eitherDecode++
− src/Network/Legion/Discovery/App.hs
@@ -1,265 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{- |- This module contains the legion application definition.-- ToJSON instances are only to support a better 'Show' instance for- debugging, they are not meant to be used as--}-module Network.Legion.Discovery.App (- Input(..),- Output(..),- State,- ServiceId(..),- ServiceAddr(..),- InstanceInfo(..),- Client(..),- RequestInfo(..),- Time(..),- Service(..),- toKey,-) where--import Data.Aeson (ToJSON, toJSON, object, (.=))-import Data.Binary (Binary, get, put)-import Data.Default.Class (Default, def)-import Data.Digest.Pure.SHA (sha256)-import Data.Map (Map)-import Data.Monoid ((<>))-import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8)-import Data.Time (UTCTime(UTCTime), Day(ModifiedJulianDay), addUTCTime,- NominalDiffTime)-import Data.Version (showVersion)-import Distribution.Text (display)-import Distribution.Version (Version, VersionRange, withinRange)-import GHC.Generics (Generic)-import Network.Legion (Event, apply, PartitionKey, Tag(Tag),- Indexable, indexEntries)-import qualified Data.Aeson as A-import qualified Data.Binary as B-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE---data Input- = GetRange [Client] ServiceId Time VersionRange- | Ping Time ServiceId Version ServiceAddr- | GetService Time- | GetRequests- deriving (Show, Eq, Generic)-instance Binary Input---data Output- = InstanceList (Map ServiceAddr InstanceInfo)- | ServiceResponse (Maybe Service)- | PingResponse- deriving (Show, Generic)-instance Binary Output---newtype State = State {- _unState :: Maybe Service- }- deriving (Binary)-instance Show State where- show = T.unpack . decodeUtf8 . LBS.toStrict . A.encode-instance Default State where- def = State Nothing-instance Indexable State where- indexEntries (State Nothing) = Set.empty- indexEntries (State (Just Service {name})) =- (Set.singleton . Tag . TE.encodeUtf8 . unServiceId) name-instance ToJSON State where- toJSON (State s) = object ["state" .= s]---{- | This type represents a discoverable service. -}-data Service = Service {- name :: ServiceId,- instances :: Map ServiceAddr InstanceInfo,- requests :: Map Client RequestInfo- }- deriving (Show, Generic)-instance Binary Service-instance ToJSON Service where- toJSON (Service name_ instances_ requests_) = object [- "name" .= name_,- "instances" .= Map.mapKeys (T.unpack . unServiceAddr) instances_,- "requests" .= Map.mapKeys show requests_- ]---{- | Information about a request. -}-data RequestInfo = RequestInfo {- riTime :: Time,- riRange :: VersionRange- }- deriving (Show, Eq, Generic)-instance Binary RequestInfo-instance ToJSON RequestInfo where- toJSON (RequestInfo time range) = object [- "time" .= time,- "range" .= display range- ]---{- | Information about a query client. -}-data Client = Client {- cName :: ServiceId,- cVersion :: Maybe Version- }- deriving (Eq, Generic, Ord)-instance Binary Client-instance Show Client where- show (Client name version) =- T.unpack (unServiceId name) <> maybe "" (("/" <>) . showVersion) version---{- | The address on which a service can be contacted. -}-newtype ServiceAddr = ServiceAddr {unServiceAddr :: Text}- deriving (Show, Eq, Ord, Binary)---{- | Additional information about the service instance. -}-data InstanceInfo = InstanceInfo {- version :: Version,- lastPing :: Time- }- deriving (Show, Generic)-instance Binary InstanceInfo-instance ToJSON InstanceInfo---{- | The main request handler. -}-handle :: Input -> State -> (Output, State)-handle (GetRange clients name now range) (State Nothing) =- (- InstanceList Map.empty,- State (Just Service {- name,- instances = Map.empty,- requests = Map.fromList [- (client, RequestInfo {- riTime = now,- riRange = range- })- | client <- clients- ]- })- )-handle (GetRange clients _name now range) (State (Just service)) =- let- output =- InstanceList . Map.fromAscList $ [- (addr, info)- | (addr, info) <- Map.toAscList (instances service)- , addUTCTime thirtySeconds (unTime (lastPing info)) >= unTime now- , withinRange (version info) range- ]- in (output, State (Just (addRequest service)))- where- addRequest :: Service -> Service- addRequest s@Service {requests} = s {- requests =- Map.union- (Map.fromList [- (client, RequestInfo {- riTime = now,- riRange = range- })- | client <- clients- ])- requests- }-handle (Ping now name version addr) (State Nothing) =- let- state = State (Just Service {- name = name,- requests = Map.empty,- instances = Map.singleton addr InstanceInfo {- version,- lastPing = now- }- })- in (PingResponse, state)-handle (Ping now name version addr) (State (Just service)) =- let- state = State (Just service {- name = name,- instances = Map.alter ping addr (instances service)- })- ping Nothing = Just InstanceInfo {- version,- lastPing = now- }- ping (Just info) = Just info {- version,- lastPing = now- }- in (PingResponse, state)-handle (GetService _ ) (State Nothing) =- (ServiceResponse Nothing, State Nothing)-handle (GetService now) state@(State (Just service)) =- let- i = Map.filter notExpired (instances service)- output = ServiceResponse $ if Map.null i- then Nothing- else Just service {- instances = i- }- in (output, state)- where- notExpired = (unTime now <=) . addUTCTime thirtySeconds . unTime . lastPing-handle GetRequests (State Nothing) =- (ServiceResponse Nothing, State Nothing)-handle GetRequests state@(State (Just service)) =- (ServiceResponse (Just service), state)---{- | A service id. -}-newtype ServiceId = ServiceId {- unServiceId :: Text- }- deriving (Show, Eq, Binary, Ord, ToJSON)---instance Event Input Output State where- apply = handle---{- |- Wrapper for UTCTime. Useful beacuse UTCTime doesn't have a `Binary`- instane.--}-newtype Time = Time {unTime :: UTCTime}- deriving (Show, Eq, Ord, ToJSON)-instance Binary Time where- put (Time (UTCTime (ModifiedJulianDay day) time)) = put (day, toRational time)- get = do- (day, time) <- get- return (Time (UTCTime (ModifiedJulianDay day) (fromRational time)))---{- | Convert a ServiceId into a partition key. -}-toKey :: ServiceId -> PartitionKey-toKey =- B.decode- . B.encode- . sha256- . LBS.fromStrict- . TE.encodeUtf8- . unServiceId---thirtySeconds :: NominalDiffTime-thirtySeconds = 30--
src/Network/Legion/Discovery/Graphviz.hs view
@@ -17,10 +17,10 @@ import Data.Set (Set) import Data.Version (showVersion, Version) import Distribution.Version (withinRange)-import Network.Legion.Discovery.App (Service(Service), name, instances,- InstanceInfo(InstanceInfo), version, unServiceId, Client(Client),- requests, cName, cVersion, ServiceId, RequestInfo(RequestInfo),- riRange, ServiceAddr, unServiceAddr)+import Network.Legion.Discovery.LegionApp (Service(Service), name,+ instances, InstanceInfo(InstanceInfo), version, unEntityName,+ Client(Client), requests, cName, cVersion, EntityName,+ RequestInfo(RequestInfo), riRange, ServiceAddr, unServiceAddr) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text.Lazy as TL@@ -63,7 +63,7 @@ ] {- | Organize the services by name and version. -}- byNameAndVersion :: Map (ServiceId, Version) (Set ServiceAddr)+ byNameAndVersion :: Map (EntityName, Version) (Set ServiceAddr) byNameAndVersion = Map.fromList [ ((name, v), addys) | Service {name, instances} <- services@@ -82,9 +82,9 @@ , addy <- addys ] -{- | Show a 'ServiceId' as 'TL.Text'. -}-showName :: ServiceId -> TL.Text-showName = TL.fromStrict . unServiceId+{- | Show a 'EntityName' as 'TL.Text'. -}+showName :: EntityName -> TL.Text+showName = TL.fromStrict . unEntityName {- | Show a version as 'TL.Text'. -}@@ -106,7 +106,7 @@ {- | Convert a service instance to a 'DotNode'. -}-instanceToNodeId :: ServiceId -> InstanceInfo -> ServiceAddr -> TL.Text+instanceToNodeId :: EntityName -> InstanceInfo -> ServiceAddr -> TL.Text instanceToNodeId name info addy = showName name <> "/" <> showV (version info) <> ":" <> showAddy addy @@ -128,7 +128,11 @@ } {- | Create a version cluster subgraph. -}-versionCluster :: ServiceId -> Version -> Set ServiceAddr -> DotSubGraph TL.Text+versionCluster+ :: EntityName+ -> Version+ -> Set ServiceAddr+ -> DotSubGraph TL.Text versionCluster n v addys = DotSG { isCluster = True, subGraphID = Just (Str (showName n <> "/" <> showV v)),
− src/Network/Legion/Discovery/HttpError.hs
@@ -1,26 +0,0 @@-{- |- This module contains a `ScottyError` error type that short-cuts to http- response types.--}-module Network.Legion.Discovery.HttpError (- HttpError(..),-) where--import Control.Exception (Exception)-import Data.Text (Text, pack)-import Data.Text.Lazy (fromStrict)-import Network.HTTP.Types (Status)-import Web.Scotty.Trans (ScottyError, stringError, showError)--data HttpError- = Transient Status Text- | Critical Text- deriving (Show)--instance Exception HttpError--instance ScottyError HttpError where- stringError = Critical . pack- showError (Transient _ msg) = fromStrict msg- showError (Critical msg) = fromStrict msg-
− src/Network/Legion/Discovery/LIO.hs
@@ -1,22 +0,0 @@-{- |- Logging IO Monad.--}--module Network.Legion.Discovery.LIO (- LIO,- runLIO,-) where--import Canteven.Log.MonadLog (LoggerTImpl)-import Control.Monad.Logger (LoggingT, runLoggingT)---{- | The logging IO monad. -}-type LIO = LoggingT IO---{- | run an LIO monad in IO. -}-runLIO :: LoggerTImpl -> LIO a -> IO a-runLIO logging = (`runLoggingT` logging)--
+ src/Network/Legion/Discovery/LegionApp.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{- |+ This module contains the legion application definition.++ ToJSON instances are only to support a better 'Show' instance for+ debugging, they are not meant to be used as+-}+module Network.Legion.Discovery.LegionApp (+ -- * Types that make up the legion application definition.+ Input,+ Output,+ State,+ EntityName(..),+ ServiceAddr(..),+ InstanceInfo(..),+ Client(..),+ RequestInfo(..),+ Time(..),+ Service(..),++ -- * A more user-friendly interface to our legion application.+ getRange,+ ping,+ getService,+ getAllServices,++ -- * Utilities+ toKey,+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (ToJSON, toJSON, object, (.=))+import Data.Binary (Binary, get, put)+import Data.Conduit ((=$=), runConduit)+import Data.Default.Class (Default, def)+import Data.Digest.Pure.SHA (sha256)+import Data.Map (Map)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Data.Time (UTCTime(UTCTime), Day(ModifiedJulianDay), addUTCTime,+ NominalDiffTime, getCurrentTime)+import Data.Version (showVersion)+import Distribution.Text (display)+import Distribution.Version (Version, VersionRange, withinRange)+import GHC.Generics (Generic)+import Network.Legion (Runtime, makeRequest, search, SearchTag(SearchTag),+ irKey, PartitionKey, Event, apply, Tag(Tag), Indexable, indexEntries)+import Web.HttpApiData (FromHttpApiData, parseUrlPiece)+import qualified Data.Aeson as A+import qualified Data.Binary as B+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Conduit.List as CL+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+++data Input+ = GetRange [Client] EntityName Time VersionRange+ | Ping Time EntityName Version ServiceAddr+ | GetService Time+ deriving (Show, Eq, Generic)+instance Binary Input+++data Output+ = InstanceList (Map ServiceAddr InstanceInfo)+ | ServiceResponse (Maybe Service)+ | PingResponse+ deriving (Show, Generic)+instance Binary Output+++newtype State = State {+ _unState :: Maybe Service+ }+ deriving (Binary)+instance Show State where+ show = T.unpack . decodeUtf8 . LBS.toStrict . A.encode+instance Default State where+ def = State Nothing+instance Indexable State where+ indexEntries (State Nothing) = Set.empty+ indexEntries (State (Just Service {name})) =+ (Set.singleton . Tag . TE.encodeUtf8 . unEntityName) name+instance ToJSON State where+ toJSON (State s) = object ["state" .= s]+++{- | This type represents a discoverable service. -}+data Service = Service {+ name :: EntityName,+ instances :: Map ServiceAddr InstanceInfo,+ requests :: Map Client RequestInfo+ }+ deriving (Show, Generic)+instance Binary Service+instance ToJSON Service where+ toJSON (Service name_ instances_ requests_) = object [+ "name" .= name_,+ "instances" .= Map.mapKeys (T.unpack . unServiceAddr) instances_,+ "requests" .= Map.mapKeys show requests_+ ]+++{- | Information about a request. -}+data RequestInfo = RequestInfo {+ riTime :: Time,+ riRange :: VersionRange+ }+ deriving (Show, Eq, Generic)+instance Binary RequestInfo+instance ToJSON RequestInfo where+ toJSON (RequestInfo time range) = object [+ "time" .= time,+ "range" .= display range+ ]+++{- | Information about a query client. -}+data Client = Client {+ cName :: EntityName,+ cVersion :: Maybe Version+ }+ deriving (Eq, Generic, Ord)+instance Binary Client+instance Show Client where+ show (Client name version) =+ T.unpack (unEntityName name) <> maybe "" (("/" <>) . showVersion) version+++{- | The address on which a service can be contacted. -}+newtype ServiceAddr = ServiceAddr {unServiceAddr :: Text}+ deriving (Show, Eq, Ord, Binary)+++{- | Additional information about the service instance. -}+data InstanceInfo = InstanceInfo {+ version :: Version,+ lastPing :: Time+ }+ deriving (Show, Generic)+instance Binary InstanceInfo+instance ToJSON InstanceInfo+++{- | The main request handler. -}+handle :: Input -> State -> (Output, State)+handle (GetRange clients name now range) (State Nothing) =+ (+ InstanceList Map.empty,+ State (Just Service {+ name,+ instances = Map.empty,+ requests = Map.fromList [+ (client, RequestInfo {+ riTime = now,+ riRange = range+ })+ | client <- clients+ ]+ })+ )+handle (GetRange clients _name now range) (State (Just service)) =+ let+ output =+ InstanceList . Map.fromAscList $ [+ (addr, info)+ | (addr, info) <- Map.toAscList (instances service)+ , addUTCTime thirtySeconds (unTime (lastPing info)) >= unTime now+ , withinRange (version info) range+ ]+ in (output, State (Just (addRequest service)))+ where+ addRequest :: Service -> Service+ addRequest s@Service {requests} = s {+ requests =+ Map.union+ (Map.fromList [+ (client, RequestInfo {+ riTime = now,+ riRange = range+ })+ | client <- clients+ ])+ requests+ }+handle (Ping now name version addr) (State Nothing) =+ let+ state = State (Just Service {+ name = name,+ requests = Map.empty,+ instances = Map.singleton addr InstanceInfo {+ version,+ lastPing = now+ }+ })+ in (PingResponse, state)+handle (Ping now name version addr) (State (Just service)) =+ let+ state = State (Just service {+ name = name,+ instances = Map.alter doPing addr (instances service)+ })+ doPing Nothing = Just InstanceInfo {+ version,+ lastPing = now+ }+ doPing (Just info) = Just info {+ version,+ lastPing = now+ }+ in (PingResponse, state)+handle (GetService _ ) (State Nothing) =+ (ServiceResponse Nothing, State Nothing)+handle (GetService now) state@(State (Just service)) =+ let+ i = Map.filter notExpired (instances service)+ output = ServiceResponse $ if Map.null i+ then Nothing+ else Just service {+ instances = i+ }+ in (output, state)+ where+ notExpired = (unTime now <=) . addUTCTime thirtySeconds . unTime . lastPing+++{- | The name of an entity (client, or service, or both). -}+newtype EntityName = EntityName {+ unEntityName :: Text+ }+ deriving (Show, Eq, Binary, Ord, ToJSON)+instance FromHttpApiData EntityName where+ parseUrlPiece = Right . EntityName+++instance Event Input Output State where+ apply = handle+++{- |+ Wrapper for UTCTime. Useful beacuse UTCTime doesn't have a `Binary`+ instane.+-}+newtype Time = Time {unTime :: UTCTime}+ deriving (Show, Eq, Ord, ToJSON)+instance Binary Time where+ put (Time (UTCTime (ModifiedJulianDay day) time)) = put (day, toRational time)+ get = do+ (day, time) <- get+ return (Time (UTCTime (ModifiedJulianDay day) (fromRational time)))+++{- | Convert a EntityName into a partition key. -}+toKey :: EntityName -> PartitionKey+toKey =+ B.decode+ . B.encode+ . sha256+ . LBS.fromStrict+ . TE.encodeUtf8+ . unEntityName+++thirtySeconds :: NominalDiffTime+thirtySeconds = 30+++{- | Get the instances of a service that match a version range. -}+getRange :: (MonadIO io)+ => Runtime Input Output+ -> [Client] {- ^ The clients making the requests. -}+ -> EntityName {- ^ The name of the target service. -}+ -> VersionRange {- ^ The allowable instance versions. -}+ -> io (Map ServiceAddr InstanceInfo)+getRange runtime clients name range = do+ now <- Time <$> liftIO getCurrentTime+ let req = GetRange clients name now range+ makeRequest runtime (toKey name) req >>= \case+ InstanceList instances -> return instances+ r -> fail $ "Bad runtime response to req [" ++ show req ++ "]: " ++ show r+++{- | Register a service instance. -}+ping :: (MonadIO io)+ => Runtime Input Output+ -> EntityName {- ^ The name of the registering service. -}+ -> Version {- ^ The version of the registering service. -}+ -> ServiceAddr+ {- ^ The service address on which the service can be contacted. -}+ -> io ()+ping runtime name version addy = do+ now <- Time <$> liftIO getCurrentTime+ let req = Ping now name version addy+ makeRequest runtime (toKey name) req >>= \case+ PingResponse -> return ()+ r -> fail $ "Bad runtime response to req [" ++ show req ++ "]: " ++ show r+++{- | Returns all current information about a service. -}+getService :: (MonadIO io)+ => Runtime Input Output+ -> EntityName {- ^ The name of the service to retrieve. -}+ -> io (Maybe Service)+getService runtime name = getServiceByKey runtime (toKey name)+++{- | Like `getService`, but using the precomputed partition key. -}+getServiceByKey :: (MonadIO io)+ => Runtime Input Output+ -> PartitionKey+ -> io (Maybe Service)+getServiceByKey runtime key = do+ now <- Time <$> liftIO getCurrentTime+ let req = GetService now+ makeRequest runtime key req >>= \case+ ServiceResponse s -> return s+ r -> fail $ "Bad runtime response to req [" ++ show req ++ "]: " ++ show r+++{- | Returns all services. -}+getAllServices :: (MonadIO io)+ => Runtime Input Output+ -> io [Service]+getAllServices runtime =+ runConduit (+ search runtime (SearchTag "" Nothing)+ =$= CL.mapMaybeM (getServiceByKey runtime . irKey)+ =$= CL.consume+ )++
+ src/Network/Legion/Discovery/Server.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{- | Contains the servant implentation of the 'DiscoveryApi'. -}+module Network.Legion.Discovery.Server (+ discoveryServer,+) where++import Control.Monad.Except (throwError)+import Control.Monad.IO.Class (liftIO)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.Version (Version)+import Distribution.Version (anyVersion)+import Network.Legion (Runtime)+import Network.Legion.Discovery.Api(DiscoveryApi, V1Api,+ ClientList(ClientList), DiscoveryApi, PingRequest(PingRequest),+ Range(Range), serviceAddress, PingApi, InstancesApi,+ InstanceList(InstanceList), GraphApi, Graph(Graph))+import Network.Legion.Discovery.Graphviz (toDotGraph)+import Network.Legion.Discovery.LegionApp (Input, Output, unEntityName,+ Client(Client), cName, cVersion, EntityName, Client, Output, getRange,+ getAllServices)+import Servant ((:<|>)((:<|>)), Server, ServantErr, errBody,+ errHeaders, err400, NoContent(NoContent), Handler)+import qualified Data.ByteString.Lazy as BSL+import qualified Network.Legion.Discovery.LegionApp as App+++{- | The implementation of the 'DiscoveryApi' api. -}+discoveryServer :: Runtime Input Output -> Server DiscoveryApi+discoveryServer = v1+++{- | version 1 of the api. -}+v1 :: Runtime Input Output -> Server V1Api+v1 runtime =+ (\case+ Just (ClientList (clients@(_:_))) ->+ ping clients :<|>+ (\name ->+ allInstances clients name :<|>+ rangedInstances clients name+ )+ Just (ClientList []) ->+ let bad = throwError (badRequest "Invalid User-Agent request header.")+ in const bad :<|> const (bad :<|> const bad)+ _ ->+ let bad = throwError (badRequest "Missing User-Agent request header.")+ in const bad :<|> const (bad :<|> const bad)+ ) :<|>+ graph+ where+ graph :: Server GraphApi+ graph = Graph . toDotGraph <$> getAllServices runtime++ ping :: [Client] -> Server PingApi+ ping clients PingRequest {serviceAddress} = do+ strictClients <- mapM toStrict clients+ liftIO $ do+ sequence_ [+ App.ping runtime name version serviceAddress+ | (name, version) <- strictClients+ ]+ return NoContent+ where+ {- |+ Return the client name and version, or else throw an error if+ the client doesn't provide a version.+ -}+ toStrict :: Client -> Handler (EntityName, Version)+ toStrict Client {cName, cVersion = Just version} =+ return (cName, version)+ toStrict Client {cName, cVersion = Nothing} =+ throwError $ badRequest (+ "Missing version for client product: "+ <> unEntityName cName+ <> ". Please fix your User-Agent header."+ )++ allInstances :: [Client] -> EntityName -> Server InstancesApi+ allInstances clients name = rangedInstances clients name (Range anyVersion)++ rangedInstances :: [Client] -> EntityName -> Range -> Server InstancesApi+ rangedInstances clients name (Range range) = liftIO $+ InstanceList <$> getRange runtime clients name range+++{- | 400 BadRequest servant error helper. -}+badRequest :: Text -> ServantErr+badRequest msg = err400 {+ errBody = BSL.fromStrict (encodeUtf8 msg),+ errHeaders = [("content-type", "text/plain")]+ }++
src/Network/Legion/Discovery/UserAgent.hs view
@@ -15,9 +15,12 @@ import Control.Monad (void) import Data.Attoparsec.ByteString (Parser, word8, takeWhile1, satisfy, inClass, option, string, many1, parseOnly)+import Data.Bifunctor (first) import Data.ByteString (ByteString)+import Data.Text (Text) import Data.Word (Word8) import qualified Data.ByteString as BS+import qualified Data.Text as T {- | The User-Agent header field is defined as a list of tokens, each of@@ -43,8 +46,8 @@ Parse a user-agent header according to the specification in RFC-2616, or else return a reason why parsing failed. -}-parseUserAgent :: ByteString -> Either String [UserAgent]-parseUserAgent = parseOnly userAgent+parseUserAgent :: ByteString -> Either Text [UserAgent]+parseUserAgent = first T.pack . parseOnly userAgent {- |