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.0 +version: 0.3.0.1 synopsis: A discovery service based on Legion. description: A simple service discovery service based on Legion, @@ -16,84 +16,69 @@ copyright: 2016 Rick Owens category: value build-type: Simple -extra-source-files: - README.md +extra-source-files: README.md cabal-version: >=1.10 library - hs-source-dirs: - src + hs-source-dirs: src exposed-modules: Network.Legion.Discovery other-modules: - Network.Legion.Discovery.App + Network.Legion.Discovery.Api Network.Legion.Discovery.Config Network.Legion.Discovery.Graphviz - Network.Legion.Discovery.HttpError - Network.Legion.Discovery.LIO + Network.Legion.Discovery.LegionApp + Network.Legion.Discovery.Server Network.Legion.Discovery.UserAgent Paths_legion_discovery build-depends: - Cabal >= 1.22.5.0 && < 1.25, + Cabal >= 1.24.0.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.9 && < 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, + 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-log >= 2.0.0.1 && < 2.1, + conduit >= 1.2.8 && < 1.3, + containers >= 0.5.7.1 && < 0.6, + data-default-class >= 0.1.2.0 && < 0.2, ekg >= 0.4.0.11 && < 0.5, graphviz >= 2999.18.1.2 && < 2999.19, - http-types >= 0.9.1 && < 0.10, + http-api-data >= 0.2.4 && < 0.3, legion >= 0.8 && < 0.9, - 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.1 && < 0.2, - scotty-resource >= 0.1.1.0 && < 0.3, + legion-extra >= 0.1.0.6 && < 0.2, + monad-logger >= 0.3.20.1 && < 0.4, + mtl >= 2.2.1 && < 2.3, + servant-server >= 0.8.1 && < 0.9, text >= 1.2.2.1 && < 1.3, - time >= 1.5.0.1 && < 1.7, - transformers >= 0.4.2.0 && < 0.6, + time >= 1.6.0.1 && < 1.7, wai >= 3.2.1.1 && < 3.3, - wai-extra >= 3.0.17 && < 3.1, - warp >= 3.2.8 && < 3.3 + wai-extra >= 3.0.19 && < 3.1, + warp >= 3.2.9 && < 3.3 default-language: Haskell2010 executable legion-discovery - hs-source-dirs: - app - main-is: - legion-discovery.hs - ghc-options: - -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: app + main-is: legion-discovery.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base, legion-discovery - default-language: - Haskell2010 + default-language: Haskell2010 test-suite legion-discovery-test - type: - exitcode-stdio-1.0 - hs-source-dirs: - test - main-is: - Spec.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs build-depends: base, legion-discovery - ghc-options: - -threaded -rtsopts -with-rtsopts=-N - default-language: - Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 source-repository head - type: - git - location: - https://github.com/owensmurray/legion-discovery + type: git + location: https://github.com/owensmurray/legion-discovery 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 @@ -1,69 +1,30 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} module Network.Legion.Discovery ( - main + main, ) where -import Canteven.HTTP (requestLogging, logExceptionsAndContinue, - DecodeResult(Unsupported, BadEntity, Ok), FromEntity, decodeEntity) +import Canteven.HTTP (requestLogging, logExceptionsAndContinue) import Canteven.Log.MonadLog (getCantevenOutput) -import Control.Exception (throwIO) -import Control.Monad (void, (<=<)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger (MonadLoggerIO, logInfo) -import Control.Monad.Trans.Class (lift) -import Data.Aeson (encode, object, (.=), FromJSON, parseJSON, - Value(Object), (.:), eitherDecode) -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, unpack) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time (getCurrentTime) -import Data.Version (showVersion, Version) -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, - newMemoryPersistence, Persistence) +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.Config (parseArgs) -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, State, Client(Client), cName, cVersion) -import Network.Legion.Discovery.Config (servicePort, ekgPort) -import Network.Legion.Discovery.Graphviz (toDotGraph) -import Network.Legion.Discovery.HttpError (HttpError(Critical, Transient)) -import Network.Legion.Discovery.LIO (runLIO, LIO) -import Network.Legion.Discovery.UserAgent (UserAgent(UAProduct), Product( - Product), productName, productVersion, parseUserAgent) +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 Web.Scotty.Format.Trans (respondTo, format, ResponseFormat) -import Web.Scotty.Resource.Trans (resource, get, post) -import Web.Scotty.Trans (scottyT, middleware, ScottyT, param, setHeader, - raw, status, text, ActionT, ScottyError, body, header, defaultHandler, - raise) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Conduit.List as CL -import qualified Data.Map as Map +import Servant (serve) +import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE 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 @@ -71,322 +32,36 @@ main = do (settings, startupMode, config) <- parseArgs logging <- getCantevenOutput (C.logging config) - void $ Ekg.forkServer "localhost" (ekgPort config) + void $ Ekg.forkServer "localhost" (C.ekgPort config) persist <- newMemoryPersistence :: IO (Persistence Input Output State) - runLIO logging $ do - legion <- forkLegionary persist settings startupMode - scottyT (servicePort config) (runLIO logging) $ do - middleware - $ requestLogging logging - . setServer "legion-discovery" - . logExceptionsAndContinue logging - defaultHandler handleEx - webService legion - - -{- | Handle 'HttpError' errors. -} -handleEx :: (MonadLoggerIO m, ScottyError e) => HttpError -> ActionT e m () -handleEx e@(Critical _) = - liftIO (throwIO e) -handleEx (Transient statusCode msg) = do - lift . $(logInfo) - $ "Transient error: " <> msg - status statusCode - text (TL.fromStrict msg) - - -{- | The web service endpoint definitions. -} -webService :: Runtime Input Output -> ScottyT HttpError LIO () -webService runtime = do - resource "/v1/ping" $ - post . withStrictClients $ \clients -> do - now <- Time <$> liftIO getCurrentTime - withEntity (\ PingRequest {serviceAddress} -> do - sequence_ [ - makeRequest runtime (toKey serviceId) req >>= \case - PingResponse -> return () - InstanceList _ -> fail "Invalid runtime response." - ServiceResponse _ -> fail "Invalid runtime response." - | (serviceId, ver) <- clients - , let req = Ping now serviceId ver serviceAddress - ] - status noContent204 - ) - resource "/v1/services" $ - get $ do - now <- Time <$> liftIO getCurrentTime - 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 :: (MonadIO m, ScottyError e) - => DotGraph TL.Text - -> ResponseFormat e m () - renderSvg graph = format svgCT $ do - setHeader "content-type" svgCT - bytes <- liftIO $ graphvizWithHandle Dot graph Svg hGetContents - raw (LBS.fromStrict bytes) - - renderGraphviz :: (MonadIO m, ScottyError e) - => DotGraph TL.Text - -> ResponseFormat e m () - 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" - queryResource serviceId anyVersion - resource "/v1/services/:serviceId/:versionRange" $ - get $ - simpleParse <$> param "versionRange" >>= \case - Nothing -> do - status badRequest400 - text "Invalid version range." - Just range -> do - serviceId <- ServiceId <$> param "serviceId" - queryResource serviceId range - where - {- | Like 'withClients', but do not allow missing client versions. -} - withStrictClients :: (Monad m) - => ([(ServiceId, Version)] -> ActionT HttpError m ()) - -> ActionT HttpError m () - withStrictClients f = - withClients $ f <=< mapM toStrict - where - toStrict :: (Monad m) - => Client - -> ActionT HttpError m (ServiceId, Version) - toStrict Client {cName, cVersion = Just version} = - return (cName, version) - toStrict Client {cName, cVersion = Nothing} = - raise (Transient badRequest400 ( - "Missing version for client product: " - <> unServiceId cName - <> ". Please fix your User-Agent header." - )) - - {- | - 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 :: (MonadIO m, ScottyError e) - => Time - -> IndexRecord - -> 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 :: (Monad m, ScottyError e) - => Map ServiceAddr InstanceInfo - -> ActionT e m () - respondInstances is = do - setHeader "content-type" instanceListCT - (raw . encode . encodeInstances) is - - {- | Encode instances into a JSON object -} - encodeInstances :: Map ServiceAddr InstanceInfo -> Value - encodeInstances instances = object [ - unServiceAddr addr .= object [ - "version" .= showVersion (version info) - ] - | (addr, info) <- Map.toList instances - ] - -{- | Send a legion request that returns an InstanceList response. -} -getInstances :: (MonadIO io) - => Runtime Input Output - -> PartitionKey - -> Input - -> io (Map ServiceAddr InstanceInfo) -getInstances runtime key input = - makeRequest runtime key input >>= \case - InstanceList instances -> return instances - PingResponse -> fail "Invalid runtime response." - 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." + legion <- (`runLoggingT` logging) + $ forkLegionary persist settings startupMode + Warp.run + (C.servicePort config) + ( + requestLogging logging + . setServer "legion-discovery" + . logExceptionsAndContinue logging + . serve (Proxy :: Proxy DiscoveryApi) + . discoveryServer + $ legion + ) {- | Set the server header. -} setServer :: String -> Middleware setServer serviceName = addServerHeader . stripServerHeader where - {- | - Strip the server header - -} + {- | Strip the server header. -} stripServerHeader :: Middleware stripServerHeader = modifyResponse (stripHeader "Server") - {- | - Add our own server header. - -} + {- | Add our own server header. -} addServerHeader :: Middleware addServerHeader = addHeaders [("Server", serverValue)] - {- | - The value of the @Server:@ header. - -} + {- | The value of the @Server:@ header. -} serverValue = - TE.encodeUtf8 (pack (serviceName ++ "/" ++ showVersion P.version)) - - -{- | The service instance list content type. -} -instanceListCT :: (IsString a) => a -instanceListCT = "application/vnd.legion-discovery.instance-list+json" - - -{- | The known service list content type. -} -serviceListCT :: (IsString a) => a -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 ()) - -> ActionT e m () -withEntity f = - decodeEntity <$> headerLBS "content-type" <*> body >>= \case - Unsupported -> status unsupportedMediaType415 - BadEntity why -> do - status badRequest400 - text (TL.pack why) - Ok b -> f b - - -{- | Get a header as a 'Date.ByteString.Lazy.ByteString'. -} -headerLBS :: (ScottyError e, Monad m) - => TL.Text - -> ActionT e m (Maybe LBS.ByteString) -headerLBS headerName = fmap TLE.encodeUtf8 <$> header headerName - - -{- | Decode a ping request entity. -} -newtype PingRequest = PingRequest { - serviceAddress :: ServiceAddr - } -instance FromJSON PingRequest where - parseJSON (Object o) = - PingRequest . ServiceAddr <$> o .: "serviceAddress" - parseJSON v = fail - $ "Can't parse PingRequest from: " ++ show v -instance FromEntity PingRequest where - decodeEntity (Just PingRequestCT) bytes = - case eitherDecode bytes of - Left err -> BadEntity err - Right req -> Ok req - decodeEntity _ _ = Unsupported - - -{- | 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 + TE.encodeUtf8 (T.pack (serviceName ++ "/" ++ showVersion P.version)) diff --git a/src/Network/Legion/Discovery/Api.hs b/src/Network/Legion/Discovery/Api.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/Api.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{- | The descovery api specification. -} +module Network.Legion.Discovery.Api ( + -- * Api types + DiscoveryApi, + V1Api, + PingApi, + InstancesApi, + GraphApi, + + -- * "Real" data types. + ClientList(..), + InstanceList(..), + Range(..), + PingRequest(..), + Graph(..), +) 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.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.Encoding (encodeUtf8, decodeUtf8) +import Data.Version (showVersion) +import Distribution.Text (simpleParse) +import Distribution.Version (VersionRange) +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 +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import qualified Servant as S + + +type DiscoveryApi = + "v1" :> V1Api + + +type V1Api = + Header "User-Agent" ClientList :> ( + "ping" :> PingApi :<|> + "services" :> ( + Capture "serviceName" EntityName :> ( + InstancesApi :<|> + Capture "versionRange" Range :> InstancesApi + ) + ) + ) :<|> + "graph" :> GraphApi + + +{- | The "graph" endpoint. -} +type GraphApi = Get '[SvgCT, DotCT] Graph + + +{- | The "ping" endpoint. -} +type PingApi = ReqBody '[PingRequestCT] PingRequest :> PostNoContent + + +{- | Shorthand for a post returning no contents. -} +type PostNoContent = S.PostNoContent '[StupidArbitraryPlaceholder] NoContent + + +{- | see: https://github.com/haskell-servant/servant/issues/498 -} +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 + 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 Range = Range VersionRange +instance FromHttpApiData Range where + parseUrlPiece r = case simpleParse (T.unpack r) of + Nothing -> Left . T.pack $ ("Invalid version range: " ++ show r) + Just vr -> Right (Range vr) + + +data InstanceListCT +instance Accept InstanceListCT where + contentType Proxy = "application/vnd.legion-discovery.instance-list+json" + + +data PingRequestCT +instance Accept PingRequestCT where + contentType Proxy = "application/vnd.legion-discovery.ping-request+json" + + +data DotCT +instance Accept DotCT where + contentType Proxy = "text/vnd.graphviz" + + +data SvgCT +instance Accept SvgCT where + contentType Proxy = "image/svg+xml" + + +newtype ClientList = ClientList [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) + ] + + +newtype InstanceList = InstanceList (Map ServiceAddr InstanceInfo) +instance MimeRender InstanceListCT InstanceList where + mimeRender Proxy (InstanceList instances) = + encode $ object [ + unServiceAddr addr .= object [ + "version" .= showVersion (version info) + ] + | (addr, info) <- Map.toList instances + ] + + +{- | Decode a ping request entity. -} +newtype PingRequest = PingRequest { + serviceAddress :: ServiceAddr + } +instance FromJSON PingRequest where + parseJSON (Object o) = + PingRequest . ServiceAddr <$> o .: "serviceAddress" + parseJSON v = fail + $ "Can't parse PingRequest from: " ++ show v +instance MimeUnrender PingRequestCT PingRequest where + mimeUnrender Proxy = eitherDecode + + diff --git a/src/Network/Legion/Discovery/App.hs b/src/Network/Legion/Discovery/App.hs deleted file mode 100644 --- a/src/Network/Legion/Discovery/App.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# 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 --} -module Network.Legion.Discovery.App ( - Input(..), - Output(..), - State, - ServiceId(..), - ServiceAddr(..), - InstanceInfo(..), - Client(..), - RequestInfo(..), - Time(..), - Service(..), - toKey, -) where - -import Data.Aeson (ToJSON, toJSON, object, (.=)) -import Data.Binary (Binary, get, put) -import Data.Default.Class (Default, def) -import Data.Digest.Pure.SHA (sha256) -import Data.Map (Map) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) -import Data.Time (UTCTime(UTCTime), Day(ModifiedJulianDay), addUTCTime, - NominalDiffTime) -import Data.Version (showVersion) -import Distribution.Text (display) -import Distribution.Version (Version, VersionRange, withinRange) -import GHC.Generics (Generic) -import Network.Legion (Event, apply, PartitionKey, Tag(Tag), - Indexable, indexEntries) -import qualified Data.Aeson as A -import qualified Data.Binary as B -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - - -data Input - = GetRange [Client] ServiceId Time VersionRange - | Ping Time ServiceId Version ServiceAddr - | GetService Time - | GetRequests - deriving (Show, Eq, Generic) -instance Binary Input - - -data Output - = InstanceList (Map ServiceAddr InstanceInfo) - | ServiceResponse (Maybe Service) - | PingResponse - deriving (Show, Generic) -instance Binary Output - - -newtype State = State { - _unState :: Maybe Service - } - deriving (Binary) -instance Show State where - show = T.unpack . decodeUtf8 . LBS.toStrict . A.encode -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 -instance ToJSON State where - toJSON (State s) = object ["state" .= s] - - -{- | This type represents a discoverable service. -} -data Service = Service { - name :: ServiceId, - instances :: Map ServiceAddr InstanceInfo, - requests :: Map Client RequestInfo - } - deriving (Show, Generic) -instance Binary Service -instance ToJSON Service where - toJSON (Service name_ instances_ requests_) = object [ - "name" .= name_, - "instances" .= Map.mapKeys (T.unpack . unServiceAddr) instances_, - "requests" .= Map.mapKeys show requests_ - ] - - -{- | Information about a request. -} -data RequestInfo = RequestInfo { - riTime :: Time, - riRange :: VersionRange - } - deriving (Show, Eq, Generic) -instance Binary RequestInfo -instance ToJSON RequestInfo where - toJSON (RequestInfo time range) = object [ - "time" .= time, - "range" .= display range - ] - - -{- | Information about a query client. -} -data Client = Client { - cName :: ServiceId, - cVersion :: Maybe Version - } - deriving (Eq, Generic, Ord) -instance Binary Client -instance Show Client where - show (Client name version) = - T.unpack (unServiceId name) <> maybe "" (("/" <>) . showVersion) version - - -{- | The address on which a service can be contacted. -} -newtype ServiceAddr = ServiceAddr {unServiceAddr :: Text} - deriving (Show, Eq, Ord, Binary) - - -{- | Additional information about the service instance. -} -data InstanceInfo = InstanceInfo { - version :: Version, - lastPing :: Time - } - deriving (Show, Generic) -instance Binary InstanceInfo -instance ToJSON InstanceInfo - - -{- | The main request handler. -} -handle :: Input -> State -> (Output, State) -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 - } - }) - in (PingResponse, state) -handle (Ping now name version addr) (State (Just service)) = - let - state = State (Just service { - name = name, - instances = Map.alter ping addr (instances service) - }) - ping Nothing = Just InstanceInfo { - version, - lastPing = now - } - ping (Just info) = Just info { - version, - lastPing = now - } - in (PingResponse, state) -handle (GetService _ ) (State Nothing) = - (ServiceResponse Nothing, State Nothing) -handle (GetService now) state@(State (Just service)) = - let - i = Map.filter notExpired (instances service) - output = ServiceResponse $ if Map.null i - then Nothing - else Just service { - instances = i - } - 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, Ord, ToJSON) - - -instance Event Input Output State where - apply = handle - - -{- | - Wrapper for UTCTime. Useful beacuse UTCTime doesn't have a `Binary` - instane. --} -newtype Time = Time {unTime :: UTCTime} - deriving (Show, Eq, Ord, ToJSON) -instance Binary Time where - put (Time (UTCTime (ModifiedJulianDay day) time)) = put (day, toRational time) - get = do - (day, time) <- get - return (Time (UTCTime (ModifiedJulianDay day) (fromRational time))) - - -{- | Convert a ServiceId into a partition key. -} -toKey :: ServiceId -> PartitionKey -toKey = - B.decode - . B.encode - . sha256 - . LBS.fromStrict - . TE.encodeUtf8 - . unServiceId - - -thirtySeconds :: NominalDiffTime -thirtySeconds = 30 - - diff --git a/src/Network/Legion/Discovery/Graphviz.hs b/src/Network/Legion/Discovery/Graphviz.hs --- a/src/Network/Legion/Discovery/Graphviz.hs +++ b/src/Network/Legion/Discovery/Graphviz.hs @@ -17,10 +17,10 @@ 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 Network.Legion.Discovery.LegionApp (Service(Service), name, + instances, InstanceInfo(InstanceInfo), version, unEntityName, + Client(Client), requests, cName, cVersion, EntityName, + RequestInfo(RequestInfo), riRange, ServiceAddr, unServiceAddr) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text.Lazy as TL @@ -63,7 +63,7 @@ ] {- | Organize the services by name and version. -} - byNameAndVersion :: Map (ServiceId, Version) (Set ServiceAddr) + byNameAndVersion :: Map (EntityName, Version) (Set ServiceAddr) byNameAndVersion = Map.fromList [ ((name, v), addys) | Service {name, instances} <- services @@ -82,9 +82,9 @@ , addy <- addys ] -{- | Show a 'ServiceId' as 'TL.Text'. -} -showName :: ServiceId -> TL.Text -showName = TL.fromStrict . unServiceId +{- | Show a 'EntityName' as 'TL.Text'. -} +showName :: EntityName -> TL.Text +showName = TL.fromStrict . unEntityName {- | Show a version as 'TL.Text'. -} @@ -106,7 +106,7 @@ {- | Convert a service instance to a 'DotNode'. -} -instanceToNodeId :: ServiceId -> InstanceInfo -> ServiceAddr -> TL.Text +instanceToNodeId :: EntityName -> InstanceInfo -> ServiceAddr -> TL.Text instanceToNodeId name info addy = showName name <> "/" <> showV (version info) <> ":" <> showAddy addy @@ -128,7 +128,11 @@ } {- | Create a version cluster subgraph. -} -versionCluster :: ServiceId -> Version -> Set ServiceAddr -> DotSubGraph TL.Text +versionCluster + :: EntityName + -> Version + -> Set ServiceAddr + -> DotSubGraph TL.Text versionCluster n v addys = DotSG { isCluster = True, subGraphID = Just (Str (showName n <> "/" <> showV v)), diff --git a/src/Network/Legion/Discovery/HttpError.hs b/src/Network/Legion/Discovery/HttpError.hs deleted file mode 100644 --- a/src/Network/Legion/Discovery/HttpError.hs +++ /dev/null @@ -1,26 +0,0 @@ -{- | - This module contains a `ScottyError` error type that short-cuts to http - response types. --} -module Network.Legion.Discovery.HttpError ( - HttpError(..), -) where - -import Control.Exception (Exception) -import Data.Text (Text, pack) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types (Status) -import Web.Scotty.Trans (ScottyError, stringError, showError) - -data HttpError - = Transient Status Text - | Critical Text - deriving (Show) - -instance Exception HttpError - -instance ScottyError HttpError where - stringError = Critical . pack - showError (Transient _ msg) = fromStrict msg - showError (Critical msg) = fromStrict msg - diff --git a/src/Network/Legion/Discovery/LIO.hs b/src/Network/Legion/Discovery/LIO.hs deleted file mode 100644 --- a/src/Network/Legion/Discovery/LIO.hs +++ /dev/null @@ -1,22 +0,0 @@ -{- | - Logging IO Monad. --} - -module Network.Legion.Discovery.LIO ( - LIO, - runLIO, -) where - -import Canteven.Log.MonadLog (LoggerTImpl) -import Control.Monad.Logger (LoggingT, runLoggingT) - - -{- | The logging IO monad. -} -type LIO = LoggingT IO - - -{- | run an LIO monad in IO. -} -runLIO :: LoggerTImpl -> LIO a -> IO a -runLIO logging = (`runLoggingT` logging) - - diff --git a/src/Network/Legion/Discovery/LegionApp.hs b/src/Network/Legion/Discovery/LegionApp.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/LegionApp.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# 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 +-} +module Network.Legion.Discovery.LegionApp ( + -- * Types that make up the legion application definition. + Input, + Output, + State, + EntityName(..), + ServiceAddr(..), + InstanceInfo(..), + Client(..), + RequestInfo(..), + Time(..), + Service(..), + + -- * A more user-friendly interface to our legion application. + getRange, + ping, + getService, + getAllServices, + + -- * Utilities + toKey, +) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (ToJSON, toJSON, object, (.=)) +import Data.Binary (Binary, get, put) +import Data.Conduit ((=$=), runConduit) +import Data.Default.Class (Default, def) +import Data.Digest.Pure.SHA (sha256) +import Data.Map (Map) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Time (UTCTime(UTCTime), Day(ModifiedJulianDay), addUTCTime, + NominalDiffTime, getCurrentTime) +import Data.Version (showVersion) +import Distribution.Text (display) +import Distribution.Version (Version, VersionRange, withinRange) +import GHC.Generics (Generic) +import Network.Legion (Runtime, makeRequest, search, SearchTag(SearchTag), + irKey, PartitionKey, Event, apply, Tag(Tag), Indexable, indexEntries) +import Web.HttpApiData (FromHttpApiData, parseUrlPiece) +import qualified Data.Aeson as A +import qualified Data.Binary as B +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Conduit.List as CL +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + + +data Input + = GetRange [Client] EntityName Time VersionRange + | Ping Time EntityName Version ServiceAddr + | GetService Time + deriving (Show, Eq, Generic) +instance Binary Input + + +data Output + = InstanceList (Map ServiceAddr InstanceInfo) + | ServiceResponse (Maybe Service) + | PingResponse + deriving (Show, Generic) +instance Binary Output + + +newtype State = State { + _unState :: Maybe Service + } + deriving (Binary) +instance Show State where + show = T.unpack . decodeUtf8 . LBS.toStrict . A.encode +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 . unEntityName) name +instance ToJSON State where + toJSON (State s) = object ["state" .= s] + + +{- | This type represents a discoverable service. -} +data Service = Service { + name :: EntityName, + instances :: Map ServiceAddr InstanceInfo, + requests :: Map Client RequestInfo + } + deriving (Show, Generic) +instance Binary Service +instance ToJSON Service where + toJSON (Service name_ instances_ requests_) = object [ + "name" .= name_, + "instances" .= Map.mapKeys (T.unpack . unServiceAddr) instances_, + "requests" .= Map.mapKeys show requests_ + ] + + +{- | Information about a request. -} +data RequestInfo = RequestInfo { + riTime :: Time, + riRange :: VersionRange + } + deriving (Show, Eq, Generic) +instance Binary RequestInfo +instance ToJSON RequestInfo where + toJSON (RequestInfo time range) = object [ + "time" .= time, + "range" .= display range + ] + + +{- | Information about a query client. -} +data Client = Client { + cName :: EntityName, + cVersion :: Maybe Version + } + deriving (Eq, Generic, Ord) +instance Binary Client +instance Show Client where + show (Client name version) = + T.unpack (unEntityName name) <> maybe "" (("/" <>) . showVersion) version + + +{- | The address on which a service can be contacted. -} +newtype ServiceAddr = ServiceAddr {unServiceAddr :: Text} + deriving (Show, Eq, Ord, Binary) + + +{- | Additional information about the service instance. -} +data InstanceInfo = InstanceInfo { + version :: Version, + lastPing :: Time + } + deriving (Show, Generic) +instance Binary InstanceInfo +instance ToJSON InstanceInfo + + +{- | The main request handler. -} +handle :: Input -> State -> (Output, State) +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 + } + }) + in (PingResponse, state) +handle (Ping now name version addr) (State (Just service)) = + let + state = State (Just service { + name = name, + instances = Map.alter doPing addr (instances service) + }) + doPing Nothing = Just InstanceInfo { + version, + lastPing = now + } + doPing (Just info) = Just info { + version, + lastPing = now + } + in (PingResponse, state) +handle (GetService _ ) (State Nothing) = + (ServiceResponse Nothing, State Nothing) +handle (GetService now) state@(State (Just service)) = + let + i = Map.filter notExpired (instances service) + output = ServiceResponse $ if Map.null i + then Nothing + else Just service { + instances = i + } + in (output, state) + where + notExpired = (unTime now <=) . addUTCTime thirtySeconds . unTime . lastPing + + +{- | The name of an entity (client, or service, or both). -} +newtype EntityName = EntityName { + unEntityName :: Text + } + deriving (Show, Eq, Binary, Ord, ToJSON) +instance FromHttpApiData EntityName where + parseUrlPiece = Right . EntityName + + +instance Event Input Output State where + apply = handle + + +{- | + Wrapper for UTCTime. Useful beacuse UTCTime doesn't have a `Binary` + instane. +-} +newtype Time = Time {unTime :: UTCTime} + deriving (Show, Eq, Ord, ToJSON) +instance Binary Time where + put (Time (UTCTime (ModifiedJulianDay day) time)) = put (day, toRational time) + get = do + (day, time) <- get + return (Time (UTCTime (ModifiedJulianDay day) (fromRational time))) + + +{- | Convert a EntityName into a partition key. -} +toKey :: EntityName -> PartitionKey +toKey = + B.decode + . B.encode + . sha256 + . LBS.fromStrict + . TE.encodeUtf8 + . unEntityName + + +thirtySeconds :: NominalDiffTime +thirtySeconds = 30 + + +{- | Get the instances of a service that match a version range. -} +getRange :: (MonadIO io) + => Runtime Input Output + -> [Client] {- ^ The clients making the requests. -} + -> EntityName {- ^ The name of the target service. -} + -> VersionRange {- ^ The allowable instance versions. -} + -> io (Map ServiceAddr InstanceInfo) +getRange runtime clients name range = do + now <- Time <$> liftIO getCurrentTime + let req = GetRange clients name now range + makeRequest runtime (toKey name) req >>= \case + InstanceList instances -> return instances + r -> fail $ "Bad runtime response to req [" ++ show req ++ "]: " ++ show r + + +{- | Register a service instance. -} +ping :: (MonadIO io) + => Runtime Input Output + -> EntityName {- ^ The name of the registering service. -} + -> Version {- ^ The version of the registering service. -} + -> ServiceAddr + {- ^ The service address on which the service can be contacted. -} + -> io () +ping runtime name version addy = do + now <- Time <$> liftIO getCurrentTime + let req = Ping now name version addy + makeRequest runtime (toKey name) req >>= \case + PingResponse -> return () + r -> fail $ "Bad runtime response to req [" ++ show req ++ "]: " ++ show r + + +{- | Returns all current information about a service. -} +getService :: (MonadIO io) + => Runtime Input Output + -> EntityName {- ^ The name of the service to retrieve. -} + -> io (Maybe Service) +getService runtime name = getServiceByKey runtime (toKey name) + + +{- | Like `getService`, but using the precomputed partition key. -} +getServiceByKey :: (MonadIO io) + => Runtime Input Output + -> PartitionKey + -> io (Maybe Service) +getServiceByKey runtime key = do + now <- Time <$> liftIO getCurrentTime + let req = GetService now + makeRequest runtime key req >>= \case + ServiceResponse s -> return s + r -> fail $ "Bad runtime response to req [" ++ show req ++ "]: " ++ show r + + +{- | Returns all services. -} +getAllServices :: (MonadIO io) + => Runtime Input Output + -> io [Service] +getAllServices runtime = + runConduit ( + search runtime (SearchTag "" Nothing) + =$= CL.mapMaybeM (getServiceByKey runtime . irKey) + =$= CL.consume + ) + + diff --git a/src/Network/Legion/Discovery/Server.hs b/src/Network/Legion/Discovery/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/Server.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{- | Contains the servant implentation of the 'DiscoveryApi'. -} +module Network.Legion.Discovery.Server ( + discoveryServer, +) where + +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +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)) +import Network.Legion.Discovery.Graphviz (toDotGraph) +import Network.Legion.Discovery.LegionApp (Input, Output, unEntityName, + Client(Client), cName, cVersion, EntityName, Client, Output, getRange, + getAllServices) +import Servant ((:<|>)((:<|>)), Server, ServantErr, errBody, + errHeaders, err400, NoContent(NoContent), Handler) +import qualified Data.ByteString.Lazy as BSL +import qualified Network.Legion.Discovery.LegionApp as App + + +{- | The implementation of the 'DiscoveryApi' api. -} +discoveryServer :: Runtime Input Output -> Server DiscoveryApi +discoveryServer = v1 + + +{- | 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 + where + graph :: Server GraphApi + graph = Graph . toDotGraph <$> getAllServices runtime + + ping :: [Client] -> Server PingApi + ping clients PingRequest {serviceAddress} = do + strictClients <- mapM toStrict clients + liftIO $ do + sequence_ [ + App.ping runtime name version serviceAddress + | (name, version) <- strictClients + ] + return NoContent + where + {- | + Return the client name and version, or else throw an error if + the client doesn't provide a version. + -} + toStrict :: Client -> Handler (EntityName, Version) + toStrict Client {cName, cVersion = Just version} = + return (cName, version) + toStrict Client {cName, cVersion = Nothing} = + throwError $ badRequest ( + "Missing version for client product: " + <> unEntityName cName + <> ". Please fix your User-Agent header." + ) + + allInstances :: [Client] -> EntityName -> Server InstancesApi + 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 + + +{- | 400 BadRequest servant error helper. -} +badRequest :: Text -> ServantErr +badRequest msg = err400 { + errBody = BSL.fromStrict (encodeUtf8 msg), + errHeaders = [("content-type", "text/plain")] + } + + diff --git a/src/Network/Legion/Discovery/UserAgent.hs b/src/Network/Legion/Discovery/UserAgent.hs --- a/src/Network/Legion/Discovery/UserAgent.hs +++ b/src/Network/Legion/Discovery/UserAgent.hs @@ -15,9 +15,12 @@ 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 @@ -43,8 +46,8 @@ 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 +parseUserAgent :: ByteString -> Either Text [UserAgent] +parseUserAgent = first T.pack . parseOnly userAgent {- |