Run tests in CI

.github/workflows/haskell-ci.yml

@@ -34,6 +34,10 @@ jobs:
     container:
       image: buildpack-deps:jammy
     continue-on-error: ${{ matrix.allow-failure }}
+    services:
+      valkey:
+        image: "valkey/valkey:9"
+        options: --health-cmd "valkey-cli ping" --health-interval 10s --health-timeout 5s --health-retries 5
     strategy:
       matrix:
         include:
@@ -223,6 +227,11 @@ jobs:
       - name: build
         run: |
           $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
+      - name: tests
+        env:
+          REDIS_HOST: valkey
+        run: |
+          $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
       - name: doctest
         run: |
           cd ${PKGDIR_hedis} || false

cabal.haskell-ci

@@ -4,8 +4,4 @@ doctest:         True
 doctest-version: ^>=0.24
 
 tests:           True
-
 benchmarks:      True
-
--- Some tests don't pass.
-run-tests:       False

test/ClusterMain.hs

@@ -6,8 +6,10 @@
 module Main (main) where
 
 import qualified Test.Framework as Test
+import Control.Exception
 import Data.ByteString (ByteString)
 import Database.Redis
+import System.Exit
 import Tests
 
 main :: IO ()
@@ -17,8 +19,12 @@ main = do
     -- spin up a cluster on this port using docker you can run:
     --
     --     docker run -e "IP=0.0.0.0" -p 7000-7010:7000-7010 grokzen/redis-cluster:5.0.6
-    conn <- connectCluster defaultConnectInfo { connectPort = PortNumber 7000 }
-    Test.defaultMain (tests conn)
+    result <- try @IOException $ connectCluster defaultConnectInfo { connectPort = PortNumber 7000 }
+    case result of
+        Left e -> do
+            putStrLn $ "Skipping cluster tests, no cluster available on port 7000: " ++ show e
+            exitSuccess
+        Right conn -> Test.defaultMain (tests conn)
 
 tests :: Connection -> [Test.Test]
 tests conn = map ($ conn) $ concat @[]

test/Main.hs

@@ -1,13 +1,18 @@
 module Main (main) where
 
+import Data.Maybe
+import System.Environment
 import qualified Test.Framework as Test
 import Database.Redis
 import Tests
 import PubSubTest
 
 main :: IO ()
 main = do
-    conn <- connect defaultConnectInfo
+    host <- fromMaybe "localhost" <$> lookupEnv "REDIS_HOST"
+    port <- maybe 6379 read <$> lookupEnv "REDIS_PORT"
+    conn <- connect defaultConnectInfo { connectHost = host, connectPort = PortNumber port }
+    runRedis conn ping
     Test.defaultMain (tests conn)
 
 tests :: Connection -> [Test.Test]

test/MainHooks.hs

@@ -1,68 +1,72 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-import qualified Test.Framework.Providers.HUnit as Test (testCase)
-import qualified Test.Framework as Test
-import Database.Redis
-import Data.IORef
-import qualified Test.HUnit as HUnit
-import Control.Monad.IO.Class (MonadIO(liftIO))
-
-main :: IO ()
-main = Test.defaultMain [testSetGet]
-
-data Counts =
-    Counts 
-        { sendRequestCount :: Word
-        , sendPubSubCount :: Word
-        , callbackCount :: Word
-        , sendCount :: Word
-        , receiveCount :: Word
-        }
-    deriving (Show, Eq)
-
-testCase :: String -> Counts -> Redis () -> Test.Test
-testCase name expected r = Test.testCase name $ do
-    ref <- newIORef $ Counts 0 0 0 0 0
-    conn <- connect defaultConnectInfo {connectHooks = hooks ref}
-    t <- runRedis conn $ flushdb >>=? Ok >> r
-    actual <- readIORef ref
-    HUnit.assertEqual "count" expected actual
-    return t
-
-hooks :: IORef Counts -> Hooks
-hooks ref =
-    defaultHooks
-        { sendRequestHook = \f message -> do
-            modifyIORef ref $ \c -> c {sendRequestCount = succ $ sendRequestCount c}
-            f message
-        , sendPubSubHook = \f message -> do
-            modifyIORef ref $ \c -> c {sendPubSubCount = succ $ sendPubSubCount c}
-            f message
-        , callbackHook = \f message -> do
-            modifyIORef ref $ \c -> c {callbackCount = succ $ callbackCount c}
-            f message
-        , sendHook = \f message -> do
-            modifyIORef ref $ \c -> c {sendCount = succ $ sendCount c}
-            f message
-        , receiveHook = \m -> do
-            modifyIORef ref $ \c -> c {receiveCount = succ $ receiveCount c}
-            m
-        }
-
-(>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis ()
-redis >>=? expected = redis >>@? (expected HUnit.@=?)
-
-(>>@?) :: (Eq a, Show a) => Redis (Either Reply a) -> (a -> HUnit.Assertion) -> Redis ()
-redis >>@? predicate = do
-    a <- redis
-    liftIO $ case a of
-        Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply
-        Right actual -> predicate actual
-
-testSetGet :: Test.Test
-testSetGet =
-    testCase
-        "set/get"
-        (Counts 3 0 0 3 3) $ do
-    set "{same}key" "value"     >>=? Ok
-    get "{same}key"             >>=? Just "value"
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Maybe
+import System.Environment
+import qualified Test.Framework.Providers.HUnit as Test (testCase)
+import qualified Test.Framework as Test
+import Database.Redis
+import Data.IORef
+import qualified Test.HUnit as HUnit
+import Control.Monad.IO.Class
+
+main :: IO ()
+main = Test.defaultMain [testSetGet]
+
+data Counts =
+    Counts
+        { sendRequestCount :: Word
+        , sendPubSubCount :: Word
+        , callbackCount :: Word
+        , sendCount :: Word
+        , receiveCount :: Word
+        }
+    deriving (Show, Eq)
+
+testCase :: String -> Counts -> Redis () -> Test.Test
+testCase name expected r = Test.testCase name $ do
+    ref <- newIORef $ Counts 0 0 0 0 0
+    host <- fromMaybe "localhost" <$> lookupEnv "REDIS_HOST"
+    port <- maybe 6379 read <$> lookupEnv "REDIS_PORT"
+    conn <- connect defaultConnectInfo {connectHost = host, connectPort = PortNumber port, connectHooks = hooks ref}
+    t <- runRedis conn $ flushdb >>=? Ok >> r
+    actual <- readIORef ref
+    HUnit.assertEqual "count" expected actual
+    return t
+
+hooks :: IORef Counts -> Hooks
+hooks ref =
+    defaultHooks
+        { sendRequestHook = \f message -> do
+            modifyIORef ref $ \c -> c {sendRequestCount = succ $ sendRequestCount c}
+            f message
+        , sendPubSubHook = \f message -> do
+            modifyIORef ref $ \c -> c {sendPubSubCount = succ $ sendPubSubCount c}
+            f message
+        , callbackHook = \f message -> do
+            modifyIORef ref $ \c -> c {callbackCount = succ $ callbackCount c}
+            f message
+        , sendHook = \f message -> do
+            modifyIORef ref $ \c -> c {sendCount = succ $ sendCount c}
+            f message
+        , receiveHook = \m -> do
+            modifyIORef ref $ \c -> c {receiveCount = succ $ receiveCount c}
+            m
+        }
+
+(>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis ()
+redis >>=? expected = redis >>@? (expected HUnit.@=?)
+
+(>>@?) :: (Eq a, Show a) => Redis (Either Reply a) -> (a -> HUnit.Assertion) -> Redis ()
+redis >>@? predicate = do
+    a <- redis
+    liftIO $ case a of
+        Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply
+        Right actual -> predicate actual
+
+testSetGet :: Test.Test
+testSetGet =
+    testCase
+        "set/get"
+        (Counts 3 0 0 3 3) $ do
+    set "{same}key" "value"     >>=? Ok
+    get "{same}key"             >>=? Just "value"

test/MainRedis7.hs

@@ -1,12 +1,17 @@
 module Main (main) where
 
+import Data.Maybe
+import System.Environment
 import qualified Test.Framework as Test
 import Database.Redis
 import Tests
 
 main :: IO ()
 main = do
-    conn <- connect defaultConnectInfo
+    host <- fromMaybe "localhost" <$> lookupEnv "REDIS_HOST"
+    port <- maybe 6379 read <$> lookupEnv "REDIS_PORT"
+    conn <- connect defaultConnectInfo { connectHost = host, connectPort = PortNumber port }
+    runRedis conn ping
     Test.defaultMain (tests conn)
 
 tests :: Connection -> [Test.Test]

test/Tests.hs

@@ -446,7 +446,7 @@ testPubSub conn = testCase "pubSub" go conn
         -- producer
         asyncProducer <- liftIO $ Async.async $ do
             runRedis conn $ do
-                let t = 10^(5 :: Int)
+                let t = 10^(6 :: Int)
                 liftIO $ threadDelay t
                 publish "chan1" "hello" >>=? 1
                 liftIO $ threadDelay t