{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Image
(stageContainerImageArtifacts, createContainerImageFromStage,
imgCmdName, imgDockerCmdName, imgOptsFromMonoid,
imgDockerOptsFromMonoid, imgOptsParser, imgDockerOptsParser)
where
import Control.Applicative
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.Monoid
import qualified Data.Text as T
import Data.Typeable
import Options.Applicative
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
imageDir <- imageStagingDir <$> getWorkingDir
removeTreeIfExists imageDir
createTree imageDir
stageExesInDir imageDir
syncAddContentToDir imageDir
createContainerImageFromStage :: Assemble e m
=> m ()
createContainerImageFromStage = do
imageDir <- imageStagingDir <$> getWorkingDir
createDockerImage imageDir
extendDockerImageWithEntrypoint imageDir
stageExesInDir :: Build e m => Path Abs Dir -> m ()
stageExesInDir dir = do
srcBinPath <-
(</> $(mkRelDir "bin")) <$>
installationRootLocal
let destBinPath = dir </>
$(mkRelDir "usr/local/bin")
createTree destBinPath
copyDirectoryRecursive srcBinPath destBinPath
syncAddContentToDir :: Build e m => Path Abs Dir -> m ()
syncAddContentToDir dir = do
config <- asks getConfig
bconfig <- asks getBuildConfig
let imgAdd = maybe Map.empty imgDockerAdd (imgDocker (configImage config))
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 => Path Abs Dir -> m ()
createDockerImage dir = do
menv <- getMinimalEnvOverride
config <- asks getConfig
let dockerConfig = imgDocker (configImage config)
case imgDockerBase =<< dockerConfig of
Nothing -> throwM StackImageDockerBaseUnspecifiedException
Just base -> do
liftIO
(writeFile
(toFilePath
(dir </>
$(mkRelFile "Dockerfile")))
(unlines ["FROM " ++ base, "ADD ./ /"]))
callProcess
Nothing
menv
"docker"
[ "build"
, "-t"
, fromMaybe
(imageName (parent (parent dir)))
(imgDockerImageName =<< dockerConfig)
, toFilePathNoTrailingSep dir]
extendDockerImageWithEntrypoint :: Assemble e m => Path Abs Dir -> m ()
extendDockerImageWithEntrypoint dir = do
menv <- getMinimalEnvOverride
config <- asks getConfig
let dockerConfig = imgDocker (configImage config)
let dockerImageName = fromMaybe
(imageName (parent (parent dir)))
(imgDockerImageName =<< dockerConfig)
let imgEntrypoints = maybe Nothing 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
Nothing
menv
"docker"
[ "build"
, "-t"
, dockerImageName ++ "-" ++ ep
, toFilePathNoTrailingSep dir])
imgCmdName :: String
imgCmdName = "image"
imgDockerCmdName :: String
imgDockerCmdName = "container"
imgOptsParser :: Parser ImageOptsMonoid
imgOptsParser = ImageOptsMonoid <$>
optional
(subparser
(command
imgDockerCmdName
(info
imgDockerOptsParser
(progDesc "Create a container image (EXPERIMENTAL)"))))
imgDockerOptsParser :: Parser ImageDockerOptsMonoid
imgDockerOptsParser = ImageDockerOptsMonoid <$>
optional
(option
str
(long (imgDockerCmdName ++ "-" ++ T.unpack imgDockerBaseArgName) <>
metavar "NAME" <>
help "Docker base image name")) <*>
pure Nothing <*>
pure Nothing <*>
pure Nothing
imgOptsFromMonoid :: ImageOptsMonoid -> ImageOpts
imgOptsFromMonoid ImageOptsMonoid{..} = ImageOpts
{ imgDocker = imgDockerOptsFromMonoid <$> imgMonoidDocker
}
imgDockerOptsFromMonoid :: ImageDockerOptsMonoid -> ImageDockerOpts
imgDockerOptsFromMonoid ImageDockerOptsMonoid{..} = ImageDockerOpts
{ imgDockerBase = emptyToNothing imgDockerMonoidBase
, imgDockerEntrypoints = emptyToNothing imgDockerMonoidEntrypoints
, imgDockerAdd = fromMaybe Map.empty imgDockerMonoidAdd
, imgDockerImageName = emptyToNothing imgDockerMonoidImageName
}
where emptyToNothing Nothing = Nothing
emptyToNothing (Just s)
| null s =
Nothing
| otherwise =
Just s
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."