create a second test suite based on sydtest

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

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 <url>`
-    sha256 = "0whxlm098vas4ngq6hm3xa4mdd2yblxcl5x5ny216zajp08yp1wf";
+    sha256 = "1sm1p2qliz11qw6va01knm0rikhpq2h4c70ci98vi4q26y4q9z72";
   }) {};
 
   packageName = "consul-haskell";
@@ -27,13 +27,15 @@ let
     name = "consul-haskell";
     includeDirs = [
       ./src
+      ./test
       ./tests
     ];
     includeFiles = [
       ./consul-haskell.cabal
       ./Setup.hs
       ./LICENSE
       ./README.md
+      ./CHANGELOG.md
     ];
     pathComponentExcludes = [ "build" "gen" ];
   };

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 <https://github.com/alphaHeavy/consul-haskell#readme>.
 
-
 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

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 <url>`
-    sha256 = "110kgp4x5bx44rgw55ngyhayr4s19xwy19n6qw9g01hvhdisilwf";
+    sha256 = "1sm1p2qliz11qw6va01knm0rikhpq2h4c70ci98vi4q26y4q9z72";
   }) {};
 
   # Needs NUR from https://github.com/nix-community/NUR

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

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"

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