legion-discovery 0.2.1.1 → 0.2.2.0
raw patch · 5 files changed
+614/−110 lines, 5 filesdep +attoparsecdep +graphvizdep +scotty-formatdep ~legion
Dependencies added: attoparsec, graphviz, scotty-format
Dependency ranges changed: legion
Files
- legion-discovery.cabal +29/−24
- src/Network/Legion/Discovery.hs +157/−37
- src/Network/Legion/Discovery/App.hs +80/−49
- src/Network/Legion/Discovery/Graphviz.hs +166/−0
- src/Network/Legion/Discovery/UserAgent.hs +182/−0
legion-discovery.cabal view
@@ -1,5 +1,5 @@ name: legion-discovery-version: 0.2.1.1+version: 0.2.2.0 synopsis: Initial project template from stack description: Please see README.md homepage: https://github.com/owensmurray/legion-discovery#readme@@ -21,33 +21,38 @@ other-modules: Network.Legion.Discovery.App Network.Legion.Discovery.Config+ Network.Legion.Discovery.Graphviz Network.Legion.Discovery.HttpError Network.Legion.Discovery.LIO+ Network.Legion.Discovery.UserAgent Paths_legion_discovery build-depends:- Cabal >= 1.22.5.0 && < 1.25,- SHA >= 1.6.4.1 && < 1.7,- aeson >= 0.11.2.1 && < 0.12,- base >= 4.8 && < 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,- http-types >= 0.9.1 && < 0.10,- legion >= 0.5 && < 0.6,- legion-extra >= 0.1.0.3 && < 0.2,- monad-logger >= 0.3.19 && < 0.4,- scotty >= 0.11.0 && < 0.12,- scotty-resource >= 0.1.1.0 && < 0.3,- text >= 1.2.2.1 && < 1.3,- time >= 1.5.0.1 && < 1.7,- transformers >= 0.4.2.0 && < 0.6,- wai >= 3.2.1.1 && < 3.3,- wai-extra >= 3.0.17 && < 3.1,- warp >= 3.2.8 && < 3.3+ Cabal >= 1.22.5.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.8 && < 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,+ graphviz >= 2999.18.1.2 && < 2999.19,+ http-types >= 0.9.1 && < 0.10,+ legion >= 0.7 && < 0.8,+ 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 && < 0.2,+ scotty-resource >= 0.1.1.0 && < 0.3,+ text >= 1.2.2.1 && < 1.3,+ time >= 1.5.0.1 && < 1.7,+ transformers >= 0.4.2.0 && < 0.6,+ wai >= 3.2.1.1 && < 3.3,+ wai-extra >= 3.0.17 && < 3.1,+ warp >= 3.2.8 && < 3.3 default-language: Haskell2010
src/Network/Legion/Discovery.hs view
@@ -12,29 +12,42 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (encode, object, (.=), FromJSON, parseJSON, Value(Object), (.:), eitherDecode)-import Data.Conduit ((=$=), ($$))+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)+import Data.Text (pack, unpack)+import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time (getCurrentTime) import Data.Version (showVersion) 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)+import Network.Legion (forkLegionary, Runtime, makeRequest,+ search, SearchTag(SearchTag), IndexRecord, irKey, PartitionKey,+ newMemoryPersistence, Persistence) import Network.Legion.Config (parseArgs)-import Network.Legion.Discovery.App (newApp, Input(GetRange, GetAll, Ping,- GetService), Output(InstanceList, PingResponse, ServiceResponse),+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)+ unServiceId, State, Client(Client), cName, cVersion) import Network.Legion.Discovery.Config (servicePort)+import Network.Legion.Discovery.Graphviz (toDotGraph) import Network.Legion.Discovery.HttpError (HttpError) import Network.Legion.Discovery.LIO (runLIO, LIO)+import Network.Legion.Discovery.UserAgent (UserAgent(UAProduct), Product(+ Product), productName, productVersion, parseUserAgent) import Network.Wai (Middleware, modifyResponse) import Network.Wai.Middleware.AddHeaders (addHeaders) import Network.Wai.Middleware.StripHeaders (stripHeader)+import Web.Scotty.Format.Trans (respondTo, format) import Web.Scotty.Resource.Trans (resource, get, post) import Web.Scotty.Trans (scottyT, middleware, ScottyT, param, setHeader, raw, status, text, ActionT, ScottyError, body, header)@@ -51,10 +64,9 @@ main = do (settings, startupMode, config) <- parseArgs logging <- getCantevenOutput (C.logging config)- app <- newApp-+ persist <- newMemoryPersistence :: IO (Persistence Input Output State) runLIO logging $ do- legion <- forkLegionary app settings startupMode+ legion <- forkLegionary persist settings startupMode scottyT (servicePort config) (runLIO logging) $ do middleware $ requestLogging logging@@ -85,47 +97,122 @@ resource "/v1/services" $ get $ do now <- Time <$> liftIO getCurrentTime- list <-- search runtime (SearchTag "" Nothing)- =$= CL.mapMaybeM (fillServiceInfo now)- $$ CL.consume- setHeader "content-type" serviceListCT- raw . encode $ object [- unServiceId (name service) .= encodeInstances (instances service)- | service <- list- ]+ 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 graph = format svgCT $ do+ setHeader "content-type" svgCT+ bytes <- liftIO $ graphvizWithHandle Dot graph Svg hGetContents+ raw (LBS.fromStrict bytes)++ 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"- now <- Time <$> liftIO getCurrentTime- respondInstances =<< getInstances runtime (toKey serviceId) (GetAll now)+ queryResource serviceId anyVersion resource "/v1/services/:serviceId/:versionRange" $- get $ do- serviceId <- ServiceId <$> param "serviceId"+ get $ simpleParse <$> param "versionRange" >>= \case Nothing -> do status badRequest400 text "Invalid version range." Just range -> do- now <- Time <$> liftIO getCurrentTime- respondInstances =<<- getInstances runtime (toKey serviceId) (GetRange now range)+ serviceId <- ServiceId <$> param "serviceId"+ queryResource serviceId range where+ {- |+ 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- :: Time+ fillServiceInfo :: (MonadIO m, ScottyError e)+ => Time -> IndexRecord- -> ActionT HttpError LIO (Maybe Service)- fillServiceInfo now ir =- makeRequest runtime (irKey ir) (GetService now) >>= \case- ServiceResponse service -> return service- PingResponse -> fail "Invalid runtime response."- InstanceList _ -> fail "Invalid runtime response."+ -> 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- :: Map ServiceAddr InstanceInfo- -> ActionT HttpError LIO ()+ respondInstances :: (Monad m, ScottyError e)+ => Map ServiceAddr InstanceInfo+ -> ActionT e m () respondInstances is = do setHeader "content-type" instanceListCT (raw . encode . encodeInstances) is@@ -152,6 +239,19 @@ 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."++ {- | Set the server header. -} setServer :: String -> Middleware setServer serviceName = addServerHeader . stripServerHeader@@ -185,6 +285,16 @@ 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 ())@@ -225,5 +335,15 @@ {- | 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
src/Network/Legion/Discovery/App.hs view
@@ -4,13 +4,14 @@ {-# LANGUAGE NamedFieldPuns #-} {- | This module contains the legion application definition. -} module Network.Legion.Discovery.App (- newApp, Input(..), Output(..), State, ServiceId(..), ServiceAddr(..), InstanceInfo(..),+ Client(..),+ RequestInfo(..), Time(..), Service(..), toKey,@@ -25,8 +26,8 @@ NominalDiffTime) import Distribution.Version (Version, VersionRange, withinRange) import GHC.Generics (Generic)-import Network.Legion (Legionary(Legionary), ApplyDelta, apply, PartitionKey,- newMemoryPersistence, handleRequest, persistence, index, Tag(Tag))+import Network.Legion (Event, apply, PartitionKey, Tag(Tag),+ Indexable, indexEntries) import qualified Data.Binary as B import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map@@ -35,10 +36,10 @@ data Input- = GetRange Time VersionRange- | GetAll Time+ = GetRange [Client] ServiceId Time VersionRange | Ping Time ServiceId Version ServiceAddr | GetService Time+ | GetRequests deriving (Show, Eq, Generic) instance Binary Input @@ -58,16 +59,39 @@ 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 {- | This type represents a discoverable service. -} data Service = Service { name :: ServiceId,- instances :: Map ServiceAddr InstanceInfo+ instances :: Map ServiceAddr InstanceInfo,+ requests :: Map Client RequestInfo } deriving (Show, Generic) instance Binary Service +{- | Information about a request. -}+data RequestInfo = RequestInfo {+ riTime :: Time,+ riRange :: VersionRange+ }+ deriving (Show, Eq, Generic)+instance Binary RequestInfo+++{- | Information about a query client. -}+data Client = Client {+ cName :: ServiceId,+ cVersion :: Maybe Version+ }+ deriving (Show, Eq, Generic, Ord)+instance Binary Client++ {- | The address on which a service can be contacted. -} newtype ServiceAddr = ServiceAddr {unServiceAddr :: Text} deriving (Show, Eq, Ord, Binary)@@ -82,49 +106,52 @@ instance Binary InstanceInfo -newApp :: IO (Legionary Input Output State)-newApp = do- persist <- newMemoryPersistence- return Legionary {- handleRequest = \i s -> let (o, _) = handle i s in o,- persistence = persist,- index- }- where- index (State Nothing) = Set.empty- index (State (Just Service {name})) =- (Set.singleton . Tag . TE.encodeUtf8 . unServiceId) name-- {- | The main request handler. -} handle :: Input -> State -> (Output, State)-handle (GetRange _ _) (State Nothing) =- (InstanceList Map.empty, State Nothing)-handle (GetRange 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 service))-handle (GetAll _) (State Nothing) =- (InstanceList Map.empty, State Nothing)-handle (GetAll now) (State (Just service)) =- let- output =- InstanceList . Map.fromAscList $ [- (addr, info)- | (addr, info) <- Map.toAscList (instances service)- , addUTCTime thirtySeconds (unTime (lastPing info)) >= unTime now- ]- in (output, State (Just service))+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@@ -148,7 +175,7 @@ in (PingResponse, state) handle (GetService _ ) (State Nothing) = (ServiceResponse Nothing, State Nothing)-handle (GetService now) (State (Just service)) =+handle (GetService now) state@(State (Just service)) = let i = Map.filter notExpired (instances service) output = ServiceResponse $ if Map.null i@@ -156,20 +183,24 @@ else Just service { instances = i }- in (output, State (Just service))+ 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)+ deriving (Show, Eq, Binary, Ord) -instance ApplyDelta Input State where- apply i s = let (_, s2) = handle i s in s2+instance Event Input Output State where+ apply = handle {- |@@ -177,7 +208,7 @@ instane. -} newtype Time = Time {unTime :: UTCTime}- deriving (Show, Eq)+ deriving (Show, Eq, Ord) instance Binary Time where put (Time (UTCTime (ModifiedJulianDay day) time)) = put (day, toRational time) get = do
+ src/Network/Legion/Discovery/Graphviz.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{- | This module contains graphviz utilities. -}+module Network.Legion.Discovery.Graphviz (+ toDotGraph,+) where++import Data.GraphViz.Attributes.Complete (Attribute(Label, Style),+ Label(StrLabel), StyleName(Rounded, Dashed), StyleItem(SItem))+import Data.GraphViz.Types.Canonical (DotGraph(DotGraph), DotStatements(+ DotStmts), strictGraph, directedGraph, graphID, graphStatements,+ attrStmts, subGraphs, nodeStmts, edgeStmts, DotSubGraph(DotSG),+ DotNode(DotNode), DotEdge(DotEdge), isCluster, subGraphID,+ subGraphStmts, GlobalAttributes(GraphAttrs), GraphID(Str))+import Data.Map (Map)+import Data.Monoid ((<>))+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 qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text.Lazy as TL+++toDotGraph :: [Service] -> DotGraph TL.Text+toDotGraph services = DotGraph {+ strictGraph = True,+ directedGraph = True,+ graphID = Nothing,+ graphStatements = DotStmts {+ attrStmts = [GraphAttrs [Style [SItem Rounded []]]],+ subGraphs,+ nodeStmts,+ edgeStmts+ }+ }+ where+ subGraphs :: [DotSubGraph TL.Text]+ subGraphs = [+ serviceCluster service+ | service <- services+ ]++ nodeStmts = [+ DotNode clientName [Style cStyle]+ | Service {requests} <- services+ , (client, _) <- Map.toList requests+ , (clientName, cStyle) <- clientNames client+ ]++ edgeStmts :: [DotEdge TL.Text]+ edgeStmts = [+ DotEdge clientName (instanceToNodeId name inst iaddy) [Style cStyle]+ | Service {name, instances, requests} <- services+ , (client, RequestInfo {riRange}) <- Map.toList requests+ , (clientName, cStyle) <- clientNames client+ , (iaddy, inst) <- Map.toList instances+ , withinRange (version inst) riRange+ ]++ {- | Organize the services by name and version. -}+ byNameAndVersion :: Map (ServiceId, Version) (Set ServiceAddr)+ byNameAndVersion = Map.fromList [+ ((name, v), addys)+ | Service {name, instances} <- services+ , (v, addys) <- Map.toList (byVersion instances)+ ]++ clientNames :: Client -> [(TL.Text, [StyleItem])]+ clientNames client@Client {cName, cVersion} = case cVersion of+ Nothing -> [clientToNodeId client Nothing]+ Just v -> [+ clientToNodeId client addy+ | let+ addys = case Map.lookup (cName, v) byNameAndVersion of+ Just as | not (Set.null as) -> Just <$> Set.toList as+ _ -> [Nothing]+ , addy <- addys+ ]++{- | Show a 'ServiceId' as 'TL.Text'. -}+showName :: ServiceId -> TL.Text+showName = TL.fromStrict . unServiceId+++{- | Show a version as 'TL.Text'. -}+showV :: Version -> TL.Text+showV = TL.pack . showVersion+++{- | Convert a 'Client' to a 'DotNode'. -}+clientToNodeId :: Client -> Maybe ServiceAddr -> (TL.Text, [StyleItem])+clientToNodeId Client {cName, cVersion} addy =+ (+ showName cName+ <> maybe "" (("/" <>) . showV) cVersion+ <> maybe "" ((":" <>) . showAddy) addy,+ case addy of+ Nothing -> [SItem Dashed []]+ _ -> []+ )+++{- | Convert a service instance to a 'DotNode'. -}+instanceToNodeId :: ServiceId -> InstanceInfo -> ServiceAddr -> TL.Text+instanceToNodeId name info addy =+ showName name <> "/" <> showV (version info) <> ":" <> showAddy addy+++{- | Convert a service into a cluster subgraph. -}+serviceCluster :: Service -> DotSubGraph TL.Text+serviceCluster Service {name, instances} = DotSG {+ isCluster = True,+ subGraphID = Just (Str (showName name)),+ subGraphStmts = DotStmts {+ attrStmts = [GraphAttrs [Label (StrLabel (showName name))]],+ subGraphs = [+ versionCluster name v addys+ | (v, addys) <- Map.toList (byVersion instances)+ ],+ nodeStmts = [],+ edgeStmts = []+ }+ }++{- | Create a version cluster subgraph. -}+versionCluster :: ServiceId -> Version -> Set ServiceAddr -> DotSubGraph TL.Text+versionCluster n v addys = DotSG {+ isCluster = True,+ subGraphID = Just (Str (showName n <> "/" <> showV v)),+ subGraphStmts = DotStmts {+ attrStmts = [+ GraphAttrs [Label (StrLabel (showName n <> "/" <> showV v))]+ ],+ subGraphs = [],+ nodeStmts = [+ DotNode (showName n <> "/" <> showV v <> ":" <> showAddy a) []+ | a <- Set.toList addys+ ],+ edgeStmts = []+ }+ }+++{- | Organize some instances by version. -}+byVersion+ :: Map ServiceAddr InstanceInfo+ -> Map Version (Set ServiceAddr)+byVersion instances =+ foldr push Map.empty (Map.toList instances)+ where+ push (addy, InstanceInfo {version}) acc =+ case version `Map.lookup` acc of+ Nothing -> Map.insert version (Set.singleton addy) acc+ Just addys -> Map.insert version (Set.insert addy addys) acc+++{- | Show a service address as a 'TL.Text'. -}+showAddy :: ServiceAddr -> TL.Text+showAddy = TL.fromStrict . unServiceAddr++
+ src/Network/Legion/Discovery/UserAgent.hs view
@@ -0,0 +1,182 @@+{-# 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.ByteString (ByteString)+import Data.Word (Word8)+import qualified Data.ByteString as BS++{- |+ 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 String [UserAgent]+parseUserAgent = 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"++