{-# 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, startupAll,
withTmpConn)
aProc :: HList '[TmpRedis]
aProc :: HList '[TmpRedis]
aProc = [SvcURI] -> TmpRedis
TmpRedis [] forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` HList '[]
HNil
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
data 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 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