UsingDockerImage.hs

module Buffet.Test.UsingDockerImage
  ( Configuration(..)
  , DockerBuild(..)
  , get
  ) where

import qualified Buffet.Ir.Ir as Ir
import qualified Buffet.Toolbox.TextTools as TextTools
import qualified Control.Exception as Exception
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Word as Word
import qualified Numeric
import Prelude (Eq, IO, Ord, Show, ($), (.), concatMap, mconcat, pure)
import qualified System.IO as IO
import qualified System.Process.Typed as Process
import qualified System.Random as Random

data Configuration =
  Configuration
    { log :: IO.Handle
    , dockerBuild :: DockerBuild
    }
  deriving (Eq, Show)

data DockerBuild =
  DockerBuild
    { dockerfile :: T.Text
    , arguments :: Map.Map Ir.Option T.Text
    }
  deriving (Eq, Ord, Show)

get :: (T.Text -> IO a) -> Configuration -> IO a
get useImage configuration =
  Exception.bracket
    (buildImage configuration)
    (removeImage configuration)
    useImage

buildImage :: Configuration -> IO T.Text
buildImage configuration = do
  image <- randomImage
  let processBase =
        Process.proc "docker" $
        mconcat [["build", "--tag", T.unpack image], buildArgs, ["-"]]
  Process.runProcess_ .
    Process.setStderr (Process.useHandleOpen log') .
    Process.setStdout (Process.useHandleOpen log') $
    Process.setStdin (textInput dockerfile') processBase
  pure image
  where
    buildArgs =
      concatMap
        (\(key, value) ->
           [ "--build-arg"
           , mconcat [T.unpack $ Ir.option key, "=", T.unpack value]
           ]) $
      Map.toAscList arguments'
    arguments' = arguments $ dockerBuild configuration
    log' = log configuration
    textInput = Process.byteStringInput . TextTools.encodeUtf8
    dockerfile' = dockerfile $ dockerBuild configuration

randomImage :: IO T.Text
randomImage = do
  tagNumber <- Random.randomIO
  let _ = tagNumber :: Word.Word64
      tag = T.pack $ Numeric.showHex tagNumber ""
  pure $ mconcat [name, T.pack ":", tag]
  where
    name = T.pack "buffet-tmp"

removeImage :: Configuration -> T.Text -> IO ()
removeImage configuration image =
  Process.runProcess_ .
  Process.setStderr (Process.useHandleOpen log') .
  Process.setStdout (Process.useHandleOpen log') $
  Process.proc "docker" ["rmi", T.unpack image]
  where
    log' = log configuration