{-# 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 <[email protected] >

Provides an instance of 'Proc' that launches @postgres@ 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 @postgres@ in different
ways; for those, this instance can be used as a reference example.
-}
module System.TmpProc.Docker.Postgres
  ( -- * 'Proc' instance
    TmpPostgres (..)

    -- * Useful definitions
  , aProc
  , aHandle

    -- * Re-exports
  , 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
  , only
  , startupAll
  , withTmpConn
  )


-- | A singleton 'HList' containing a 'TmpPostgres'.
aProc :: HList '[TmpPostgres]
aProc :: HList '[TmpPostgres]
aProc = TmpPostgres -> HList '[TmpPostgres]
forall x. x -> HList '[x]
only (TmpPostgres -> HList '[TmpPostgres])
-> TmpPostgres -> HList '[TmpPostgres]
forall a b. (a -> b) -> a -> b
$ [Text] -> TmpPostgres
TmpPostgres []


-- | An 'HList' that contains the handle created from 'aProc'.
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


{- | Provides the capability to launch a Postgres database as a @tmp proc@.

The constructor receives the names of the tables to be dropped on 'reset'.
-}
newtype TmpPostgres = TmpPostgres [Text]


-- | Specifies how to run @postgres@ as a @tmp proc@.
instance Proc TmpPostgres where
  type Image TmpPostgres = "postgres:10.6"
  type Name TmpPostgres = "a-postgres-db"
  uriOf :: Text -> ByteString
uriOf = Text -> ByteString
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
. ByteString -> IO Connection
connectPostgreSQL (ByteString -> IO Connection)
-> (ProcHandle TmpPostgres -> ByteString)
-> ProcHandle TmpPostgres
-> IO Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcHandle TmpPostgres -> ByteString
forall a. ProcHandle a -> ByteString
hUri
  reset :: ProcHandle TmpPostgres -> IO ()
reset = ProcHandle TmpPostgres -> IO ()
reset'


-- | Specifies how to connect to a tmp @postgres@ db.
instance Connectable TmpPostgres where
  type Conn TmpPostgres = Connection
  openConn :: ProcHandle TmpPostgres -> IO (Conn TmpPostgres)
openConn = ByteString -> IO Connection
connectPostgreSQL (ByteString -> IO Connection)
-> (ProcHandle TmpPostgres -> ByteString)
-> ProcHandle TmpPostgres
-> IO Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcHandle TmpPostgres -> ByteString
forall a. ProcHandle a -> ByteString
hUri
  closeConn :: Conn TmpPostgres -> IO ()
closeConn = Connection -> IO ()
Conn TmpPostgres -> IO ()
close


-- | Makes a uri whose password matches the one specified in 'runArgs''.
mkUri' :: HostIpAddress -> SvcURI
mkUri' :: Text -> ByteString
mkUri' Text
ip =
  ByteString
"postgres://postgres:"
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
dbPassword
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"@"
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
C8.pack (Text -> [Char]
Text.unpack Text
ip)
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/postgres"


dbPassword :: C8.ByteString
dbPassword :: ByteString
dbPassword = ByteString
"mysecretpassword"


-- | Match the password used in 'mkUri''.
runArgs' :: [Text]
runArgs' :: [Text]
runArgs' =
  [ Text
"-e"
  , Text
"POSTGRES_PASSWORD=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (ByteString -> [Char]
C8.unpack ByteString
dbPassword)
  ]


toPinged :: IO a -> IO Pinged
toPinged :: forall a. IO a -> IO Pinged
toPinged IO a
action =
  ( (IO a
action IO a -> IO Pinged -> IO Pinged
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pinged -> IO Pinged
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pinged
NotOK)


-- | Empty all rows in the tables, if any are specified.
reset' :: ProcHandle TmpPostgres -> IO ()
reset' :: ProcHandle TmpPostgres -> IO ()
reset' handle :: ProcHandle TmpPostgres
handle@(ProcHandle {TmpPostgres
hProc :: TmpPostgres
hProc :: forall a. ProcHandle a -> a
hProc}) =
  let go :: TmpPostgres -> IO ()
go (TmpPostgres []) = () -> IO ()
forall a. a -> IO a
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
. ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString ([Char] -> Query) -> ([Char] -> [Char]) -> [Char] -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++) [Char]
"DELETE FROM ") ([Char] -> Query) -> (Text -> [Char]) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack) [Text]
tables
   in TmpPostgres -> IO ()
go TmpPostgres
hProc