consul-haskell 0.1 → 0.2
raw patch · 5 files changed
+349/−38 lines, 5 filesdep +http-typesdep +lifted-asyncdep +lifted-base
Dependencies added: http-types, lifted-async, lifted-base, monad-control, stm
Files
- consul-haskell.cabal +9/−2
- src/Network/Consul.hs +98/−11
- src/Network/Consul/Internal.hs +37/−15
- src/Network/Consul/Types.hs +93/−7
- tests/Main.hs +112/−3
consul-haskell.cabal view
@@ -1,5 +1,5 @@ name: consul-haskell-version: 0.1+version: 0.2 synopsis: A consul client for Haskell description: A consul client for Haskell@@ -35,9 +35,14 @@ base64-bytestring, bytestring, http-client,+ http-types,+ lifted-async,+ lifted-base,+ monad-control, network, text,- transformers+ transformers,+ stm ghc-options: -Wall @@ -57,6 +62,8 @@ network, tasty, tasty-hunit,+ text,+ transformers, HUnit >= 1.2 ghc-options: -Wall
src/Network/Consul.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -8,12 +9,19 @@ , destroyManagedSession , getKey , getKeys+ , getSelf+ , getSessionInfo+ , getSequencerForLock , initializeConsulClient+ , isValidSequencer , listKeys , putKey , putKeyAcquireLock , putKeyReleaseLock+ , registerService , withManagedSession+ , withSequencer+ , withSession , Consistency(..) , ConsulClient(..) , Datacenter(..)@@ -23,16 +31,23 @@ , Session(..) ) where -import Control.Concurrent+import Control.Concurrent hiding (killThread)+import Control.Concurrent.Async.Lifted hiding (cancel)+import Control.Concurrent.Lifted (fork, killThread)+import Control.Concurrent.STM import Control.Monad.IO.Class+import Control.Monad.Trans.Control import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as TR import Data.Traversable-import qualified Network.Consul.Internal as I import Data.Word+import qualified Network.Consul.Internal as I import Network.Consul.Types import Network.HTTP.Client (defaultManagerSettings, newManager, Manager) import Network.Socket (PortNumber) + import Prelude hiding (mapM) initializeConsulClient :: MonadIO m => Text -> PortNumber -> Maybe Manager -> m ConsulClient@@ -67,23 +82,91 @@ deleteKey _client@ConsulClient{..} key = I.deleteKey ccManager ccHostname ccPort key {- Agent -}+getSelf :: MonadIO m => ConsulClient -> m (Maybe Self)+getSelf _client@ConsulClient{..} = I.getSelf ccManager ccHostname ccPort -{- Helper Functions -}+registerService :: MonadIO m => ConsulClient -> RegisterService -> Maybe Datacenter -> m Bool+registerService _client@ConsulClient{..} = I.registerService ccManager ccHostname ccPort +{- Session -}+getSessionInfo :: MonadIO m => ConsulClient -> Text -> Maybe Datacenter -> m (Maybe [SessionInfo])+getSessionInfo _client@ConsulClient{..} = I.getSessionInfo ccManager ccHostname 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+ where+ runThread :: TMVar a -> TMVar ThreadId -> m ()+ runThread var threadVar = do+ liftIO $ threadDelay (10 * 1000000)+ x <- getSessionInfo client (sId session) Nothing+ case x of+ Just [] -> cancel var threadVar+ Nothing -> cancel var threadVar+ Just _ -> runThread var threadVar++ cancel :: TMVar a -> TMVar ThreadId -> m ()+ cancel 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 ()++getSequencerForLock :: MonadIO m => ConsulClient -> Text -> Session -> Maybe Datacenter -> m (Maybe Sequencer)+getSequencerForLock client key session datacenter = do+ kv <- getKey client key Nothing (Just Consistent) datacenter+ case kv of+ Just k -> do+ let isValid = maybe False ((sId session) ==) $ kvSession k+ if isValid then return $ Just $ Sequencer key (kvLockIndex k) session else return Nothing+ Nothing -> return Nothing++isValidSequencer :: MonadIO m => ConsulClient -> Sequencer -> Maybe Datacenter -> m Bool+isValidSequencer client sequencer datacenter = do+ mkv <- getKey client (sKey sequencer) Nothing (Just Consistent) datacenter+ 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+ where+ pulseLock = 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 :: MonadIO m => ConsulClient -> Int -> (Session -> m ()) -> m ()-withManagedSession client ttl action = do+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 -> action (msSession s) >> destroyManagedSession client s- Nothing -> return ()+ Just s -> withSession client (msSession s) action lostAction >> destroyManagedSession client s+ Nothing -> lostAction -createManagedSession :: MonadIO m => ConsulClient -> Maybe Text -> Int -> m (Maybe ManagedSession)+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 ccHostname ccPort r Nothing@@ -93,11 +176,15 @@ 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 10- I.renewSession ccManager ccHostname ccPort s Nothing- return ()+ threadDelay $ (saneTtl - (saneTtl - 10)) * 1000000+ x <- I.renewSession ccManager ccHostname ccPort s Nothing+ case x of+ True -> runThread s+ False -> return () destroyManagedSession :: MonadIO m => ConsulClient -> ManagedSession -> m () destroyManagedSession _client@ConsulClient{..} (ManagedSession session tid) = do
src/Network/Consul/Internal.hs view
@@ -14,6 +14,7 @@ , deregisterHealthCheck , deregisterService , failHealthCheck+ , getSelf , passHealthCheck , registerHealthCheck , registerService@@ -26,6 +27,7 @@ -- Session , createSession , destroySession+ , getSessionInfo , renewSession --Catalog@@ -44,6 +46,7 @@ import Data.Word import Network.Consul.Types import Network.HTTP.Client+import Network.HTTP.Types import Network.Socket (PortNumber(..)) createRequest :: MonadIO m => Text -> PortNumber -> Text -> Maybe Text -> Maybe ByteString -> Bool -> Maybe Datacenter -> m Request@@ -65,7 +68,7 @@ request <- createRequest hostname portnumber (T.concat ["/v1/kv/",key]) fquery Nothing (isJust index) dc liftIO $ withResponse request manager $ \ response -> do case responseStatus response of- _status200 -> do+ x | x == status200 -> do bodyParts <- brConsume $ responseBody response let body = B.concat bodyParts return $ listToMaybe =<< (decode $ BL.fromStrict body)@@ -81,7 +84,7 @@ request <- createRequest hostname portnumber (T.concat ["/v1/kv/",key]) fquery Nothing (isJust index) dc liftIO $ withResponse request manager $ \ response -> do case responseStatus response of- _status200 -> do+ x | x == status200 -> do bodyParts <- brConsume $ responseBody response let body = B.concat bodyParts return $ maybe [] id $ decode $ BL.fromStrict body@@ -98,7 +101,7 @@ initReq <- createRequest hostname portNumber (T.concat ["/v1/kv/", prefix]) fquery Nothing (isJust index) dc liftIO $ withResponse initReq manager $ \ response -> case responseStatus response of- _status200 -> do+ x | x == status200 -> do bodyParts <- brConsume $ responseBody response let body = B.concat bodyParts return $ maybe [] id $ decode $ BL.fromStrict body@@ -210,13 +213,13 @@ _bodyParts <- brConsume $ responseBody response return () -registerService :: MonadIO m => Manager -> Text -> PortNumber -> RegisterService -> m ()-registerService manager hostname (PortNum portNumber) request = do- initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/service/register"]- let httpReq = initReq { method = "PUT", requestBody = RequestBodyBS $ BL.toStrict $ encode request}- liftIO $ withResponse httpReq manager $ \ response -> do- _bodyParts <- brConsume $ responseBody response- return ()+registerService :: MonadIO m => Manager -> Text -> PortNumber -> RegisterService -> Maybe Datacenter -> m Bool+registerService manager hostname portNumber request dc = do+ initReq <- createRequest hostname portNumber "/v1/agent/service/register" Nothing (Just $ BL.toStrict $ encode request) False dc+ liftIO $ withResponse initReq manager $ \ response -> do+ case responseStatus response of+ x | x == status200 -> return True+ _ -> return False deregisterService :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m () deregisterService manager hostname (PortNum portNumber) service = do@@ -225,7 +228,15 @@ _bodyParts <- brConsume $ responseBody response return () +getSelf :: MonadIO m => Manager -> Text -> PortNumber -> m (Maybe Self)+getSelf manager hostname (PortNum portNumber) = do+ initReq <- liftIO $ parseUrl $ T.unpack $ T.concat ["http://",hostname, ":", T.pack $ show portNumber ,"/v1/agent/self"]+ liftIO $ withResponse initReq manager $ \ response -> do+ bodyParts <- brConsume $ responseBody response+ let body = B.concat bodyParts+ return $ decode $ BL.fromStrict body + {- Health -} getServiceChecks :: MonadIO m => Manager -> Text -> PortNumber -> Text -> m [Check] getServiceChecks manager hostname (PortNum portNumber) name = do@@ -249,7 +260,7 @@ initReq <- createRequest hostname portNumber "/v1/session/create" Nothing (Just $ BL.toStrict $ encode request) False dc liftIO $ withResponse initReq manager $ \ response -> do case responseStatus response of- status200 -> do+ x | x == status200 -> do bodyParts <- brConsume $ responseBody response return $ decode $ BL.fromStrict $ B.concat bodyParts _ -> return Nothing@@ -257,16 +268,27 @@ destroySession :: MonadIO m => Manager -> Text -> PortNumber -> Session -> Maybe Datacenter -> m () destroySession manager hostname portNumber (Session session _) dc = do initReq <- createRequest hostname portNumber (T.concat ["/v1/session/destroy/", session]) Nothing Nothing False dc- liftIO $ withResponse initReq manager $ \ response -> do- return ()+ let req = initReq{method = "PUT"}+ liftIO $ withResponse req manager $ \ _response -> return () renewSession :: MonadIO m => Manager -> Text -> PortNumber -> Session -> Maybe Datacenter -> m Bool renewSession manager hostname portNumber (Session session _) dc = do initReq <- createRequest hostname portNumber (T.concat ["/v1/session/renew/", session]) Nothing Nothing False dc- liftIO $ withResponse initReq manager $ \ response -> do+ let req = initReq{method = "PUT"}+ liftIO $ withResponse req manager $ \ response -> do case responseStatus response of- status200 -> return True+ 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+ req <- createRequest hostname portNumber (T.concat ["/v1/session/info/",session]) Nothing Nothing False dc+ liftIO $ withResponse req manager $ \ response -> do+ case responseStatus response of+ x | x == status200 -> do+ bodyParts <- brConsume $ responseBody response+ return $ decode $ BL.fromStrict $ B.concat bodyParts+ _ -> return Nothing {- Catalog -} getDatacenters :: MonadIO m => Manager -> Text -> PortNumber -> m [Datacenter]
src/Network/Consul/Types.hs view
@@ -1,26 +1,35 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Network.Consul.Types ( Check(..),+ Config(..), Consistency(..), ConsulClient(..), Datacenter (..), Health(..),+ HealthCheck(..), KeyValue(..), KeyValuePut(..),+ Member(..),+ Node(..), RegisterRequest(..), RegisterHealthCheck(..), RegisterService(..),+ Self(..),+ Service(..), Session(..), SessionBehavior(..),- SessionRequest(..)+ SessionInfo(..),+ SessionRequest(..),+ Sequencer(..) ) where -import Control.Applicative import Control.Monad import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64+import Data.Foldable import Data.Int import Data.Text(Text) import qualified Data.Text.Encoding as TE@@ -43,6 +52,8 @@ data SessionBehavior = Release | Delete deriving (Eq,Show,Enum,Ord) +data HealthCheck = Script Text Text | Ttl Text | Http Text deriving (Eq,Show,Ord)+ data KeyValue = KeyValue { kvCreateIndex :: Word64, kvLockIndex :: Word64,@@ -63,17 +74,36 @@ data Session = Session { sId :: Text, sCreateIndex :: Maybe Word64-}+} deriving (Show) +data SessionInfo = SessionInfo {+ siLockDelay :: Maybe Word64,+ siChecks :: [Text],+ siNode :: Text,+ siId :: Text,+ siBehavior :: Maybe SessionBehavior,+ siCreateIndex :: Word64,+ siName :: Maybe Text,+ siTtl :: Maybe Text+} deriving (Eq,Show)++newtype SessionInfoList = SessionInfoList [SessionInfo]+ data SessionRequest = SessionRequest { srLockDelay :: Maybe Text, srName :: Maybe Text, srNode :: Maybe Node, srChecks :: [Text], srBehavor :: Maybe SessionBehavior,- srTtl :: Maybe Int+ srTtl :: Maybe Text } +data Sequencer = Sequencer{+ sKey :: Text,+ sLockIndex :: Word64,+ sSession :: Session+}+ data RegisterRequest = RegisterRequest { rrDatacenter :: Maybe Datacenter, rrNode :: Text,@@ -120,9 +150,35 @@ rsName :: Text, rsTags :: [Text], rsPort :: Maybe Int16,- rsCheck :: Either (Text,Text) Text -- (script,interval) ttl+ rsCheck :: Maybe HealthCheck } +data Self = Self{+ sMember :: Member+} deriving (Show)++data Config = Config{+ cBootstrap :: Bool,+ cServer :: Bool,+ cDatacenter :: Datacenter,+ cDataDir :: Text,+ cClientAddr :: Text+}++data Member = Member{+ mName :: Text,+ mAddress :: Text,+ mPort :: Int ,+ mTags :: Object,+ mStatus :: Int,+ mProtocolMin :: Int,+ mProtocolMax :: Int,+ mProtocolCur :: Int,+ mDelegateMin :: Int,+ mDelegateMax :: Int,+ mDelegateCur :: Int+} deriving (Show)+ {- Health -} data Health = Health { hNode :: Node,@@ -132,6 +188,18 @@ {- JSON Instances -}+instance FromJSON Self where+ parseJSON (Object v) = Self <$> v .: "Member"+ parseJSON _ = mzero++instance FromJSON Config where+ parseJSON (Object v) = Config <$> v .: "Bootstrap" <*> v .: "Server" <*> v .: "Datacenter" <*> v .: "DataDir" <*> v .: "ClientAddr"+ parseJSON _ = mzero++instance FromJSON Member where+ parseJSON (Object v) = Member <$> v .: "Name" <*> v .: "Addr" <*> v .: "Port" <*> v .: "Tags" <*> v .: "Status" <*> v .: "ProtocolMin" <*> v .: "ProtocolMax" <*> v .: "ProtocolCur" <*> v .: "DelegateMin" <*> v .: "DelegateMax" <*> v .: "DelegateCur"+ parseJSON _ = mzero+ instance FromJSON HealthCheckStatus where parseJSON (String "Critical") = pure Critical parseJSON (String "Passing") = pure Passing@@ -167,15 +235,33 @@ parseJSON (Object x) = Session <$> x .: "ID" <*> pure Nothing parseJSON _ = mzero +instance FromJSON SessionInfoList where+ parseJSON (Array x) = SessionInfoList <$> traverse parseJSON (toList x)+ parseJSON _ = mzero++instance FromJSON SessionInfo where+ parseJSON (Object x) = SessionInfo <$> x .:? "LockDelay" <*> x .: "Checks" <*> x .: "Node" <*> x .: "ID" <*> x .:? "Behavior" <*> x .: "CreateIndex" <*> x .:? "Name" <*> x .:? "TTL"+ parseJSON _ = mzero++instance FromJSON SessionBehavior where+ parseJSON (String "release") = pure Release+ parseJSON (String "delete") = pure Delete+ parseJSON _ = mzero+ instance ToJSON SessionBehavior where toJSON Release = String "release" toJSON Delete = String "delete" instance ToJSON RegisterHealthCheck where- toJSON (RegisterHealthCheck id name notes script interval ttl) = object ["id" .= id, "name" .= name, "notes" .= notes, "script" .= script, "interval" .= interval, "ttl" .= ttl]+ toJSON (RegisterHealthCheck i name notes script interval ttl) = object ["id" .= i, "name" .= name, "notes" .= notes, "script" .= script, "interval" .= interval, "ttl" .= ttl] instance ToJSON RegisterService where- toJSON (RegisterService id name tags port check) = object ["ID" .= id, "Name" .= name, "Tags" .= tags, "Port" .= port, "Check" .= check]+ toJSON (RegisterService i name tags port check) = object ["ID" .= i, "Name" .= name, "Tags" .= tags, "Port" .= port, "Check" .= check]++instance ToJSON HealthCheck where+ toJSON (Ttl x) = object ["TTL" .= x]+ toJSON (Http x) = object ["HTTP" .= x]+ toJSON (Script x y) = object ["Script" .= x, "Interval" .= y] instance ToJSON SessionRequest where toJSON (SessionRequest lockDelay name node checks behavior ttl) = object["LockDelay" .= lockDelay, "Name" .= name, "Node" .= (fmap nNode node), "Checks" .= checks, "Behavior" .= behavior, "TTL" .= ttl]
tests/Main.hs view
@@ -1,4 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+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 Network.Consul.Types import qualified Network.Consul.Internal as I import Network.HTTP.Client@@ -76,8 +81,16 @@ testRegisterService :: TestTree testRegisterService = testCase "testRegisterService" $ do man <- manager- let req = RegisterService Nothing "testService" ["test"] Nothing (Right "10s")- I.registerService man "localhost" (PortNum 8500) req+ let req = RegisterService Nothing "testService" ["test"] Nothing (Just $ Ttl "10s")+ val <- I.registerService man "localhost" (PortNum 8500) req Nothing+ assertEqual "testRegisterService: Service was not created" val True++testGetSelf :: TestTree+testGetSelf = testCase "testGetSelf" $ do+ man <- manager+ x <- I.getSelf man "localhost" (PortNum 8500)+ assertEqual "testGetSelf: Self not returned" True (isJust x)+ {- testRegisterHealthCheck :: TestTree testRegisterHealthCheck = testCase "testRegisterHealthCheck" $ do@@ -89,5 +102,101 @@ {- Health Checks -} --testServiceChecks :: +{- Session -}+testCreateSession :: TestTree+testCreateSession = testCase "testCreateSession" $ do+ man <- manager+ let req = SessionRequest Nothing (Just "testCreateSession") Nothing ["serfHealth"] (Just Release) (Just "30s")+ result <- I.createSession man "localhost" (PortNum 8500) req Nothing+ case result of+ Just _ -> return ()+ Nothing -> assertFailure "testCreateSession: No session was created"++testGetSessionInfo :: TestTree+testGetSessionInfo = testCase "testGetSessionInfo" $ do+ man <- manager+ let req = SessionRequest Nothing (Just "testGetSessionInfo") Nothing ["serfHealth"] (Just Release) (Just "30s")+ result <- I.createSession man "localhost" (PortNum 8500) req Nothing+ case result of+ Just x -> do+ x1 <- I.getSessionInfo man "localhost" (PortNum 8500) (sId x) Nothing+ case x1 of+ Just _ -> return ()+ Nothing -> assertFailure "testGetSessionInfo: Session Info was not returned"+ Nothing -> assertFailure "testGetSessionInfo: No session was created"++testRenewSession :: TestTree+testRenewSession = testCase "testRenewSession" $ do+ man <- manager+ let req = SessionRequest Nothing (Just "testRenewSession") Nothing ["serfHealth"] (Just Release) (Just "30s")+ result <- I.createSession man "localhost" (PortNum 8500) req Nothing+ case result of+ Just x -> do+ x1 <- I.renewSession man "localhost" (PortNum 8500) x Nothing+ case x1 of+ True -> return ()+ False -> assertFailure "testRenewSession: Session was not renewed"+ Nothing -> assertFailure "testRenewSession: No session was created"++testDestroySession :: TestTree+testDestroySession = testCase "testDestroySession" $ do+ man <- manager+ let req = SessionRequest Nothing (Just "testDestroySession") Nothing ["serfHealth"] (Just Release) (Just "30s")+ result <- I.createSession man "localhost" (PortNum 8500) req Nothing+ case result of+ Just x -> do+ _ <- I.destroySession man "localhost" (PortNum 8500) x Nothing+ x1 <- I.getSessionInfo man "localhost" (PortNum 8500) (sId x) Nothing+ assertEqual "testDestroySession: Session info was returned after destruction" Nothing x1+ Nothing -> assertFailure "testDestroySession: No session was created"++testInternalSession :: TestTree+testInternalSession = testGroup "Internal Session Tests" [testCreateSession, testGetSessionInfo, testRenewSession, testDestroySession]++{- Managed Session -}+testCreateManagedSession :: TestTree+testCreateManagedSession = testCase "testCreateManagedSession" $ do+ client <- initializeConsulClient "localhost" (PortNum 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" (PortNum 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)++testWithSessionCancel :: TestTree+testWithSessionCancel = testCase "testWithSessionCancel" $ do+ man <- manager+ client <- initializeConsulClient "localhost" (PortNum 8500) Nothing+ let req = SessionRequest Nothing (Just "testWithSessionCancel") Nothing ["serfHealth"] (Just Release) (Just "10s")+ result <- I.createSession man "localhost" (PortNum 8500) req Nothing+ case result of+ Just x -> do+ x1 <- withSession client x (\ y -> action y man ) cancelAction+ assertEqual "testWithSessionCancel: Incorrect value" "Canceled" x1+ Nothing -> assertFailure "testWithSessionCancel: No session was created"+ where+ action x man = do+ I.destroySession man "localhost" (PortNum 8500) x Nothing+ threadDelay (30 * 1000000)+ return ("NotCanceled" :: Text)+ cancelAction = return ("Canceled" :: Text)+++managedSessionTests :: TestTree+managedSessionTests = testGroup "Managed Session Tests" [ testCreateManagedSession, testSessionMaintained, testWithSessionCancel]++agentTests :: TestTree+agentTests = testGroup "Agent Tests" [testGetSelf,testRegisterService]++allTests :: TestTree+allTests = testGroup "All Tests" [testInternalSession, internalKVTests, managedSessionTests, agentTests]+ main :: IO ()-main = defaultMain internalKVTests+main = defaultMain allTests