sydtest-hedis (empty) → 0.0.0.0
raw patch · 5 files changed
+244/−0 lines, 5 filesdep +basedep +bytestringdep +hedis
Dependencies added: base, bytestring, hedis, network, path, path-io, port-utils, sydtest, sydtest-hedis, sydtest-typed-process, text, typed-process
Files
- LICENSE.md +5/−0
- src/Test/Syd/Redis.hs +129/−0
- sydtest-hedis.cabal +70/−0
- test/Spec.hs +1/−0
- test/Test/Syd/RedisSpec.hs +39/−0
+ LICENSE.md view
@@ -0,0 +1,5 @@+# Sydtest License++Copyright (c) 2021 Tom Sydney Kerckhove++See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text.
+ src/Test/Syd/Redis.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}++-- TODO possibly supply a variant of 'redisSpec' that uses a different database scope per test+-- so that the tests can still happen in parallel:+-- see https://hackage.haskell.org/package/hedis-0.14.2/docs/Database-Redis.html#v:select+-- and connectDatabase:+-- https://hackage.haskell.org/package/hedis-0.14.2/docs/Database-Redis.html#t:ConnectInfo+module Test.Syd.Redis+ ( redisSpec,+ redisConnectionSetupFunc,+ checkedConnectSetupFunc,+ RedisServerHandle (..),+ redisServerSpec,+ cleanRedisServerState,+ redisServerSetupFunc,+ redisServerSetupFunc',+ )+where++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Database.Redis as Redis+import Network.Socket+import Network.Socket.Free+import qualified Network.Socket.Wait as Socket+import Path+import Path.IO+import System.Process.Typed+import Test.Syd+import Test.Syd.Path+import Test.Syd.Process.Typed++-- | A handle to a child process that is a Redis server.+data RedisServerHandle = RedisServerHandle+ { redisServerHandleProcessHandle :: !(Process () () ()),+ redisServerHandlePort :: !PortNumber+ }++-- | Run a redis server around a group of test and provide a clean connection to every test+--+-- Example usage:+--+-- > redisSpec $ do+-- > it "sets up and tears down a redis connection nicely" $ \conn -> do+-- > runRedis conn $ do+-- > errOrStatus <- Redis.set "hello" "world"+-- > liftIO $ case errOrStatus of+-- > Left err -> expectationFailure $ show err+-- > Right status -> status `shouldBe` Ok+-- > errOrReply <- Redis.get "hello"+-- > liftIO $ case errOrReply of+-- > Left err -> expectationFailure $ show err+-- > Right val -> val `shouldBe` Just "world"+--+-- This function just combines 'redisServerSpec' with 'setupAroundWith' redisConnectionSetupFunc'.+redisSpec :: TestDefM (RedisServerHandle ': outers) Redis.Connection result -> TestDefM outers inner result+redisSpec = redisServerSpec . setupAroundWith' (\serverHandle _ -> redisConnectionSetupFunc serverHandle)++-- | Set up a clean redis connection given a handle to the redis server.+--+-- This function cleans the state using `flushall`.+redisConnectionSetupFunc :: RedisServerHandle -> SetupFunc Redis.Connection+redisConnectionSetupFunc RedisServerHandle {..} = do+ let connInfo = Redis.defaultConnectInfo {connectPort = PortNumber redisServerHandlePort}+ conn <- checkedConnectSetupFunc connInfo+ SetupFunc $ \func -> do+ cleanRedisServerState conn+ func conn++-- | A 'SetupFunc' that 'bracket's 'checkedConnect' and 'disconnect'.+checkedConnectSetupFunc :: Redis.ConnectInfo -> SetupFunc Redis.Connection+checkedConnectSetupFunc connInfo = bracketSetupFunc (checkedConnect connInfo) disconnect++-- | Run a redis server around a group of tests.+redisServerSpec :: TestDefM (RedisServerHandle ': outers) inner result -> TestDefM outers inner result+redisServerSpec = setupAroundAll redisServerSetupFunc . sequential -- Must run sequentially because state is shared.++-- | Clean the redis server's state.+cleanRedisServerState :: Connection -> IO ()+cleanRedisServerState conn = do+ errOrStatus <- runRedis conn Redis.flushall -- Clean state+ case errOrStatus of+ Left err -> expectationFailure $ "Something went wrong while trying to clean the state before the test starts: " <> show err+ Right s -> s `shouldBe` Ok++-- | Setup func for running a Redis server+--+-- This function uses a temporary directory (using 'tempDirSetupFunc') for any state.+redisServerSetupFunc :: SetupFunc RedisServerHandle+redisServerSetupFunc = do+ td <- tempDirSetupFunc "sydtest-hedis"+ redisServerSetupFunc' td++-- | Setup func for running a Redis server in a given directory+redisServerSetupFunc' :: Path Abs Dir -> SetupFunc RedisServerHandle+redisServerSetupFunc' td = do+ pidFile <- resolveFile td "redis.pid"+ logFile <- resolveFile td "redis.log"+ portInt <- liftIO $ do+ (portInt, _socket) <- openFreePort+ close _socket+ pure portInt+ let pn = fromIntegral portInt -- (hopefully) safe because it came from 'getFreePort'.+ let configFileContents =+ T.pack $+ unlines+ [ unwords ["port", show (fromIntegral pn :: Int)],+ unwords ["pidfile", fromAbsFile pidFile],+ unwords ["always-show-logo", "no"], -- No need to see the logo.+ unwords ["logfile", fromAbsFile logFile]+ ]+ configFile <- tempBinaryFileWithContentsSetupFunc "config-file" (TE.encodeUtf8 configFileContents)+ let pc =+ setWorkingDir (fromAbsDir td) $+ setStdout inherit $+ setStderr inherit $+ proc+ "redis-server"+ [fromAbsFile configFile]+ ph <- typedProcessSetupFunc pc+ liftIO $ Socket.wait "127.0.0.1" portInt+ pure $+ RedisServerHandle+ { redisServerHandleProcessHandle = ph,+ redisServerHandlePort = pn+ }
+ sydtest-hedis.cabal view
@@ -0,0 +1,70 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: sydtest-hedis+version: 0.0.0.0+synopsis: An hedis companion library for sydtest+category: Testing+homepage: https://github.com/NorfairKing/sydtest#readme+bug-reports: https://github.com/NorfairKing/sydtest/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: Copyright (c) 2021 Tom Sydney Kerckhove+license: OtherLicense+license-file: LICENSE.md+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NorfairKing/sydtest++flag sydtest_integration_tests+ description: Whether to allow building integration tests+ manual: False+ default: True++library+ exposed-modules:+ Test.Syd.Redis+ other-modules:+ Paths_sydtest_hedis+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , bytestring+ , hedis+ , network+ , path+ , path-io+ , port-utils+ , sydtest+ , sydtest-typed-process+ , text+ , typed-process+ default-language: Haskell2010++test-suite sydtest-hedis-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Test.Syd.RedisSpec+ Paths_sydtest_hedis+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-tool-depends:+ sydtest-discover:sydtest-discover+ build-depends:+ base >=4.7 && <5+ , hedis+ , sydtest+ , sydtest-hedis+ if flag(sydtest_integration_tests)+ buildable: True+ else+ buildable: False+ default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ test/Test/Syd/RedisSpec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.RedisSpec (spec) where++import Database.Redis as Redis+import Test.Syd+import Test.Syd.Redis++spec :: Spec+spec = do+ describe "redisServerSpec" $+ redisServerSpec $+ it "sets up and tears down the redis server nicely" $ do+ pure () :: IO ()+ describe "redisSpec" $+ redisSpec $ do+ it "sets up and tears down a redis connection nicely" $ \conn -> do+ runRedis conn $ do+ errOrStatus <- Redis.set "hello" "world"+ liftIO $ case errOrStatus of+ Left err -> expectationFailure $ show err+ Right status -> status `shouldBe` Ok+ errOrReply <- Redis.get "hello"+ liftIO $ case errOrReply of+ Left err -> expectationFailure $ show err+ Right val -> val `shouldBe` Just "world"+ doNotRandomiseExecutionOrder $+ describe "shared state" $ do+ it "can write a message" $ \conn -> runRedis conn $ do+ errOrStatus <- Redis.set "hello" "world"+ liftIO $ case errOrStatus of+ Left err -> expectationFailure $ show err+ Right status -> status `shouldBe` Ok+ it "cannot read a message that has not been written yet" $ \conn -> runRedis conn $ do+ errOrReply <- Redis.get "hello"+ liftIO $ case errOrReply of+ Left err -> expectationFailure $ show err+ Right Nothing -> pure ()+ Right (Just val) -> expectationFailure $ "Should not have been able to read anything, but got: " <> show val