dockercook-0.5.0.0: src/lib/Cook/Build.hs
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
module Cook.Build (cookBuild, cookParse) where
import Cook.BuildFile
import Cook.State.Manager
import Cook.Types
import Cook.Uploader
import Cook.Util
import Cook.Downloads
import qualified Cook.Docker as D
import qualified Cook.DirectDocker as Docker
import Control.Applicative
import Control.Monad
import Control.Exception (bracket)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (runResourceT, MonadResource)
import Data.Conduit
import Data.Maybe (fromMaybe, isJust, catMaybes)
import Data.Monoid
import Data.Time (getCurrentTime, diffUTCTime)
import System.Directory
import System.Exit
import System.FilePath
import System.IO (hPutStr, hPutStrLn, hFlush, stderr)
import System.IO.Temp
import System.Process
import Text.Regex (mkRegex, matchRegex)
import qualified Data.HashMap.Strict as HM
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Conduit.Combinators as C
import qualified Data.Streaming.Filesystem as F
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Traversable as T
import qualified Data.Vector as V
import qualified Filesystem.Path.CurrentOS as FP
fixTailingSlash :: FilePath -> FilePath
fixTailingSlash s =
case reverse s of
('/':_) -> s
d -> reverse ('/':d)
sourceDirectoryDeep' :: MonadResource m
=> Bool -- ^ Follow directory symlinks
-> (FP.FilePath -> IO Bool) -- ^ Should a directory be expanded
-> FP.FilePath -- ^ Root directory
-> Producer m FP.FilePath
sourceDirectoryDeep' followSymlinks shouldFollow =
start
where
start :: MonadResource m => FP.FilePath -> Producer m FP.FilePath
start dir = C.sourceDirectory dir =$= awaitForever go
go :: MonadResource m => FP.FilePath -> Producer m FP.FilePath
go fp =
do ft <- liftIO $ F.getFileType (FP.encodeString fp)
case ft of
F.FTFile -> yield fp
F.FTFileSym -> yield fp
F.FTDirectory ->
do followOk <- liftIO $ shouldFollow fp
if followOk then start fp else return ()
F.FTDirectorySym
| followSymlinks ->
do followOk <- liftIO $ shouldFollow fp
if followOk then start fp else return ()
| otherwise -> return ()
F.FTOther -> return ()
makeDirectoryFileHashTable :: HashManager -> (FP.FilePath -> Bool) -> FilePath -> IO [(FP.FilePath, SHA1)]
makeDirectoryFileHashTable hMgr ignore (FP.decodeString . fixTailingSlash -> root) =
do currentDir <- getCurrentDirectory
let fullRoot = currentDir </> FP.encodeString root
logInfo $ "Hashing directory tree at " ++ fullRoot ++ ". This could take some time..."
x <- runResourceT $! sourceDirectoryDeep' False dirCheck root =$= C.concatMapM (hashFile fullRoot) $$ C.sinkList
hPutStr stderr "\n"
logDebug "Done hashing your repo!"
return x
where
dirCheck rf =
case FP.stripPrefix root rf of
Nothing ->
let cd = show $ FP.commonPrefix [root, rf]
in fail ("Expected " ++ show rf ++ " to start with " ++ show root ++ ". Common dirs:" ++ cd)
Just relToRootF ->
let shouldIgnore = ignore relToRootF
in if shouldIgnore
then do logDebug ("Ignoring " ++ show relToRootF)
return False
else do logDebug ("Traversing " ++ show relToRootF)
return True
hashFile fullRoot relToCurrentF =
case FP.stripPrefix root relToCurrentF of
Nothing ->
let cd = show $ FP.commonPrefix [root, relToCurrentF]
in fail ("Expected " ++ show relToCurrentF ++ " to start with " ++ show root ++ ". Common dirs:" ++ cd)
Just relToRootF ->
hashFile' fullRoot relToRootF relToCurrentF
hashFile' fullRoot relToRootF relToCurrentF
| ignore relToRootF =
do logDebug ("Ignored " ++ show relToRootF)
return Nothing
| otherwise =
do logDebug ("Hashed " ++ show relToRootF)
let fullFilePath = fullRoot </> FP.encodeString relToRootF
hashComp =
do bs <- C.sourceFile relToCurrentF $$ C.sinkList
liftIO $ hPutStr stderr "#"
return $! quickHash bs
hash <- fastFileHash hMgr fullFilePath hashComp
liftIO $ hPutStr stderr "."
return $ Just (relToCurrentF, hash)
runPrepareCommands ::
FilePath -> FilePath -> BuildFile -> (BSC.ByteString -> IO ())
-> [(DockerImage, [(FilePath, FilePath)])]
-> IO (Maybe FilePath, IO (), SHA1)
runPrepareCommands tempDir prepareDir bf streamHook cookCopyHm =
do logDebug "Running PREPARE commands"
let outTar = "_dc_prepared.tar.gz"
initDirSt <- getDirectoryContents prepareDir
forM_ (V.toList $ bf_prepare bf) $ \(T.unpack -> cmd) ->
do ec <- systemStream (Just prepareDir) cmd streamHook
unless (ec == ExitSuccess) (fail $ "Preparation command failed: " ++ cmd)
forM_ cookCopyHm $ \(dockerImage, filesToCopy) ->
bracket (D.dockerRunForCopy dockerImage) (D.dockerRm True) $ \ct ->
forM_ filesToCopy $ \(src, dst) ->
D.dockerCp ct src (prepareDir </> dst)
generated <- getDirectoryContents prepareDir
let fileCount = (length generated) - (length initDirSt)
when (not $ V.null $ bf_prepare bf) $
logInfo ("Prepare generated " ++ (show fileCount) ++ " files")
if fileCount <= 0
then return (Nothing, return (), quickHash ["no-prepare"])
else do hashes <-
runResourceT $! sourceDirectoryDeep' False (const $ return True) (FP.decodeString prepareDir)
=$= C.concatMapM computeHash $$ C.sinkList
let buildPrepareTar =
do logDebug "Actually compressing the tar dir"
compressFilesInDir True (tempDir </> outTar) prepareDir ["."]
return $ (Just outTar, buildPrepareTar, concatHash hashes)
where
computeHash fp =
do bs <- C.sourceFile fp $$ C.sinkList
logDebug ("PREPARE: Hashing " ++ show fp)
return $ [quickHash bs]
data BuildEnv
= BuildEnv
{ be_hostInfo :: Docker.DockerInfo
, be_rootDir :: FilePath
, be_imCache :: Docker.DockerImagesCache
, be_streamHook :: Maybe StreamHook
, be_config :: CookConfig
, be_stateManager :: StateManager
, be_hashManager :: HashManager
, be_fileHashes :: [(FP.FilePath, SHA1)]
, be_uploader :: Uploader
}
buildImage :: BuildEnv -> (BuildFile, FilePath) -> IO DockerImage
buildImage env (bf, bfRootDir) =
withSystemTempDirectory "cookbuildXXX" $ \buildTempDir ->
withSystemTempDirectory "cookprepareXXX" $ \prepareDir ->
do logDebug $ "Inspecting " ++ name ++ "..."
baseImage <-
case bf_base bf of
(BuildBaseCook parentBuildFile) ->
do parent <- prepareEntryPoint $ buildFileIdAddParent bfRootDir parentBuildFile
buildImage env (parent, bfRootDir)
(BuildBaseDocker rootImage) ->
do baseExists <- dockerImageExists rootImage
if baseExists
then do markUsingImage (be_stateManager env) rootImage (Docker.di_id hostInfo)
return rootImage
else do hPutStrLn stderr $ "Downloading the docker root image " ++ show (unDockerImage rootImage) ++ "... "
(ec, stdOut, stdErr) <-
readProcessWithExitCode "docker" ["pull", T.unpack $ unDockerImage rootImage] ""
if ec == ExitSuccess
then do markUsingImage (be_stateManager env) rootImage (Docker.di_id hostInfo)
return rootImage
else error ("Can't find provided base docker image "
++ (show $ unDockerImage rootImage) ++ ": " ++ stdOut ++ "\n" ++ stdErr)
baseDockerId <-
case bf_base bf of
BuildBaseDocker rootImage ->
do mImageId <- Docker.dockerImageId rootImage
case mImageId of
Nothing ->
error ("Failed to get image id of " ++ (show $ unDockerImage rootImage))
Just i -> return $ Just (T.encodeUtf8 $ unDockerImageId i)
_ -> return Nothing
(dockerCommandsBase, txHashes) <- buildTxScripts buildTempDir bf
cookCopyHm <-
forM (HM.toList $ bf_cookCopy bf) $ \(cookFile, files) ->
do cookPrep <- prepareEntryPoint (buildFileIdAddParent bfRootDir $ BuildFileId $ T.pack cookFile)
image <- buildImage env (cookPrep, bfRootDir)
return (image, files)
(mTar, mkPrepareTar, prepareHash) <-
runPrepareCommands buildTempDir prepareDir bf streamHook cookCopyHm
downloadHashes <- mapM getUrlHash (V.toList $ bf_downloadDeps bf)
envVarCommands <-
flip V.mapM (bf_requiredVars bf) $ \(var, maybeDefault) ->
do varVal <-
case HM.lookup var cc_compileVars of
Nothing ->
case maybeDefault of
Nothing ->
fail ("Image " ++ (T.unpack $ unBuildFileId $ bf_name bf)
++ " required env var " ++ T.unpack var ++ ", but "
++ "it is not defined and no default is provided!")
Just defVal ->
return defVal
Just val ->
return val
return $ DockerCommand "ENV" (var <> " " <> varVal)
let (copyPreparedTar, cleanupCmds) =
case mTar of
Just preparedTar ->
( V.fromList $ copyTarAndUnpack OverwriteExisting preparedTar "/_cookpreps"
, V.fromList
[ DockerCommand "RUN" (T.pack $ "rm -rf /_cookpreps")
]
)
Nothing -> (V.empty, V.empty)
contextAdd =
V.fromList $
case (bf_unpackTarget bf, null targetedFiles) of
(_, True) -> []
(Nothing, _) -> []
(Just target, _) ->
copyTarAndUnpack SkipExisting "context.tar.gz" target
dockerCommands =
V.concat
[ contextAdd
, copyPreparedTar
, envVarCommands
, dockerCommandsBase
, cleanupCmds
]
dockerBS =
BSC.concat [ "FROM ", T.encodeUtf8 (unDockerImage baseImage), "\n"
, T.encodeUtf8 $ T.unlines $ V.toList $ V.map dockerCmdToText dockerCommands
]
dockerHash =
quickHash $ catMaybes
[ Just dockerBS
, baseDockerId
]
allFHashes = map snd targetedFiles
buildFileHash = quickHash [BSC.pack (show $ bf { bf_name = BuildFileId "static" })]
superHash =
B16.encode $ unSha1 $
concatHash (prepareHash : txHashes : dockerHash : buildFileHash : (allFHashes ++ downloadHashes))
imageName = DockerImage $ T.concat ["cook-", T.decodeUtf8 superHash]
imageTag = T.unpack $ unDockerImage imageName
logDebug $ "Include files: " ++ (show $ length targetedFiles)
++ " FileHashCount: " ++ (show $ length allFHashes)
++ "\nDocker: " ++ (show $ B16.encode $ unSha1 dockerHash)
++ "\nBuildFile: " ++ (show $ B16.encode $ unSha1 buildFileHash)
logDebug' $ "Image name will be " ++ imageTag
let mUserTagName =
fmap (\prefix -> prefix ++ drop cc_cookFileDropCount name) cc_tagprefix
markImage :: IO (Maybe DockerImage)
markImage =
do markUsingImage (be_stateManager env) imageName (Docker.di_id hostInfo)
T.forM mUserTagName $ \userTag ->
do _ <- systemStream Nothing ("docker tag -f " ++ imageTag ++ " " ++ userTag) streamHook
return (DockerImage $ T.pack userTag)
announceBegin =
do let move = 30 - length name
if move < 2
then hPutStr stderr (name ++ "... \n" ++ replicate 30 ' ')
else hPutStr stderr (name ++ "... " ++ replicate move ' ')
tagInfo =
fromMaybe "" $ fmap (\userTag -> " --> " ++ userTag) mUserTagName
nameTagArrow =
imageTag ++ tagInfo
announceBegin
imageExists <- dockerImageExists imageName
(mNewTag, newImage) <-
if imageExists && (not cc_forceRebuild)
then do hPutStrLn stderr ("found " ++ nameTagArrow)
logDebug' "The image already exists!"
mTag <- markImage
return (mTag, imageName)
else do hPutStrLn stderr ("building " ++ imageTag ++ " ("
++ if cc_forceRebuild then "forced" else "hash changed"
++ ")"
)
unless (cc_forceRebuild) $ logDebug' "Image not found!"
mkPrepareTar
(x, buildTime) <- launchImageBuilder dockerBS imageName buildTempDir
mTag <- markImage
setImageBuildTime (be_stateManager env) imageName (Docker.di_id hostInfo) buildTime
announceBegin
hPutStrLn stderr ("built " ++ nameTagArrow ++ " (" ++ show buildTime ++ ")")
withRawImageId imageName $ \imageId ->
do logDebug' $ "The raw id of " ++ imageTag ++ " is " ++ show imageId
setImageId (be_stateManager env) imageName imageId
return (mTag, x)
when (cc_autoPush) $
case mNewTag of
Nothing ->
logError ("Autopush is enabled, but no tag provided!")
Just newTag ->
do logInfo ("enqueuing " ++ (T.unpack $ unDockerImage newTag)
++ " for upload to registry")
enqueueImage uploader newTag
return newImage
where
(CookConfig{..}) = be_config env
hostInfo = be_hostInfo env
imCache = be_imCache env
rootDir = be_rootDir env
uploader = be_uploader env
mStreamHook = be_streamHook env
withRawImageId imageName action =
do mImageId <- Docker.dockerInspectImage imageName
case mImageId of
Nothing ->
do let errorMsg =
"Failed to get the raw image id of " ++ (T.unpack $ unDockerImage $ imageName)
++ ". Did you run dockercook sync?"
logWarn errorMsg
error errorMsg
Just imageInfo -> action (Docker.dii_id imageInfo)
name = dropExtension $ takeFileName $ T.unpack $ unBuildFileId $ bf_name bf
logDebug' m =
do logDebug m
case mStreamHook of
Nothing -> return ()
Just (StreamHook hook) -> hook (BSC.pack (m ++ "\n"))
streamHook bs =
do hPutStr stderr (BSC.unpack bs)
hFlush stderr
case mStreamHook of
Nothing -> return ()
Just (StreamHook hook) -> hook bs
dockerImageExists localIm@(DockerImage imageName) =
do logDebug' $ "Checking if the image " ++ show imageName ++ " is already present... "
known <-
do locallyKnown <- isImageKnown (be_stateManager env) localIm (Docker.di_id hostInfo)
if locallyKnown
then do remotelyKnown <- Docker.doesImageExist imCache (Left localIm)
unless remotelyKnown $
do logInfo $
"My local state is not up to date with the remote host. "
++ "Forgetting " ++ show imageName
++ " for now and rebuilding it."
forgetImage (be_stateManager env) localIm (Docker.di_id hostInfo)
return remotelyKnown
else return False
mRawImageId <- getImageId (be_stateManager env) localIm (Docker.di_id hostInfo)
let storeRawId =
unless (isJust mRawImageId) $
withRawImageId localIm $ \imageId ->
do logDebug' $ "The raw id of " ++ (T.unpack imageName) ++ " is " ++ show imageId
setImageId (be_stateManager env) localIm imageId
if known
then do logDebug' $ "Image " ++ show imageName ++ " is registered in your state directory. Assuming it is present!"
storeRawId
return True
else do taggedExists <- Docker.doesImageExist imCache (Left localIm)
case (taggedExists, mRawImageId) of
(True, _) ->
do storeRawId
return True
(False, Just rawId) ->
do rawExists <- Docker.doesImageExist imCache (Right rawId)
when rawExists $
D.tagImage rawId localIm
return rawExists
(False, Nothing) -> return False
compressContext tempDir =
do let contextPkg = tempDir </> "context.tar.gz"
case (null targetedFiles) of
False ->
do
let includedFiles = map (FP.encodeString . localName . fst) targetedFiles
compressFilesInDir False contextPkg rootDir includedFiles
currentDir <- getCurrentDirectory
let includedFilesFull = map (FP.encodeString . fst) targetedFiles
forM_ includedFilesFull $ \f ->
do didChange <- (hm_didFileChange $ be_hashManager env) (currentDir </> f)
when didChange $
fail $ "Inconsistency error: File " ++ f ++ " changed during build!"
True ->
logWarn ("You've provided an UNPACK directive, but no files "
++ "match any of your INCLUDE directives...")
launchImageBuilder dockerBS imageName tempDir =
do case bf_unpackTarget bf of
Nothing ->
logDebug' ("No UNPACK directive. Won't copy any context! Dockerfile: " ++
show bf)
Just _ ->
do logDebug' "Compressing context..."
compressContext tempDir
logDebug' "Writing Dockerfile ..."
BS.writeFile (tempDir </> "Dockerfile") dockerBS
logDebug' ("Building " ++ name ++ "...")
let tag = T.unpack $ unDockerImage imageName
started <- getCurrentTime
ecDocker <- systemStream Nothing ("docker build --no-cache --force-rm --rm -t " ++ tag ++ " " ++ tempDir) streamHook
if ecDocker == ExitSuccess
then do finished <- getCurrentTime
return (imageName, finished `diffUTCTime` started)
else do hPutStrLn stderr ("Failed to build " ++ tag ++ "!")
hPutStrLn stderr ("Failing Cookfile: "
++ T.unpack (unBuildFileId (bf_name bf)))
hPutStrLn stderr ("Saving temp directory to COOKFAILED.")
_ <- systemStream Nothing ("rm -rf COOKFAILED; cp -r " ++ tempDir ++ " COOKFAILED") streamHook
exitWith ecDocker
localName fp =
case FP.stripPrefix (FP.decodeString $ fixTailingSlash rootDir) fp of
Nothing -> error ("Expected " ++ show fp ++ " to start with " ++ rootDir)
Just x -> x
matchesFile fp pattern = matchesFilePattern pattern (FP.encodeString (localName fp))
isNeededHash fp = or (map (matchesFile fp) (V.toList (bf_include bf)))
targetedFiles = filter (\(fp, _) -> isNeededHash fp) (be_fileHashes env)
cookBuild :: FilePath -> FilePath -> CookConfig -> Uploader -> Maybe StreamHook -> IO [DockerImage]
cookBuild rootDir stateDir cfg@(CookConfig{..}) uploader mStreamHook =
do (stateManager, hashManager) <- createStateManager stateDir
boring <- liftM (fromMaybe []) $ T.mapM (liftM parseBoring . T.readFile) cc_boringFile
fileHashes <- makeDirectoryFileHashTable hashManager (isBoring boring) rootDir
roots <-
mapM (\entryPointFile ->
(,) <$> (prepareEntryPoint . BuildFileId . T.pack) entryPointFile
<*> return (takeDirectory entryPointFile)
) cc_buildEntryPoints
hostInfo <-
do di <- Docker.dockerInfo
case di of
Nothing ->
error "docker info failed! Are you connected to a docker host?"
Just info -> return info
logInfo ("Builds will be run on " ++ (T.unpack $ Docker.di_name hostInfo))
let envVarInfo =
if HM.null cc_compileVars
then "none"
else T.unpack $
T.intercalate "; " $
map (\(k,v) -> k <> "=" <> v) $ HM.toList cc_compileVars
logInfo ("Defined compile time environment variables are: " ++ envVarInfo)
imCache <- Docker.newDockerImagesCache
let buildEnv =
BuildEnv
{ be_hostInfo = hostInfo
, be_rootDir = rootDir
, be_imCache = imCache
, be_streamHook = mStreamHook
, be_config = cfg
, be_stateManager = stateManager
, be_hashManager = hashManager
, be_fileHashes = fileHashes
, be_uploader = uploader
}
res <- mapM (buildImage buildEnv) roots
waitForWrites stateManager
logInfo "Finished building all required images!"
return res
where
parseBoring =
map (mkRegex . T.unpack) . filter (not . T.null) . filter (not . ("#" `T.isPrefixOf`) . T.strip) . map T.strip . T.lines
isBoring boring fp =
any (isJust . flip matchRegex (FP.encodeString fp)) boring
cookParse :: FilePath -> IO ()
cookParse fp =
do mRes <- parseBuildFile fp
case mRes of
Left errMsg ->
fail ("Failed to parse cook file " ++ show fp ++ ": " ++ errMsg)
Right ep ->
do putStrLn $ ("Parsed " ++ show fp ++ ", content: " ++ show ep)
return ()
prepareEntryPoint :: BuildFileId -> IO BuildFile
prepareEntryPoint (BuildFileId entryPoint) =
do mRes <- parseBuildFile (T.unpack entryPoint)
case mRes of
Left errMsg ->
error ("Failed to parse EntryPoint " ++ show entryPoint ++ ": " ++ errMsg)
Right ep ->
do logDebug $ ("Parsed " ++ show entryPoint ++ ", content: " ++ show ep)
return ep