{-# 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 = [SvcURI] -> TmpRedis
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 = 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 -> SvcURI
uriOf = Text -> SvcURI
mkUri'
  runArgs :: [Text]
runArgs = []
  ping :: ProcHandle TmpRedis -> IO Pinged
ping = forall a. IO a -> IO Pinged
toPinged forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b.
Connectable a =>
ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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 ()
disconnect
  openConn :: ProcHandle TmpRedis -> IO (Conn TmpRedis)
openConn = ProcHandle TmpRedis -> IO Connection
openConn'


openConn' :: ProcHandle TmpRedis -> IO Connection
openConn' :: ProcHandle TmpRedis -> IO Connection
openConn' ProcHandle TmpRedis
handle = case [Char] -> Either [Char] ConnectInfo
parseConnectInfo forall a b. (a -> b) -> a -> b
$ SvcURI -> [Char]
C8.unpack forall a b. (a -> b) -> a -> b
$ forall a. ProcHandle a -> SvcURI
hUri ProcHandle TmpRedis
handle of
  Left [Char]
_  -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"invalid redis uri: " forall a. [a] -> [a] -> [a]
++ (SvcURI -> [Char]
C8.unpack forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
OK)
                    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(ConnectTimeout
_ :: ConnectTimeout) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK))
                  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
_ :: IOError) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK)



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


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 []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      go (TmpRedis [SvcURI]
keys) = forall a b.
Connectable a =>
ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn ProcHandle TmpRedis
handle forall a b. (a -> b) -> a -> b
$ \Conn TmpRedis
c -> forall a. Connection -> Redis a -> IO a
runRedis Conn TmpRedis
c forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[SvcURI] -> m (f Integer)
del [SvcURI]
keys
  in
    TmpRedis -> IO ()
go TmpRedis
hProc