diff --git a/consul-haskell.cabal b/consul-haskell.cabal index 777c1e4..4214494 100644 --- a/consul-haskell.cabal +++ b/consul-haskell.cabal @@ -75,6 +75,38 @@ library , vector default-language: Haskell2010 +test-suite sydtest-testsuite + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Consul.HealthCheckSpec + Consul.KeyValueSpec + Consul.SessionSpec + Import + SocketUtils + Util + Paths_consul_haskell + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , bytestring + , consul-haskell + , http-client + , network + , random + , retry + , safe-coloured-text + , safe-coloured-text-terminfo + , sydtest + , sydtest-discover + , text + , typed-process + , unliftio + , uuid + default-language: Haskell2010 + test-suite tasty-hunit-testsuite type: exitcode-stdio-1.0 main-is: Main.hs diff --git a/default.nix b/default.nix index ee80e9f..b672a9b 100644 --- a/default.nix +++ b/default.nix @@ -2,11 +2,11 @@ let pinnedPkgs = import (builtins.fetchTarball { # Descriptive name to make the store path easier to identify - name = "nixos-20.09-2020-12-13"; + name = "nixos-20.09-2021-04-13"; # Current commit from https://github.com/NixOS/nixpkgs/tree/nixos-20.09 - url = "https://github.com/nixos/nixpkgs/archive/65c9cc79f1d179713c227bf447fb0dac384cdcda.tar.gz"; + url = "https://github.com/nixos/nixpkgs/archive/dec334fa196a4aeedb1b60d8f7d61aa00d327499.tar.gz"; # Hash obtained using `nix-prefetch-url --unpack ` - sha256 = "0whxlm098vas4ngq6hm3xa4mdd2yblxcl5x5ny216zajp08yp1wf"; + sha256 = "1sm1p2qliz11qw6va01knm0rikhpq2h4c70ci98vi4q26y4q9z72"; }) {}; packageName = "consul-haskell"; @@ -27,6 +27,7 @@ let name = "consul-haskell"; includeDirs = [ ./src + ./test ./tests ]; includeFiles = [ @@ -34,6 +35,7 @@ let ./Setup.hs ./LICENSE ./README.md + ./CHANGELOG.md ]; pathComponentExcludes = [ "build" "gen" ]; }; diff --git a/package.yaml b/package.yaml index b591825..1a3c723 100644 --- a/package.yaml +++ b/package.yaml @@ -21,7 +21,6 @@ description: Requires consul 1.0 or later. Tested with the latest consul release in each of the release series from 1.3 to 1.9, as well as 1.10.0-alpha. For more info, please see the README on GitHub at . - library: source-dirs: src dependencies: @@ -46,8 +45,32 @@ library: ghc-options: -Wall - tests: + sydtest-testsuite: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall + dependencies: + - base >= 4.7 && < 5 + - bytestring + - consul-haskell + - http-client + - network + - random + - retry + - safe-coloured-text + - safe-coloured-text-terminfo + - sydtest + - sydtest-discover + - text + - typed-process + - unliftio + - uuid + tasty-hunit-testsuite: main: Main.hs source-dirs: tests diff --git a/shell.nix b/shell.nix index 12155f3..ceb899a 100644 --- a/shell.nix +++ b/shell.nix @@ -4,11 +4,11 @@ let # see https://github.com/mpickering/old-ghc-nix/issues/8. pkgs = import (builtins.fetchTarball { # Descriptive name to make the store path easier to identify - name = "nixos-20.03-2020-12-08"; + name = "nixos-20.09-2021-04-13"; # Current commit from https://github.com/NixOS/nixpkgs/tree/nixos-20.03 - url = "https://github.com/nixos/nixpkgs/archive/030e2ce817c8e83824fb897843ff70a15c131b96.tar.gz"; + url = "https://github.com/nixos/nixpkgs/archive/dec334fa196a4aeedb1b60d8f7d61aa00d327499.tar.gz"; # Hash obtained using `nix-prefetch-url --unpack ` - sha256 = "110kgp4x5bx44rgw55ngyhayr4s19xwy19n6qw9g01hvhdisilwf"; + sha256 = "1sm1p2qliz11qw6va01knm0rikhpq2h4c70ci98vi4q26y4q9z72"; }) {}; # Needs NUR from https://github.com/nix-community/NUR diff --git a/stack.yaml b/stack.yaml index 920434f..c703a2d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,24 @@ flags: {} packages: - '.' -extra-deps: [] +extra-deps: + - envparse-0.4.1@sha256:989902e6368532548f61de1fa245ad2b39176cddd8743b20071af519a709ce30,2842 + - yamlparse-applicative-0.1.0.2@sha256:bda91f2818c1b5b124963931cb7f9a4e5758d026c09713e9ae2234534062747d,2133 + - github: NorfairKing/safe-coloured-text + commit: 2e61b50dfa65bed862aff903f574175cfc747e14 + subdirs: + - safe-coloured-text + - safe-coloured-text-terminfo + - github: NorfairKing/sydtest + commit: 83685ec68c3c167503ba8aee44000f2d8bb43a07 + subdirs: + - sydtest + - sydtest-discover + - sydtest-wai + - sydtest-yesod + # When bumping the resolver, update the GHC version in shell.nix accordingly. -resolver: lts-13.27 +resolver: lts-18.20 nix: shell-file: shell.nix diff --git a/test/Consul/HealthCheckSpec.hs b/test/Consul/HealthCheckSpec.hs new file mode 100644 index 0000000..21d4533 --- /dev/null +++ b/test/Consul/HealthCheckSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Consul.HealthCheckSpec (spec) where + +import Import +import Test.Syd + +spec :: Spec +spec = do + pure () + +-- spec = testGroup "Health Check Tests" [testGetServiceHealth] +-- +-- {- Health Checks -} +-- +-- {- +-- testRegisterHealthCheck :: TestTree +-- testRegisterHealthCheck = testCase "testRegisterHealthCheck" $ do +-- client@ConsulClient{..} <- newClient +-- let check = RegisterHealthCheck "testHealthCheck" "testHealthCheck" "" Nothing Nothing (Just "15s") +-- x1 <- registerHealthCheck ccManager (hostWithScheme client) ccPort check +-- undefined -} +-- +-- testGetServiceHealth :: TestTree +-- testGetServiceHealth = testCase "testGetServiceHealth" $ do +-- client@ConsulClient{..} <- newClient +-- let req = RegisterService (Just "testGetServiceHealth") "testGetServiceHealth" [] Nothing Nothing +-- r1 <- registerService client req +-- case r1 of +-- True -> do +-- liftIO $ sleep 1 +-- r2 <- getServiceHealth client "testGetServiceHealth" +-- case r2 of +-- Just [x] -> return () +-- Just [] -> assertFailure "testGetServiceHealth: No Services Returned" +-- Nothing -> assertFailure "testGetServiceHealth: Failed to parse result" +-- False -> assertFailure "testGetServiceHealth: Service was not created" diff --git a/test/Consul/KeyValueSpec.hs b/test/Consul/KeyValueSpec.hs new file mode 100644 index 0000000..616adc7 --- /dev/null +++ b/test/Consul/KeyValueSpec.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Consul.KeyValueSpec where + +import Import +import Test.Syd + +spec :: Spec +spec = aroundAll withConsulServer $ do + + itWithOuter "Get Invalid Key" $ \_ -> do + client@ConsulClient{..} <- newClient + -- specify the datacenter as part of our request + x <- getKey client{ ccDatacenter = dc1 } "nokey" Nothing Nothing + context "testGetInvalidKey: Found a key that doesn't exist" $ shouldBe x Nothing + + itWithOuter "testPutKey" $ \_ -> do + client@ConsulClient{..} <- newClient + let put = KeyValuePut "/testPutKey" "Test" Nothing Nothing + x <- putKey client put + context "testPutKey: Write failed" $ shouldBe True x + + itWithOuter "testPutKeyAcquireLock" $ \_ -> do + client@ConsulClient{..} <- newClient + let ttl = "30s" + req = + SessionRequest + lockDelay + (Just "testPutKeyAcquireLock") + localNode + checkIds + (Just Release) + (Just ttl) + result <- createSession client req + case result of + Nothing -> expectationFailure "testPutKeyAcquireLock: No session was created" + Just session -> do + let put = KeyValuePut "/testPutKeyAcquireLock" "Test" Nothing Nothing + x <- putKeyAcquireLock client put session + context "testPutKeyAcquireLock: Write failed" $ shouldBe True x + Just kv <- getKey client "/testPutKeyAcquireLock" Nothing Nothing + let Just returnedSession = kvSession kv + context "testPutKeyAcquireLock: Session was not found on key" $ shouldBe returnedSession (sId session) + + + itWithOuter "testPutKeyReleaseLock" $ \_ -> do + client@ConsulClient{..} <- newClient + let ttl = "30s" + req = + SessionRequest + Nothing + (Just "testPutKeyReleaseLock") + localNode + checkIds + (Just Release) + (Just ttl) + result <- createSession client req + case result of + Nothing -> expectationFailure "testPutKeyReleaseLock: No session was created" + Just session -> do + let put = KeyValuePut "/testPutKeyReleaseLock" "Test" Nothing Nothing + x <- putKeyAcquireLock client put session + context "testPutKeyReleaseLock: Write failed" $ shouldBe True x + Just kv <- getKey client "/testPutKeyReleaseLock" Nothing Nothing + let Just returnedSession = kvSession kv + context "testPutKeyReleaseLock: Session was not found on key" $ shouldBe returnedSession (sId session) + let put2 = KeyValuePut "/testPutKeyReleaseLock" "Test" Nothing Nothing + x2 <- putKeyReleaseLock client put2 session + context "testPutKeyReleaseLock: Release failed" $ shouldBe True x2 + Just kv2 <- getKey client "/testPutKeyReleaseLock" Nothing Nothing + context "testPutKeyAcquireLock: Session still held" $ shouldBe Nothing (kvSession kv2) + + + itWithOuter "testGetKey" $ \_ -> do + client@ConsulClient{..} <- newClient + let put = KeyValuePut "/testGetKey" "Test" Nothing Nothing + x1 <- putKey client put + context "testGetKey: Write failed" $ shouldBe True x1 + x2 <- getKey client "/testGetKey" Nothing Nothing + case x2 of + Just x -> context "testGetKey: Incorrect Value" $ shouldBe (kvValue x) (Just "Test") + Nothing -> expectationFailure "testGetKey: No value returned" + + itWithOuter "testGetNullValueKey" $ \_ -> do + client@ConsulClient{..} <- newClient + let put = KeyValuePut "/testGetNullValueKey" "" Nothing Nothing + x1 <- putKey client put + context "testGetNullValueKey: Write failed" $ shouldBe True x1 + liftIO $ sleep 0.5 + x2 <- getKey client "/testGetNullValueKey" Nothing Nothing + case x2 of + Just x -> context "testGetNullValueKey: Incorrect Value" $ shouldBe (kvValue x) Nothing + Nothing -> expectationFailure "testGetNullValueKey: No value returned" + + itWithOuter "testGetKeys" $ \_ -> do + client@ConsulClient{..} <- newClient + let put1 = KeyValuePut "/testGetKeys/key1" "Test" Nothing Nothing + x1 <- putKey client put1 + context "testGetKeys: Write failed" $ shouldBe True x1 + let put2 = KeyValuePut "/testGetKeys/key2" "Test" Nothing Nothing + x2 <- putKey client put2 + context "testGetKeys: Write failed" $ shouldBe True x2 + x3 <- getKeys client "/testGetKeys" Nothing Nothing + context "testGetKeys: Incorrect number of results" $ shouldBe 2 (length x3) + + itWithOuter "testListKeys" $ \_ -> do + client@ConsulClient{..} <- newClient + let put1 = KeyValuePut "/testListKeys/key1" "Test" Nothing Nothing + x1 <- putKey client put1 + context "testListKeys: Write failed" $ shouldBe True x1 + let put2 = KeyValuePut "/testListKeys/key2" "Test" Nothing Nothing + x2 <- putKey client put2 + context "testListKeys: Write failed" $ shouldBe True x2 + x3 <- listKeys client "/testListKeys/" Nothing Nothing + context "testListKeys: Incorrect number of results" $ shouldBe 2 (length x3) + + itWithOuter "testDeleteKey" $ \_ -> do + client@ConsulClient{..} <- newClient + let put1 = KeyValuePut "/testDeleteKey" "Test" Nothing Nothing + x1 <- putKey client put1 + context "testDeleteKey: Write failed" $ shouldBe True x1 + x2 <- deleteKey client "/testDeleteKey" False + context "testDeleteKey: Delete Failed" $ shouldBe True x2 + x3 <- getKey client "/testDeleteKey" Nothing Nothing + context "testDeleteKey: Key was not deleted" $ shouldBe Nothing x3 + + itWithOuter "testDeleteRecursive" $ \_ -> do + client@ConsulClient{..} <- newClient + let put1 = KeyValuePut "/testDeleteRecursive/1" "Test" Nothing Nothing + put2 = KeyValuePut "/testDeleteRecursive/2" "Test" Nothing Nothing + x1 <- putKey client put1 + context "testDeleteKey: Write failed" $ shouldBe True x1 + x2 <- putKey client put2 + context "testDeleteKey: Write failed" $ shouldBe True x2 + deleteKey client "/testDeleteRecursive/" True + x3 <- getKey client "/testDeleteRecursive/1" Nothing Nothing + context "testDeleteKey: Key was not deleted" $ shouldBe Nothing x3 diff --git a/test/Consul/SessionSpec.hs b/test/Consul/SessionSpec.hs new file mode 100644 index 0000000..5680acb --- /dev/null +++ b/test/Consul/SessionSpec.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Consul.SessionSpec (spec) where + +import Import +import Test.Syd + +spec :: Spec +spec = do + pure () + +{- Session -} +-- testCreateSession :: TestTree +-- testCreateSession = testCase "testCreateSession" $ do +-- client@ConsulClient{..} <- newClient +-- let ttl = "30s" +-- req = +-- SessionRequest +-- lockDelay +-- (Just "testCreateSession") +-- localNode +-- checkIds +-- (Just Release) +-- (Just ttl) +-- let loopUntilSession :: IO () +-- loopUntilSession = do +-- resp <- createSession client req +-- case resp of +-- Just _ -> return () +-- Nothing -> do +-- putStrLn "Session creation failed, retrying..." +-- sleep 0.05 -- pause for 50ms +-- loopUntilSession +-- result <- timeout fiveSecondMicros loopUntilSession +-- case result of +-- Just _ -> return () +-- Nothing -> assertFailure $ "testCreateSession: Session creation failed after retrying for 5 seconds" +-- +-- +-- testGetSessionInfo :: TestTree +-- testGetSessionInfo = testCase "testGetSessionInfo" $ do +-- client@ConsulClient{..} <- newClient +-- let ttl = "30s" +-- req = +-- SessionRequest +-- lockDelay +-- (Just "testGetSessionInfo") +-- localNode +-- checkIds +-- (Just Release) +-- (Just ttl) +-- result <- createSession client req +-- case result of +-- Just x -> do +-- sleep 1 +-- x1 <- getSessionInfo client x +-- 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 +-- client@ConsulClient{..} <- newClient +-- let ttl = "30s" +-- req = SessionRequest Nothing (Just "testRenewSession") localNode checkIds (Just Release) (Just ttl) +-- result <- createSession client req +-- case result of +-- Just x -> do +-- x1 <- renewSession client x +-- case x1 of +-- True -> return () +-- False -> assertFailure "testRenewSession: Session was not renewed" +-- Nothing -> assertFailure "testRenewSession: No session was created" +-- +-- testRenewNonexistentSession :: TestTree +-- testRenewNonexistentSession = testCase "testRenewNonexistentSession" $ do +-- client@ConsulClient{..} <- newClient +-- sessId :: UUID <- randomIO +-- let session = Session (toText sessId) Nothing +-- x <- renewSession client session +-- case x of +-- True -> assertFailure "testRenewNonexistentSession: Non-existent session was renewed" +-- False -> return () +-- +-- testDestroySession :: TestTree +-- testDestroySession = testCase "testDestroySession" $ do +-- client@ConsulClient{..} <- newClient +-- let ttl = "30s" +-- req = SessionRequest Nothing (Just "testDestroySession") localNode checkIds (Just Release) (Just ttl) +-- result <- createSession client req +-- case result of +-- Just x -> do +-- _ <- destroySession client x +-- x1 <- getSessionInfo client x +-- 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, testRenewNonexistentSession, testDestroySession] +-- +-- testSessionMaintained :: TestTree +-- testSessionMaintained = testCase "testSessionMaintained" $ do +-- client@ConsulClient{..} <- newClient +-- let req = SessionRequest Nothing (Just "testSessionMaintained") localNode checkIds (Just Release) (Just "15s") +-- result <- createSession client req +-- case result of +-- Just session -> do +-- sleep 12 +-- y <- getSessionInfo client session +-- assertEqual "testSessionMaintained: Session not found" True (isJust y) +-- Nothing -> assertFailure "testSessionMaintained: No Session was created" +-- +-- +-- testWithSessionCancel :: TestTree +-- testWithSessionCancel = testCase "testWithSessionCancel" $ do +-- client@ConsulClient{..} <- newClient +-- let req = SessionRequest Nothing (Just "testWithSessionCancel") localNode checkIds (Just Release) (Just "10s") +-- result <- createSession client req +-- case result of +-- Just session -> do +-- x1 <- withSession client Nothing 5 session (\ y -> action y client ) cancelAction +-- assertEqual "testWithSessionCancel: Incorrect value" "Canceled" x1 +-- z <- getSessionInfo client session +-- 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 +-- destroySession client x +-- liftIO $ sleep 30 +-- return ("NotCanceled" :: Text) +-- +-- cancelAction :: MonadIO m => m Text +-- cancelAction = return ("Canceled" :: Text) +-- +-- +-- {-testSequencerLostSession :: TestTree +-- testSequencerLostSession = testCase "testSequencerLostSession" $ do +-- client@ConsulClient{..} <- initializeConsulClient "localhost" consulPort Nothing +-- -} +-- +-- -- TODO: drop stringified values (localhost, dc1, etc) +-- testIsValidSequencer :: TestTree +-- testIsValidSequencer = testCase "testIsValidSequencer" $ do +-- client@ConsulClient{..} <- initializeConsulClient localhost consulPort Nothing +-- let req = SessionRequest Nothing (Just "testIsValidSequencer") localNode checkIds (Just Release) (Just "10s") +-- result <- createSession client req +-- 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 +-- assertEqual "testIsValidSequencer: Write failed" True x +-- Just sequencer <- getSequencerForLock client "/testIsValidSequencer" session +-- result1 <- isValidSequencer client sequencer +-- assertEqual "testIsValidSequencer: Valid sequencer was invalid" True result1 +-- _ <- destroySession client session +-- result2 <- isValidSequencer client sequencer +-- assertEqual "testIsValidSequencer: Invalid session was valid" False result2 +-- diff --git a/test/Import.hs b/test/Import.hs new file mode 100644 index 0000000..4255ece --- /dev/null +++ b/test/Import.hs @@ -0,0 +1,46 @@ +module Import + ( module Import + , module Util + , module Network.Consul.Types + , module Network.Consul + ) where + +import qualified Control.Concurrent as Import +import qualified Control.Monad as Import (when) +import qualified Control.Monad.IO.Class as Import +import qualified Control.Retry as Import +import qualified Data.ByteString as Import.BS +import qualified Data.ByteString.Char8 as Import.BS8 +import qualified Data.Maybe as Import + +import qualified Data.Text as Import (unpack, Text) +import qualified Data.UUID as Import +import qualified Network.Consul as Import + ( createSession + , deleteKey + , destroySession + , getKey + , getSequencerForLock + , getSessionInfo + , initializeConsulClient + , isValidSequencer + , putKey + , putKeyAcquireLock + , withSession + , ConsulClient(..) + , runService + , getServiceHealth + ) +import Network.Consul.Types +import Network.Consul +import qualified Network.Consul.Internal as Import (hostWithScheme, emptyHttpManager) +import qualified Network.HTTP.Client as Import +import qualified Network.Socket as Import (PortNumber) +import qualified System.IO as Import (hFlush) +import qualified System.Process.Typed as Import (proc) +import qualified System.Process.Typed as Import.PT +import qualified System.Random as Import +import qualified System.Timeout as Import (timeout) +import qualified UnliftIO.Temporary as Import (withSystemTempFile) + +import Util diff --git a/test/SocketUtils.hs b/test/SocketUtils.hs new file mode 100644 index 0000000..8dc12e1 --- /dev/null +++ b/test/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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..ebed7e1 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 index 0000000..96e99a0 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Util + ( checkIds + , consulPort + , dc1 + , fiveSecondMicros + , newClient + , withProcessTerm + , waitForConsulOrFail + , sleep + , localhost + , localNode + , lockDelay + , withSystemTempFile + , withConsulServer + ) where + +import qualified Data.ByteString.Char8 as BS8 +import qualified System.Process.Typed as PT + +import Control.Concurrent +import Control.Monad (when) +import Control.Retry +import Data.Text (unpack, Text) +import Network.Socket (PortNumber) +import SocketUtils (isPortOpen, simpleSockAddr) +import System.IO (hFlush) +import System.Process.Typed (proc) +import UnliftIO.Temporary (withSystemTempFile) + +import Network.Consul.Internal +import Network.Consul.Types +import Network.Consul (initializeConsulClient) + +-- 5 seconds. +fiveSecondMicros :: Int +fiveSecondMicros = 5 * 1000 * 1000 + +-- Name of existing health check we can rely on for tests that use the Session API +serfHealth :: Text +serfHealth = "serfHealth" + +-- list of names of service/node checks (which should exist in consul already) +checkIds :: [Text] +checkIds = [serfHealth] + +-- for requests to session API +lockDelay :: Maybe a +lockDelay = Nothing + +-- Sleep for N seconds with `threadDelay()`. +sleep :: Double -> IO () +sleep seconds = threadDelay (ceiling (seconds * 1e6)) + +-- Define a `consulHost` for use in running tests against the Consul Agent +localhost :: ConsulHost +localhost = "localhost" + +-- The IP Address of the local agent. +localNodeAddr :: Text +localNodeAddr = "127.0.0.1" + +-- Instantiate a `ConsulHost` for these tests. +localNode :: Node +localNode = Node localhost localNodeAddr + +-- The network port where the Consul Agent will listen for the HTTP API. +consulPort :: PortNumber +consulPort = 18500 + +dc1 :: Maybe Datacenter +dc1 = Just $ Datacenter "dc1" + +-- Initialize a new `ConsulClient`. +newClient :: IO ConsulClient +newClient = initializeConsulClient localhost consulPort emptyHttpManager + + + +-- 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" + + +--withConsulServer :: ( -> IO ()) -> IO () +withConsulServer app = 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 + "/home/user/bin/consul" + [ "agent", "-dev" + , "-node", (unpack localhost) -- hardcode node name as "localhost" * see below + , "-log-level", "err" + --, "-log-level", "debug" -- for debugging + , "-http-port", show (fromIntegral consulPort :: Int) + , "-config-file", configFilePath + ] + withProcessTerm consulProc $ \_p -> do + waitForConsulOrFail + -- to let the consul agent register itself (the node the agent is running on) + -- TODO: should we instead query consul to lookup the node registration? + sleep 3 + +-- +-- Regarding why we set an explicit node name (via `-node`) when running consul: +-- +-- When we create a session, we need to reference a Node that has been +-- registered in Consul's node catalog. By telling the agent to use localhost, +-- after the agent boots, we can expect that the agent has registered a node for +-- itself and that the node's name is localhost, so that when we create a session, +-- we can simply reference that existing/registered node from the agent instead +-- of having to make up and register a Node for the test. + +--withConsulServer :: (ClientEnv -> IO ()) -> IO () +--withConsulServer = undefined