{- HLINT ignore "Use camelCase" -}

module HaskellWorks.TestContainers.LocalStack (
    LocalStackEndpoint (..),
    TC.Container,
    setupContainers,
    setupContainers',
    waitForLocalStack,
) where

import           Prelude

import           Control.Concurrent                           (threadDelay)
import qualified Control.Concurrent                           as IO
import           Control.Exception                            (try)
import qualified Control.Exception                            as E
import           Control.Monad.IO.Class
import qualified Data.ByteString.Lazy                         as LBS
import           Data.Function
import qualified Data.Text                                    as T
import           Data.Time.Clock.POSIX                        (getPOSIXTime)
import           Network.HTTP.Conduit                         (HttpException,
                                                               simpleHttp)
import qualified System.Environment                           as IO

import           HaskellWorks.Prelude
import           HaskellWorks.TestContainers.LocalStack.Types (LocalStackEndpoint (LocalStackEndpoint))
import qualified TestContainers.Monad                         as TC
import qualified TestContainers.Tasty                         as TC

-- | Sets up and runs the containers required for this test suite.
setupContainers ::
    () =>
    (TC.MonadDocker m) =>
    m TC.Container
setupContainers :: forall (m :: * -> *). MonadDocker m => m Container
setupContainers = Text -> m Container
forall (m :: * -> *). MonadDocker m => Text -> m Container
setupContainers' Text
"localstack/localstack-pro:latest"

-- | Sets up and runs the containers required for this test suite.
setupContainers' ::
    () =>
    (TC.MonadDocker m) =>
    Text ->
    m TC.Container
setupContainers' :: forall (m :: * -> *). MonadDocker m => Text -> m Container
setupContainers' Text
dockerTag = do
    Maybe [Char]
authToken <- IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> m (Maybe [Char]))
-> IO (Maybe [Char]) -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
IO.lookupEnv [Char]
"LOCALSTACK_AUTH_TOKEN"
    -- Launch the container based on the postgres image.
    Container
localstackContainer <-
        ContainerRequest -> TestContainer Container
TC.run (ContainerRequest -> TestContainer Container)
-> ContainerRequest -> TestContainer Container
forall a b. (a -> b) -> a -> b
$
            ToImage -> ContainerRequest
TC.containerRequest (Text -> ToImage
TC.fromTag Text
dockerTag)
                ContainerRequest
-> (ContainerRequest -> ContainerRequest) -> ContainerRequest
forall a b. a -> (a -> b) -> b
& [(Text, Text)] -> ContainerRequest -> ContainerRequest
TC.setEnv [(Text
"LOCALSTACK_AUTH_TOKEN", Text -> ([Char] -> Text) -> Maybe [Char] -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" [Char] -> Text
T.pack Maybe [Char]
authToken)]
                -- Expose the port 4566 from within the container. The respective port
                -- on the host machine can be looked up using `containerPort` (see below).
                ContainerRequest
-> (ContainerRequest -> ContainerRequest) -> ContainerRequest
forall a b. a -> (a -> b) -> b
& [Port] -> ContainerRequest -> ContainerRequest
TC.setExpose
                    ( [[Port]] -> [Port]
forall a. Monoid a => [a] -> a
mconcat
                        [ [Port
4566]
                        ]
                    )
                -- Wait until the container is ready to accept requests. `run` blocks until
                -- readiness can be established.
                ContainerRequest
-> (ContainerRequest -> ContainerRequest) -> ContainerRequest
forall a b. a -> (a -> b) -> b
& WaitUntilReady -> ContainerRequest -> ContainerRequest
TC.setWaitingFor (Port -> WaitUntilReady
TC.waitUntilMappedPortReachable Port
4566)

    -- Look up the corresponding port on the host machine for the exposed port 4566.
    let localStackPort :: Int
localStackPort = Container -> Port -> Int
TC.containerPort Container
localstackContainer Port
4566

    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> Int -> IO ()
waitForLocalStack [Char]
"localhost" Int
localStackPort Int
100

    Container -> m Container
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Container
localstackContainer

waitForLocalStack :: String -> Int -> Int -> IO ()
waitForLocalStack :: [Char] -> Int -> Int -> IO ()
waitForLocalStack [Char]
host Int
port Int
timeout = do
    POSIXTime
startTime <- IO POSIXTime
getPOSIXTime
    let url :: [Char]
url = [Char]
"http://" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
host [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port
    POSIXTime -> [Char] -> IO ()
checkLoop POSIXTime
startTime [Char]
url
  where
    checkLoop :: POSIXTime -> [Char] -> IO ()
checkLoop POSIXTime
startTime [Char]
url = do
        Either HttpException ByteString
result <- IO ByteString -> IO (Either HttpException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either HttpException ByteString))
-> IO ByteString -> IO (Either HttpException ByteString)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
forall (m :: * -> *). MonadIO m => [Char] -> m ByteString
simpleHttp [Char]
url :: IO (Either HttpException LBS.ByteString)
        case Either HttpException ByteString
result of
            Right ByteString
_ -> do
                Int -> IO ()
IO.threadDelay Int
1_000_000
                [Char] -> IO ()
putStrLn [Char]
""
            Left HttpException
e -> do
                POSIXTime
currentTime <- IO POSIXTime
getPOSIXTime
                let elapsedTime :: POSIXTime
elapsedTime = POSIXTime
currentTime POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
startTime
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (POSIXTime
elapsedTime POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timeout) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Int -> IO ()
threadDelay Int
500_000
                    POSIXTime -> [Char] -> IO ()
checkLoop POSIXTime
startTime [Char]
url
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (POSIXTime
elapsedTime POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timeout) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    [Char] -> IO ()
putStrLn [Char]
"Timeout reached. LocalStack is not ready."
                    HttpException -> IO ()
forall a e. Exception e => e -> a
E.throw HttpException
e