diff --git a/legion-discovery-client.cabal b/legion-discovery-client.cabal --- a/legion-discovery-client.cabal +++ b/legion-discovery-client.cabal @@ -1,5 +1,5 @@ name: legion-discovery-client -version: 0.1.0.3 +version: 0.1.1.0 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,13 @@ Network.Legion.Discovery.Client build-depends: Cabal >= 1.22.5.0 && < 1.25, - aeson >= 0.11.2.1 && < 0.12, - base >= 4.7 && < 5, + aeson >= 0.11.2.1 && < 1.1, + base >= 4.7 && < 4.10, bytestring >= 0.10.6.0 && < 0.11, containers >= 0.5.6.2 && < 0.6, - data-default-class >= 0.0.1 && < 0.2, - http-client >= 0.4.31.1 && < 0.5, + http-client >= 0.5.6.1 && < 0.6, http-types >= 0.9.1 && < 0.10, load-balancing >= 1.0 && < 1.1, - network >= 2.6.3.1 && < 2.7, resourcet >= 1.1.7.5 && < 1.2, text >= 1.2.2.1 && < 1.3, transformers >= 0.4.2.0 && < 0.6 diff --git a/src/Network/Legion/Discovery/Client.hs b/src/Network/Legion/Discovery/Client.hs --- a/src/Network/Legion/Discovery/Client.hs +++ b/src/Network/Legion/Discovery/Client.hs @@ -15,6 +15,7 @@ -- * HTTP Utilities. newLB, withResponse, + httpLbs, -- * Other Types. LBHttp, Discovery, @@ -31,7 +32,6 @@ import Control.Monad.Trans.Resource (runResourceT, allocate) import Data.Aeson (eitherDecode, Value, encode, object, (.=)) import Data.ByteString.Lazy (fromChunks) -import Data.Default.Class (def) import Data.Map (Map) import Data.Monoid ((<>)) import Data.Set (Set) @@ -40,11 +40,13 @@ import Data.Text.Encoding (encodeUtf8) import Distribution.Text (display) import Distribution.Version (VersionRange, Version) -import Network.HTTP.Client (Request, Response, BodyReader, - parseRequest, host, secure, port, Manager, requestHeaders, - checkStatus, responseStatus, brConsume, responseBody, path, method, - RequestBody(RequestBodyLBS), requestBody) +import Network.HTTP.Client (Request, Response, BodyReader, parseRequest, + host, secure, port, Manager, requestHeaders, responseStatus, brConsume, + responseBody, path, method, RequestBody(RequestBodyLBS), requestBody, + defaultRequest) import Network.HTTP.Types (urlEncode, statusIsSuccessful) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import qualified Data.Map as Map import qualified Data.Set as Set import qualified Network.HTTP.Client as C @@ -75,8 +77,9 @@ via the 'withResponse' function. -} -> IO Discovery -connect name version urls manager = - D name version . LB manager <$> evenlyDistributed (return urls) +connect name version urls manager = do + lb <- evenlyDistributed (return urls) + return $ D name version (LB manager lb (pack (show urls))) {- | @@ -115,14 +118,13 @@ let userAgent = encodeUtf8 $ unName (dName d) <> "/" <> pack (display (dVersion d)) - req = def { + req = defaultRequest { path = "/v1/ping", method = "POST", requestHeaders = [ ("user-agent", userAgent), ("content-type", pingRequestCT) ], - checkStatus = const . const . const $ Nothing, requestBody = RequestBodyLBS . encode . object $ [ "serviceAddress" .= unServiceAddr addy ] @@ -147,15 +149,14 @@ let userAgent = encodeUtf8 $ unName (dName d) <> "-" <> pack (display (dVersion d)) - req = def { + req = defaultRequest { path = "/v1/services/" <> urlEncode False (encodeUtf8 (unName name)) <> "/" <> urlEncode False (encodeUtf8 (pack (display range))), method = "GET", - requestHeaders = [("user-agent", userAgent)], - checkStatus = const . const . const $ Nothing + requestHeaders = [("user-agent", userAgent)] } withResponse req (dLb d) (\case Nothing -> fail "No Discovery instances available." @@ -192,9 +193,9 @@ {- | - Analog of 'C.withResponse', but automatically replaces the host, port, - and scheme portions of the 'Request' with values obtained from the - load balancer. + Analog of 'http-client''s 'C.withResponse', but automatically replaces + the host, port, and scheme portions of the 'Request' with values + obtained from the load balancer. If a 'Nothing' value is passed to the response handler, that means that there are no available instances that match the query params that were @@ -219,11 +220,43 @@ ) +{- | + Analog of 'http-client''s 'C.httpLbs', but automatically replaces + the host, port, and scheme portions of the 'Request' with values + obtained from the load balancer. + + If a 'Nothing' value is returned, that means that there are no available + instances that match the query params that were passed to 'newLB'. +-} +httpLbs + :: Request + -> LBHttp + -> IO (Maybe (Response BSL.ByteString)) +httpLbs r lb = withResponse r lb (\case + Nothing -> return Nothing + Just res -> do + chunks <- consumeAll (responseBody res) + return (Just res {responseBody = BSL.fromChunks chunks}) + ) + where + consumeAll :: IO BS.ByteString -> IO [BS.ByteString] + consumeAll io = do + chunk <- io + if BS.null chunk + then return [] + else do + more <- consumeAll io + return (chunk:more) + + {- | A handle on the load balancing context. -} data LBHttp = LB { lbManager :: Manager, - lbLb :: LoadBalanced ServiceAddr + lbLb :: LoadBalanced ServiceAddr, + lbDesc :: Text } +instance Show LBHttp where + show = unpack . lbDesc {- | Create a new load balanced http client, for use with 'withResponse'. -} @@ -236,7 +269,11 @@ {- ^ The range of service versions with which you are compatible. -} -> IO LBHttp {- ^ Returns a load balanced http client, for use with 'withResponse'. -} -newLB d n r = LB (lbManager (dLb d)) <$> evenlyDistributed (query n r d) +newLB d n r = + LB + <$> pure (lbManager (dLb d)) + <*> evenlyDistributed (query n r d) + <*> pure (unName n <> " => " <> pack (display r)) {- | The content type of a ping request. -}