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 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, MonadCatch m, MonadIO m, MonadLogger m, MonadMask m, MonadReader e m)
stageContainerImageArtifacts :: Build e m => m ()
stageContainerImageArtifacts = do
config <- asks getConfig
workingDir <- getWorkingDir
forM_ (zip [0..] $ imgDockers $ configImage config) $ \(idx, opts) -> do
imageDir <- imageStagingDir workingDir idx
removeTreeIfExists imageDir
createTree imageDir
stageExesInDir opts imageDir
syncAddContentToDir opts imageDir
createContainerImageFromStage :: Assemble e m => m ()
createContainerImageFromStage = do
config <- asks getConfig
workingDir <- getWorkingDir
forM_ (zip [0..] $ imgDockers $ configImage config) $ \(idx, opts) -> do
imageDir <- imageStagingDir workingDir idx
createDockerImage opts imageDir
extendDockerImageWithEntrypoint opts imageDir
stageExesInDir :: Build e m => ImageDockerOpts -> Path Abs Dir -> m ()
stageExesInDir opts dir = do
srcBinPath <-
liftM (</> $(mkRelDir "bin")) installationRootLocal
let destBinPath = dir </>
$(mkRelDir "usr/local/bin")
createTree destBinPath
case imgDockerExecutables opts of
Nothing -> copyDirectoryRecursive 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 <- parseRelDir source
destPath <- parseAbsDir dest
let destFullPath = dir </> dropRoot destPath
createTree destFullPath
copyDirectoryRecursive
(bcRoot bconfig </> 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])
imgCmdName :: String
imgCmdName = "image"
imgDockerCmdName :: String
imgDockerCmdName = "container"
imgOptsFromMonoid :: ImageOptsMonoid -> ImageOpts
imgOptsFromMonoid ImageOptsMonoid{..} = ImageOpts
{ imgDockers = imgMonoidDockers
}
data StackImageException =
StackImageDockerBaseUnspecifiedException
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."