{-# 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, startupAll,
                                        withTmpConn)


{-| A singleton 'HList' containing an example 'TmpRedis'. -}
aProc :: HList '[TmpRedis]
aProc :: HList '[TmpRedis]
aProc = [KeyName] -> TmpRedis
TmpRedis [] TmpRedis -> HList '[] -> HList '[TmpRedis]
forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` HList '[]
HNil


{-| 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'.

-}
data 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 -> KeyName
uriOf = Text -> KeyName
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 ()
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 (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 String -> Either String ConnectInfo
parseConnectInfo (String -> Either String ConnectInfo)
-> String -> Either String ConnectInfo
forall a b. (a -> b) -> a -> b
$ KeyName -> String
C8.unpack (KeyName -> String) -> KeyName -> String
forall a b. (a -> b) -> a -> b
$ ProcHandle TmpRedis -> KeyName
forall a. ProcHandle a -> KeyName
hUri ProcHandle TmpRedis
handle of
  Left String
_  -> String -> IO Connection
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Connection) -> String -> IO Connection
forall a b. (a -> b) -> a -> b
$ String
"invalid redis uri: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (KeyName -> String
C8.unpack (KeyName -> String) -> KeyName -> String
forall a b. (a -> b) -> a -> b
$ ProcHandle TmpRedis -> KeyName
forall a. ProcHandle a -> KeyName
hUri ProcHandle TmpRedis
handle)
  Right ConnectInfo
x -> ConnectInfo -> IO Connection
checkedConnect ConnectInfo
x


toPinged :: IO a -> IO Pinged
toPinged :: IO a -> IO Pinged
toPinged IO a
action = ((IO a
action IO a -> IO Pinged -> IO Pinged
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pinged -> IO Pinged
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK)



mkUri' :: HostIpAddress -> SvcURI
mkUri' :: Text -> KeyName
mkUri' Text
ip =  KeyName
"redis://" KeyName -> KeyName -> KeyName
forall a. Semigroup a => a -> a -> a
<> (String -> KeyName
C8.pack (String -> KeyName) -> String -> KeyName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
ip) KeyName -> KeyName -> KeyName
forall a. Semigroup a => a -> a -> a
<> KeyName
"/"


clearKeys :: ProcHandle TmpRedis -> IO ()
clearKeys :: ProcHandle TmpRedis -> IO ()
clearKeys handle :: ProcHandle TmpRedis
handle@(ProcHandle {TmpRedis
hProc :: forall a. ProcHandle a -> a
hProc :: TmpRedis
hProc}) =
  let go :: TmpRedis -> IO ()
go (TmpRedis []) = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      go (TmpRedis [KeyName]
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
$ [KeyName] -> Redis (Either Reply Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[KeyName] -> m (f Integer)
del [KeyName]
keys
  in
    TmpRedis -> IO ()
go TmpRedis
hProc