{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module TestContainers.Docker
(
MonadDocker
, ImageTag
, Image
, imageTag
, ContainerId
, Container
, containerId
, containerImage
, containerIp
, containerPort
, containerReleaseKey
, ToImage
, fromTag
, fromBuildContext
, fromDockerfile
, build
, DockerException(..)
, ContainerRequest
, containerRequest
, setName
, setCmd
, setRm
, setEnv
, setLink
, setExpose
, setWaitingFor
, run
, InspectOutput
, inspect
, stop
, kill
, rm
, withLogs
, WaitUntilReady
, waitUntilReady
, TimeoutException(..)
, waitUntilTimeout
, waitWithLogs
, UnexpectedEndOfPipe(..)
, Pipe(..)
, waitForLogLine
, waitUntilMappedPortReachable
, ResIO
, runResourceT
, (&)
) where
import Control.Concurrent (threadDelay)
import Control.Exception (IOException, throw)
import Control.Lens ((^?))
import Control.Monad.Catch (Exception, MonadCatch, MonadMask,
MonadThrow, bracket, throwM, try)
import Control.Monad.Fix (mfix)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO))
import Control.Monad.Trans.Resource (MonadResource (liftResourceT),
ReleaseKey, ResIO, register,
runResourceT)
import Data.Aeson (Value, decode')
import qualified Data.Aeson.Lens as Lens
import qualified Data.ByteString.Lazy.Char8 as LazyByteString
import Data.Function ((&))
import Data.List (find)
import Data.Text (Text, pack, strip, unpack)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText
import GHC.Stack (HasCallStack, withFrozenCallStack)
import qualified Network.Socket as Socket
import Prelude hiding (error, id)
import qualified Prelude
import System.Exit (ExitCode (..))
import System.IO (Handle, hClose)
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Process as Process
import System.Timeout (timeout)
data DockerException
= DockerException
{
exitCode :: ExitCode
, args :: [Text]
, stderr :: Text
}
| InspectUnknownContainerId { id :: ContainerId }
| InspectOutputInvalidJSON { id :: ContainerId }
| InspectOutputUnexpected { id :: ContainerId }
| UnknownPortMapping
{
id :: ContainerId
, port :: Text
}
deriving (Eq, Show)
instance Exception DockerException
type MonadDocker m =
(MonadIO m, MonadMask m, MonadThrow m, MonadCatch m, MonadResource m)
data ContainerRequest = ContainerRequest
{
toImage :: ToImage
, cmd :: Maybe [Text]
, env :: [(Text, Text)]
, exposedPorts :: [Int]
, volumeMounts :: [(Text, Text)]
, links :: [ContainerId]
, name :: Maybe Text
, rmOnExit :: Bool
, readiness :: Maybe WaitUntilReady
}
containerRequest :: ToImage -> ContainerRequest
containerRequest image = ContainerRequest
{
toImage = image
, name = Nothing
, cmd = Nothing
, env = []
, exposedPorts = []
, volumeMounts = []
, links = []
, rmOnExit = True
, readiness = Nothing
}
setName :: Text -> ContainerRequest -> ContainerRequest
setName newName req =
req { name = Just newName }
setCmd :: [Text] -> ContainerRequest -> ContainerRequest
setCmd newCmd req =
req { cmd = Just newCmd }
setRm :: Bool -> ContainerRequest -> ContainerRequest
setRm newRm req =
req { rmOnExit = newRm }
setEnv :: [(Text, Text)] -> ContainerRequest -> ContainerRequest
setEnv newEnv req =
req { env = newEnv }
setLink :: [ContainerId] -> ContainerRequest -> ContainerRequest
setLink newLink req =
req { links = newLink }
setExpose :: [Int] -> ContainerRequest -> ContainerRequest
setExpose newExpose req =
req { exposedPorts = newExpose }
setWaitingFor :: WaitUntilReady -> ContainerRequest -> ContainerRequest
setWaitingFor newWaitingFor req =
req { readiness = Just newWaitingFor }
run :: MonadDocker m => ContainerRequest -> m Container
run request = liftResourceT $ do
let
ContainerRequest
{
toImage
, name
, cmd
, env
, exposedPorts
, volumeMounts
, links
, rmOnExit
, readiness
} = request
image@Image{ tag } <- runToImage toImage
let
dockerRun :: [Text]
dockerRun = concat $
[ [ "run" ] ] ++
[ [ "--detach" ] ] ++
[ [ "--name", containerName ] | Just containerName <- [name] ] ++
[ [ "--env", variable <> "=" <> value ] | (variable, value) <- env ] ++
[ [ "--publish", pack (show port)] | port <- exposedPorts ] ++
[ [ "--link", container ] | container <- links ] ++
[ [ "--volume", src <> ":" <> dest ] | (src, dest) <- volumeMounts ] ++
[ [ "--rm" ] | rmOnExit ] ++
[ [ tag ] ] ++
[ command | Just command <- [cmd] ]
stdout <- docker dockerRun
let
id :: ContainerId
!id =
strip (pack stdout)
let
~inspectOutput = unsafePerformIO $
internalInspect id
container <- mfix $ \container -> do
releaseKey <- register $ runResourceT (stop container)
pure $ Container
{
id
, releaseKey
, image
, inspectOutput
}
case readiness of
Just wait ->
waitUntilReady container wait
Nothing ->
pure ()
pure container
docker :: MonadIO m => [Text] -> m String
docker args =
dockerWithStdin args ""
dockerWithStdin :: MonadIO m => [Text] -> Text -> m String
dockerWithStdin args stdin = liftIO $ do
(exitCode, stdout, stderr) <- Process.readProcessWithExitCode "docker"
(map unpack args) (unpack stdin)
case exitCode of
ExitSuccess -> pure stdout
_ -> throwM $ DockerException
{
exitCode, args
, stderr = pack stderr
}
kill :: MonadDocker m => Container -> m ()
kill Container { id } = do
_ <- docker [ "kill", id ]
return ()
stop :: MonadDocker m => Container -> m ()
stop Container { id } = do
_ <- docker [ "stop", id ]
return ()
rm :: MonadDocker m => Container -> m ()
rm Container { id } = do
_ <- docker [ "rm", "-f", "-v", id ]
return ()
withLogs :: forall m a . MonadDocker m => Container -> (Handle -> Handle -> m a) -> m a
withLogs Container { id } logger = do
let
acquire :: m (Handle, Handle, Handle, Process.ProcessHandle)
acquire =
liftIO $ Process.runInteractiveProcess
"docker"
[ "logs", unpack id ]
Nothing
Nothing
release :: (Handle, Handle, Handle, Process.ProcessHandle) -> m ()
release (stdin, stdout, stderr, handle) =
liftIO $ Process.cleanupProcess
(Just stdin, Just stdout, Just stderr, handle)
bracket acquire release $ \(stdin, stdout, stderr, _handle) -> do
liftIO $ hClose stdin
logger stdout stderr
type ImageTag = Text
data ToImage = ToImage
{
runToImage :: forall m. MonadDocker m => m Image
, applyToContainerRequest :: ContainerRequest -> ContainerRequest
}
build :: MonadDocker m => ToImage -> m ToImage
build toImage@ToImage { applyToContainerRequest } = do
image <- runToImage toImage
return $ ToImage
{
runToImage = pure image
, applyToContainerRequest
}
defaultToImage :: (forall m . MonadDocker m => m Image) -> ToImage
defaultToImage action = ToImage
{
runToImage = action
, applyToContainerRequest = \x -> x
}
fromTag :: ImageTag -> ToImage
fromTag imageTag = defaultToImage $ do
output <- docker [ "pull", "--quiet", imageTag ]
return $ Image
{
tag = strip (pack output)
}
fromBuildContext
:: FilePath
-> Maybe FilePath
-> ToImage
fromBuildContext path mdockerfile = defaultToImage $ do
let
args
| Just dockerfile <- mdockerfile =
[ "build", "-f", pack dockerfile, pack path ]
| otherwise =
[ "build", pack path ]
output <- docker args
return $ Image
{
tag = strip (pack output)
}
fromDockerfile
:: Text
-> ToImage
fromDockerfile dockerfile = defaultToImage $ do
output <- dockerWithStdin [ "build", "--quiet", "-" ] dockerfile
return $ Image
{
tag = strip (pack output)
}
type ContainerId = Text
data Logger = Logger
{
debug :: forall m . (HasCallStack, MonadIO m) => Text -> m ()
, info :: forall m . (HasCallStack, MonadIO m) => Text -> m ()
, warn :: forall m . (HasCallStack, MonadIO m) => Text -> m ()
, error :: forall m . (HasCallStack, MonadIO m) => Text -> m ()
}
silentLogger :: Logger
silentLogger = Logger
{
debug = \_ -> pure ()
, info = \_ -> pure ()
, warn = \_ -> pure ()
, error = \_ -> pure ()
}
newtype WaitUntilReady = WaitUntilReady
{
checkContainerReady :: Logger -> Container -> ResIO ()
}
newtype UnexpectedEndOfPipe = UnexpectedEndOfPipe
{
id :: ContainerId
}
deriving (Eq, Show)
instance Exception UnexpectedEndOfPipe
newtype TimeoutException = TimeoutException
{
id :: ContainerId
}
deriving (Eq, Show)
instance Exception TimeoutException
waitUntilTimeout :: Int -> WaitUntilReady -> WaitUntilReady
waitUntilTimeout seconds wait = WaitUntilReady $ \logger container@Container{ id } -> do
withRunInIO $ \runInIO -> do
result <- timeout (seconds * 1000000) $
runInIO (checkContainerReady wait logger container)
case result of
Nothing ->
throwM $ TimeoutException { id }
Just _ ->
pure ()
waitUntilMappedPortReachable
:: Int
-> WaitUntilReady
waitUntilMappedPortReachable port = WaitUntilReady $ \logger container ->
withFrozenCallStack $ do
let
hostIp :: String
hostIp = unpack (containerIp container)
hostPort :: String
hostPort = show $ containerPort container port
resolve = do
let hints = Socket.defaultHints { Socket.addrSocketType = Socket.Stream }
head <$> Socket.getAddrInfo (Just hints) (Just hostIp) (Just hostPort)
open addr = do
socket <- Socket.socket
(Socket.addrFamily addr)
(Socket.addrSocketType addr)
(Socket.addrProtocol addr)
Socket.connect
socket
(Socket.addrAddress addr)
pure socket
retry = do
debug logger $ "Trying to open socket to " <> pack hostIp <> ":" <> pack hostPort
result <- try (resolve >>= open)
case result of
Right socket -> do
debug logger $ "Successfully opened socket to " <> pack hostIp <> ":" <> pack hostPort
Socket.close socket
pure ()
Left (exception :: IOException) -> do
debug logger $ "Failed to open socket to " <> pack hostIp <> ":" <>
pack hostPort <> " with " <> pack (show exception)
threadDelay 500000
retry
liftIO retry
waitWithLogs :: (Container -> Handle -> Handle -> IO ()) -> WaitUntilReady
waitWithLogs waiter = WaitUntilReady $ \_logger container -> do
withLogs container $ \stdout stderr ->
liftIO $ waiter container stdout stderr
data Pipe
= Stdout
| Stderr
deriving (Eq, Ord, Show)
waitForLogLine :: Pipe -> (LazyText.Text -> Bool) -> WaitUntilReady
waitForLogLine whereToLook matches = waitWithLogs $ \Container { id } stdout stderr -> do
let
logs :: Handle
logs = case whereToLook of
Stdout -> stdout
Stderr -> stderr
logContent <- LazyByteString.hGetContents logs
let
logLines :: [LazyText.Text]
logLines =
map
(LazyText.decodeUtf8With lenientDecode)
(LazyByteString.lines logContent)
case find matches logLines of
Just _ -> pure ()
Nothing -> throwM $ UnexpectedEndOfPipe { id }
waitUntilReady :: MonadDocker m => Container -> WaitUntilReady -> m ()
waitUntilReady container waiter =
liftResourceT $ checkContainerReady waiter silentLogger container
data Image = Image
{
tag :: ImageTag
}
deriving (Eq, Show)
imageTag :: Image -> ImageTag
imageTag Image { tag } = tag
data Container = Container
{
id :: ContainerId
, releaseKey :: ReleaseKey
, image :: Image
, inspectOutput :: InspectOutput
}
type InspectOutput = Value
containerId :: Container -> ContainerId
containerId Container { id } = id
containerImage :: Container -> Image
containerImage Container { image } = image
containerReleaseKey :: Container -> ReleaseKey
containerReleaseKey Container { releaseKey } = releaseKey
containerIp :: Container -> Text
containerIp Container { id, inspectOutput } =
case inspectOutput
^? Lens.key "NetworkSettings"
. Lens.key "IPAddress"
. Lens._String of
Nothing ->
throw $ InspectOutputUnexpected { id }
Just address ->
address
containerPort :: Container -> Int -> Int
containerPort Container { id, inspectOutput } port =
let
textPort :: Text
textPort = pack (show port) <> "/tcp"
in
case inspectOutput
^? Lens.key "NetworkSettings"
. Lens.key "Ports"
. Lens.key textPort
. Lens.values
. Lens.key "HostPort"
. Lens._String of
Nothing ->
throw $ UnknownPortMapping
{
id
, port = textPort
}
Just hostPort ->
read (unpack hostPort)
inspect :: MonadDocker m => Container -> m InspectOutput
inspect Container { inspectOutput } =
pure inspectOutput
internalInspect :: (MonadThrow m, MonadIO m) => ContainerId -> m InspectOutput
internalInspect id = do
stdout <- docker [ "inspect", id ]
case decode' (LazyByteString.pack stdout) of
Nothing ->
throwM $ InspectOutputInvalidJSON { id }
Just [] ->
throwM $ InspectUnknownContainerId { id }
Just [value] ->
pure value
Just _ ->
Prelude.error "Internal: Multiple results where I expected single result"