consul-haskell 0.3 → 0.4

raw patch · 4 files changed

+172/−130 lines, 4 filesdep +exceptionsdep +randomdep +retryPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, random, retry, unordered-containers, uuid, vector

API changes (from Hackage documentation)

Files

• consul-haskell.cabal +8/−2
• src/Network/Consul.hs +49/−92
• src/Network/Consul/Internal.hs +37/−6
• tests/Main.hs +78/−30

@@ -1,5 +1,5 @@ name:                consul-haskell-version:             0.3+version:             0.4 synopsis:            A consul client for Haskell description:   A consul client for Haskell@@ -36,6 +36,7 @@     bytestring,     connection,     either,+    exceptions,     http-client,     http-client-tls,     http-types,@@ -43,9 +44,12 @@     lifted-base,     monad-control >= 1.0,     network,+    retry,+    stm,     text,     transformers,-    stm+    unordered-containers,+    vector   ghc-options:     -Wall @@ -63,10 +67,12 @@     consul-haskell,     http-client,     network,+    random,     tasty,     tasty-hunit,     text,     transformers,+    uuid,     HUnit                      >= 1.2   ghc-options:     -Wall

@@ -4,13 +4,15 @@ {-# LANGUAGE ScopedTypeVariables #-}  module Network.Consul (-    createManagedSession+    createSession   , deleteKey-  , destroyManagedSession+  , destroySession+  , deregisterService   , getKey   , getKeys   , getSelf   , getService+  , getServices   , getServiceHealth   , getSessionInfo   , getSequencerForLock@@ -18,26 +20,26 @@   , initializeTlsConsulClient   , isValidSequencer   , listKeys-  , ManagedSession (..)   , passHealthCheck   , putKey   , putKeyAcquireLock   , putKeyReleaseLock   , registerService+  , renewSession   , runService-  , withManagedSession-  , withSequencer   , withSession   , module Network.Consul.Types ) where  import Control.Concurrent hiding (killThread) import Control.Concurrent.Async.Lifted-import Control.Concurrent.Lifted (fork, killThread) import Control.Concurrent.STM import Control.Exception.Lifted 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@@ -88,7 +90,7 @@ putKeyReleaseLock :: MonadIO m => ConsulClient -> KeyValuePut -> Session -> Maybe Datacenter -> m Bool putKeyReleaseLock _client@ConsulClient{..} = I.putKeyReleaseLock ccManager (I.hostWithScheme _client) ccPort -deleteKey :: MonadIO m => ConsulClient -> Text -> Bool -> Maybe Datacenter -> m ()+deleteKey :: MonadIO m => ConsulClient -> Text -> Bool -> Maybe Datacenter -> m Bool deleteKey _client@ConsulClient{..} key = I.deleteKey ccManager (I.hostWithScheme _client) ccPort key  {- Health Checks -}@@ -102,10 +104,16 @@ getService :: MonadIO m => ConsulClient -> Text -> Maybe Text -> Maybe Datacenter -> m (Maybe [ServiceResult]) getService _client@ConsulClient{..} = I.getService ccManager (I.hostWithScheme _client) ccPort +getServices :: MonadIO m => ConsulClient -> Maybe Text -> Maybe Datacenter -> m [Text]+getServices _client@ConsulClient{..} = I.getServices ccManager (I.hostWithScheme _client) ccPort+ {- Agent -} getSelf :: MonadIO m => ConsulClient -> m (Maybe Self) getSelf _client@ConsulClient{..} = I.getSelf ccManager (I.hostWithScheme _client) ccPort +deregisterService :: MonadIO m => ConsulClient -> Text -> m ()+deregisterService _client@ConsulClient{..} = I.deregisterService ccManager (I.hostWithScheme _client) ccPort + registerService :: MonadIO m => ConsulClient -> RegisterService -> Maybe Datacenter -> m Bool registerService _client@ConsulClient{..} = I.registerService ccManager (I.hostWithScheme _client) ccPort @@ -120,56 +128,44 @@                         a <- async $ ttlFunc x                         return $ Just a                       _ -> return Nothing-      _foo :: () <- wait mainFunc+      _foo :: () <- wait mainFunc --prevent: 'StM’ is a type function, and may not be injective       case checkAction of         Just a -> cancel a         Nothing -> return ()     False -> return ()   where     ttlFunc y@(Ttl x) = do-      (do-        let ttl = parseTtl x-        liftIO $ threadDelay $ (ttl - (fromIntegral $ floor (fromIntegral ttl / fromIntegral 2))) * 1000000-        let checkId = T.concat["service:",maybe (rsName request) id (rsId request)]-        passHealthCheck client checkId dc) `catch` (\ e -> do-           let _x :: SomeException = e-           return ())-      ttlFunc y+      let ttl = parseTtl x+      liftIO $ threadDelay $ (ttl - (fromIntegral $ floor (fromIntegral ttl / fromIntegral 2))) * 1000000+      let checkId = T.concat["service:",maybe (rsName request) id (rsId request)]+      passHealthCheck client checkId dc  {- Session -}-getSessionInfo :: MonadIO m => ConsulClient -> Text -> Maybe Datacenter -> m (Maybe [SessionInfo])-getSessionInfo _client@ConsulClient{..} = I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort+createSession :: MonadIO m => ConsulClient -> SessionRequest -> Maybe Datacenter -> m (Maybe Session)+createSession client@ConsulClient{..} = I.createSession ccManager (I.hostWithScheme client) ccPort -withSession :: forall a m. (MonadIO m,MonadBaseControl IO m) => ConsulClient -> Session -> (Session -> m a) -> m a -> m a-withSession client session action lostAction = do-  var <- liftIO $ newEmptyTMVarIO-  tidVar <- liftIO $ newEmptyTMVarIO-  stid <- fork $ runThread var tidVar-  tid <- fork $ action session >>= \ x -> liftIO $ atomically $ putTMVar var x-  liftIO $ atomically $ putTMVar tidVar tid-  ret <- liftIO $ atomically $ takeTMVar var-  killThread stid-  return ret+destroySession :: MonadIO m => ConsulClient -> Session -> Maybe Datacenter ->  m ()+destroySession client@ConsulClient{..} = I.destroySession ccManager (I.hostWithScheme client) ccPort++renewSession :: MonadIO m => ConsulClient -> Session -> Maybe Datacenter ->  m Bool+renewSession client@ConsulClient{..} = I.renewSession ccManager (I.hostWithScheme client) ccPort++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 client@ConsulClient{..} name delay session action lostAction = (do+  withAsync (action session) $ \ mainAsync -> withAsync extendSession $ \ extendAsync -> do+    result :: a <- return . snd =<< waitAnyCancel [mainAsync,extendAsync]+    return result) `finally` (destroySession client session Nothing)   where-    runThread :: TMVar a -> TMVar ThreadId -> m ()-    runThread var threadVar = do-      liftIO $ threadDelay (10 * 1000000)-      x <- getSessionInfo client (sId session) Nothing+    extendSession :: m a+    extendSession = do+      liftIO $ threadDelay $ (delay * 1000000)+      x <- renewSession client session Nothing       case x of-        Just [] -> cancelAction var threadVar-        Nothing -> cancelAction var threadVar-        Just _ -> runThread var threadVar--    cancelAction :: TMVar a -> TMVar ThreadId -> m ()-    cancelAction resultVar tidVar = do-      tid <- liftIO $ atomically $ readTMVar tidVar-      killThread tid-      empty <- liftIO $ atomically $ isEmptyTMVar resultVar-      if empty then do-        result <- lostAction-        liftIO $ atomically $ putTMVar resultVar result-        return ()-        else return ()+        True -> extendSession+        False -> lostAction  getSequencerForLock :: MonadIO m => ConsulClient -> Text -> Session -> Maybe Datacenter -> m (Maybe Sequencer) getSequencerForLock client key session datacenter = do@@ -186,55 +182,16 @@   case mkv of     Just kv -> return $ (maybe False ((sId $ sSession sequencer) ==) $ kvSession kv) && (kvLockIndex kv) == (sLockIndex sequencer)     Nothing -> return False--withSequencer :: (MonadBaseControl IO m, MonadIO m) => ConsulClient -> Sequencer -> m a -> m a -> Int -> Maybe Datacenter -> m a-withSequencer client sequencer action lostAction delay dc = do-  mainFunc <- async action-  pulseFunc <- async pulseLock-  waitAny [mainFunc, pulseFunc] >>= return . snd+{- +withSequencer :: (MonadBaseControl IO m, MonadIO m, MonadMask 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   where-    pulseLock = do+    pulseLock = recoverAll (exponentialBackoff 50000 <>  limitRetries 5) $ \ _ -> do       liftIO $ threadDelay delay       valid <- isValidSequencer client sequencer dc       case valid of         True -> pulseLock         False -> lostAction--{- Helper Functions -}-{- ManagedSession is a session with an associated TTL healthcheck so the session will be terminated if the client dies. The healthcheck will be automatically updated. -}-data ManagedSession = ManagedSession{-  msSession :: Session,-  msThreadId :: ThreadId-}--withManagedSession :: (MonadBaseControl IO m, MonadIO m) => ConsulClient -> Text -> (Session -> m ()) -> m () -> m ()-withManagedSession client ttl action lostAction = do-  x <- createManagedSession client Nothing ttl-  case x of-    Just s -> withSession client (msSession s) action lostAction >> destroyManagedSession client s-    Nothing -> lostAction--createManagedSession :: MonadIO m => ConsulClient -> Maybe Text -> Text -> m (Maybe ManagedSession)-createManagedSession _client@ConsulClient{..} name ttl = do-  let r = SessionRequest Nothing name Nothing [] (Just Release) (Just ttl)-  s <- I.createSession ccManager (I.hostWithScheme _client) ccPort r Nothing-  mapM f s-  where-    f x = do-      tid <- liftIO $ forkIO $ runThread x-      return $ ManagedSession x tid--    saneTtl = let Right (x,_) = TR.decimal $ T.filter (/= 's') ttl in x--    runThread :: Session -> IO ()-    runThread s = do-      threadDelay $ (saneTtl - (saneTtl - 10)) * 1000000-      x <- I.renewSession ccManager (I.hostWithScheme _client) ccPort s Nothing-      case x of-        True -> runThread s-        False -> return ()--destroyManagedSession :: MonadIO m => ConsulClient -> ManagedSession -> m ()-destroyManagedSession _client@ConsulClient{..} (ManagedSession session tid) = do-  liftIO $ killThread tid-  I.destroySession ccManager (I.hostWithScheme _client) ccPort session Nothing+-}

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -37,15 +38,18 @@   --Catalog   , getDatacenters   , getService+  , getServices   ) where  import Control.Monad.IO.Class-import Data.Aeson (decode,encode)+import Data.Aeson (Value(..), decode,encode) import Data.ByteString (ByteString) import qualified Data.ByteString as B --import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as H import Data.Maybe+import qualified Data.Vector as V import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -64,13 +68,23 @@   let baseUrl = T.concat [hostWithScheme,":",T.pack $ show portNumber,endpoint,needQueryString                          ,maybe "" id query, prefixAnd, maybe "" (\ (Datacenter x) -> T.concat["dc=",x]) dc]   initReq <- liftIO $ parseUrl $ T.unpack baseUrl+#if MIN_VERSION_http_client(0,5,0)   case body of+      Just x -> return $ indef $ initReq{ method = "PUT", requestBody = RequestBodyBS x, checkResponse = \ _ _ -> return ()}+      Nothing -> return $ indef $ initReq{checkResponse = \ _ _ -> return ()}+#else+  case body of     Just x -> return $ indef $ initReq{ method = "PUT", requestBody = RequestBodyBS x, checkStatus = \ _ _ _ -> Nothing}     Nothing -> return $ indef $ initReq{checkStatus = \ _ _ _ -> Nothing}+#endif   where     needQueryString = if isJust dc || isJust query then "?" else ""     prefixAnd = if isJust query && isJust dc then "&" else ""+#if MIN_VERSION_http_client(0,5,0)+    indef req = if wait == True then req{responseTimeout = responseTimeoutNone} else req+#else     indef req = if wait == True then req{responseTimeout = Nothing} else req+#endif  {- Key Value Store -} getKey :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Word64 -> Maybe Consistency -> Maybe Datacenter -> m (Maybe Network.Consul.Types.KeyValue)@@ -172,13 +186,17 @@     query = T.intercalate "&" $ catMaybes [flags,cas,Just release]     fquery = if query /= T.empty then Just query else Nothing -deleteKey :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Bool -> Maybe Datacenter -> m ()+deleteKey :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Bool -> Maybe Datacenter -> m Bool deleteKey manager hostname portNumber key recurse dc = do   initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", key]) (if recurse then Just "recurse" else Nothing) Nothing False dc   let httpReq = initReq { method = "DELETE"}   liftIO $ withResponse httpReq manager $ \ response -> do-    _bodyParts <- brConsume $ responseBody response-    return ()+    bodyParts <- brConsume $ responseBody response+    let body = B.concat bodyParts+    case TE.decodeUtf8 body of+      "true" -> return True+      "false" -> return False+      _ -> return False  {- Agent -} {-getHealthChecks :: MonadIO m => Manager -> Text -> PortNumber -> Maybe Datacenter -> m [Check]@@ -289,8 +307,8 @@       x | x == status200 -> return True       _ -> return False -getSessionInfo :: MonadIO m => Manager -> Text -> PortNumber -> Text -> Maybe Datacenter -> m (Maybe [SessionInfo])-getSessionInfo manager hostname portNumber session dc = do+getSessionInfo :: MonadIO m => Manager -> Text -> PortNumber -> Session -> Maybe Datacenter -> m (Maybe [SessionInfo])+getSessionInfo manager hostname portNumber (Session session _) dc = do   req <- createRequest hostname portNumber (T.concat ["/v1/session/info/",session]) Nothing Nothing False dc   liftIO $ withResponse req manager $ \ response -> do     case responseStatus response of@@ -317,3 +335,16 @@   liftIO $ withResponse req manager $ \ response -> do     bodyParts <- brConsume $ responseBody response     return $ decode $ BL.fromStrict $ B.concat bodyParts++getServices :: MonadIO m => Manager -> Text -> PortNumber -> Maybe Text -> Maybe Datacenter -> m [Text]+getServices manager hostname portNumber tag dc = do+    req <- createRequest hostname portNumber "/v1/catalog/services" Nothing Nothing False dc+    liftIO $ withResponse req manager $ \ response -> do+        bodyParts <- brConsume $ responseBody response+        return $ parseServices tag $ decode $ BL.fromStrict $ B.concat bodyParts+  where+    parseServices t (Just (Object v)) = filterTags t $ H.toList v+    parseServices _   _               = []+    filterTags :: Maybe Text -> [(Text, Value)] -> [Text]+    filterTags (Just t)               = map fst . filter (\ (_, (Array v)) -> (String t) `V.elem` v)+    filterTags Nothing                = map fst

@@ -1,14 +1,18 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+ import Control.Concurrent import Control.Monad.IO.Class import Data.Maybe import Data.Text (Text)-import Network.Consul (createManagedSession,getSessionInfo,initializeConsulClient,withSession,ConsulClient(..),ManagedSession(..))+import Data.UUID+import Network.Consul (deleteKey,getKey,getSessionInfo,initializeConsulClient,putKey,withSession,ConsulClient(..)) import Network.Consul.Types import qualified Network.Consul.Internal as I import Network.HTTP.Client import Network.Socket (PortNumber(..))+import System.Random import Test.Tasty import Test.Tasty.HUnit @@ -18,7 +22,7 @@ {- Internal Tests -} internalKVTests :: TestTree internalKVTests = testGroup "Internal Key Value" [testGetInvalidKey, testPutKey,-  testGetKey,testGetKeys,testListKeys,testDeleteKey,testGetNullValueKey]+  testGetKey,testGetKeys,testListKeys,testDeleteKey,testGetNullValueKey,testDeleteRecursive]  testGetInvalidKey :: TestTree testGetInvalidKey = testCase "testGetInvalidKey" $ do@@ -56,7 +60,6 @@     Just x -> assertEqual "testGetNullValueKey: Incorrect Value" (kvValue x) Nothing     Nothing -> assertFailure "testGetNullValueKey: No value returned" - testGetKeys :: TestTree testGetKeys = testCase "testGetKeys" $ do   _client@ConsulClient{..} <- client@@ -87,10 +90,42 @@   let put1 = KeyValuePut "/testDeleteKey" "Test" Nothing Nothing   x1 <- I.putKey ccManager (I.hostWithScheme _client) ccPort put1 Nothing   assertEqual "testDeleteKey: Write failed" True x1-  I.deleteKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteKey" False Nothing-  x2 <- I.getKey ccManager (I.hostWithScheme _client) ccPort "/testDeleteKey" Nothing Nothing Nothing-  assertEqual "testDeleteKey: Key was not deleted" Nothing x2+  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+  assertEqual "testDeleteKey: Key was not deleted" Nothing x3+  print x3 +testDeleteRecursive :: TestTree+testDeleteRecursive = testCase "testDeleteRecursive" $ do+  _client@ConsulClient{..} <- client+  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+  assertEqual "testDeleteKey: Write failed" True x1+  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+  assertEqual "testDeleteKey: Key was not deleted" Nothing x3++{- Client KV -}+clientKVTests :: TestTree+clientKVTests = testGroup "Client KV Tests" [testDeleteRecursiveClient]++testDeleteRecursiveClient :: TestTree+testDeleteRecursiveClient = testCase "testDeleteRecursiveClient" $ do+  c <- client+  let put1 = KeyValuePut "/testDeleteRecursive/1" "Test" Nothing Nothing+      put2 = KeyValuePut "/testDeleteRecursive/2" "Test" Nothing Nothing+  x1 <- putKey c put1 Nothing+  assertEqual "testDeleteKey: Write failed" True x1+  x2 <- putKey c put2 Nothing+  assertEqual "testDeleteKey: Write failed" True x2+  deleteKey c "/testDeleteRecursive/" True Nothing+  x3 <- getKey c "/testDeleteRecursive/1" Nothing Nothing Nothing+  assertEqual "testDeleteKey: Key was not deleted" Nothing x3+ {- Agent -} testRegisterService :: TestTree testRegisterService = testCase "testRegisterService" $ do@@ -149,7 +184,7 @@   result <- I.createSession ccManager (I.hostWithScheme _client) ccPort req Nothing   case result of     Just x -> do-      x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort (sId 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"@@ -168,6 +203,16 @@         False -> assertFailure "testRenewSession: Session was not renewed"     Nothing -> assertFailure "testRenewSession: No session was created" +testRenewNonexistentSession :: TestTree+testRenewNonexistentSession = testCase "testRenewNonexistentSession" $ do+  _client@ConsulClient{..} <- client+  sessId :: UUID <- randomIO+  let session = Session (toText sessId) 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@@ -176,56 +221,59 @@   case result of     Just x -> do       _ <- I.destroySession ccManager (I.hostWithScheme _client) ccPort x Nothing-      x1 <- I.getSessionInfo ccManager (I.hostWithScheme _client) ccPort (sId x) Nothing-      assertEqual "testDestroySession: Session info was returned after destruction" Nothing x1+      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"  testInternalSession :: TestTree-testInternalSession = testGroup "Internal Session Tests" [testCreateSession, testGetSessionInfo, testRenewSession, testDestroySession]+testInternalSession = testGroup "Internal Session Tests" [testCreateSession, testGetSessionInfo, testRenewSession, testRenewNonexistentSession, testDestroySession] -{- Managed Session -}-testCreateManagedSession :: TestTree-testCreateManagedSession = testCase "testCreateManagedSession" $ do-  client <- initializeConsulClient "localhost" 8500 Nothing-  x <- createManagedSession client (Just "testCreateManagedSession") "60s"-  assertEqual "testCreateManagedSession: Session not created" True (isJust x)  testSessionMaintained :: TestTree testSessionMaintained = testCase "testSessionMaintained" $ do-  client <- initializeConsulClient "localhost" 8500 Nothing-  x <- createManagedSession client (Just "testCreateManagedSession") "10s"-  assertEqual "testSessionMaintained: Session not created" True (isJust x)-  let (Just foo) = x-  threadDelay (12 * 1000000)-  y <- getSessionInfo client (sId $ msSession foo) Nothing-  assertEqual "testSessionMaintained: Session not found" True (isJust y)+  client@ConsulClient{..} <- client+  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+    Just session -> do+      threadDelay (12 * 1000000)+      y <- getSessionInfo client session Nothing+      assertEqual "testSessionMaintained: Session not found" True (isJust y)+    Nothing -> assertFailure "testSessionMaintained: No Session was created" + testWithSessionCancel :: TestTree testWithSessionCancel = testCase "testWithSessionCancel" $ do   client@ConsulClient{..} <- initializeConsulClient "localhost" 8500 Nothing   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-    Just x -> do-      x1 <- withSession client x (\ y -> action y client ) cancelAction+    Just session -> do+      x1 <- withSession client Nothing 5 session (\ y -> action y client ) cancelAction       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     action x client@ConsulClient{..} = do       I.destroySession ccManager (I.hostWithScheme client) ccPort x Nothing-      threadDelay (30 * 1000000)+      liftIO $ threadDelay (30 * 1000000)       return ("NotCanceled" :: Text)++    cancelAction :: MonadIO m => m Text     cancelAction = return ("Canceled" :: Text)  -managedSessionTests :: TestTree-managedSessionTests = testGroup "Managed Session Tests" [ testCreateManagedSession, testSessionMaintained, testWithSessionCancel]+sessionWorkflowTests :: TestTree+sessionWorkflowTests = testGroup "Session Workflow Tests" [testWithSessionCancel,testSessionMaintained]  agentTests :: TestTree agentTests = testGroup "Agent Tests" [testGetSelf,testRegisterService]  allTests :: TestTree-allTests = testGroup "All Tests" [testInternalSession, internalKVTests, managedSessionTests, agentTests,testHealth]+allTests = testGroup "All Tests" [testInternalSession, internalKVTests, sessionWorkflowTests, agentTests,testHealth, clientKVTests]  main :: IO () main = defaultMain allTests