consul-haskell 0.4.2 → 0.5.0

raw patch · 6 files changed

+280/−96 lines, 6 filesdep +typed-processdep +unliftiodep −lifted-asyncdep −lifted-basedep −monad-controldep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: typed-process, unliftio

Dependencies removed: lifted-async, lifted-base, monad-control

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• consul-haskell.cabal +10/−6
• src/Network/Consul.hs +10/−13
• src/Network/Consul/Internal.hs +26/−7
• src/Network/Consul/Types.hs +0/−4
• tests/Main.hs +182/−66
• tests/SocketUtils.hs +52/−0

@@ -1,10 +1,10 @@ name:                consul-haskell-version:             0.4.2+version:             0.5.0 synopsis:            A consul client for Haskell description:   A consul client for Haskell   .-  Requires consul 0.5 or later.+  Requires consul 0.5 or later. Tested with consul 1.6.  license:             BSD3 license-file:        LICENSE@@ -31,7 +31,7 @@     Network.Consul.Types   build-depends:     aeson,-    base                       >= 4.6 && < 5,+    base                       >= 4.10 && < 5,     base64-bytestring,     bytestring,     connection,@@ -40,14 +40,12 @@     http-client,     http-client-tls,     http-types,-    lifted-async,-    lifted-base,-    monad-control >= 1.0,     network,     retry,     stm,     text,     transformers,+    unliftio >= 0.2.4,     unordered-containers,     vector   ghc-options:@@ -62,16 +60,22 @@     exitcode-stdio-1.0   main-is:     Main.hs+  other-modules:+    SocketUtils   build-depends:     base                       >= 4.6 && < 5,+    bytestring,     consul-haskell,     http-client,     network,     random,+    retry,     tasty,     tasty-hunit,     text,     transformers,+    typed-process,+    unliftio,     uuid,     HUnit                      >= 1.2   ghc-options:

@@ -28,48 +28,45 @@   , renewSession   , runService   , withSession+  , withSequencer   , module Network.Consul.Types ) where  import Control.Concurrent hiding (killThread)-import Control.Concurrent.Async.Lifted-import Control.Concurrent.STM-import Control.Exception.Lifted import Control.Monad (forever) import Control.Monad.IO.Class import Control.Monad.Catch (MonadMask)-import Control.Monad.Trans.Control import Control.Retry import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Read as TR-import Data.Traversable import Data.Word import qualified Network.Consul.Internal as I import Network.Consul.Types-import Network.HTTP.Client (defaultManagerSettings, newManager, Manager)-import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Client (Manager)+import Network.HTTP.Client.TLS (newTlsManager, newTlsManagerWith, tlsManagerSettings) import Network.Socket (PortNumber)+import UnliftIO (MonadUnliftIO, async, cancel, finally, wait, waitAnyCancel, withAsync)   import Prelude hiding (mapM) -parseTtl :: forall t. Integral t => Text -> t+parseTtl :: Integral t => Text -> t parseTtl ttl = let Right (x,_) = TR.decimal $ T.filter (/= 's') ttl in x  initializeConsulClient :: MonadIO m => Text -> PortNumber -> Maybe Manager -> m ConsulClient initializeConsulClient hostname port man = do   manager <- liftIO $ case man of                         Just x -> return x-                        Nothing -> newManager defaultManagerSettings+                        Nothing -> newTlsManager   return $ ConsulClient manager hostname port False  initializeTlsConsulClient :: MonadIO m => Text -> PortNumber -> Maybe Manager -> m ConsulClient initializeTlsConsulClient hostname port man = do     manager <- liftIO $ case man of                         Just x -> return x-                        Nothing -> newManager tlsManagerSettings+                        Nothing -> newTlsManagerWith tlsManagerSettings     return $ ConsulClient manager hostname port True  {- Key Value -}@@ -118,7 +115,7 @@ registerService :: MonadIO m => ConsulClient -> RegisterService -> Maybe Datacenter -> m Bool registerService _client@ConsulClient{..} = I.registerService ccManager (I.hostWithScheme _client) ccPort -runService :: (MonadBaseControl IO m, MonadIO m) => ConsulClient -> RegisterService -> m () -> Maybe Datacenter -> m ()+runService :: MonadUnliftIO m => ConsulClient -> RegisterService -> m () -> Maybe Datacenter -> m () runService client request action dc = do   r <- registerService client request dc   case r of@@ -157,7 +154,7 @@ getSessionInfo :: MonadIO m => ConsulClient -> Session -> Maybe Datacenter ->  m (Maybe [SessionInfo]) getSessionInfo client@ConsulClient{..} = I.getSessionInfo ccManager (I.hostWithScheme client) ccPort -withSession :: forall m a. (MonadBaseControl IO m, MonadIO m, MonadMask m) => ConsulClient -> Maybe Text -> Int -> Session -> (Session -> m a) -> m a -> m a+withSession :: forall m a. (MonadMask m, MonadUnliftIO m) => ConsulClient -> Maybe Text -> Int -> Session -> (Session -> m a) -> m a -> m a withSession client@ConsulClient{..} name delay session action lostAction = (do   withAsync (action session) $ \ mainAsync -> withAsync extendSession $ \ extendAsync -> do     result :: a <- return . snd =<< waitAnyCancel [mainAsync,extendAsync]@@ -187,7 +184,7 @@     Just kv -> return $ (maybe False ((sId $ sSession sequencer) ==) $ kvSession kv) && (kvLockIndex kv) == (sLockIndex sequencer)     Nothing -> return False -withSequencer :: (MonadBaseControl IO m, MonadIO m, MonadMask m) => ConsulClient -> Sequencer -> m a -> m a -> Int -> Maybe Datacenter -> m a+withSequencer :: (MonadMask m, MonadUnliftIO m) => ConsulClient -> Sequencer -> m a -> m a -> Int -> Maybe Datacenter -> m a withSequencer client sequencer action lostAction delay dc =   withAsync action $ \ mainAsync -> withAsync pulseLock $ \ pulseAsync -> do     waitAnyCancel [mainAsync, pulseAsync] >>= return . snd

@@ -12,8 +12,7 @@   , getKeys   , listKeys   , putKey-  , putKeyAcquireLock-  , putKeyReleaseLock+  , putKeyAcquireLock , putKeyReleaseLock    --Agent   , deregisterHealthCheck@@ -136,13 +135,18 @@     query = T.intercalate "&" $ catMaybes [cons,ind, Just "keys"]     fquery = if query /= T.empty then Just query else Nothing ++decodeAndStrip :: ByteString -> String+decodeAndStrip = T.unpack . T.strip . TE.decodeUtf8+ putKey :: MonadIO m => Manager -> Text -> PortNumber -> KeyValuePut -> Maybe Datacenter -> m Bool putKey manager hostname portNumber request dc = do   initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", kvpKey request]) fquery (Just $ kvpValue request) False dc   liftIO $ withResponse initReq manager $ \ response -> do     bodyParts <- brConsume $ responseBody response     let body = B.concat bodyParts-    case TE.decodeUtf8 body of+    let result = decodeAndStrip body+    case result of       "true" -> return True       "false" -> return False       _ -> return False@@ -152,13 +156,16 @@     query = T.intercalate "&" $ catMaybes [flags,cas]     fquery = if query /= T.empty then Just query else Nothing ++ putKeyAcquireLock :: MonadIO m => Manager -> Text -> PortNumber -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool putKeyAcquireLock manager hostname portNumber request (Session session _) dc = do   initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", kvpKey request]) fquery (Just $ kvpValue request) False dc   liftIO $ withResponse initReq manager $ \ response -> do     bodyParts <- brConsume $ responseBody response     let body = B.concat bodyParts-    case TE.decodeUtf8 body of+    let result = decodeAndStrip body+    case result of       "true" -> return True       "false" -> return False       _ -> return False@@ -175,7 +182,8 @@   liftIO $ withResponse initReq manager $ \ response -> do     bodyParts <- brConsume $ responseBody response     let body = B.concat bodyParts-    case TE.decodeUtf8 body of+    let result = decodeAndStrip body+    case result of       "true" -> return True       "false" -> return False       _ -> return False@@ -193,7 +201,8 @@   liftIO $ withResponse httpReq manager $ \ response -> do     bodyParts <- brConsume $ responseBody response     let body = B.concat bodyParts-    case TE.decodeUtf8 body of+    let result = decodeAndStrip body+    case result of       "true" -> return True       "false" -> return False       _ -> return False@@ -222,7 +231,17 @@  passHealthCheck :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Datacenter -> m () passHealthCheck manager hostname portNumber checkId dc = do-  initReq <- createRequest hostname portNumber (T.concat ["/v1/agent/check/pass/", checkId]) Nothing Nothing False dc+  -- Using `Just ""` as the `body` to ensure a PUT request is used.+  -- Consul < 1.0 accepted a GET here (which was a legacy mistake).+  -- In 1.0, they switched it to require a PUT.+  -- See also:+  --   * https://github.com/hashicorp/consul/issues/3659+  --   * https://github.com/cablehead/python-consul/pull/182+  --   * https://github.com/hashicorp/consul/blob/51ea240df8476e02215d53fbfad5838bf0d44d21/CHANGELOG.md+  --     Section "HTTP Verbs are Enforced in Many HTTP APIs":+  --     > Many endpoints in the HTTP API that previously took any HTTP verb+  --     > now check for specific HTTP verbs and enforce them.+  initReq <- createRequest hostname portNumber (T.concat ["/v1/agent/check/pass/", checkId]) Nothing (Just "") False dc   liftIO $ withResponse initReq manager $ \ response -> do     return () 

@@ -27,10 +27,6 @@   SessionRequest(..),   Sequencer(..) ) where-#ifdef __GLASGOW_HASKELL__ <710-import Control.Applicative-import Data.Traversable-#endif import Control.Monad import Data.Aeson import Data.Aeson.Types

@@ -1,111 +1,167 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}  import Control.Concurrent+import Control.Monad (when) import Control.Monad.IO.Class+import Control.Retry+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8 import Data.Maybe+#if MIN_VERSION_base(4,11,0)+-- (<>) is part of Prelude+#else+import Data.Monoid ((<>))+#endif import Data.Text (Text) import Data.UUID-import Network.Consul (deleteKey,getKey,getSessionInfo,initializeConsulClient,putKey,withSession,ConsulClient(..),runService,getServiceHealth)+import Network.Consul (createSession, deleteKey, destroySession,getKey, getSequencerForLock,getSessionInfo,initializeConsulClient, isValidSequencer,putKey,putKeyAcquireLock,withSession,ConsulClient(..),runService,getServiceHealth) import Network.Consul.Types import qualified Network.Consul.Internal as I import Network.HTTP.Client import Network.Socket (PortNumber(..))+import System.IO (hFlush)+import System.Process.Typed (proc, stopProcess)+import qualified System.Process.Typed as PT import System.Random import Test.Tasty import Test.Tasty.HUnit+import UnliftIO.Temporary (withSystemTempFile) -client :: IO ConsulClient-client = initializeConsulClient "localhost" 8500 Nothing+import SocketUtils (isPortOpen, simpleSockAddr) +consulPort :: PortNumber+consulPort = 18500++newClient :: IO ConsulClient+newClient = initializeConsulClient "localhost" consulPort Nothing+ {- Internal Tests -} internalKVTests :: TestTree-internalKVTests = testGroup "Internal Key Value" [testGetInvalidKey, testPutKey,+internalKVTests = testGroup "Internal Key Value" [testGetInvalidKey, testPutKey, testPutKeyAcquireLock,testPutKeyReleaseLock,   testGetKey,testGetKeys,testListKeys,testDeleteKey,testGetNullValueKey,testDeleteRecursive]  testGetInvalidKey :: TestTree testGetInvalidKey = testCase "testGetInvalidKey" $ do-  _client@ConsulClient{..} <- client-  x <- I.getKey ccManager (I.hostWithScheme _client) ccPort "nokey" Nothing Nothing Nothing+  client@ConsulClient{..} <- newClient+  x <- I.getKey ccManager (I.hostWithScheme client) ccPort "nokey" Nothing Nothing Nothing   assertEqual "testGetInvalidKey: Found a key that doesn't exist" x Nothing  testPutKey :: TestTree testPutKey = testCase "testPutKey" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let put = KeyValuePut "/testPutKey" "Test" Nothing Nothing-  x <- I.putKey ccManager (I.hostWithScheme _client) ccPort put Nothing+  x <- I.putKey ccManager (I.hostWithScheme client) ccPort put Nothing   assertEqual "testPutKey: Write failed" True x +testPutKeyAcquireLock :: TestTree+testPutKeyAcquireLock = testCase "testPutKeyAcquireLock" $ do+  client@ConsulClient{..} <- newClient+  let req = SessionRequest Nothing (Just "testPutKeyAcquireLock") Nothing ["serfHealth"] (Just Release) (Just "30s")+  result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing+  case result of+    Nothing -> assertFailure "testPutKeyAcquireLock: No session was created"+    Just session -> do+      let put = KeyValuePut "/testPutKeyAcquireLock" "Test" Nothing Nothing+      x <- I.putKeyAcquireLock ccManager (I.hostWithScheme client) ccPort put session Nothing+      assertEqual "testPutKeyAcquireLock: Write failed" True x+      Just kv <- I.getKey ccManager (I.hostWithScheme client) ccPort "/testPutKeyAcquireLock" Nothing Nothing Nothing+      let Just returnedSession = kvSession kv+      assertEqual "testPutKeyAcquireLock: Session was not found on key" returnedSession (sId session)++testPutKeyReleaseLock :: TestTree+testPutKeyReleaseLock = testCase "testPutKeyReleaseLock" $ do+  client@ConsulClient{..} <- newClient+  let req = SessionRequest Nothing (Just "testPutKeyReleaseLock") Nothing ["serfHealth"] (Just Release) (Just "30s")+  result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing+  case result of+    Nothing -> assertFailure "testPutKeyReleaseLock: No session was created"+    Just session -> do+      let put = KeyValuePut "/testPutKeyReleaseLock" "Test" Nothing Nothing+      x <- I.putKeyAcquireLock ccManager (I.hostWithScheme client) ccPort put session Nothing+      assertEqual "testPutKeyReleaseLock: Write failed" True x+      Just kv <- I.getKey ccManager (I.hostWithScheme client) ccPort "/testPutKeyReleaseLock" Nothing Nothing Nothing+      let Just returnedSession = kvSession kv+      assertEqual "testPutKeyReleaseLock: Session was not found on key" returnedSession (sId session)+      let put2 = KeyValuePut "/testPutKeyReleaseLock" "Test" Nothing Nothing+      x2 <- I.putKeyReleaseLock ccManager (I.hostWithScheme client) ccPort put2 session Nothing+      assertEqual "testPutKeyReleaseLock: Release failed" True x2+      Just kv2 <- I.getKey ccManager (I.hostWithScheme client) ccPort "/testPutKeyReleaseLock" Nothing Nothing Nothing+      assertEqual "testPutKeyAcquireLock: Session still held" Nothing (kvSession kv2)+++ testGetKey :: TestTree testGetKey = testCase "testGetKey" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let put = KeyValuePut "/testGetKey" "Test" Nothing Nothing-  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme client) ccPort put Nothing   assertEqual "testGetKey: Write failed" True x1-  x2 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testGetKey" Nothing Nothing Nothing+  x2 <- I.getKey ccManager (I.hostWithScheme client) ccPort "/testGetKey" Nothing Nothing Nothing   case x2 of     Just x -> assertEqual "testGetKey: Incorrect Value" (kvValue x) (Just "Test")     Nothing -> assertFailure "testGetKey: No value returned"  testGetNullValueKey :: TestTree testGetNullValueKey = testCase "testGetNullValueKey" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let put = KeyValuePut "/testGetNullValueKey" "" Nothing Nothing-  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme client) ccPort put Nothing   assertEqual "testGetNullValueKey: Write failed" True x1   liftIO $ threadDelay (500 * 1000)-  x2 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testGetNullValueKey" Nothing Nothing Nothing+  x2 <- I.getKey ccManager (I.hostWithScheme client) ccPort "/testGetNullValueKey" Nothing Nothing Nothing   case x2 of     Just x -> assertEqual "testGetNullValueKey: Incorrect Value" (kvValue x) Nothing     Nothing -> assertFailure "testGetNullValueKey: No value returned"  testGetKeys :: TestTree testGetKeys = testCase "testGetKeys" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let put1 = KeyValuePut "/testGetKeys/key1" "Test" Nothing Nothing-  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put1 Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme client) ccPort put1 Nothing   assertEqual "testGetKeys: Write failed" True x1   let put2 = KeyValuePut "/testGetKeys/key2" "Test" Nothing Nothing-  x2 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put2 Nothing+  x2 <- I.putKey ccManager (I.hostWithScheme client) ccPort put2 Nothing   assertEqual "testGetKeys: Write failed" True x2-  x3 <- I.getKeys ccManager (I.hostWithScheme _client) ccPort "/testGetKeys" Nothing Nothing Nothing+  x3 <- I.getKeys ccManager (I.hostWithScheme client) ccPort "/testGetKeys" Nothing Nothing Nothing   assertEqual "testGetKeys: Incorrect number of results" 2 (length x3)  testListKeys :: TestTree testListKeys = testCase "testListKeys" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let put1 = KeyValuePut "/testListKeys/key1" "Test" Nothing Nothing-  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put1 Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme client) ccPort put1 Nothing   assertEqual "testListKeys: Write failed" True x1   let put2 = KeyValuePut "/testListKeys/key2" "Test" Nothing Nothing-  x2 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put2 Nothing+  x2 <- I.putKey ccManager (I.hostWithScheme client) ccPort put2 Nothing   assertEqual "testListKeys: Write failed" True x2-  x3 <- I.listKeys ccManager (I.hostWithScheme _client) ccPort "/testListKeys/" Nothing Nothing Nothing+  x3 <- I.listKeys ccManager (I.hostWithScheme client) ccPort "/testListKeys/" Nothing Nothing Nothing   assertEqual "testListKeys: Incorrect number of results" 2 (length x3)  testDeleteKey :: TestTree testDeleteKey = testCase "testDeleteKey" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let put1 = KeyValuePut "/testDeleteKey" "Test" Nothing Nothing-  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put1 Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme client) ccPort put1 Nothing   assertEqual "testDeleteKey: Write failed" True x1-  x2 <- I.deleteKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteKey" False Nothing+  x2 <- I.deleteKey ccManager (I.hostWithScheme client) ccPort "/testDeleteKey" False Nothing   assertEqual "testDeleteKey: Delete Failed" True x2-  x3 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteKey" Nothing Nothing Nothing+  x3 <- I.getKey ccManager (I.hostWithScheme client) ccPort "/testDeleteKey" Nothing Nothing Nothing   assertEqual "testDeleteKey: Key was not deleted" Nothing x3  testDeleteRecursive :: TestTree testDeleteRecursive = testCase "testDeleteRecursive" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let put1 = KeyValuePut "/testDeleteRecursive/1" "Test" Nothing Nothing       put2 = KeyValuePut "/testDeleteRecursive/2" "Test" Nothing Nothing-  x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put1 Nothing+  x1 <- I.putKey ccManager (I.hostWithScheme client) ccPort put1 Nothing   assertEqual "testDeleteKey: Write failed" True x1-  x2 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put2 Nothing+  x2 <- I.putKey ccManager (I.hostWithScheme client) ccPort put2 Nothing   assertEqual "testDeleteKey: Write failed" True x2-  I.deleteKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteRecursive/" True Nothing-  x3 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteRecursive/1" Nothing Nothing Nothing+  I.deleteKey ccManager (I.hostWithScheme client) ccPort "/testDeleteRecursive/" True Nothing+  x3 <- I.getKey ccManager (I.hostWithScheme client) ccPort "/testDeleteRecursive/1" Nothing Nothing Nothing   assertEqual "testDeleteKey: Key was not deleted" Nothing x3  {- Client KV -}@@ -114,53 +170,53 @@  testDeleteRecursiveClient :: TestTree testDeleteRecursiveClient = testCase "testDeleteRecursiveClient" $ do-  c <- client+  client <- newClient   let put1 = KeyValuePut "/testDeleteRecursive/1" "Test" Nothing Nothing       put2 = KeyValuePut "/testDeleteRecursive/2" "Test" Nothing Nothing-  x1 <- putKey c put1 Nothing+  x1 <- putKey client put1 Nothing   assertEqual "testDeleteKey: Write failed" True x1-  x2 <- putKey c put2 Nothing+  x2 <- putKey client put2 Nothing   assertEqual "testDeleteKey: Write failed" True x2-  deleteKey c "/testDeleteRecursive/" True Nothing-  x3 <- getKey c "/testDeleteRecursive/1" Nothing Nothing Nothing+  deleteKey client "/testDeleteRecursive/" True Nothing+  x3 <- getKey client "/testDeleteRecursive/1" Nothing Nothing Nothing   assertEqual "testDeleteKey: Key was not deleted" Nothing x3  {- Agent -} testRegisterService :: TestTree testRegisterService = testCase "testRegisterService" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let req = RegisterService Nothing "testService" ["test"] Nothing (Just $ Ttl "10s")-  val <- I.registerService ccManager (I.hostWithScheme _client) ccPort req Nothing+  val <- I.registerService ccManager (I.hostWithScheme client) ccPort req Nothing   assertEqual "testRegisterService: Service was not created" val True-  mService <- I.getService ccManager (I.hostWithScheme _client) ccPort "testService" Nothing Nothing+  mService <- I.getService ccManager (I.hostWithScheme client) ccPort "testService" Nothing Nothing   case mService of     Just _ -> return ()     Nothing -> assertFailure "testRegisterService: Service was not found"  testGetSelf :: TestTree testGetSelf = testCase "testGetSelf" $ do-  _client@ConsulClient{..} <- client-  x <- I.getSelf ccManager (I.hostWithScheme _client) ccPort+  client@ConsulClient{..} <- newClient+  x <- I.getSelf ccManager (I.hostWithScheme client) ccPort   assertEqual "testGetSelf: Self not returned" True (isJust x)  {- testRegisterHealthCheck :: TestTree testRegisterHealthCheck = testCase "testRegisterHealthCheck" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let check = RegisterHealthCheck "testHealthCheck" "testHealthCheck" "" Nothing Nothing (Just "15s")-  x1 <- I.registerHealthCheck ccManager (I.hostWithScheme _client) ccPort check+  x1 <- I.registerHealthCheck ccManager (I.hostWithScheme client) ccPort check   undefined -}  {- Health Checks -} testGetServiceHealth :: TestTree testGetServiceHealth = testCase "testGetServiceHealth" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let req = RegisterService (Just "testGetServiceHealth") "testGetServiceHealth" [] Nothing Nothing-  r1 <- I.registerService ccManager (I.hostWithScheme _client) ccPort req Nothing+  r1 <- I.registerService ccManager (I.hostWithScheme client) ccPort req Nothing   case r1 of     True -> do       liftIO $ threadDelay 1000000-      r2 <- I.getServiceHealth ccManager (I.hostWithScheme _client) ccPort "testGetServiceHealth"+      r2 <- I.getServiceHealth ccManager (I.hostWithScheme client) ccPort "testGetServiceHealth"       case r2 of         Just [x] -> return ()         Just [] -> assertFailure "testGetServiceHealth: No Services Returned"@@ -173,21 +229,21 @@ {- Session -} testCreateSession :: TestTree testCreateSession = testCase "testCreateSession" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let req = SessionRequest Nothing (Just "testCreateSession") Nothing ["serfHealth"] (Just Release) (Just "30s")-  result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing+  result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing   case result of     Just _ -> return ()     Nothing -> assertFailure "testCreateSession: No session was created"  testGetSessionInfo :: TestTree testGetSessionInfo = testCase "testGetSessionInfo" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let req = SessionRequest Nothing (Just "testGetSessionInfo") Nothing ["serfHealth"] (Just Release) (Just "30s")-  result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing+  result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing   case result of     Just x -> do-      x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort x Nothing+      x1 <- I.getSessionInfo ccManager (I.hostWithScheme client) ccPort x Nothing       case x1 of         Just _ -> return ()         Nothing -> assertFailure "testGetSessionInfo: Session Info was not returned"@@ -195,12 +251,12 @@  testRenewSession :: TestTree testRenewSession = testCase "testRenewSession" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let req = SessionRequest Nothing (Just "testRenewSession") Nothing ["serfHealth"] (Just Release) (Just "30s")-  result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing+  result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing   case result of     Just x -> do-      x1 <- I.renewSession ccManager (I.hostWithScheme _client) ccPort x Nothing+      x1 <- I.renewSession ccManager (I.hostWithScheme client) ccPort x Nothing       case x1 of         True -> return ()         False -> assertFailure "testRenewSession: Session was not renewed"@@ -208,23 +264,23 @@  testRenewNonexistentSession :: TestTree testRenewNonexistentSession = testCase "testRenewNonexistentSession" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   sessId :: UUID <- randomIO   let session = Session (toText sessId) Nothing-  x <- I.renewSession ccManager (I.hostWithScheme _client) ccPort session Nothing+  x <- I.renewSession ccManager (I.hostWithScheme client) ccPort session Nothing   case x of     True -> assertFailure "testRenewNonexistentSession: Non-existent session was renewed"     False -> return ()  testDestroySession :: TestTree testDestroySession = testCase "testDestroySession" $ do-  _client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let req = SessionRequest Nothing (Just "testDestroySession") Nothing ["serfHealth"] (Just Release) (Just "30s")-  result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing+  result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing   case result of     Just x -> do-      _ <- I.destroySession ccManager (I.hostWithScheme _client) ccPort x Nothing-      x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort x Nothing+      _ <- I.destroySession ccManager (I.hostWithScheme client) ccPort x Nothing+      x1 <- I.getSessionInfo ccManager (I.hostWithScheme client) ccPort x Nothing       assertBool "testDestroySession: Session info was returned after destruction" $ (x1 == Nothing) || (x1 == Just [])     Nothing -> assertFailure "testDestroySession: No session was created" @@ -234,7 +290,7 @@  testSessionMaintained :: TestTree testSessionMaintained = testCase "testSessionMaintained" $ do-  client@ConsulClient{..} <- client+  client@ConsulClient{..} <- newClient   let req = SessionRequest Nothing (Just "testSessionMaintained") Nothing ["serfHealth"] (Just Release) (Just "10s")   result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing   case result of@@ -247,7 +303,7 @@  testWithSessionCancel :: TestTree testWithSessionCancel = testCase "testWithSessionCancel" $ do-  client@ConsulClient{..} <- initializeConsulClient "localhost" 8500 Nothing+  client@ConsulClient{..} <- newClient   let req = SessionRequest Nothing (Just "testWithSessionCancel") Nothing ["serfHealth"] (Just Release) (Just "10s")   result <- I.createSession ccManager (I.hostWithScheme client) ccPort req Nothing   case result of@@ -256,7 +312,6 @@       assertEqual "testWithSessionCancel: Incorrect value" "Canceled" x1       z <- getSessionInfo client session Nothing       assertBool "testWithSessionCancel: Session was found" $ (z == Nothing) || (z == Just [])-     Nothing -> assertFailure "testWithSessionCancel: No session was created"   where     action :: MonadIO m => Session -> ConsulClient -> m Text@@ -271,7 +326,7 @@  testRunServiceTtl :: TestTree testRunServiceTtl = testCase "testRunServiceTtl" $ do-  client@ConsulClient{..} <- initializeConsulClient "localhost" 8500 Nothing+  client@ConsulClient{..} <- newClient   let register = RegisterService Nothing "testRunServiceTtl" [] (Just 8000) $ Just $ Ttl "10s"   runService client register (action client) Nothing   where@@ -287,6 +342,30 @@       assertBool "testRunServiceTtl: Check not passing" $ cStatus check == Passing  +{-testSequencerLostSession :: TestTree+testSequencerLostSession = testCase "testSequencerLostSession" $ do+  client@ConsulClient{..} <- initializeConsulClient "localhost" consulPort Nothing+-}++testIsValidSequencer :: TestTree+testIsValidSequencer = testCase "testIsValidSequencer" $ do+  client@ConsulClient{..} <- initializeConsulClient "localhost" consulPort Nothing+  let req = SessionRequest Nothing (Just "testIsValidSequencer") Nothing ["serfHealth"] (Just Release) (Just "10s")+  result <- createSession client req Nothing+  case result of+    Nothing -> assertFailure "testIsValidSequencer: No session was created"+    Just session -> do+      let put = KeyValuePut "/testIsValidSequencer" "Test" Nothing Nothing+      x <- putKeyAcquireLock client put session Nothing+      assertEqual "testIsValidSequencer: Write failed" True x+      Just sequencer <- getSequencerForLock client "/testIsValidSequencer" session Nothing+      result1 <- isValidSequencer client sequencer Nothing+      assertEqual "testIsValidSequencer: Valid sequencer was invalid" True result1+      _ <- destroySession client session Nothing+      result2 <- isValidSequencer client sequencer Nothing+      assertEqual "testIsValidSequencer: Invalid session was valid" False result2++ sessionWorkflowTests :: TestTree sessionWorkflowTests = testGroup "Session Workflow Tests" [testWithSessionCancel,testSessionMaintained] @@ -296,8 +375,45 @@ agentTests :: TestTree agentTests = testGroup "Agent Tests" [testGetSelf,testRegisterService] +sequencerTests :: TestTree+sequencerTests = testGroup "Sequencer Tests" [testIsValidSequencer]+ allTests :: TestTree-allTests = testGroup "All Tests" [testInternalSession, internalKVTests, sessionWorkflowTests, agentTests,testHealth, clientKVTests, runServiceTests]+allTests = testGroup "All Tests" [testInternalSession, internalKVTests, sessionWorkflowTests, agentTests,testHealth, clientKVTests, runServiceTests, sequencerTests] +-- Backwards compatible `withProcessTerm`.+withProcessTerm :: PT.ProcessConfig stdin stdout stderr -> (PT.Process stdin stdout stderr -> IO a) -> IO a+#if MIN_VERSION_typed_process(0,2,5)+withProcessTerm = PT.withProcessTerm+#else+withProcessTerm = PT.withProcess+#endif++waitForConsulOrFail :: IO ()+waitForConsulOrFail = do+  success <-+    retrying+      (constantDelay 50000 <> limitRetries 100) -- 100 times, 50 ms each+      (\_status isOpen -> return (not isOpen)) -- when to retry+      $ \_status -> do+        isPortOpen $ (simpleSockAddr (127,0,0,1) consulPort)+  when (not success) $ do+    error $ "Could not connect to Consul within reasonable time"+ main :: IO ()-main = defaultMain allTests+main = do+  -- We use a non-standard port in the test suite and spawn consul there,+  -- to ensure that the test suite doesn't mess with real consul deployments.+  withSystemTempFile "haskell-consul-test-config.json" $ \configFilePath h -> do+    BS8.hPutStrLn h "{ \"disable_update_check\": true }" >> hFlush h+    let consulProc =+          proc+            "consul"+            [ "agent", "-dev"+            , "-log-level", "err"+            , "-http-port", show (fromIntegral consulPort :: Int)+            , "-config-file", configFilePath+            ]+    withProcessTerm consulProc $ \_p -> do+      waitForConsulOrFail+      defaultMain allTests

@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}++module SocketUtils+  ( isPortOpen+  , simpleSockAddr+  ) where++import           Data.Word (Word8)+import           Foreign.C.Error (Errno(..), eCONNREFUSED)+import           GHC.IO.Exception (IOException(..))+import           Network.Socket (Socket, PortNumber, socket, connect, Family(AF_INET), SocketType(Stream), SockAddr(SockAddrInet), tupleToHostAddress)+import qualified Network.Socket as Socket+import           UnliftIO.Exception (try, bracket, throwIO)+++-- | `socket` < 2.7.0.2 does not have `close'` which throws on error,+-- which we desire for sanity.+-- If it's not available, we fall back to the silently failing one.+close'fallback :: Socket -> IO ()+close'fallback =+  -- Unfortunately, `MIN_VERSION` does not accept a 4th argument,+  -- so we have to make the check for 2.8.0.+#if MIN_VERSION_network(2,8,0)+  Socket.close'+#else+  Socket.close+#endif+++-- | Checks whether @connect()@ to a given TCPv4 `SockAddr` succeeds or+-- returns `eCONNREFUSED`.+--+-- Rethrows connection exceptions in all other cases (e.g. when the host+-- is unroutable).+isPortOpen :: SockAddr -> IO Bool+isPortOpen sockAddr = do+  bracket (socket AF_INET Stream 6 {- TCP -}) close'fallback $ \sock -> do+    res <- try $ connect sock sockAddr+    case res of+      Right () -> return True+      Left e ->+        if (Errno <$> ioe_errno e) == Just eCONNREFUSED+          then return False+          else throwIO e+++-- | Creates a `SockAttr` from host IP and port number.+--+-- Example:+-- > simpleSockAddr (127,0,0,1) 8000+simpleSockAddr :: (Word8, Word8, Word8, Word8) -> PortNumber -> SockAddr+simpleSockAddr addr port = SockAddrInet port (tupleToHostAddress addr)