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

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

    -- * Creating networks
    createNetwork,
    NetworkRequest,
    networkRequest,
    withDriver,
    withIpv6,
  )
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, 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 :: Text
id :: Network -> 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)]
  }

-- | 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 = forall a. Maybe a
Nothing,
      labels :: [(Text, Text)]
labels = []
    }

-- | Enable IPv6 for the Docker network.
--
-- @since 0.5.0.0
withIpv6 :: NetworkRequest -> NetworkRequest
withIpv6 :: NetworkRequest -> NetworkRequest
withIpv6 NetworkRequest
request =
  NetworkRequest
request {ipv6 :: Bool
ipv6 = Bool
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 :: Maybe Text
driver = forall a. a -> Maybe a
Just Text
driver}

-- | 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
labels :: [(Text, Text)]
driver :: Maybe Text
ipv6 :: Bool
labels :: NetworkRequest -> [(Text, Text)]
driver :: NetworkRequest -> Maybe Text
ipv6 :: NetworkRequest -> Bool
..} = do
  Config {Maybe Int
Tracer
TestContainer Reaper
configCreateReaper :: Config -> TestContainer Reaper
configTracer :: Config -> Tracer
configDefaultWaitTimeout :: Config -> Maybe Int
configCreateReaper :: TestContainer Reaper
configTracer :: Tracer
configDefaultWaitTimeout :: Maybe Int
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask

  Text
name <-
    String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
16 (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 =
        Reaper -> [(Text, Text)]
reaperLabels Reaper
reaper

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

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