{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK prune not-home #-}
module System.TmpProc.Docker.Redis
(
TmpRedis (..)
, aProc
, aHandle
, KeyName
, 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
)
aProc :: HList '[TmpRedis]
aProc :: HList '[TmpRedis]
aProc = forall x. x -> HList '[x]
only forall a b. (a -> b) -> a -> b
$ [SvcURI] -> TmpRedis
TmpRedis []
aHandle :: IO (HandlesOf '[TmpRedis])
aHandle :: IO (HandlesOf '[TmpRedis])
aHandle = forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList '[TmpRedis]
aProc
type KeyName = C8.ByteString
newtype TmpRedis = TmpRedis [KeyName]
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
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. 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 (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