{-# 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
  { RedisServerHandle -> Process () () ()
redisServerHandleProcessHandle :: !(Process () () ()),
    RedisServerHandle -> PortNumber
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 :: 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)

-- | 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 -> 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

-- | A 'SetupFunc' that 'bracket's 'checkedConnect' and 'disconnect'.
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

-- | Run a redis server around a group of tests.
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 -- Must run sequentially because state is shared.

-- | Clean the redis server's state.
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 -- Clean state
  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

-- | Setup func for running a Redis server
--
-- This function uses a temporary directory (using 'tempDirSetupFunc') for any state.
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

-- | Setup func for running a Redis server in a given directory
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 -- (hopefully) safe because it came from 'getFreePort'.
  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"], -- No need to see the logo.
              [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
      }