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.1 +version: 0.3.0.2 synopsis: A discovery service based on Legion. description: A simple service discovery service based on Legion, @@ -29,7 +29,6 @@ Network.Legion.Discovery.Graphviz Network.Legion.Discovery.LegionApp Network.Legion.Discovery.Server - Network.Legion.Discovery.UserAgent Paths_legion_discovery build-depends: Cabal >= 1.24.0.0 && < 1.25, @@ -39,7 +38,7 @@ 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-http >= 0.1.2.0 && < 0.2, canteven-log >= 2.0.0.1 && < 2.1, conduit >= 1.2.8 && < 1.3, containers >= 0.5.7.1 && < 0.6, @@ -47,8 +46,9 @@ ekg >= 0.4.0.11 && < 0.5, graphviz >= 2999.18.1.2 && < 2999.19, http-api-data >= 0.2.4 && < 0.3, - legion >= 0.8 && < 0.9, - legion-extra >= 0.1.0.6 && < 0.2, + http-grammar >= 0.1.0.0 && < 0.2, + legion >= 0.9 && < 0.10, + legion-extra >= 0.1.2.0 && < 0.2, monad-logger >= 0.3.20.1 && < 0.4, mtl >= 2.2.1 && < 2.3, servant-server >= 0.8.1 && < 0.9, diff --git a/src/Network/Legion/Discovery.hs b/src/Network/Legion/Discovery.hs --- a/src/Network/Legion/Discovery.hs +++ b/src/Network/Legion/Discovery.hs @@ -6,23 +6,17 @@ main, ) where -import Canteven.HTTP (requestLogging, logExceptionsAndContinue) +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 Data.Version (showVersion) -import Network.Legion (forkLegionary, newMemoryPersistence, Persistence) +import Network.Legion (forkLegionary) import Network.Legion.Config (parseArgs) 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 Network.Legion.Persistence (newMemoryPersistence) import Servant (serve) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import qualified Network.Legion.Discovery.Config as C import qualified Network.Wai.Handler.Warp as Warp import qualified Paths_legion_discovery as P @@ -33,35 +27,18 @@ (settings, startupMode, config) <- parseArgs logging <- getCantevenOutput (C.logging config) void $ Ekg.forkServer "localhost" (C.ekgPort config) - persist <- newMemoryPersistence :: IO (Persistence Input Output State) - legion <- (`runLoggingT` logging) - $ forkLegionary persist settings startupMode + persist <- newMemoryPersistence + legion <- (`runLoggingT` logging) $ + forkLegionary persist settings startupMode Warp.run (C.servicePort config) ( requestLogging logging - . setServer "legion-discovery" + . setServer "legion-discovery" P.version . logExceptionsAndContinue logging . serve (Proxy :: Proxy DiscoveryApi) . discoveryServer $ legion ) - - -{- | Set the server header. -} -setServer :: String -> Middleware -setServer serviceName = addServerHeader . stripServerHeader - where - {- | Strip the server header. -} - stripServerHeader :: Middleware - stripServerHeader = modifyResponse (stripHeader "Server") - - {- | Add our own server header. -} - addServerHeader :: Middleware - addServerHeader = addHeaders [("Server", serverValue)] - - {- | The value of the @Server:@ header. -} - serverValue = - TE.encodeUtf8 (T.pack (serviceName ++ "/" ++ showVersion P.version)) 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 @@ -18,31 +18,32 @@ Range(..), PingRequest(..), Graph(..), + SvgGraph(..), ) 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.Attoparsec.ByteString (parseOnly) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) 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 (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Version (showVersion) import Distribution.Text (simpleParse) import Distribution.Version (VersionRange) +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.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 @@ -51,7 +52,6 @@ import qualified Data.Text.Lazy.Encoding as TLE import qualified Servant as S - type DiscoveryApi = "v1" :> V1Api @@ -70,7 +70,9 @@ {- | The "graph" endpoint. -} -type GraphApi = Get '[SvgCT, DotCT] Graph +type GraphApi = + Get '[SvgCT] SvgGraph :<|> + Get '[DotCT] Graph {- | The "ping" endpoint. -} @@ -94,12 +96,13 @@ 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 SvgGraph = SvgGraph BSL.ByteString +instance MimeRender SvgCT SvgGraph where + mimeRender Proxy (SvgGraph bytes) = bytes + + newtype Range = Range VersionRange instance FromHttpApiData Range where parseUrlPiece r = case simpleParse (T.unpack r) of @@ -131,22 +134,29 @@ 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) - ] + 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) + ] + where + {- | + Parse a user-agent header according to the specification in + RFC-2616, or else return a reason why parsing failed. + -} + parseUserAgent :: ByteString -> Either Text [UserAgent] + parseUserAgent = first T.pack . parseOnly userAgent newtype InstanceList = InstanceList (Map ServiceAddr InstanceInfo) diff --git a/src/Network/Legion/Discovery/Config.hs b/src/Network/Legion/Discovery/Config.hs --- a/src/Network/Legion/Discovery/Config.hs +++ b/src/Network/Legion/Discovery/Config.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {- | This module contains the configuration data structures. 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 @@ -8,6 +8,9 @@ import Control.Monad.Except (throwError) import Control.Monad.IO.Class (liftIO) +import Data.ByteString (hGetContents) +import Data.GraphViz (graphvizWithHandle, GraphvizCommand(Dot), + GraphvizOutput(Svg)) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) @@ -17,7 +20,7 @@ import Network.Legion.Discovery.Api(DiscoveryApi, V1Api, ClientList(ClientList), DiscoveryApi, PingRequest(PingRequest), Range(Range), serviceAddress, PingApi, InstancesApi, - InstanceList(InstanceList), GraphApi, Graph(Graph)) + InstanceList(InstanceList), GraphApi, Graph(Graph), SvgGraph(SvgGraph)) import Network.Legion.Discovery.Graphviz (toDotGraph) import Network.Legion.Discovery.LegionApp (Input, Output, unEntityName, Client(Client), cName, cVersion, EntityName, Client, Output, getRange, @@ -53,7 +56,13 @@ graph where graph :: Server GraphApi - graph = Graph . toDotGraph <$> getAllServices runtime + 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 diff --git a/src/Network/Legion/Discovery/UserAgent.hs b/src/Network/Legion/Discovery/UserAgent.hs deleted file mode 100644 --- a/src/Network/Legion/Discovery/UserAgent.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - This module parses a user-agent header according to the specification in - RFC-2616. --} -module Network.Legion.Discovery.UserAgent ( - parseUserAgent, - UserAgent(..), - Product(..), -) where - -import Prelude hiding (product) - -import Control.Applicative (many, (<|>)) -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 - which is either a product or a comment. This data type represents one - such token. --} -data UserAgent - = UAProduct Product - | UAComment ByteString - - -{- | - A representation of an HTTP User-Agent product. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.8 --} -data Product = Product { - productName :: ByteString, - productVersion :: Maybe ByteString - } - - -{- | - Parse a user-agent header according to the specification in RFC-2616, or else - return a reason why parsing failed. --} -parseUserAgent :: ByteString -> Either Text [UserAgent] -parseUserAgent = first T.pack . parseOnly userAgent - - -{- | - Parser for the User-Agent header, defined: - https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.43 --} -userAgent :: Parser [UserAgent] -userAgent = many1 ( - (UAProduct <$> product) - <|> (UAComment <$> comment) - ) - - -{- | - product - http product token. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.8 --} -product :: Parser Product -product = - Product - <$> token - <*> option Nothing versionParser - where - versionParser = do - void $ string "/" - Just <$> token - - -{- | - comment - basic http grammar rule. - The result is the parsed comment content, rather than the raw source. - - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -comment :: Parser ByteString -comment = do - void $ word8 40 -- "(" - segments <- many ( - takeWhile1 ctext - <|> (BS.singleton <$> quotedPair) - <|> comment - ) - void $ word8 41 -- ")" - return (mconcat segments) - - -{- | - ctext - basic http grammar rule. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -ctext :: Word8 -> Bool -ctext x = text x && x /= 40 && x /= 41 -- "(", ")" - - -{- | - quotedPair - basic http grammar rule. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -quotedPair :: Parser Word8 -quotedPair = do - void $ word8 92 -- <\> - satisfy char - - -{- | - text - basic http grammar rule. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -text :: Word8 -> Bool -text = not . ctl - - -{- | - CHAR - basic http grammar rule. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -char :: Word8 -> Bool -char x = x >= 0 && x <= 127 - - -{- - CTL - basic http grammar rule. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -ctl :: Word8 -> Bool -ctl x = (x >= 0 && x <= 31) || x == 127 - - -{- | - token - basic http grammar rule. - - The grammar specifies that adjacent LWS should be consumed without affecting - the meaning of the token. This parser returns the token stripped of any - adjacent lws. - - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -token :: Parser ByteString -token = do - option () lws - t <- takeWhile1 (\x -> char x && not (separators x) && not (ctl x)) - option () lws - return t - - -{- | - separators - basic http grammar rule. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -separators :: Word8 -> Bool -separators = inClass "()<>@,;:\\\"/[]?={} \t" - - -{- | - LWS - basic http grammar rule. (L)inear (W)hite(S)pace. - - Consumes all linear whitespace. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -lws :: Parser () -lws = do - option () crlf - void $ takeWhile1 (\x -> x == 32 || x == 9) - - -{- | - crlf - basic http grammar rule. - - Consumes one crlf. - https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2 --} -crlf :: Parser () -crlf = void $ string "\r\n" - -