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.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 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 @@ -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 diff --git a/src/Network/Legion/Discovery/App.hs b/src/Network/Legion/Discovery/App.hs --- a/src/Network/Legion/Discovery/App.hs +++ b/src/Network/Legion/Discovery/App.hs @@ -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 diff --git a/src/Network/Legion/Discovery/Graphviz.hs b/src/Network/Legion/Discovery/Graphviz.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/Graphviz.hs @@ -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 + + diff --git a/src/Network/Legion/Discovery/UserAgent.hs b/src/Network/Legion/Discovery/UserAgent.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/UserAgent.hs @@ -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" + +