legion-discovery 0.3.0.1 → 0.3.0.2
raw patch · 6 files changed
+61/−251 lines, 6 filesdep +http-grammardep ~canteven-httpdep ~legiondep ~legion-extraPVP ok
version bump matches the API change (PVP)
Dependencies added: http-grammar
Dependency ranges changed: canteven-http, legion, legion-extra
API changes (from Hackage documentation)
Files
- legion-discovery.cabal +5/−5
- src/Network/Legion/Discovery.hs +7/−30
- src/Network/Legion/Discovery/Api.hs +38/−28
- src/Network/Legion/Discovery/Config.hs +0/−1
- src/Network/Legion/Discovery/Server.hs +11/−2
- src/Network/Legion/Discovery/UserAgent.hs +0/−185
legion-discovery.cabal view
@@ -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,
src/Network/Legion/Discovery.hs view
@@ -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))
src/Network/Legion/Discovery/Api.hs view
@@ -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)
src/Network/Legion/Discovery/Config.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {- | This module contains the configuration data structures.
src/Network/Legion/Discovery/Server.hs view
@@ -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
− src/Network/Legion/Discovery/UserAgent.hs
@@ -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"--