legion-discovery 0.2.2.0 → 0.2.2.1
raw patch · 3 files changed
+49/−11 lines, 3 filesdep ~legiondep ~scotty-format
Dependency ranges changed: legion, scotty-format
Files
- legion-discovery.cabal +4/−4
- src/Network/Legion/Discovery.hs +7/−1
- src/Network/Legion/Discovery/App.hs +38/−6
legion-discovery.cabal view
@@ -1,12 +1,12 @@ name: legion-discovery-version: 0.2.2.0+version: 0.2.2.1 synopsis: Initial project template from stack description: Please see README.md homepage: https://github.com/owensmurray/legion-discovery#readme license: Apache-2.0 license-file: LICENSE author: Rick Owens-maintainer: rick@owensmurray.comm+maintainer: rick@owensmurray.com copyright: 2016 Rick Owens category: value build-type: Simple@@ -41,11 +41,11 @@ 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 >= 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 && < 0.2,+ scotty-format >= 0.1.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,
src/Network/Legion/Discovery.hs view
@@ -47,7 +47,7 @@ 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.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)@@ -118,11 +118,17 @@ =$= 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))
src/Network/Legion/Discovery/App.hs view
@@ -2,7 +2,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}-{- | This module contains the legion application definition. -}+{-# 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(..),@@ -17,21 +23,28 @@ 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 @@ -55,15 +68,19 @@ newtype State = State { _unState :: Maybe Service }- deriving (Show, Binary)+ 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,@@ -72,6 +89,12 @@ } 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. -}@@ -81,6 +104,11 @@ } 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. -}@@ -88,8 +116,11 @@ cName :: ServiceId, cVersion :: Maybe Version }- deriving (Show, Eq, Generic, Ord)+ 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. -}@@ -104,6 +135,7 @@ } deriving (Show, Generic) instance Binary InstanceInfo+instance ToJSON InstanceInfo {- | The main request handler. -}@@ -196,7 +228,7 @@ newtype ServiceId = ServiceId { unServiceId :: Text }- deriving (Show, Eq, Binary, Ord)+ deriving (Show, Eq, Binary, Ord, ToJSON) instance Event Input Output State where@@ -208,7 +240,7 @@ instane. -} newtype Time = Time {unTime :: UTCTime}- deriving (Show, Eq, Ord)+ deriving (Show, Eq, Ord, ToJSON) instance Binary Time where put (Time (UTCTime (ModifiedJulianDay day) time)) = put (day, toRational time) get = do