{-# 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.4.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 -> 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
<$ :: forall a b. a -> TestContainer b -> TestContainer a
$c<$ :: forall a b. a -> TestContainer b -> TestContainer a
fmap :: forall a b. (a -> b) -> TestContainer a -> TestContainer b
$cfmap :: forall a b. (a -> b) -> TestContainer a -> TestContainer b
Functor,
      Functor 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
<* :: forall a b. TestContainer a -> TestContainer b -> TestContainer a
$c<* :: forall a b. TestContainer a -> TestContainer b -> TestContainer a
*> :: forall a b. TestContainer a -> TestContainer b -> TestContainer b
$c*> :: forall a b. TestContainer a -> TestContainer b -> TestContainer b
liftA2 :: forall a b c.
(a -> b -> c)
-> TestContainer a -> TestContainer b -> TestContainer c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> TestContainer a -> TestContainer b -> TestContainer c
<*> :: forall a b.
TestContainer (a -> b) -> TestContainer a -> TestContainer b
$c<*> :: forall a b.
TestContainer (a -> b) -> TestContainer a -> TestContainer b
pure :: forall a. a -> TestContainer a
$cpure :: forall a. a -> TestContainer a
Applicative,
      Applicative 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
return :: forall a. a -> TestContainer a
$creturn :: forall a. a -> TestContainer a
>> :: forall a b. TestContainer a -> TestContainer b -> TestContainer b
$c>> :: forall a b. TestContainer a -> TestContainer b -> TestContainer b
>>= :: forall a b.
TestContainer a -> (a -> TestContainer b) -> TestContainer b
$c>>= :: forall a b.
TestContainer a -> (a -> TestContainer b) -> TestContainer b
Monad,
      Monad TestContainer
forall a. IO a -> TestContainer a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> TestContainer a
$cliftIO :: forall a. IO a -> TestContainer a
MonadIO,
      MonadCatch TestContainer
forall b.
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
forall a b c.
TestContainer a
-> (a -> ExitCase b -> TestContainer c)
-> (a -> TestContainer b)
-> TestContainer (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
TestContainer a
-> (a -> ExitCase b -> TestContainer c)
-> (a -> TestContainer b)
-> TestContainer (b, c)
$cgeneralBracket :: forall a b c.
TestContainer a
-> (a -> ExitCase b -> TestContainer c)
-> (a -> TestContainer b)
-> TestContainer (b, c)
uninterruptibleMask :: forall b.
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
$cuninterruptibleMask :: forall b.
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
mask :: forall b.
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
$cmask :: forall b.
((forall a. TestContainer a -> TestContainer a) -> TestContainer b)
-> TestContainer b
MonadMask,
      MonadThrow TestContainer
forall e a.
Exception e =>
TestContainer a -> (e -> TestContainer a) -> TestContainer a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a.
Exception e =>
TestContainer a -> (e -> TestContainer a) -> TestContainer a
$ccatch :: forall e a.
Exception e =>
TestContainer a -> (e -> TestContainer a) -> TestContainer a
MonadCatch,
      Monad TestContainer
forall e a. Exception e => e -> TestContainer a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> TestContainer a
$cthrowM :: forall e a. Exception e => e -> TestContainer a
MonadThrow,
      MonadIO TestContainer
forall a. ResourceT IO a -> TestContainer a
forall (m :: * -> *).
MonadIO m -> (forall a. ResourceT IO a -> m a) -> MonadResource m
liftResourceT :: forall a. ResourceT IO a -> TestContainer a
$cliftResourceT :: forall a. ResourceT IO a -> TestContainer a
MonadResource,
      Monad TestContainer
forall a. (a -> TestContainer a) -> TestContainer a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a. (a -> TestContainer a) -> TestContainer a
$cmfix :: 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 = forall a.
ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a
TestContainer forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO 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 (forall a. ReaderT TestContainerEnv (ResourceT IO) a -> IO a
runInIo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
TestContainer a -> ReaderT TestContainerEnv (ResourceT IO) a
unTestContainer)

instance MonadReader Config TestContainer where
  ask :: TestContainer Config
ask = forall a.
ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a
TestContainer forall a b. (a -> b) -> a -> b
$ do
    TestContainerEnv {Config
config :: Config
config :: TestContainerEnv -> Config
config} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    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) = forall a.
ReaderT TestContainerEnv (ResourceT IO) a -> TestContainer a
TestContainer forall a b. (a -> b) -> a -> b
$ do
    forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: TestContainerEnv
env@TestContainerEnv {Config
config :: Config
config :: TestContainerEnv -> Config
config} -> TestContainerEnv
env {config :: Config
config = Config -> Config
f Config
config}) ReaderT TestContainerEnv (ResourceT IO) a
action

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

instance (Monoid a) => Monoid (TestContainer a) where
  mempty :: TestContainer a
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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.4.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 <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
  let getOrCreateReaper :: TestContainer Reaper
getOrCreateReaper = do
        Maybe Reaper
mreaper <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef (Maybe Reaper)
reaperRef)
        case Maybe Reaper
mreaper of
          Just Reaper
reaper ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Reaper
reaper
          Maybe Reaper
Nothing -> do
            Reaper
reaper <- Config -> TestContainer Reaper
configCreateReaper Config
config
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Reaper)
reaperRef (forall a. a -> Maybe a
Just Reaper
reaper))
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Reaper
reaper

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

-- | Docker related functionality is parameterized over this `Monad`. Since 0.4.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
  }