{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
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
data RedisServerHandle = RedisServerHandle
{ RedisServerHandle -> Process () () ()
redisServerHandleProcessHandle :: !(Process () () ()),
RedisServerHandle -> PortNumber
redisServerHandlePort :: !PortNumber
}
redisSpec :: TestDefM (RedisServerHandle ': outers) Redis.Connection result -> TestDefM outers inner result
redisSpec :: TestDefM (RedisServerHandle : outers) Connection result
-> TestDefM outers inner result
redisSpec = TestDefM (RedisServerHandle : outers) inner result
-> TestDefM outers inner result
forall (outers :: [*]) inner result.
TestDefM (RedisServerHandle : outers) inner result
-> TestDefM outers inner result
redisServerSpec (TestDefM (RedisServerHandle : outers) inner result
-> TestDefM outers inner result)
-> (TestDefM (RedisServerHandle : outers) Connection result
-> TestDefM (RedisServerHandle : outers) inner result)
-> TestDefM (RedisServerHandle : outers) Connection result
-> TestDefM outers inner result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RedisServerHandle -> inner -> SetupFunc Connection)
-> TestDefM (RedisServerHandle : outers) Connection result
-> TestDefM (RedisServerHandle : outers) inner result
forall (outers :: [*]) outer oldInner newInner result.
HContains outers outer =>
(outer -> oldInner -> SetupFunc newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWith' (\RedisServerHandle
serverHandle inner
_ -> RedisServerHandle -> SetupFunc Connection
redisConnectionSetupFunc RedisServerHandle
serverHandle)
redisConnectionSetupFunc :: RedisServerHandle -> SetupFunc Redis.Connection
redisConnectionSetupFunc :: RedisServerHandle -> SetupFunc Connection
redisConnectionSetupFunc RedisServerHandle {PortNumber
Process () () ()
redisServerHandlePort :: PortNumber
redisServerHandleProcessHandle :: Process () () ()
redisServerHandlePort :: RedisServerHandle -> PortNumber
redisServerHandleProcessHandle :: RedisServerHandle -> Process () () ()
..} = do
let connInfo :: ConnectInfo
connInfo = ConnectInfo
Redis.defaultConnectInfo {connectPort :: PortID
connectPort = PortNumber -> PortID
PortNumber PortNumber
redisServerHandlePort}
Connection
conn <- ConnectInfo -> SetupFunc Connection
checkedConnectSetupFunc ConnectInfo
connInfo
(forall r. (Connection -> IO r) -> IO r) -> SetupFunc Connection
forall resource.
(forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
SetupFunc ((forall r. (Connection -> IO r) -> IO r) -> SetupFunc Connection)
-> (forall r. (Connection -> IO r) -> IO r) -> SetupFunc Connection
forall a b. (a -> b) -> a -> b
$ \Connection -> IO r
func -> do
Connection -> IO ()
cleanRedisServerState Connection
conn
Connection -> IO r
func Connection
conn
checkedConnectSetupFunc :: Redis.ConnectInfo -> SetupFunc Redis.Connection
checkedConnectSetupFunc :: ConnectInfo -> SetupFunc Connection
checkedConnectSetupFunc ConnectInfo
connInfo = IO Connection -> (Connection -> IO ()) -> SetupFunc Connection
forall resource r.
IO resource -> (resource -> IO r) -> SetupFunc resource
bracketSetupFunc (ConnectInfo -> IO Connection
checkedConnect ConnectInfo
connInfo) Connection -> IO ()
disconnect
redisServerSpec :: TestDefM (RedisServerHandle ': outers) inner result -> TestDefM outers inner result
redisServerSpec :: TestDefM (RedisServerHandle : outers) inner result
-> TestDefM outers inner result
redisServerSpec = SetupFunc RedisServerHandle
-> TestDefM (RedisServerHandle : outers) inner result
-> TestDefM outers inner result
forall outer (outers :: [*]) inner result.
SetupFunc outer
-> TestDefM (outer : outers) inner result
-> TestDefM outers inner result
setupAroundAll SetupFunc RedisServerHandle
redisServerSetupFunc (TestDefM (RedisServerHandle : outers) inner result
-> TestDefM outers inner result)
-> (TestDefM (RedisServerHandle : outers) inner result
-> TestDefM (RedisServerHandle : outers) inner result)
-> TestDefM (RedisServerHandle : outers) inner result
-> TestDefM outers inner result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestDefM (RedisServerHandle : outers) inner result
-> TestDefM (RedisServerHandle : outers) inner result
forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
sequential
cleanRedisServerState :: Connection -> IO ()
cleanRedisServerState :: Connection -> IO ()
cleanRedisServerState Connection
conn = do
Either Reply Status
errOrStatus <- Connection
-> Redis (Either Reply Status) -> IO (Either Reply Status)
forall a. Connection -> Redis a -> IO a
runRedis Connection
conn Redis (Either Reply Status)
forall (m :: * -> *) (f :: * -> *). RedisCtx m f => m (f Status)
Redis.flushall
case Either Reply Status
errOrStatus of
Left Reply
err -> String -> IO ()
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Something went wrong while trying to clean the state before the test starts: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Reply -> String
forall a. Show a => a -> String
show Reply
err
Right Status
s -> Status
s Status -> Status -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Status
Ok
redisServerSetupFunc :: SetupFunc RedisServerHandle
redisServerSetupFunc :: SetupFunc RedisServerHandle
redisServerSetupFunc = do
Path Abs Dir
td <- String -> SetupFunc (Path Abs Dir)
tempDirSetupFunc String
"sydtest-hedis"
Path Abs Dir -> SetupFunc RedisServerHandle
redisServerSetupFunc' Path Abs Dir
td
redisServerSetupFunc' :: Path Abs Dir -> SetupFunc RedisServerHandle
redisServerSetupFunc' :: Path Abs Dir -> SetupFunc RedisServerHandle
redisServerSetupFunc' Path Abs Dir
td = do
Path Abs File
pidFile <- Path Abs Dir -> String -> SetupFunc (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile Path Abs Dir
td String
"redis.pid"
Path Abs File
logFile <- Path Abs Dir -> String -> SetupFunc (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile Path Abs Dir
td String
"redis.log"
Int
portInt <- IO Int -> SetupFunc Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> SetupFunc Int) -> IO Int -> SetupFunc Int
forall a b. (a -> b) -> a -> b
$ do
(Int
portInt, Socket
_socket) <- IO (Int, Socket)
openFreePort
Socket -> IO ()
close Socket
_socket
Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
portInt
let pn :: PortNumber
pn = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
portInt
let configFileContents :: Text
configFileContents =
String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ [String] -> String
unwords [String
"port", Int -> String
forall a. Show a => a -> String
show (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
pn :: Int)],
[String] -> String
unwords [String
"pidfile", Path Abs File -> String
fromAbsFile Path Abs File
pidFile],
[String] -> String
unwords [String
"always-show-logo", String
"no"],
[String] -> String
unwords [String
"logfile", Path Abs File -> String
fromAbsFile Path Abs File
logFile]
]
Path Abs File
configFile <- String -> ByteString -> SetupFunc (Path Abs File)
tempBinaryFileWithContentsSetupFunc String
"config-file" (Text -> ByteString
TE.encodeUtf8 Text
configFileContents)
let pc :: ProcessConfig () () ()
pc =
String -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
String
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setWorkingDir (Path Abs Dir -> String
fromAbsDir Path Abs Dir
td) (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$
StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$
StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$
String -> [String] -> ProcessConfig () () ()
proc
String
"redis-server"
[Path Abs File -> String
fromAbsFile Path Abs File
configFile]
Process () () ()
ph <- ProcessConfig () () () -> SetupFunc (Process () () ())
forall stdin stdout stderr.
ProcessConfig stdin stdout stderr
-> SetupFunc (Process stdin stdout stderr)
typedProcessSetupFunc ProcessConfig () () ()
pc
IO () -> SetupFunc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SetupFunc ()) -> IO () -> SetupFunc ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> IO ()
Socket.wait String
"127.0.0.1" Int
portInt
RedisServerHandle -> SetupFunc RedisServerHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RedisServerHandle -> SetupFunc RedisServerHandle)
-> RedisServerHandle -> SetupFunc RedisServerHandle
forall a b. (a -> b) -> a -> b
$
RedisServerHandle :: Process () () () -> PortNumber -> RedisServerHandle
RedisServerHandle
{ redisServerHandleProcessHandle :: Process () () ()
redisServerHandleProcessHandle = Process () () ()
ph,
redisServerHandlePort :: PortNumber
redisServerHandlePort = PortNumber
pn
}