legion-discovery 0.3.0.2 → 1.0.0.0
raw patch · 7 files changed
+192/−159 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Network.Legion.Discovery: main :: IO ()
+ Network.Legion.Discovery.Main: main :: IO ()
Files
- app/legion-discovery.hs +2/−2
- legion-discovery.cabal +2/−2
- src/Network/Legion/Discovery.hs +0/−44
- src/Network/Legion/Discovery/Api.hs +67/−52
- src/Network/Legion/Discovery/LegionApp.hs +31/−18
- src/Network/Legion/Discovery/Main.hs +43/−0
- src/Network/Legion/Discovery/Server.hs +47/−41
app/legion-discovery.hs view
@@ -1,7 +1,7 @@ module Main (main) where -import qualified Network.Legion.Discovery+import qualified Network.Legion.Discovery.Main main :: IO ()-main = Network.Legion.Discovery.main+main = Network.Legion.Discovery.Main.main
legion-discovery.cabal view
@@ -1,5 +1,5 @@ name: legion-discovery-version: 0.3.0.2+version: 1.0.0.0 synopsis: A discovery service based on Legion. description: A simple service discovery service based on Legion,@@ -22,7 +22,7 @@ library hs-source-dirs: src exposed-modules:- Network.Legion.Discovery+ Network.Legion.Discovery.Main other-modules: Network.Legion.Discovery.Api Network.Legion.Discovery.Config
− src/Network/Legion/Discovery.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-module Network.Legion.Discovery (- main,-) where--import Canteven.HTTP (requestLogging, logExceptionsAndContinue, setServer)-import Canteven.Log.MonadLog (getCantevenOutput)-import Control.Monad (void)-import Control.Monad.Logger (runLoggingT)-import Data.Proxy (Proxy(Proxy))-import Network.Legion (forkLegionary)-import Network.Legion.Config (parseArgs)-import Network.Legion.Discovery.Api(DiscoveryApi)-import Network.Legion.Discovery.Server (discoveryServer)-import Network.Legion.Persistence (newMemoryPersistence)-import Servant (serve)-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--main :: IO ()-main = do- (settings, startupMode, config) <- parseArgs- logging <- getCantevenOutput (C.logging config)- void $ Ekg.forkServer "localhost" (C.ekgPort config)- persist <- newMemoryPersistence- legion <- (`runLoggingT` logging) $- forkLegionary persist settings startupMode- Warp.run- (C.servicePort config)- (- requestLogging logging- . setServer "legion-discovery" P.version- . logExceptionsAndContinue logging- . serve (Proxy :: Proxy DiscoveryApi)- . discoveryServer- $ legion- ) --
src/Network/Legion/Discovery/Api.hs view
@@ -1,18 +1,20 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-}+ {- | The descovery api specification. -} module Network.Legion.Discovery.Api (- -- * Api types+ -- * Types that descirbe the API structure. DiscoveryApi, V1Api, PingApi,- InstancesApi,+ ServicesApi, GraphApi, - -- * "Real" data types.+ -- * Types that describe API data. ClientList(..), InstanceList(..), Range(..),@@ -21,8 +23,7 @@ SvgGraph(..), ) where -import Data.Aeson (FromJSON, parseJSON, Value(Object), (.:), eitherDecode,- encode, object, (.=))+import Data.Aeson (FromJSON, eitherDecode, encode, object, (.=)) import Data.Attoparsec.ByteString (parseOnly) import Data.Bifunctor (first) import Data.ByteString (ByteString)@@ -36,11 +37,12 @@ import Data.Version (showVersion) import Distribution.Text (simpleParse) import Distribution.Version (VersionRange)+import GHC.Generics (Generic) import Network.HTTP.Grammar (UserAgent(UAProduct), Product(Product), productName, productVersion, userAgent)-import Network.Legion.Discovery.LegionApp (ServiceAddr(ServiceAddr),- Client(Client), cName, cVersion, EntityName(EntityName), Client,- unServiceAddr, version, InstanceInfo)+import Network.Legion.Discovery.LegionApp (ServiceAddr, Client(Client),+ cName, cVersion, EntityName(EntityName), Client, unServiceAddr, version,+ InstanceInfo, Metadata) import Servant ((:>), (:<|>), Get, Accept, contentType, ReqBody, Capture, Header, MimeUnrender, mimeUnrender, MimeRender, mimeRender, NoContent, JSON)@@ -50,35 +52,47 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE+import qualified Network.Legion.Discovery.LegionApp as App import qualified Servant as S -type DiscoveryApi =- "v1" :> V1Api +type DiscoveryApi = V1Api -type V1Api =- Header "User-Agent" ClientList :> (- "ping" :> PingApi :<|>- "services" :> (- Capture "serviceName" EntityName :> (- InstancesApi :<|>- Capture "versionRange" Range :> InstancesApi- )- )- ) :<|>- "graph" :> GraphApi +type V1Api = "v1" :> (PingApi :<|> ServicesApi :<|> GraphApi) + {- | The "graph" endpoint. -} type GraphApi =- Get '[SvgCT] SvgGraph :<|>- Get '[DotCT] Graph+ "graph"+ :> Get '[SvgCT] SvgGraph+ :<|>+ "graph"+ :> Get '[DotCT] Graph {- | The "ping" endpoint. -}-type PingApi = ReqBody '[PingRequestCT] PingRequest :> PostNoContent+type PingApi =+ "ping"+ :> Header "User-Agent" ClientList+ :> ReqBody '[PingRequestCT] PingRequest+ :> PostNoContent +{- | The "services" endpoint. -}+type ServicesApi =+ "services"+ :> Header "User-Agent" ClientList+ :> Capture "serviceName" EntityName+ :> Get '[InstanceListCT] InstanceList+ :<|>+ "services"+ :> Header "User-Agent" ClientList+ :> Capture "serviceName" EntityName+ :> Capture "versionRange" Range+ :> Get '[InstanceListCT] InstanceList++ {- | Shorthand for a post returning no contents. -} type PostNoContent = S.PostNoContent '[StupidArbitraryPlaceholder] NoContent @@ -87,10 +101,6 @@ 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@@ -130,26 +140,32 @@ contentType Proxy = "image/svg+xml" -newtype ClientList = ClientList [Client]+newtype ClientList = ClientList {+ unClientList :: [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)- ]+ let+ clients = [+ 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)+ ]+ case clients of+ [] -> Left "Invalid User-Agent request header."+ _ -> Right (ClientList clients) where {- | Parse a user-agent header according to the specification in@@ -164,21 +180,20 @@ mimeRender Proxy (InstanceList instances) = encode $ object [ unServiceAddr addr .= object [- "version" .= showVersion (version info)+ "version" .= showVersion (version info),+ "metadata" .= App.metadata info ] | (addr, info) <- Map.toList instances ] {- | Decode a ping request entity. -}-newtype PingRequest = PingRequest {- serviceAddress :: ServiceAddr+data PingRequest = PingRequest {+ serviceAddress :: ServiceAddr,+ metadata :: Maybe Metadata }-instance FromJSON PingRequest where- parseJSON (Object o) =- PingRequest . ServiceAddr <$> o .: "serviceAddress"- parseJSON v = fail- $ "Can't parse PingRequest from: " ++ show v+ deriving (Generic)+instance FromJSON PingRequest instance MimeUnrender PingRequestCT PingRequest where mimeUnrender Proxy = eitherDecode
src/Network/Legion/Discovery/LegionApp.hs view
@@ -4,12 +4,7 @@ {-# 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--}+{- | This module contains the legion application definition. -} module Network.Legion.Discovery.LegionApp ( -- * Types that make up the legion application definition. Input,@@ -22,6 +17,7 @@ RequestInfo(..), Time(..), Service(..),+ Metadata(..), -- * A more user-friendly interface to our legion application. getRange,@@ -34,7 +30,7 @@ ) where import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Aeson (ToJSON, toJSON, object, (.=))+import Data.Aeson (ToJSON, toJSON, object, (.=), Value, FromJSON) import Data.Binary (Binary, get, put) import Data.Conduit ((=$=), runConduit) import Data.Default.Class (Default, def)@@ -64,7 +60,7 @@ data Input = GetRange [Client] EntityName Time VersionRange- | Ping Time EntityName Version ServiceAddr+ | Ping Time EntityName Version ServiceAddr (Maybe Metadata) | GetService Time deriving (Show, Eq, Generic) instance Binary Input@@ -137,20 +133,33 @@ {- | The address on which a service can be contacted. -}-newtype ServiceAddr = ServiceAddr {unServiceAddr :: Text}- deriving (Show, Eq, Ord, Binary)+newtype ServiceAddr = ServiceAddr {+ unServiceAddr :: Text+ }+ deriving (Show, Eq, Ord, Binary, FromJSON) {- | Additional information about the service instance. -} data InstanceInfo = InstanceInfo { version :: Version,- lastPing :: Time+ lastPing :: Time,+ metadata :: Maybe Metadata } deriving (Show, Generic) instance Binary InstanceInfo instance ToJSON InstanceInfo +{- | Data about a service instance, supplied by the user. -}+newtype Metadata = Metadata {+ unMetadata :: Value+ }+ deriving (Show, Eq, ToJSON, FromJSON)+instance Binary Metadata where+ put = put . A.encode . unMetadata+ get = get >>= (either fail (return . Metadata) . A.eitherDecode)++ {- | The main request handler. -} handle :: Input -> State -> (Output, State) handle (GetRange clients name now range) (State Nothing) =@@ -192,18 +201,19 @@ ]) requests }-handle (Ping now name version addr) (State Nothing) =+handle (Ping now name version addr metadata) (State Nothing) = let state = State (Just Service { name = name, requests = Map.empty, instances = Map.singleton addr InstanceInfo { version,- lastPing = now+ lastPing = now,+ metadata } }) in (PingResponse, state)-handle (Ping now name version addr) (State (Just service)) =+handle (Ping now name version addr metadata) (State (Just service)) = let state = State (Just service { name = name,@@ -211,11 +221,13 @@ }) doPing Nothing = Just InstanceInfo { version,- lastPing = now+ lastPing = now,+ metadata } doPing (Just info) = Just info { version,- lastPing = now+ lastPing = now,+ metadata } in (PingResponse, state) handle (GetService _ ) (State Nothing) =@@ -296,10 +308,11 @@ -> Version {- ^ The version of the registering service. -} -> ServiceAddr {- ^ The service address on which the service can be contacted. -}+ -> Maybe Metadata -> io ()-ping runtime name version addy = do+ping runtime name version addy metadata = do now <- Time <$> liftIO getCurrentTime- let req = Ping now name version addy+ let req = Ping now name version addy metadata makeRequest runtime (toKey name) req >>= \case PingResponse -> return () r -> fail $ "Bad runtime response to req [" ++ show req ++ "]: " ++ show r
+ src/Network/Legion/Discovery/Main.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+module Network.Legion.Discovery.Main (+ main,+) where++import Canteven.HTTP (requestLogging, logExceptionsAndContinue, setServer)+import Canteven.Log.MonadLog (getCantevenOutput)+import Control.Monad (void)+import Control.Monad.Logger (runLoggingT)+import Data.Proxy (Proxy(Proxy))+import Network.Legion (forkLegionary)+import Network.Legion.Config (parseArgs)+import Network.Legion.Discovery.Api(DiscoveryApi)+import Network.Legion.Discovery.Server (discoveryServer)+import Network.Legion.Persistence (newMemoryPersistence)+import Servant (serve)+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++main :: IO ()+main = do+ (settings, startupMode, config) <- parseArgs+ logging <- getCantevenOutput (C.logging config)+ void $ Ekg.forkServer "localhost" (C.ekgPort config)+ persist <- newMemoryPersistence+ legion <- (`runLoggingT` logging) $+ forkLegionary persist settings startupMode+ Warp.run+ (C.servicePort config)+ (+ requestLogging logging+ . setServer "legion-discovery" P.version+ . logExceptionsAndContinue logging+ . serve (Proxy :: Proxy DiscoveryApi)+ . discoveryServer+ $ legion+ ) ++
src/Network/Legion/Discovery/Server.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {- | Contains the servant implentation of the 'DiscoveryApi'. -}@@ -17,10 +16,10 @@ 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), SvgGraph(SvgGraph))+import Network.Legion.Discovery.Api(DiscoveryApi, V1Api, ClientList,+ DiscoveryApi, PingRequest(PingRequest), Range(Range), serviceAddress,+ metadata, PingApi, InstanceList(InstanceList), GraphApi, Graph(Graph),+ SvgGraph(SvgGraph), ServicesApi, unClientList) import Network.Legion.Discovery.Graphviz (toDotGraph) import Network.Legion.Discovery.LegionApp (Input, Output, unEntityName, Client(Client), cName, cVersion, EntityName, Client, Output, getRange,@@ -33,43 +32,20 @@ {- | The implementation of the 'DiscoveryApi' api. -} discoveryServer :: Runtime Input Output -> Server DiscoveryApi-discoveryServer = v1+discoveryServer = v1Server {- | 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+v1Server :: Runtime Input Output -> Server V1Api+v1Server runtime = pingServer :<|> servicesServer :<|> graphServer where- graph :: Server GraphApi- graph = svgGraph :<|> dotGraph- where- dotGraph = Graph . toDotGraph <$> getAllServices runtime- svgGraph = do- g <- toDotGraph <$> getAllServices runtime- bytes <- liftIO $ graphvizWithHandle Dot g Svg hGetContents- return (SvgGraph (BSL.fromStrict bytes))-- ping :: [Client] -> Server PingApi- ping clients PingRequest {serviceAddress} = do- strictClients <- mapM toStrict clients+ pingServer :: Server PingApi+ pingServer Nothing _ = throwError missingUserAgent+ pingServer (Just clients) PingRequest {serviceAddress, metadata} = do+ strictClients <- mapM toStrict (unClientList clients) liftIO $ do sequence_ [- App.ping runtime name version serviceAddress+ App.ping runtime name version serviceAddress metadata | (name, version) <- strictClients ] return NoContent@@ -88,19 +64,49 @@ <> ". Please fix your User-Agent header." ) - allInstances :: [Client] -> EntityName -> Server InstancesApi- allInstances clients name = rangedInstances clients name (Range anyVersion)+ servicesServer :: Server ServicesApi+ servicesServer =+ allInstances+ :<|>+ rangedInstances+ where+ allInstances+ :: Maybe ClientList+ -> EntityName+ -> Handler InstanceList+ 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+ rangedInstances+ :: Maybe ClientList+ -> EntityName+ -> Range+ -> Handler InstanceList+ rangedInstances Nothing _ _ = throwError missingUserAgent+ rangedInstances (Just clients) name (Range range) = liftIO $+ InstanceList <$> getRange runtime (unClientList clients) name range + graphServer :: Server GraphApi+ graphServer = svgGraph :<|> dotGraph+ where+ dotGraph = Graph . toDotGraph <$> getAllServices runtime+ svgGraph = do+ g <- toDotGraph <$> getAllServices runtime+ bytes <- liftIO $ graphvizWithHandle Dot g Svg hGetContents+ return (SvgGraph (BSL.fromStrict bytes))++ {- | 400 BadRequest servant error helper. -} badRequest :: Text -> ServantErr badRequest msg = err400 { errBody = BSL.fromStrict (encodeUtf8 msg), errHeaders = [("content-type", "text/plain")] }+++{- | Errror for when the user-agent header is missing. -}+missingUserAgent :: ServantErr+missingUserAgent = badRequest "Missing User-Agent request header."