diff --git a/app/legion-discovery.hs b/app/legion-discovery.hs --- a/app/legion-discovery.hs +++ b/app/legion-discovery.hs @@ -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 diff --git a/legion-discovery.cabal b/legion-discovery.cabal --- a/legion-discovery.cabal +++ b/legion-discovery.cabal @@ -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 diff --git a/src/Network/Legion/Discovery.hs b/src/Network/Legion/Discovery.hs deleted file mode 100644 --- a/src/Network/Legion/Discovery.hs +++ /dev/null @@ -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 - ) - - diff --git a/src/Network/Legion/Discovery/Api.hs b/src/Network/Legion/Discovery/Api.hs --- a/src/Network/Legion/Discovery/Api.hs +++ b/src/Network/Legion/Discovery/Api.hs @@ -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 diff --git a/src/Network/Legion/Discovery/LegionApp.hs b/src/Network/Legion/Discovery/LegionApp.hs --- a/src/Network/Legion/Discovery/LegionApp.hs +++ b/src/Network/Legion/Discovery/LegionApp.hs @@ -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 diff --git a/src/Network/Legion/Discovery/Main.hs b/src/Network/Legion/Discovery/Main.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/Main.hs @@ -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 + ) + + diff --git a/src/Network/Legion/Discovery/Server.hs b/src/Network/Legion/Discovery/Server.hs --- a/src/Network/Legion/Discovery/Server.hs +++ b/src/Network/Legion/Discovery/Server.hs @@ -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."