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
    { Configuration -> Handle
log :: IO.Handle
    , Configuration -> DockerBuild
dockerBuild :: DockerBuild
    }
  deriving (Configuration -> Configuration -> Bool
(Configuration -> Configuration -> Bool)
-> (Configuration -> Configuration -> Bool) -> Eq Configuration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Configuration -> Configuration -> Bool
$c/= :: Configuration -> Configuration -> Bool
== :: Configuration -> Configuration -> Bool
$c== :: Configuration -> Configuration -> Bool
Eq, Int -> Configuration -> ShowS
[Configuration] -> ShowS
Configuration -> String
(Int -> Configuration -> ShowS)
-> (Configuration -> String)
-> ([Configuration] -> ShowS)
-> Show Configuration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Configuration] -> ShowS
$cshowList :: [Configuration] -> ShowS
show :: Configuration -> String
$cshow :: Configuration -> String
showsPrec :: Int -> Configuration -> ShowS
$cshowsPrec :: Int -> Configuration -> ShowS
Show)

data DockerBuild =
  DockerBuild
    { DockerBuild -> Text
dockerfile :: T.Text
    , DockerBuild -> Map Option Text
arguments :: Map.Map Ir.Option T.Text
    }
  deriving (DockerBuild -> DockerBuild -> Bool
(DockerBuild -> DockerBuild -> Bool)
-> (DockerBuild -> DockerBuild -> Bool) -> Eq DockerBuild
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DockerBuild -> DockerBuild -> Bool
$c/= :: DockerBuild -> DockerBuild -> Bool
== :: DockerBuild -> DockerBuild -> Bool
$c== :: DockerBuild -> DockerBuild -> Bool
Eq, Eq DockerBuild
Eq DockerBuild
-> (DockerBuild -> DockerBuild -> Ordering)
-> (DockerBuild -> DockerBuild -> Bool)
-> (DockerBuild -> DockerBuild -> Bool)
-> (DockerBuild -> DockerBuild -> Bool)
-> (DockerBuild -> DockerBuild -> Bool)
-> (DockerBuild -> DockerBuild -> DockerBuild)
-> (DockerBuild -> DockerBuild -> DockerBuild)
-> Ord DockerBuild
DockerBuild -> DockerBuild -> Bool
DockerBuild -> DockerBuild -> Ordering
DockerBuild -> DockerBuild -> DockerBuild
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DockerBuild -> DockerBuild -> DockerBuild
$cmin :: DockerBuild -> DockerBuild -> DockerBuild
max :: DockerBuild -> DockerBuild -> DockerBuild
$cmax :: DockerBuild -> DockerBuild -> DockerBuild
>= :: DockerBuild -> DockerBuild -> Bool
$c>= :: DockerBuild -> DockerBuild -> Bool
> :: DockerBuild -> DockerBuild -> Bool
$c> :: DockerBuild -> DockerBuild -> Bool
<= :: DockerBuild -> DockerBuild -> Bool
$c<= :: DockerBuild -> DockerBuild -> Bool
< :: DockerBuild -> DockerBuild -> Bool
$c< :: DockerBuild -> DockerBuild -> Bool
compare :: DockerBuild -> DockerBuild -> Ordering
$ccompare :: DockerBuild -> DockerBuild -> Ordering
$cp1Ord :: Eq DockerBuild
Ord, Int -> DockerBuild -> ShowS
[DockerBuild] -> ShowS
DockerBuild -> String
(Int -> DockerBuild -> ShowS)
-> (DockerBuild -> String)
-> ([DockerBuild] -> ShowS)
-> Show DockerBuild
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DockerBuild] -> ShowS
$cshowList :: [DockerBuild] -> ShowS
show :: DockerBuild -> String
$cshow :: DockerBuild -> String
showsPrec :: Int -> DockerBuild -> ShowS
$cshowsPrec :: Int -> DockerBuild -> ShowS
Show)

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

buildImage :: Configuration -> IO T.Text
buildImage :: Configuration -> IO Text
buildImage Configuration
configuration = do
  Text
image <- IO Text
randomImage
  let processBase :: ProcessConfig () () ()
processBase =
        String -> [String] -> ProcessConfig () () ()
Process.proc String
"docker" ([String] -> ProcessConfig () () ())
-> [String] -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$
        [[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat [[String
"build", String
"--tag", Text -> String
T.unpack Text
image], [String]
buildArgs, [String
"-"]]
  ProcessConfig () () () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
Process.runProcess_ (ProcessConfig () () () -> IO ())
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
Process.setStderr (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
Process.useHandleOpen Handle
log') (ProcessConfig () () () -> ProcessConfig () () ())
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
-> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
Process.setStdout (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
Process.useHandleOpen Handle
log') (ProcessConfig () () () -> IO ())
-> ProcessConfig () () () -> IO ()
forall a b. (a -> b) -> a -> b
$
    StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
Process.setStdin (Text -> StreamSpec 'STInput ()
textInput Text
dockerfile') ProcessConfig () () ()
processBase
  Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
image
  where
    buildArgs :: [String]
buildArgs =
      ((Option, Text) -> [String]) -> [(Option, Text)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (\(Option
key, Text
value) ->
           [ String
"--build-arg"
           , [String] -> String
forall a. Monoid a => [a] -> a
mconcat [Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Option -> Text
Ir.option Option
key, String
"=", Text -> String
T.unpack Text
value]
           ]) ([(Option, Text)] -> [String]) -> [(Option, Text)] -> [String]
forall a b. (a -> b) -> a -> b
$
      Map Option Text -> [(Option, Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Option Text
arguments'
    arguments' :: Map Option Text
arguments' = DockerBuild -> Map Option Text
arguments (DockerBuild -> Map Option Text) -> DockerBuild -> Map Option Text
forall a b. (a -> b) -> a -> b
$ Configuration -> DockerBuild
dockerBuild Configuration
configuration
    log' :: Handle
log' = Configuration -> Handle
log Configuration
configuration
    textInput :: Text -> StreamSpec 'STInput ()
textInput = ByteString -> StreamSpec 'STInput ()
Process.byteStringInput (ByteString -> StreamSpec 'STInput ())
-> (Text -> ByteString) -> Text -> StreamSpec 'STInput ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TextTools.encodeUtf8
    dockerfile' :: Text
dockerfile' = DockerBuild -> Text
dockerfile (DockerBuild -> Text) -> DockerBuild -> Text
forall a b. (a -> b) -> a -> b
$ Configuration -> DockerBuild
dockerBuild Configuration
configuration

randomImage :: IO T.Text
randomImage :: IO Text
randomImage = do
  Word64
tagNumber <- IO Word64
forall a (m :: * -> *). (Random a, MonadIO m) => m a
Random.randomIO
  let Word64
_ = Word64
tagNumber :: Word.Word64
      tag :: Text
tag = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word64 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
Numeric.showHex Word64
tagNumber String
""
  Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
name, String -> Text
T.pack String
":", Text
tag]
  where
    name :: Text
name = String -> Text
T.pack String
"buffet-tmp"

removeImage :: Configuration -> T.Text -> IO ()
removeImage :: Configuration -> Text -> IO ()
removeImage Configuration
configuration Text
image =
  ProcessConfig () () () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
Process.runProcess_ (ProcessConfig () () () -> IO ())
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
Process.setStderr (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
Process.useHandleOpen Handle
log') (ProcessConfig () () () -> ProcessConfig () () ())
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
-> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
Process.setStdout (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
Process.useHandleOpen Handle
log') (ProcessConfig () () () -> IO ())
-> ProcessConfig () () () -> IO ()
forall a b. (a -> b) -> a -> b
$
  String -> [String] -> ProcessConfig () () ()
Process.proc String
"docker" [String
"rmi", Text -> String
T.unpack Text
image]
  where
    log' :: Handle
log' = Configuration -> Handle
log Configuration
configuration