legion-discovery-client 0.1.1.1 → 0.2.0.1
raw patch · 2 files changed
+29/−13 lines, 2 filesdep +monad-loggerdep +safe-exceptionsdep +text-showdep ~aeson
Dependencies added: monad-logger, safe-exceptions, text-show
Dependency ranges changed: aeson
Files
legion-discovery-client.cabal view
@@ -1,5 +1,5 @@ name: legion-discovery-client-version: 0.1.1.1+version: 0.2.0.1 synopsis: Client library for communicating with legion-discovery. description: Please see README.md homepage: https://github.com/owensmurray/legion-discovery-client#readme@@ -21,15 +21,18 @@ Network.Legion.Discovery.Client build-depends: Cabal >= 1.22.5.0 && < 1.25,- aeson >= 0.11.2.1 && < 1.1,+ aeson >= 0.11.2.1 && < 1.2, base >= 4.7 && < 4.10, bytestring >= 0.10.6.0 && < 0.11, containers >= 0.5.6.2 && < 0.6, http-client >= 0.5.6.1 && < 0.6, http-types >= 0.9.1 && < 0.10, load-balancing >= 1.0 && < 1.1,+ monad-logger >= 0.3.20.2 && < 0.4, resourcet >= 1.1.7.5 && < 1.2,+ safe-exceptions >= 0.1.4.0 && < 0.2, text >= 1.2.2.1 && < 1.3,+ text-show >= 3.4.1.1 && < 3.7, transformers >= 0.4.2.0 && < 0.6 default-language: Haskell2010
src/Network/Legion/Discovery/Client.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+ {- | This module contains a client library for communicating with the 'legion-discovery' service discovery program.@@ -27,7 +29,11 @@ forkIO, threadDelay) import Control.Concurrent.LoadDistribution (withResource, evenlyDistributed, LoadBalanced)+import Control.Exception.Safe (tryAny, MonadCatch) import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger (MonadLoggerIO, askLoggerIO, runLoggingT,+ Loc, LogSource, LogLevel, LogStr, logError) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Resource (runResourceT, allocate) import Data.Aeson (eitherDecode, Value, encode, object, (.=))@@ -45,6 +51,7 @@ responseBody, path, method, RequestBody(RequestBodyLBS), requestBody, defaultRequest) import Network.HTTP.Types (urlEncode, statusIsSuccessful)+import TextShow (showt) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.Map as Map@@ -85,27 +92,30 @@ {- | Run a registered service, making sure to unregister upon ternination. -}-withService- :: ServiceAddr+withService :: (MonadLoggerIO m)+ => ServiceAddr {- ^ The service address on which your service instance can be contacted. -} -> Discovery {- ^ A handle on the discovery service, obtained via `connect`. -} -> IO a {- ^ The IO action to perform while registered as a service. -}- -> IO a-withService addy d io =- runResourceT $ do- void $ allocate launchPing stopPing+ -> m a+withService addy d io = do+ logging <- askLoggerIO+ liftIO . runResourceT $ do+ void $ allocate (launchPing logging) stopPing lift io where- launchPing :: IO (MVar ())- launchPing = do+ launchPing+ :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())+ -> IO (MVar ())+ launchPing logging = do stop <- newEmptyMVar void . forkIO $ let loop = tryTakeMVar stop >>= \case- Nothing -> ping >> threadDelay tenSeconds >> loop+ Nothing -> runLoggingT ping logging >> threadDelay tenSeconds >> loop Just () -> return () in loop return stop@@ -113,7 +123,7 @@ stopPing :: MVar () -> IO () stopPing stop = putMVar stop () - ping :: IO ()+ ping :: (MonadLoggerIO m, MonadCatch m) => m () ping = do let userAgent = encodeUtf8@@ -130,7 +140,10 @@ ] } {- TODO figure out what we want to do when the ping fails. -}- withResponse req (dLb d) (const (return ()))+ tryAny (liftIO (withResponse req (dLb d) (const (return ())))) >>= \case+ Left err -> $(logError)+ $ "Can't ping legion-discovery service: " <> showt err+ Right () -> return () tenSeconds :: Int tenSeconds = 10000000 {- in microseconds. -}