{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK prune not-home #-}
module System.TmpProc.Docker.Postgres
(
TmpPostgres(..)
, aProc
, aHandle
, module System.TmpProc
)
where
import Control.Exception (catch)
import qualified Data.ByteString.Char8 as C8
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as Text
import Database.PostgreSQL.Simple (Connection, SqlError, close,
connectPostgreSQL, execute_)
import System.TmpProc (Connectable (..), HList (..),
HandlesOf, HostIpAddress,
Pinged (..), Proc (..),
ProcHandle (..), SvcURI,
startupAll, withTmpConn)
aProc :: HList '[TmpPostgres]
aProc :: HList '[TmpPostgres]
aProc = [Text] -> TmpPostgres
TmpPostgres [] TmpPostgres -> HList '[] -> HList '[TmpPostgres]
forall anyTy (manyTys :: [*]).
anyTy -> HList manyTys -> HList (anyTy : manyTys)
`HCons` HList '[]
HNil
aHandle :: IO (HandlesOf '[TmpPostgres])
aHandle :: IO (HandlesOf '[TmpPostgres])
aHandle = HList '[TmpPostgres] -> IO (HandlesOf '[TmpPostgres])
forall (procs :: [*]).
AreProcs procs =>
HList procs -> IO (HandlesOf procs)
startupAll HList '[TmpPostgres]
aProc
data TmpPostgres = TmpPostgres [Text]
instance Proc TmpPostgres where
type Image TmpPostgres = "postgres:10.6"
type Name TmpPostgres = "a-postgres-db"
uriOf :: Text -> SvcURI
uriOf = Text -> SvcURI
mkUri'
runArgs :: [Text]
runArgs = [Text]
runArgs'
ping :: ProcHandle TmpPostgres -> IO Pinged
ping = IO Connection -> IO Pinged
forall a. IO a -> IO Pinged
toPinged (IO Connection -> IO Pinged)
-> (ProcHandle TmpPostgres -> IO Connection)
-> ProcHandle TmpPostgres
-> IO Pinged
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SvcURI -> IO Connection
connectPostgreSQL (SvcURI -> IO Connection)
-> (ProcHandle TmpPostgres -> SvcURI)
-> ProcHandle TmpPostgres
-> IO Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcHandle TmpPostgres -> SvcURI
forall a. ProcHandle a -> SvcURI
hUri
reset :: ProcHandle TmpPostgres -> IO ()
reset = ProcHandle TmpPostgres -> IO ()
reset'
instance Connectable TmpPostgres where
type Conn TmpPostgres = Connection
openConn :: ProcHandle TmpPostgres -> IO (Conn TmpPostgres)
openConn = SvcURI -> IO Connection
connectPostgreSQL (SvcURI -> IO Connection)
-> (ProcHandle TmpPostgres -> SvcURI)
-> ProcHandle TmpPostgres
-> IO Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcHandle TmpPostgres -> SvcURI
forall a. ProcHandle a -> SvcURI
hUri
closeConn :: Conn TmpPostgres -> IO ()
closeConn = Connection -> IO ()
Conn TmpPostgres -> IO ()
close
mkUri' :: HostIpAddress -> SvcURI
mkUri' :: Text -> SvcURI
mkUri' Text
ip = SvcURI
"host="
SvcURI -> SvcURI -> SvcURI
forall a. Semigroup a => a -> a -> a
<> String -> SvcURI
C8.pack (Text -> String
Text.unpack Text
ip)
SvcURI -> SvcURI -> SvcURI
forall a. Semigroup a => a -> a -> a
<> SvcURI
" dbname=postgres user=postgres password="
SvcURI -> SvcURI -> SvcURI
forall a. Semigroup a => a -> a -> a
<> SvcURI
dbPassword
SvcURI -> SvcURI -> SvcURI
forall a. Semigroup a => a -> a -> a
<> SvcURI
" port=5432"
dbPassword :: C8.ByteString
dbPassword :: SvcURI
dbPassword = SvcURI
"mysecretpassword"
runArgs' :: [Text]
runArgs' :: [Text]
runArgs' =
[ Text
"-e"
, Text
"POSTGRES_PASSWORD=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (SvcURI -> String
C8.unpack SvcURI
dbPassword)
]
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 -> (SqlError -> IO Pinged) -> IO Pinged
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SqlError
_ :: SqlError) -> 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)
reset' :: ProcHandle TmpPostgres -> IO ()
reset' :: ProcHandle TmpPostgres -> IO ()
reset' handle :: ProcHandle TmpPostgres
handle@(ProcHandle {TmpPostgres
hProc :: forall a. ProcHandle a -> a
hProc :: TmpPostgres
hProc}) =
let go :: TmpPostgres -> IO ()
go (TmpPostgres []) = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
go (TmpPostgres [Text]
tables) = ProcHandle TmpPostgres -> (Conn TmpPostgres -> IO ()) -> IO ()
forall a b.
Connectable a =>
ProcHandle a -> (Conn a -> IO b) -> IO b
withTmpConn ProcHandle TmpPostgres
handle ((Conn TmpPostgres -> IO ()) -> IO ())
-> (Conn TmpPostgres -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Conn TmpPostgres
c ->
(Text -> IO Int64) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Connection -> Query -> IO Int64
execute_ Connection
Conn TmpPostgres
c (Query -> IO Int64) -> (Text -> Query) -> Text -> IO Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> (String -> String) -> String -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"DELETE FROM ") (String -> Query) -> (Text -> String) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) [Text]
tables
in TmpPostgres -> IO ()
go TmpPostgres
hProc