{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Image
(stageContainerImageArtifacts, createContainerImageFromStage,
imgCmdName, imgDockerCmdName, imgOptsFromMonoid)
where
import Stack.Prelude
import qualified Data.ByteString as B
import Data.Char (toLower)
import qualified Data.Map.Strict as Map
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
import Path
import Path.Extra
import Path.IO
import Stack.Constants.Config
import Stack.PrettyPrint
import Stack.Types.Config
import Stack.Types.Image
import RIO.Process
stageContainerImageArtifacts
:: HasEnvConfig env
=> Maybe (Path Abs Dir) -> [Text] -> RIO env ()
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
liftIO (ignoringAbsence (removeDirRecur imageDir))
ensureDir imageDir
stageExesInDir opts imageDir
syncAddContentToDir opts imageDir)
createContainerImageFromStage
:: HasConfig env
=> Maybe (Path Abs Dir) -> [Text] -> RIO env ()
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
:: HasEnvConfig env
=> ImageDockerOpts -> Path Abs Dir -> RIO env ()
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 <- liftIO $ forgivingAbsence $ listDir srcBinPath
case mcontents of
Just (files, dirs)
| not (null files) || not (null dirs) -> liftIO $ 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
:: HasEnvConfig env
=> ImageDockerOpts -> Path Abs Dir -> RIO env ()
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
liftIO $ copyDirRecur sourcePath destFullPath)
imageName
:: Path Abs Dir -> String
imageName = map toLower . toFilePathNoTrailingSep . dirname
createDockerImage
:: HasConfig env
=> ImageDockerOpts -> Path Abs Dir -> RIO env ()
createDockerImage dockerConfig dir =
case imgDockerBase dockerConfig of
Nothing -> throwM StackImageDockerBaseUnspecifiedException
Just base -> do
liftIO
(B.writeFile
(toFilePath (dir </> $(mkRelFile "Dockerfile")))
(encodeUtf8 (T.pack (unlines ["FROM " ++ base, "ADD ./ /"]))))
let args =
[ "build"
, "-t"
, fromMaybe
(imageName (parent . parent . parent $ dir))
(imgDockerImageName dockerConfig)
, toFilePathNoTrailingSep dir]
proc "docker" args runProcess_
extendDockerImageWithEntrypoint
:: HasConfig env
=> ImageDockerOpts -> Path Abs Dir -> RIO env ()
extendDockerImageWithEntrypoint dockerConfig dir = do
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
(B.writeFile
(toFilePath
(dir </> $(mkRelFile "Dockerfile")))
(encodeUtf8 (T.pack (unlines
[ "FROM " ++ dockerImageName
, "ENTRYPOINT [\"/usr/local/bin/" ++
ep ++ "\"]"
, "CMD []"]))))
proc
"docker"
[ "build"
, "-t"
, dockerImageName ++ "-" ++ ep
, toFilePathNoTrailingSep dir]
runProcess_)
fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir
fromMaybeProjectRoot =
fromMaybe (impureThrow 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."