{-# 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.Reader                  (runReaderT)
import           Control.Monad.Trans.Resource          (InternalState,
                                                        getInternalState)
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)


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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure String
"testcontainers-default-timeout"

  optionHelp :: Tagged DefaultTimeout String
optionHelp =
    String -> Tagged DefaultTimeout String
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 (f :: * -> *) a. Applicative f => a -> f a
pure String
"testcontainers-trace"

  optionHelp :: Tagged Trace String
optionHelp =
    String -> Tagged Trace String
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
  .  (forall m. MonadDocker m => m a)
  -> (IO a -> TestTree)
  -> TestTree
withContainers :: (forall (m :: * -> *). MonadDocker m => m a)
-> (IO a -> TestTree) -> TestTree
withContainers forall (m :: * -> *). MonadDocker m => m 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 :: ResourceT (ReaderT Config IO) b -> IO b
runC ResourceT (ReaderT Config IO) b
action = do
      Config
config <- IO Config
determineConfig

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

      ReaderT Config IO b -> Config -> IO b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ResourceT (ReaderT Config IO) b -> ReaderT Config IO b
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT ResourceT (ReaderT Config IO) b
action) Config
actualConfig

    -- 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 = ResourceT (ReaderT Config IO) (a, InternalState)
-> IO (a, InternalState)
forall b. ResourceT (ReaderT Config IO) b -> IO b
runC (ResourceT (ReaderT Config IO) (a, InternalState)
 -> IO (a, InternalState))
-> ResourceT (ReaderT Config IO) (a, InternalState)
-> IO (a, InternalState)
forall a b. (a -> b) -> a -> b
$ do
      a
result     <- ResourceT (ReaderT Config IO) a
forall (m :: * -> *). MonadDocker m => m a
startContainers
      InternalState
releaseMap <- ResourceT (ReaderT Config 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 () -> ResourceT (ReaderT Config IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT (ReaderT Config IO) ())
-> IO () -> ResourceT (ReaderT Config IO) ()
forall a b. (a -> b) -> a -> b
$ InternalState -> IO ()
stateAlloc InternalState
releaseMap
      (a, InternalState)
-> ResourceT (ReaderT Config IO) (a, InternalState)
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 (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)