{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK prune not-home #-}

{- |
Copyright   : (c) 2020-2021 Tim Emiola
SPDX-License-Identifier: BSD3
Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com >

Provides an instance of 'Proc' that launches @redis@ as a @tmp proc@.

The instance this module provides can be used in integration tests as is.

It's also possible to write other instances that launch @redis@ in different
ways; for those, this instance can be used as a reference example.
-}
module System.TmpProc.Docker.Redis
  ( -- * 'Proc' instance
    TmpRedis (..)

    -- * Useful definitions
  , aProc
  , aHandle
  , KeyName

    -- * Re-exports
  , module System.TmpProc
  )
where

import Control.Exception (catch)
import Control.Monad (void)
import qualified Data.ByteString.Char8 as C8
import qualified Data.Text as Text
import Database.Redis
  ( ConnectTimeout
  , Connection
  , checkedConnect
  , del
  , disconnect
  , parseConnectInfo
  , runRedis
  )
import System.TmpProc
  ( Connectable (..)
  , HList (..)
  , HandlesOf
  , HostIpAddress
  , Pinged (..)
  , Proc (..)
  , ProcHandle (..)
  , SvcURI
  , only
  , startupAll
  , withTmpConn
  )


-- | A singleton 'HList' containing an example 'TmpRedis'.
aProc :: HList '[TmpRedis]
aProc :: HList '[TmpRedis]
aProc = TmpRedis -> HList '[TmpRedis]
forall x. x -> HList '[x]
only (TmpRedis -> HList '[TmpRedis]) -> TmpRedis -> HList '[TmpRedis]
forall a b. (a -> b) -> a -> b
$ [SvcURI] -> TmpRedis
TmpRedis []


-- | An 'HList' that just contains the handle created from 'aProc'.
aHandle :: IO (HandlesOf '[TmpRedis])
aHandle :: IO (HandlesOf '[TmpRedis])
aHandle = HList '[TmpRedis] -> IO (HandlesOf '[TmpRedis])
forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList '[TmpRedis]
aProc


-- | The name of a key in redis.
type KeyName = C8.ByteString


{- | Provides the capability to launch a redis instance as @tmp proc@.

The constructor receives the names of keys to be dropped on 'reset'.
-}
newtype TmpRedis = TmpRedis [KeyName]


-- | Specifies how to run @redis@ as a @tmp proc@.
instance Proc TmpRedis where
  type Image TmpRedis = "redis:5.0"
  type Name TmpRedis = "a-redis-db"
  uriOf :: Text -> SvcURI
uriOf = Text -> SvcURI
mkUri'
  runArgs :: [Text]
runArgs = []
  ping :: ProcHandle TmpRedis -> IO Pinged
ping = IO () -> IO Pinged
forall a. IO a -> IO Pinged
toPinged (IO () -> IO Pinged)
-> (ProcHandle TmpRedis -> IO ())
-> ProcHandle TmpRedis
-> IO Pinged
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProcHandle TmpRedis -> (Connection -> IO ()) -> IO ())
-> (Connection -> IO ()) -> ProcHandle TmpRedis -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcHandle TmpRedis -> (Connection -> IO ()) -> IO ()
ProcHandle TmpRedis -> (Conn TmpRedis -> IO ()) -> IO ()
forall a b.
Connectable a =>
ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn (IO () -> Connection -> IO ()
forall a b. a -> b -> a
const (IO () -> Connection -> IO ()) -> IO () -> Connection -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  reset :: ProcHandle TmpRedis -> IO ()
reset = ProcHandle TmpRedis -> IO ()
clearKeys


-- | Specifies how to connect to a tmp @redis@ service.
instance Connectable TmpRedis where
  type Conn TmpRedis = Connection
  closeConn :: Conn TmpRedis -> IO ()
closeConn = Connection -> IO ()
Conn TmpRedis -> IO ()
disconnect
  openConn :: ProcHandle TmpRedis -> IO (Conn TmpRedis)
openConn = ProcHandle TmpRedis -> IO Connection
ProcHandle TmpRedis -> IO (Conn TmpRedis)
openConn'


openConn' :: ProcHandle TmpRedis -> IO Connection
openConn' :: ProcHandle TmpRedis -> IO Connection
openConn' ProcHandle TmpRedis
handle = case [Char] -> Either [Char] ConnectInfo
parseConnectInfo ([Char] -> Either [Char] ConnectInfo)
-> [Char] -> Either [Char] ConnectInfo
forall a b. (a -> b) -> a -> b
$ SvcURI -> [Char]
C8.unpack (SvcURI -> [Char]) -> SvcURI -> [Char]
forall a b. (a -> b) -> a -> b
$ ProcHandle TmpRedis -> SvcURI
forall a. ProcHandle a -> SvcURI
hUri ProcHandle TmpRedis
handle of
  Left [Char]
_ -> [Char] -> IO Connection
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO Connection) -> [Char] -> IO Connection
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid redis uri: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SvcURI -> [Char]
C8.unpack (ProcHandle TmpRedis -> SvcURI
forall a. ProcHandle a -> SvcURI
hUri ProcHandle TmpRedis
handle)
  Right ConnectInfo
x -> ConnectInfo -> IO Connection
checkedConnect ConnectInfo
x


toPinged :: IO a -> IO Pinged
toPinged :: forall a. IO a -> IO Pinged
toPinged IO a
action =
  ( (IO a
action IO a -> IO Pinged -> IO Pinged
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
OK)
      IO Pinged -> (ConnectTimeout -> IO Pinged) -> IO Pinged
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(ConnectTimeout
_ :: ConnectTimeout) -> Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK)
  )
    IO Pinged -> (IOError -> IO Pinged) -> IO Pinged
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
_ :: IOError) -> Pinged -> IO Pinged
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK)


mkUri' :: HostIpAddress -> SvcURI
mkUri' :: Text -> SvcURI
mkUri' Text
ip = SvcURI
"redis://" SvcURI -> SvcURI -> SvcURI
forall a. Semigroup a => a -> a -> a
<> [Char] -> SvcURI
C8.pack (Text -> [Char]
Text.unpack Text
ip) SvcURI -> SvcURI -> SvcURI
forall a. Semigroup a => a -> a -> a
<> SvcURI
"/"


clearKeys :: ProcHandle TmpRedis -> IO ()
clearKeys :: ProcHandle TmpRedis -> IO ()
clearKeys handle :: ProcHandle TmpRedis
handle@(ProcHandle {TmpRedis
hProc :: TmpRedis
hProc :: forall a. ProcHandle a -> a
hProc}) =
  let go :: TmpRedis -> IO ()
go (TmpRedis []) = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      go (TmpRedis [SvcURI]
keys) = ProcHandle TmpRedis -> (Conn TmpRedis -> IO ()) -> IO ()
forall a b.
Connectable a =>
ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn ProcHandle TmpRedis
handle ((Conn TmpRedis -> IO ()) -> IO ())
-> (Conn TmpRedis -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Conn TmpRedis
c -> Connection -> Redis () -> IO ()
forall a. Connection -> Redis a -> IO a
runRedis Connection
Conn TmpRedis
c (Redis () -> IO ()) -> Redis () -> IO ()
forall a b. (a -> b) -> a -> b
$ Redis (Either Reply Integer) -> Redis ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Redis (Either Reply Integer) -> Redis ())
-> Redis (Either Reply Integer) -> Redis ()
forall a b. (a -> b) -> a -> b
$ [SvcURI] -> Redis (Either Reply Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[SvcURI] -> m (f Integer)
del [SvcURI]
keys
   in TmpRedis -> IO ()
go TmpRedis
hProc