{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module TestContainers.Docker.Network
  ( -- * Network
    NetworkId,
    Network,
    networkId,

    -- * Creating networks
    fromExistingNetwork,
    createNetwork,
    NetworkRequest,
    networkRequest,
    withDriver,
    withIpv6,
    withoutReaper,
  )
where

import Control.Monad (replicateM)
import Control.Monad.Reader (ask)
import Data.Text (Text, pack, strip)
import qualified System.Random as Random
import TestContainers.Docker.Internal (NetworkId, WithoutReaper (..), docker)
import TestContainers.Docker.Reaper (reaperLabels)
import TestContainers.Monad (Config (..), TestContainer)
import Prelude hiding (id)

-- | Handle to a Docker network.
--
-- @since 0.5.0.0
newtype Network = Network
  { Network -> Text
id :: NetworkId
  }

-- | Returns the id of the network.
--
-- @since 0.5.0.0
networkId :: Network -> NetworkId
networkId :: Network -> Text
networkId Network {Text
id :: Network -> Text
id :: Text
id} = Text
id

-- | Parameters for creating a new Docker network.
--
-- @since 0.5.0.0
data NetworkRequest = NetworkRequest
  { NetworkRequest -> Bool
ipv6 :: Bool,
    NetworkRequest -> Maybe Text
driver :: Maybe Text,
    NetworkRequest -> [(Text, Text)]
labels :: [(Text, Text)],
    NetworkRequest -> Bool
noReaper :: Bool
  }

instance WithoutReaper NetworkRequest where
  withoutReaper :: NetworkRequest -> NetworkRequest
withoutReaper NetworkRequest
request = NetworkRequest
request {noReaper = True}

-- | Default parameters for creating a new Docker network.
--
-- @since 0.5.0.0
networkRequest :: NetworkRequest
networkRequest :: NetworkRequest
networkRequest =
  NetworkRequest
    { ipv6 :: Bool
ipv6 = Bool
False,
      driver :: Maybe Text
driver = Maybe Text
forall a. Maybe a
Nothing,
      labels :: [(Text, Text)]
labels = [],
      noReaper :: Bool
noReaper = Bool
False
    }

-- | Enable IPv6 for the Docker network.
--
-- @since 0.5.0.0
withIpv6 :: NetworkRequest -> NetworkRequest
withIpv6 :: NetworkRequest -> NetworkRequest
withIpv6 NetworkRequest
request =
  NetworkRequest
request {ipv6 = True}

-- | Driver to manage the Network (default "bridge").
--
-- @since 0.5.0.0
withDriver :: Text -> NetworkRequest -> NetworkRequest
withDriver :: Text -> NetworkRequest -> NetworkRequest
withDriver Text
driver NetworkRequest
request =
  NetworkRequest
request {driver = Just driver}

-- | Creates a 'Network' from an existing 'NetworkId'. Note that the 'Network' is
-- not managed by the 'TestContainer' monad and as such is not being cleaned up
-- afterwards.
--
-- @since 0.5.1.0
fromExistingNetwork :: NetworkId -> TestContainer Network
fromExistingNetwork :: Text -> TestContainer Network
fromExistingNetwork Text
id =
  Network -> TestContainer Network
forall a. a -> TestContainer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Network {Text
id :: Text
id :: Text
id}

-- | Creates a new 'Network' from a 'NetworkRequest'.
--
-- @since 0.5.0.0
createNetwork :: NetworkRequest -> TestContainer Network
createNetwork :: NetworkRequest -> TestContainer Network
createNetwork NetworkRequest {Bool
[(Text, Text)]
Maybe Text
ipv6 :: NetworkRequest -> Bool
driver :: NetworkRequest -> Maybe Text
labels :: NetworkRequest -> [(Text, Text)]
noReaper :: NetworkRequest -> Bool
ipv6 :: Bool
driver :: Maybe Text
labels :: [(Text, Text)]
noReaper :: Bool
..} = do
  Config {Maybe Int
Tracer
TestContainer Reaper
configDefaultWaitTimeout :: Maybe Int
configTracer :: Tracer
configCreateReaper :: TestContainer Reaper
configDefaultWaitTimeout :: Config -> Maybe Int
configTracer :: Config -> Tracer
configCreateReaper :: Config -> TestContainer Reaper
..} <- TestContainer Config
forall r (m :: * -> *). MonadReader r m => m r
ask

  Text
name <-
    String -> Text
pack (String -> Text) -> TestContainer String -> TestContainer Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TestContainer Char -> TestContainer String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
16 ((Char, Char) -> TestContainer Char
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
Random.randomRIO (Char
'a', Char
'z'))

  Reaper
reaper <-
    TestContainer Reaper
configCreateReaper

  -- Creating the network with the reaper labels ensures cleanup
  -- at the end of the session
  let additionalLabels :: [(Text, Text)]
additionalLabels =
        if Bool
noReaper then [] else Reaper -> [(Text, Text)]
reaperLabels Reaper
reaper

  String
stdout <-
    Tracer -> [Text] -> TestContainer String
forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
configTracer ([Text] -> TestContainer String) -> [Text] -> TestContainer String
forall a b. (a -> b) -> a -> b
$
      [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$
        [[Text
"network", Text
"create"]]
          [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++ [[Text
"--driver", Text
driver_] | Just Text
driver_ <- [Maybe Text
driver]]
          [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++ [[Text
"--ipv6" | Bool
ipv6]]
          [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++ [[Text
"--label", Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value] | (Text
label, Text
value) <- [(Text, Text)]
additionalLabels [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)]
labels]
          [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++ [[Text
name]]

  let id :: NetworkId
      !id :: Text
id =
        -- N.B. Force to not leak STDOUT String
        Text -> Text
strip (String -> Text
pack String
stdout)

  Network -> TestContainer Network
forall a. a -> TestContainer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Network {Text
id :: Text
id :: Text
..}