module Stack.Image
(stageContainerImageArtifacts, createContainerImageFromStage,
imgCmdName, imgDockerCmdName, imgOptsFromMonoid)
where
import Control.Exception.Lifted hiding (finally)
import Control.Monad
import Control.Monad.Catch hiding (bracket)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.Char (toLower)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Typeable
import Data.Text (Text)
import qualified Data.Text as T
import Path
import Path.Extra
import Path.IO
import Stack.Constants
import Stack.Types
import Stack.Types.Internal
import System.Process.Run
type Build e m = (HasBuildConfig e, HasConfig e, HasEnvConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadReader e m)
type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m, MonadReader e m)
stageContainerImageArtifacts
:: Build e m
=> Maybe (Path Abs Dir) -> m ()
stageContainerImageArtifacts mProjectRoot = do
config <- asks getConfig
forM_
(zip [0 ..] (imgDockers $ configImage config))
(\(idx,opts) ->
do imageDir <-
imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx
ignoringAbsence (removeDirRecur imageDir)
ensureDir imageDir
stageExesInDir opts imageDir
syncAddContentToDir opts imageDir)
createContainerImageFromStage
:: Assemble e m
=> Maybe (Path Abs Dir) -> [Text] -> m ()
createContainerImageFromStage mProjectRoot imageNames = do
config <- asks getConfig
forM_
(zip
[0 ..]
(filterImages
(map T.unpack imageNames)
(imgDockers $ configImage config)))
(\(idx,opts) ->
do imageDir <-
imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx
createDockerImage opts imageDir
extendDockerImageWithEntrypoint opts imageDir)
where
filterImages [] = id
filterImages names = filter (imageNameFound names . imgDockerImageName)
imageNameFound names (Just name) = name `elem` names
imageNameFound _ _ = False
stageExesInDir
:: Build e m
=> ImageDockerOpts -> Path Abs Dir -> m ()
stageExesInDir opts dir = do
srcBinPath <- fmap (</> $(mkRelDir "bin")) installationRootLocal
let destBinPath = dir </> $(mkRelDir "usr/local/bin")
ensureDir destBinPath
case imgDockerExecutables opts of
Nothing -> copyDirRecur srcBinPath destBinPath
Just exes ->
forM_
exes
(\exe ->
do exeRelFile <- parseRelFile exe
copyFile
(srcBinPath </> exeRelFile)
(destBinPath </> exeRelFile))
syncAddContentToDir
:: Build e m
=> ImageDockerOpts -> Path Abs Dir -> m ()
syncAddContentToDir opts dir = do
bconfig <- asks getBuildConfig
let imgAdd = imgDockerAdd opts
forM_
(Map.toList imgAdd)
(\(source,dest) ->
do sourcePath <- resolveDir (bcRoot bconfig) source
destPath <- parseAbsDir dest
let destFullPath = dir </> dropRoot destPath
ensureDir destFullPath
copyDirRecur sourcePath destFullPath)
imageName
:: Path Abs Dir -> String
imageName = map toLower . toFilePathNoTrailingSep . dirname
createDockerImage
:: Assemble e m
=> ImageDockerOpts -> Path Abs Dir -> m ()
createDockerImage dockerConfig dir = do
menv <- getMinimalEnvOverride
case imgDockerBase dockerConfig of
Nothing -> throwM StackImageDockerBaseUnspecifiedException
Just base -> do
liftIO
(writeFile
(toFilePath (dir </> $(mkRelFile "Dockerfile")))
(unlines ["FROM " ++ base, "ADD ./ /"]))
let args =
[ "build"
, "-t"
, fromMaybe
(imageName (parent . parent . parent $ dir))
(imgDockerImageName dockerConfig)
, toFilePathNoTrailingSep dir]
callProcess (Cmd Nothing "docker" menv args)
extendDockerImageWithEntrypoint
:: Assemble e m
=> ImageDockerOpts -> Path Abs Dir -> m ()
extendDockerImageWithEntrypoint dockerConfig dir = do
menv <- getMinimalEnvOverride
let dockerImageName =
fromMaybe
(imageName (parent . parent . parent $ dir))
(imgDockerImageName dockerConfig)
let imgEntrypoints = imgDockerEntrypoints dockerConfig
case imgEntrypoints of
Nothing -> return ()
Just eps ->
forM_
eps
(\ep ->
do liftIO
(writeFile
(toFilePath
(dir </> $(mkRelFile "Dockerfile")))
(unlines
[ "FROM " ++ dockerImageName
, "ENTRYPOINT [\"/usr/local/bin/" ++
ep ++ "\"]"
, "CMD []"]))
callProcess
(Cmd
Nothing
"docker"
menv
[ "build"
, "-t"
, dockerImageName ++ "-" ++ ep
, toFilePathNoTrailingSep dir]))
fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir
fromMaybeProjectRoot =
fromMaybe (throw StackImageCannotDetermineProjectRootException)
imgCmdName
:: String
imgCmdName = "image"
imgDockerCmdName
:: String
imgDockerCmdName = "container"
imgOptsFromMonoid
:: ImageOptsMonoid -> ImageOpts
imgOptsFromMonoid ImageOptsMonoid{..} =
ImageOpts
{ imgDockers = imgMonoidDockers
}
data StackImageException
= StackImageDockerBaseUnspecifiedException
| StackImageCannotDetermineProjectRootException
deriving (Typeable)
instance Exception StackImageException
instance Show StackImageException where
show StackImageDockerBaseUnspecifiedException =
"You must specify a base docker image on which to place your haskell executables."
show StackImageCannotDetermineProjectRootException =
"Stack was unable to determine the project root in order to build a container."