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 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.PrettyPrint
import Stack.Types.Config
import Stack.Types.Image
import Stack.Types.StackT
import System.Process.Run
stageContainerImageArtifacts
:: (StackM env m, HasEnvConfig env)
=> Maybe (Path Abs Dir) -> [Text] -> m ()
stageContainerImageArtifacts mProjectRoot imageNames = do
config <- view configL
forM_
(zip
[0 ..]
(filterImages
(map T.unpack imageNames)
(imgDockers $ configImage config)))
(\(idx,opts) ->
do imageDir <-
imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx
ignoringAbsence (removeDirRecur imageDir)
ensureDir imageDir
stageExesInDir opts imageDir
syncAddContentToDir opts imageDir)
createContainerImageFromStage
:: (StackM env m, HasConfig env)
=> Maybe (Path Abs Dir) -> [Text] -> m ()
createContainerImageFromStage mProjectRoot imageNames = do
config <- view configL
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)
filterImages :: [String] -> [ImageDockerOpts] -> [ImageDockerOpts]
filterImages [] = id
filterImages names = filter (imageNameFound . imgDockerImageName)
where
imageNameFound (Just name) = name `elem` names
imageNameFound _ = False
stageExesInDir
:: (StackM env m, HasEnvConfig env)
=> 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 -> do
$logInfo ""
$logInfo "Note: 'executables' not specified for a image container, so every executable in the project's local bin dir will be used."
mcontents <- forgivingAbsence $ listDir srcBinPath
case mcontents of
Just (files, dirs)
| not (null files) || not (null dirs) -> copyDirRecur srcBinPath destBinPath
_ -> $prettyWarn "The project's local bin dir contains no files, so no executables will be added to the docker image."
$logInfo ""
Just exes ->
forM_
exes
(\exe ->
copyFile
(srcBinPath </> exe)
(destBinPath </> exe))
syncAddContentToDir
:: (StackM env m, HasEnvConfig env)
=> ImageDockerOpts -> Path Abs Dir -> m ()
syncAddContentToDir opts dir = do
root <- view projectRootL
let imgAdd = imgDockerAdd opts
forM_
(Map.toList imgAdd)
(\(source,destPath) ->
do sourcePath <- resolveDir root source
let destFullPath = dir </> dropRoot destPath
ensureDir destFullPath
copyDirRecur sourcePath destFullPath)
imageName
:: Path Abs Dir -> String
imageName = map toLower . toFilePathNoTrailingSep . dirname
createDockerImage
:: (StackM env m, HasConfig env)
=> 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
:: (StackM env m, HasConfig env)
=> 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."