{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module TestContainers.Tasty
  ( -- * Tasty Ingredient
    ingredient,

    -- * Running containers for tests
    withContainers,

    -- * Re-exports for convenience
    module Reexports,
  )
where

import Control.Applicative ((<|>))
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
  ( InternalState,
    getInternalState,
    liftResourceT,
  )
import Control.Monad.Trans.Resource.Internal
  ( stateAlloc,
    stateCleanup,
  )
import Data.Acquire (ReleaseType (ReleaseNormal))
import Data.Data (Proxy (Proxy))
import Test.Tasty
  ( TestTree,
    askOption,
    withResource,
  )
import qualified Test.Tasty as Tasty
import Test.Tasty.Ingredients (Ingredient)
import Test.Tasty.Options
  ( IsOption (..),
    OptionDescription (..),
    mkFlagCLParser,
    safeRead,
  )
import TestContainers as Reexports hiding
  ( Trace,
  )
import TestContainers.Monad (runTestContainer)

newtype DefaultTimeout = DefaultTimeout (Maybe Int)

instance IsOption DefaultTimeout where
  defaultValue :: DefaultTimeout
defaultValue =
    Maybe Int -> DefaultTimeout
DefaultTimeout forall a. Maybe a
Nothing

  parseValue :: String -> Maybe DefaultTimeout
parseValue =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Int -> DefaultTimeout
DefaultTimeout forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
safeRead

  optionName :: Tagged DefaultTimeout String
optionName =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"testcontainers-default-timeout"

  optionHelp :: Tagged DefaultTimeout String
optionHelp =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"The max. number of seconds to wait for a container to become ready"

newtype Trace = Trace Bool

instance IsOption Trace where
  defaultValue :: Trace
defaultValue =
    Bool -> Trace
Trace Bool
False

  parseValue :: String -> Maybe Trace
parseValue =
    forall a b. a -> b -> a
const forall a. Maybe a
Nothing

  optionCLParser :: Parser Trace
optionCLParser =
    forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser forall a. Monoid a => a
mempty (Bool -> Trace
Trace Bool
True)

  optionName :: Tagged Trace String
optionName =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"testcontainers-trace"

  optionHelp :: Tagged Trace String
optionHelp =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Turns on tracing of the underlying Docker operations"

-- | Tasty `Ingredient` that adds useful options to control defaults within the
-- TetContainers library.
--
-- @
-- main :: IO ()
-- main = `Tasty.defaultMainWithIngredients` (`ingredient` : `Tasty.defaultIngredients`) tests
-- @
--
-- @since 0.3.0.0
ingredient :: Ingredient
ingredient :: Ingredient
ingredient =
  [OptionDescription] -> Ingredient
Tasty.includingOptions
    [ forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy DefaultTimeout),
      forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy Trace)
    ]

withContainers ::
  forall a.
  TestContainer a ->
  (IO a -> TestTree) ->
  TestTree
withContainers :: forall a. TestContainer a -> (IO a -> TestTree) -> TestTree
withContainers TestContainer a
startContainers IO a -> TestTree
tests =
  forall v. IsOption v => (v -> TestTree) -> TestTree
askOption forall a b. (a -> b) -> a -> b
$ \(DefaultTimeout Maybe Int
defaultTimeout) ->
    forall v. IsOption v => (v -> TestTree) -> TestTree
askOption forall a b. (a -> b) -> a -> b
$ \(Trace Bool
enableTrace) ->
      let tracer :: Tracer
          tracer :: Tracer
tracer
            | Bool
enableTrace = (Trace -> IO ()) -> Tracer
newTracer forall a b. (a -> b) -> a -> b
$ \Trace
message ->
                String -> IO ()
putStrLn (forall a. Show a => a -> String
show Trace
message)
            | Bool
otherwise =
                forall a. Monoid a => a
mempty

          runC :: TestContainer b -> IO b
runC TestContainer b
action = do
            Config
config <- IO Config
determineConfig

            let actualConfig :: Config
                actualConfig :: Config
actualConfig =
                  Config
config
                    { configDefaultWaitTimeout :: Maybe Int
configDefaultWaitTimeout =
                        Maybe Int
defaultTimeout forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Int
configDefaultWaitTimeout Config
config,
                      configTracer :: Tracer
configTracer = Tracer
tracer
                    }

            forall a. Config -> TestContainer a -> IO a
runTestContainer Config
actualConfig TestContainer b
action

          -- Correct resource handling is tricky here:
          -- Tasty offers a bracket alike in IO. We  have
          -- to transfer the ReleaseMap of the ResIO safely
          -- to the release function. Fortunately resourcet
          -- let's us access the internal state..
          acquire :: IO (a, InternalState)
          acquire :: IO (a, InternalState)
acquire = forall {b}. TestContainer b -> IO b
runC forall a b. (a -> b) -> a -> b
$ do
            a
result <- TestContainer a
startContainers
            InternalState
releaseMap <- forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT forall (m :: * -> *). Monad m => ResourceT m InternalState
getInternalState

            -- N.B. runResourceT runs the finalizers on every
            -- resource. We don't want it to! We want to run
            -- finalization in the release function that is
            -- called by Tasty! stateAlloc increments a references
            -- count to accomodate for exactly these kind of
            -- cases.
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ InternalState -> IO ()
stateAlloc InternalState
releaseMap
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
result, InternalState
releaseMap)

          release :: (a, InternalState) -> IO ()
          release :: (a, InternalState) -> IO ()
release (a
_, InternalState
internalState) =
            ReleaseType -> InternalState -> IO ()
stateCleanup ReleaseType
ReleaseNormal InternalState
internalState
       in forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO (a, InternalState)
acquire (a, InternalState) -> IO ()
release forall a b. (a -> b) -> a -> b
$ \IO (a, InternalState)
mk ->
            IO a -> TestTree
tests (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst IO (a, InternalState)
mk)