diff --git a/consul-haskell.cabal b/consul-haskell.cabal --- a/consul-haskell.cabal +++ b/consul-haskell.cabal @@ -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: diff --git a/src/Network/Consul.hs b/src/Network/Consul.hs --- a/src/Network/Consul.hs +++ b/src/Network/Consul.hs @@ -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 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 @@ -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 () 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 @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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 diff --git a/tests/SocketUtils.hs b/tests/SocketUtils.hs new file mode 100644 --- /dev/null +++ b/tests/SocketUtils.hs @@ -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)