legion-discovery (empty) → 0.2.1.0
raw patch · 10 files changed
+804/−0 lines, 10 filesdep +Cabaldep +SHAdep +aesonsetup-changed
Dependencies added: Cabal, SHA, aeson, base, binary, bytestring, canteven-http, canteven-log, conduit, containers, data-default-class, http-types, legion, legion-discovery, legion-extra, monad-logger, scotty, scotty-resource, text, time, transformers, wai, wai-extra, warp
Files
- LICENSE +202/−0
- Setup.hs +2/−0
- app/legion-discovery.hs +7/−0
- legion-discovery.cabal +86/−0
- src/Network/Legion/Discovery.hs +228/−0
- src/Network/Legion/Discovery/App.hs +202/−0
- src/Network/Legion/Discovery/Config.hs +31/−0
- src/Network/Legion/Discovery/HttpError.hs +22/−0
- src/Network/Legion/Discovery/LIO.hs +22/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/legion-discovery.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import qualified Network.Legion.Discovery++main :: IO ()+main = Network.Legion.Discovery.main+
+ legion-discovery.cabal view
@@ -0,0 +1,86 @@+name: legion-discovery+version: 0.2.1.0+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+copyright: 2016 Rick Owens+category: value+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs:+ src+ exposed-modules:+ Network.Legion.Discovery+ other-modules:+ Network.Legion.Discovery.App+ Network.Legion.Discovery.Config+ Network.Legion.Discovery.HttpError+ Network.Legion.Discovery.LIO+ 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.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+ default-language:+ Haskell2010++executable legion-discovery+ hs-source-dirs:+ app+ main-is:+ legion-discovery.hs+ ghc-options:+ -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base,+ legion-discovery+ default-language:+ Haskell2010++test-suite legion-discovery-test+ 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++source-repository head+ type:+ git+ location:+ https://github.com/owensmurray/legion-discovery
+ src/Network/Legion/Discovery.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+module Network.Legion.Discovery (+ main+) where++import Canteven.HTTP (requestLogging, logExceptionsAndContinue,+ DecodeResult(Unsupported, BadEntity, Ok), FromEntity, decodeEntity)+import Canteven.Log.MonadLog (getCantevenOutput)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (encode, object, (.=), FromJSON, parseJSON,+ Value(Object), (.:), eitherDecode)+import Data.Conduit ((=$=), ($$))+import Data.Map (Map)+import Data.String (IsString)+import Data.Text (pack)+import Data.Time (getCurrentTime)+import Data.Version (showVersion)+import Distribution.Text (simpleParse)+import Network.HTTP.Types (badRequest400, unsupportedMediaType415,+ noContent204)+import Network.Legion (forkLegionary, Runtime, makeRequest, search,+ SearchTag(SearchTag), IndexRecord, irKey, PartitionKey)+import Network.Legion.Config (parseArgs)+import Network.Legion.Discovery.App (newApp, Input(GetRange, GetAll, Ping,+ GetService), Output(InstanceList, PingResponse, ServiceResponse),+ ServiceId(ServiceId), toKey, Time(Time), unServiceAddr, version,+ ServiceAddr(ServiceAddr), InstanceInfo, Service, instances, name,+ unServiceId)+import Network.Legion.Discovery.Config (servicePort)+import Network.Legion.Discovery.HttpError (HttpError)+import Network.Legion.Discovery.LIO (runLIO, LIO)+import Network.Wai (Middleware, modifyResponse)+import Network.Wai.Middleware.AddHeaders (addHeaders)+import Network.Wai.Middleware.StripHeaders (stripHeader)+import Web.Scotty.Resource.Trans (resource, get, post)+import Web.Scotty.Trans (scottyT, middleware, ScottyT, param, setHeader,+ raw, status, text, ActionT, ScottyError, body, header)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Conduit.List as CL+import qualified Data.Map as Map+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 Paths_legion_discovery as P++main :: IO ()+main = do+ (settings, startupMode, config) <- parseArgs+ logging <- getCantevenOutput (C.logging config)+ app <- newApp++ runLIO logging $ do+ legion <- forkLegionary app settings startupMode+ scottyT (servicePort config) (runLIO logging) $ do+ middleware+ $ requestLogging logging+ . setServer "legion-discovery"+ . logExceptionsAndContinue logging+ webService legion+++{- | The web service endpoint definitions. -}+webService :: Runtime Input Output -> ScottyT HttpError LIO ()+webService runtime = do+ resource "/v1/ping/:serviceId/:version" $+ post $+ simpleParse <$> param "version" >>= \case+ Nothing -> do+ status badRequest400+ text "Invalid version."+ Just ver -> do+ serviceId <- ServiceId <$> param "serviceId"+ now <- Time <$> liftIO getCurrentTime+ withEntity (\ PingRequest {serviceAddress} -> do+ let req = Ping now serviceId ver serviceAddress+ makeRequest runtime (toKey serviceId) req >>= \case+ PingResponse -> status noContent204+ InstanceList _ -> fail "Invalid runtime response."+ ServiceResponse _ -> fail "Invalid runtime response."+ )+ 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+ ]+ resource "/v1/services/:serviceId" $+ get $ do+ serviceId <- ServiceId <$> param "serviceId"+ now <- Time <$> liftIO getCurrentTime+ respondInstances =<< getInstances runtime (toKey serviceId) (GetAll now)+ resource "/v1/services/:serviceId/:versionRange" $+ get $ do+ serviceId <- ServiceId <$> param "serviceId"+ 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)+ where+ {- | Get the service info for the serivce listing. -}+ fillServiceInfo+ :: 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."++ {- | Send a response containing the service instance list. -}+ respondInstances+ :: Map ServiceAddr InstanceInfo+ -> ActionT HttpError LIO ()+ 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."+++{- | Set the server header. -}+setServer :: String -> Middleware+setServer serviceName = addServerHeader . stripServerHeader+ where+ {- |+ Strip the server header+ -}+ stripServerHeader :: Middleware+ stripServerHeader = modifyResponse (stripHeader "Server")++ {- |+ Add our own server header.+ -}+ addServerHeader :: Middleware+ addServerHeader = addHeaders [("Server", serverValue)]++ {- |+ The value of the @Server:@ header.+ -}+ serverValue =+ TE.encodeUtf8 (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"+++{- | 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 = "application/vnd.legion-discovery.ping-request+json"++
+ src/Network/Legion/Discovery/App.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{- | This module contains the legion application definition. -}+module Network.Legion.Discovery.App (+ newApp,+ Input(..),+ Output(..),+ State,+ ServiceId(..),+ ServiceAddr(..),+ InstanceInfo(..),+ Time(..),+ Service(..),+ toKey,+) where++import Data.Binary (Binary, get, put)+import Data.Default.Class (Default, def)+import Data.Digest.Pure.SHA (sha256)+import Data.Map (Map)+import Data.Text (Text)+import Data.Time (UTCTime(UTCTime), Day(ModifiedJulianDay), addUTCTime,+ 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 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.Encoding as TE+++data Input+ = GetRange Time VersionRange+ | GetAll Time+ | Ping Time ServiceId 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 (Show, Binary)+instance Default State where+ def = State Nothing+++{- | This type represents a discoverable service. -}+data Service = Service {+ name :: ServiceId,+ instances :: Map ServiceAddr InstanceInfo+ }+ deriving (Show, Generic)+instance Binary Service+++{- | 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+++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 (Ping now name version addr) (State Nothing) =+ let+ state = State (Just Service {+ name = name,+ 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 (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 (Just service))+ where+ notExpired = (unTime now <=) . addUTCTime thirtySeconds . unTime . lastPing+++{- | A service id. -}+newtype ServiceId = ServiceId {+ unServiceId :: Text+ }+ deriving (Show, Eq, Binary)+++instance ApplyDelta Input State where+ apply i s = let (_, s2) = handle i s in s2+++{- |+ Wrapper for UTCTime. Useful beacuse UTCTime doesn't have a `Binary`+ instane.+-}+newtype Time = Time {unTime :: UTCTime}+ deriving (Show, Eq)+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++
+ src/Network/Legion/Discovery/Config.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{- |+ This module contains the configuration data structures.+-}+module Network.Legion.Discovery.Config (+ Config(..),+) where++import Canteven.Log.MonadLog (LoggingConfig)+import Data.Aeson (FromJSON, Value(Object), (.:), parseJSON)+import GHC.Generics (Generic)+import Network.Wai.Handler.Warp (Port)+++data Config = Config {+ servicePort :: Port,+ ekgPort :: Port,+ logging :: LoggingConfig+ } deriving (Generic)++instance FromJSON Config where+ parseJSON v@(Object config) = Config+ <$> config .: "servicePort"+ <*> config .: "ekgPort"+ <*> parseJSON v+ parseJSON value =+ fail $ "Couldn't parse config from " ++ show value++
+ src/Network/Legion/Discovery/HttpError.hs view
@@ -0,0 +1,22 @@+{- |+ This module contains a `ScottyError` error type that short-cuts to http+ response types.+-}+module Network.Legion.Discovery.HttpError (+ HttpError,+) where++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++instance ScottyError HttpError where+ stringError = Critical . pack+ showError (Transient _ msg) = fromStrict msg+ showError (Critical msg) = fromStrict msg+
+ src/Network/Legion/Discovery/LIO.hs view
@@ -0,0 +1,22 @@+{- |+ 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)++
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"