diff --git a/consul-haskell.cabal b/consul-haskell.cabal --- a/consul-haskell.cabal +++ b/consul-haskell.cabal @@ -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 diff --git a/src/Network/Consul.hs b/src/Network/Consul.hs --- a/src/Network/Consul.hs +++ b/src/Network/Consul.hs @@ -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 diff --git a/src/Network/Consul/Internal.hs b/src/Network/Consul/Internal.hs --- a/src/Network/Consul/Internal.hs +++ b/src/Network/Consul/Internal.hs @@ -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] diff --git a/src/Network/Consul/Types.hs b/src/Network/Consul/Types.hs --- a/src/Network/Consul/Types.hs +++ b/src/Network/Consul/Types.hs @@ -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] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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