{-# 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 Maybe Int
forall a. Maybe a
Nothing

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

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

  optionHelp :: Tagged DefaultTimeout String
optionHelp =
    String -> Tagged DefaultTimeout String
forall a. a -> Tagged DefaultTimeout a
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 =
    Maybe Trace -> String -> Maybe Trace
forall a b. a -> b -> a
const Maybe Trace
forall a. Maybe a
Nothing

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

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

  optionHelp :: Tagged Trace String
optionHelp =
    String -> Tagged Trace String
forall a. a -> Tagged Trace a
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
    [ Proxy DefaultTimeout -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy DefaultTimeout
forall {k} (t :: k). Proxy t
Proxy :: Proxy DefaultTimeout),
      Proxy Trace -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy Trace
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 =
  (DefaultTimeout -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((DefaultTimeout -> TestTree) -> TestTree)
-> (DefaultTimeout -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(DefaultTimeout Maybe Int
defaultTimeout) ->
    (Trace -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption ((Trace -> TestTree) -> TestTree)
-> (Trace -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(Trace Bool
enableTrace) ->
      let tracer :: Tracer
          tracer :: Tracer
tracer
            | Bool
enableTrace = (Trace -> IO ()) -> Tracer
newTracer ((Trace -> IO ()) -> Tracer) -> (Trace -> IO ()) -> Tracer
forall a b. (a -> b) -> a -> b
$ \Trace
message ->
                String -> IO ()
putStrLn (Trace -> String
forall a. Show a => a -> String
show Trace
message)
            | Bool
otherwise =
                Tracer
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 =
                        defaultTimeout <|> configDefaultWaitTimeout config,
                      configTracer = tracer
                    }

            Config -> TestContainer b -> IO b
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 = TestContainer (a, InternalState) -> IO (a, InternalState)
forall {b}. TestContainer b -> IO b
runC (TestContainer (a, InternalState) -> IO (a, InternalState))
-> TestContainer (a, InternalState) -> IO (a, InternalState)
forall a b. (a -> b) -> a -> b
$ do
            a
result <- TestContainer a
startContainers
            InternalState
releaseMap <- ResourceT IO InternalState -> TestContainer InternalState
forall a. ResourceT IO a -> TestContainer a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT ResourceT IO InternalState
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.
            IO () -> TestContainer ()
forall a. IO a -> TestContainer a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TestContainer ()) -> IO () -> TestContainer ()
forall a b. (a -> b) -> a -> b
$ InternalState -> IO ()
stateAlloc InternalState
releaseMap
            (a, InternalState) -> TestContainer (a, InternalState)
forall a. a -> TestContainer a
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 IO (a, InternalState)
-> ((a, InternalState) -> IO ())
-> (IO (a, InternalState) -> TestTree)
-> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO (a, InternalState)
acquire (a, InternalState) -> IO ()
release ((IO (a, InternalState) -> TestTree) -> TestTree)
-> (IO (a, InternalState) -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \IO (a, InternalState)
mk ->
            IO a -> TestTree
tests (((a, InternalState) -> a) -> IO (a, InternalState) -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, InternalState) -> a
forall a b. (a, b) -> a
fst IO (a, InternalState)
mk)