diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/legion-discovery.hs b/app/legion-discovery.hs new file mode 100644 --- /dev/null +++ b/app/legion-discovery.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import qualified Network.Legion.Discovery + +main :: IO () +main = Network.Legion.Discovery.main + diff --git a/legion-discovery.cabal b/legion-discovery.cabal new file mode 100644 --- /dev/null +++ b/legion-discovery.cabal @@ -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 diff --git a/src/Network/Legion/Discovery.hs b/src/Network/Legion/Discovery.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery.hs @@ -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" + + diff --git a/src/Network/Legion/Discovery/App.hs b/src/Network/Legion/Discovery/App.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/App.hs @@ -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 + + diff --git a/src/Network/Legion/Discovery/Config.hs b/src/Network/Legion/Discovery/Config.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/Config.hs @@ -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 + + diff --git a/src/Network/Legion/Discovery/HttpError.hs b/src/Network/Legion/Discovery/HttpError.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/HttpError.hs @@ -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 + diff --git a/src/Network/Legion/Discovery/LIO.hs b/src/Network/Legion/Discovery/LIO.hs new file mode 100644 --- /dev/null +++ b/src/Network/Legion/Discovery/LIO.hs @@ -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) + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"