{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module TestContainers.Monad
  ( -- * Monad
    MonadDocker,
    TestContainer,
    runTestContainer,

    -- * Runtime configuration
    Config (..),
  )
where

import Control.Applicative (liftA2)
import Control.Monad.Catch
  ( MonadCatch,
    MonadMask,
    MonadThrow,
  )
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.IO.Unlift (MonadUnliftIO (..))
import Control.Monad.Reader (MonadReader (..), ReaderT, runReaderT)
import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT)
import Data.IORef (newIORef, readIORef, writeIORef)
import TestContainers.Docker.Reaper (Reaper)
import TestContainers.Trace (Tracer)

newtype TestContainerEnv = TestContainerEnv
  { TestContainerEnv -> Config
config :: Config
  }

-- | The heart and soul of the testcontainers library.
--
-- @since 0.5.0.0
newtype TestContainer a = TestContainer {forall a.
TestContainer a -> ReaderT TestContainerEnv (ResourceT IO) a
unTestContainer :: ReaderT TestContainerEnv (ResourceT IO) a}
  deriving newtype
    ( (forall a b. (a -> b) -> TestContainer a -> TestContainer b)
-> (forall a b. a -> TestContainer b -> TestContainer a)
-> Functor TestContainer
forall a b. a -> TestContainer b -> TestContainer a
forall a b. (a -> b) -> TestContainer a -> TestContainer b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TestContainer a -> TestContainer b
fmap :: forall a b. (a -> b) -> TestContainer a -> TestContainer b
$c<$ :: forall a b. a -> TestContainer b -> TestContainer a
<$ :: forall a b. a -> TestContainer b -> TestContainer a
Functor,
      Functor TestContainer
Functor TestContainer =>
(forall a. a -> TestContainer a)
-> (forall a b.
    TestContainer (a -> b) -> TestContainer a -> TestContainer b)
-> (forall a b c.
    (a -> b -> c)
    -> TestContainer a -> TestContainer b -> TestContainer c)
-> (forall a b.
    TestContainer a -> TestContainer b -> TestContainer b)
-> (forall a b.
    TestContainer a -> TestContainer b -> TestContainer a)
-> Applicative TestContainer
forall a. a -> TestContainer a
forall a b. TestContainer a -> TestContainer b -> TestContainer a
forall a b. TestContainer a -> TestContainer b -> TestContainer b
forall a b.
TestContainer (a -> b) -> TestContainer a -> TestContainer b
forall a b c.
(a -> b -> c)
-> TestContainer a -> TestContainer b -> TestContainer c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> TestContainer a
pure :: forall a. a -> TestContainer a
$c<*> :: forall a b.
TestContainer (a -> b) -> TestContainer a -> TestContainer b
<*> :: forall a b.
TestContainer (a -> b) -> TestContainer a -> TestContainer b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> TestContainer a -> TestContainer b -> TestContainer c
liftA2 :: forall a b c.
(a -> b -> c)
-> TestContainer a -> TestContainer b -> TestContainer c
$c*> :: forall a b. TestContainer a -> TestContainer b -> TestContainer b
*> :: forall a b. TestContainer a -> TestContainer b -> TestContainer b
$c<* :: forall a b. TestContainer a -> TestContainer b -> TestContainer a
<* :: forall a b. TestContainer a -> TestContainer b -> TestContainer a
Applicative,
      Applicative TestContainer
Applicative TestContainer =>
(forall a b.
 TestContainer a -> (a -> TestContainer b) -> TestContainer b)
-> (forall a b.
    TestContainer a -> TestContainer b -> TestContainer b)
-> (forall a. a -> TestContainer a)
-> Monad TestContainer
forall a. a -> TestContainer a
forall a b. TestContainer a -> TestContainer b -> TestContainer b
forall a b.
TestContainer a -> (a -> TestContainer b) -> TestContainer b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
TestContainer a -> (a -> TestContainer b) -> TestContainer b
>>= :: forall a b.
TestContainer a -> (a -> TestContainer b) -> TestContainer b
$c>> :: forall a b. TestContainer a -> TestContainer b -> TestContainer b
>> :: forall a b. TestContainer a -> TestContainer b -> TestContainer b
$creturn :: forall a. a -> TestContainer a
return :: forall a. a -> TestContainer a
Monad,
      Monad TestContainer
Monad TestContainer =>
(forall a. IO a -> TestContainer a) -> MonadIO TestContainer
forall a. IO a -> TestContainer a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> TestContainer a
liftIO :: forall a. IO a -> TestContainer a
MonadIO,
      MonadCatch TestContainer
MonadCatch TestContainer =>
(forall b.
 HasCallStack =>
 ((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
 -> TestContainer b)
-> (forall b.
    HasCallStack =>
    ((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
    -> TestContainer b)
-> (forall a b c.
    HasCallStack =>
    TestContainer a
    -> (a -> ExitCase b -> TestContainer c)
    -> (a -> TestContainer b)
    -> TestContainer (b, c))
-> MonadMask TestContainer
forall b.
HasCallStack =>
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
forall a b c.
HasCallStack =>
TestContainer a
-> (a -> ExitCase b -> TestContainer c)
-> (a -> TestContainer b)
-> TestContainer (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
mask :: forall b.
HasCallStack =>
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
$cgeneralBracket :: forall a b c.
HasCallStack =>
TestContainer a
-> (a -> ExitCase b -> TestContainer c)
-> (a -> TestContainer b)
-> TestContainer (b, c)
generalBracket :: forall a b c.
HasCallStack =>
TestContainer a
-> (a -> ExitCase b -> TestContainer c)
-> (a -> TestContainer b)
-> TestContainer (b, c)
MonadMask,
      MonadThrow TestContainer
MonadThrow TestContainer =>
(forall e a.
 (HasCallStack, Exception e) =>
 TestContainer a -> (e -> TestContainer a) -> TestContainer a)
-> MonadCatch TestContainer
forall e a.
(HasCallStack, Exception e) =>
TestContainer a -> (e -> TestContainer a) -> TestContainer a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
TestContainer a -> (e -> TestContainer a) -> TestContainer a
catch :: forall e a.
(HasCallStack, Exception e) =>
TestContainer a -> (e -> TestContainer a) -> TestContainer a
MonadCatch,
      Monad TestContainer
Monad TestContainer =>
(forall e a. (HasCallStack, Exception e) => e -> TestContainer a)
-> MonadThrow TestContainer
forall e a. (HasCallStack, Exception e) => e -> TestContainer a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> TestContainer a
throwM :: forall e a. (HasCallStack, Exception e) => e -> TestContainer a
MonadThrow,
      MonadIO TestContainer
MonadIO TestContainer =>
(forall a. ResourceT IO a -> TestContainer a)
-> MonadResource TestContainer
forall a. ResourceT IO a -> TestContainer a
forall (m :: * -> *).
MonadIO m =>
(forall a. ResourceT IO a -> m a) -> MonadResource m
$cliftResourceT :: forall a. ResourceT IO a -> TestContainer a
liftResourceT :: forall a. ResourceT IO a -> TestContainer a
MonadResource,
      Monad TestContainer
Monad TestContainer =>
(forall a. (a -> TestContainer a) -> TestContainer a)
-> MonadFix TestContainer
forall a. (a -> TestContainer a) -> TestContainer a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall a. (a -> TestContainer a) -> TestContainer a
mfix :: forall a. (a -> TestContainer a) -> TestContainer a
MonadFix
    )

-- Instance defined without newtype deriving as GHC has a hard time
-- deriving it for old versions of unliftio.
instance MonadUnliftIO TestContainer where
  withRunInIO :: forall b.
((forall a. TestContainer a -> IO a) -> IO b) -> TestContainer b
withRunInIO (forall a. TestContainer a -> IO a) -> IO b
action = ReaderT TestContainerEnv (ResourceT IO) b -> TestContainer b
forall a.
ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a
TestContainer (ReaderT TestContainerEnv (ResourceT IO) b -> TestContainer b)
-> ReaderT TestContainerEnv (ResourceT IO) b -> TestContainer b
forall a b. (a -> b) -> a -> b
$
    ((forall a. ReaderT TestContainerEnv (ResourceT IO) a -> IO a)
 -> IO b)
-> ReaderT TestContainerEnv (ResourceT IO) b
forall b.
((forall a. ReaderT TestContainerEnv (ResourceT IO) a -> IO a)
 -> IO b)
-> ReaderT TestContainerEnv (ResourceT IO) b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ReaderT TestContainerEnv (ResourceT IO) a -> IO a)
  -> IO b)
 -> ReaderT TestContainerEnv (ResourceT IO) b)
-> ((forall a. ReaderT TestContainerEnv (ResourceT IO) a -> IO a)
    -> IO b)
-> ReaderT TestContainerEnv (ResourceT IO) b
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT TestContainerEnv (ResourceT IO) a -> IO a
runInIo ->
      (forall a. TestContainer a -> IO a) -> IO b
action (ReaderT TestContainerEnv (ResourceT IO) a -> IO a
forall a. ReaderT TestContainerEnv (ResourceT IO) a -> IO a
runInIo (ReaderT TestContainerEnv (ResourceT IO) a -> IO a)
-> (TestContainer a -> ReaderT TestContainerEnv (ResourceT IO) a)
-> TestContainer a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestContainer a -> ReaderT TestContainerEnv (ResourceT IO) a
forall a.
TestContainer a -> ReaderT TestContainerEnv (ResourceT IO) a
unTestContainer)

instance MonadReader Config TestContainer where
  ask :: TestContainer Config
ask = ReaderT TestContainerEnv (ResourceT IO) Config
-> TestContainer Config
forall a.
ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a
TestContainer (ReaderT TestContainerEnv (ResourceT IO) Config
 -> TestContainer Config)
-> ReaderT TestContainerEnv (ResourceT IO) Config
-> TestContainer Config
forall a b. (a -> b) -> a -> b
$ do
    TestContainerEnv {Config
config :: TestContainerEnv -> Config
config :: Config
config} <- ReaderT TestContainerEnv (ResourceT IO) TestContainerEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
    Config -> ReaderT TestContainerEnv (ResourceT IO) Config
forall a. a -> ReaderT TestContainerEnv (ResourceT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
config

  local :: forall a. (Config -> Config) -> TestContainer a -> TestContainer a
local Config -> Config
f (TestContainer ReaderT TestContainerEnv (ResourceT IO) a
action) = ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a
forall a.
ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a
TestContainer (ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a)
-> ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a
forall a b. (a -> b) -> a -> b
$ do
    (TestContainerEnv -> TestContainerEnv)
-> ReaderT TestContainerEnv (ResourceT IO) a
-> ReaderT TestContainerEnv (ResourceT IO) a
forall a.
(TestContainerEnv -> TestContainerEnv)
-> ReaderT TestContainerEnv (ResourceT IO) a
-> ReaderT TestContainerEnv (ResourceT IO) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: TestContainerEnv
env@TestContainerEnv {Config
config :: TestContainerEnv -> Config
config :: Config
config} -> TestContainerEnv
env {config = f config}) ReaderT TestContainerEnv (ResourceT IO) a
action

instance (Semigroup a) => Semigroup (TestContainer a) where
  <> :: TestContainer a -> TestContainer a -> TestContainer a
(<>) =
    (a -> a -> a)
-> TestContainer a -> TestContainer a -> TestContainer a
forall a b c.
(a -> b -> c)
-> TestContainer a -> TestContainer b -> TestContainer c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Monoid a) => Monoid (TestContainer a) where
  mempty :: TestContainer a
mempty = a -> TestContainer a
forall a. a -> TestContainer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

-- | Run a 'TestContainer' action. Any container spun up during the computation are guaranteed
-- to be shutdown and cleaned up once this function returns.
--
-- @since 0.5.0.0
runTestContainer :: Config -> TestContainer a -> IO a
runTestContainer :: forall a. Config -> TestContainer a -> IO a
runTestContainer Config
config TestContainer a
action = do
  -- Ensure through caching that there is only ever exactly
  -- one 'Reaper' per session.
  IORef (Maybe Reaper)
reaperRef <- Maybe Reaper -> IO (IORef (Maybe Reaper))
forall a. a -> IO (IORef a)
newIORef Maybe Reaper
forall a. Maybe a
Nothing
  let getOrCreateReaper :: TestContainer Reaper
getOrCreateReaper = do
        Maybe Reaper
mreaper <- IO (Maybe Reaper) -> TestContainer (Maybe Reaper)
forall a. IO a -> TestContainer a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Reaper) -> IO (Maybe Reaper)
forall a. IORef a -> IO a
readIORef IORef (Maybe Reaper)
reaperRef)
        case Maybe Reaper
mreaper of
          Just Reaper
reaper ->
            Reaper -> TestContainer Reaper
forall a. a -> TestContainer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reaper
reaper
          Maybe Reaper
Nothing -> do
            Reaper
reaper <- Config -> TestContainer Reaper
configCreateReaper Config
config
            IO () -> TestContainer ()
forall a. IO a -> TestContainer a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Reaper) -> Maybe Reaper -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Reaper)
reaperRef (Reaper -> Maybe Reaper
forall a. a -> Maybe a
Just Reaper
reaper))
            Reaper -> TestContainer Reaper
forall a. a -> TestContainer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reaper
reaper

  ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
    ( ReaderT TestContainerEnv (ResourceT IO) a
-> TestContainerEnv -> ResourceT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
        (TestContainer a -> ReaderT TestContainerEnv (ResourceT IO) a
forall a.
TestContainer a -> ReaderT TestContainerEnv (ResourceT IO) a
unTestContainer TestContainer a
action)
        ( TestContainerEnv
            { config :: Config
config =
                Config
config
                  { configCreateReaper = getOrCreateReaper
                  }
            }
        )
    )

-- | Docker related functionality is parameterized over this `Monad`. Since 0.5.0.0 this is
-- just a type alias for @m ~ 'TestContainer'@.
--
-- @since 0.1.0.0
type MonadDocker m =
  (m ~ TestContainer)

-- | Configuration for defaulting behavior.
--
-- @since 0.2.0.0
data Config = Config
  { -- | The number of seconds to maximally wait for a container to
    -- become ready. Default is `Just 60`.
    --
    -- @Nothing@ <=> waits indefinitely.
    Config -> Maybe Int
configDefaultWaitTimeout :: Maybe Int,
    -- | Traces execution inside testcontainers library.
    Config -> Tracer
configTracer :: Tracer,
    -- | How to obtain a 'Reaper'
    Config -> TestContainer Reaper
configCreateReaper :: TestContainer Reaper
  }