{-# 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 = [KeyName] -> TmpRedis
TmpRedis [] TmpRedis -> HList '[] -> HList '[TmpRedis]
forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` HList '[]
HNil
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
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 -> 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
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