diff --git a/dockercook.cabal b/dockercook.cabal --- a/dockercook.cabal +++ b/dockercook.cabal @@ -1,5 +1,5 @@ name: dockercook -version: 0.4.0.0 +version: 0.4.3.0 synopsis: A build tool for multiple docker image layers description: Build and manage multiple docker image layers to speed up deployment license: MIT @@ -24,7 +24,8 @@ Cook.Sync, Cook.Types, Cook.Uploader, - Cook.Util + Cook.Util, + Cook.Downloads other-modules: Cook.Docker, Cook.State.Model @@ -34,13 +35,14 @@ base16-bytestring >=0.1, bytestring >=0.10, conduit >=1.1, - conduit-combinators >=0.2, + conduit-combinators >=0.2 && <1.0, conduit-extra >=1.1, cryptohash >=0.11, directory >=1.2, filepath >=1.3, hashable >=1.2, hslogger >=1.2.6, + lens >=4.7, monad-logger >=0.3, mtl >=2.1, persistent-sqlite >= 1.3, @@ -59,7 +61,8 @@ transformers >= 0.3, unix >=2.5, unordered-containers >=0.2, - vector >=0.10 + vector >=0.10, + wreq >=0.3 ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures diff --git a/src/lib/Cook/Build.hs b/src/lib/Cook/Build.hs --- a/src/lib/Cook/Build.hs +++ b/src/lib/Cook/Build.hs @@ -11,10 +11,13 @@ import Cook.Types import Cook.Uploader import Cook.Util +import Cook.Downloads import qualified Cook.Docker as D +import Control.Applicative import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) +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) @@ -25,6 +28,7 @@ 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 @@ -73,7 +77,7 @@ makeDirectoryFileHashTable hMgr ignore (FP.decodeString . fixTailingSlash -> root) = do currentDir <- getCurrentDirectory let fullRoot = currentDir FP.encodeString root - logInfo $ "Hashing directory tree at " ++ fullRoot ++ ". This will take some time..." + 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!" @@ -113,49 +117,59 @@ liftIO $ hPutStr stderr "." return $ Just (relToCurrentF, hash) -runPrepareCommands tempDir bf streamHook = +runPrepareCommands tempDir prepareDir bf streamHook cookCopyHm = do logDebug "Running PREPARE commands" let outTar = "_dc_prepared.tar.gz" - withSystemTempDirectory "cookprepareXXX" $ \prepareDir -> - do 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) - 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, quickHash ["no-prepare"]) - else do hashes <- - runResourceT $! sourceDirectoryDeep' False (const $ return True) (FP.decodeString prepareDir) - =$= C.concatMapM computeHash $$ C.sinkList - compressFilesInDir (tempDir outTar) prepareDir ["."] - return $ (Just outTar, concatHash hashes) + 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] -buildImage :: D.DockerImagesCache +buildImage :: FilePath + -> D.DockerImagesCache -> Maybe StreamHook - -> CookConfig -> StateManager -> HashManager -> [(FP.FilePath, SHA1)] - -> Uploader -> BuildFile -> IO DockerImage -buildImage imCache mStreamHook cfg@(CookConfig{..}) stateManager hashManager fileHashes uploader bf = + -> CookConfig + -> StateManager + -> HashManager + -> [(FP.FilePath, SHA1)] + -> Uploader -> (BuildFile, FilePath) -> IO DockerImage +buildImage rootDir imCache mStreamHook cfg@(CookConfig{..}) stateManager hashManager fileHashes uploader (bf, bfRootDir) = withSystemTempDirectory "cookbuildXXX" $ \buildTempDir -> + withSystemTempDirectory "cookprepareXXX" $ \prepareDir -> do logDebug $ "Inspecting " ++ name ++ "..." baseImage <- case bf_base bf of (BuildBaseCook parentBuildFile) -> - do parent <- prepareEntryPoint cfg parentBuildFile - buildImage imCache mStreamHook cfg stateManager hashManager fileHashes uploader parent + do parent <- prepareEntryPoint $ buildFileIdAddParent bfRootDir parentBuildFile + buildImage rootDir imCache mStreamHook cfg stateManager hashManager fileHashes uploader (parent, bfRootDir) (BuildBaseDocker rootImage) -> do baseExists <- dockerImageExists rootImage if baseExists then do markUsingImage stateManager rootImage return rootImage - else do logDebug' $ "Downloading the root image " ++ show (unDockerImage 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 @@ -164,11 +178,18 @@ else error ("Can't find provided base docker image " ++ (show $ unDockerImage rootImage) ++ ": " ++ stdOut ++ "\n" ++ stdErr) (dockerCommandsBase, txHashes) <- buildTxScripts buildTempDir bf - (mTar, prepareHash) <- runPrepareCommands buildTempDir bf streamHook + cookCopyHm <- + forM (HM.toList $ bf_cookCopy bf) $ \(cookFile, files) -> + do cookPrep <- prepareEntryPoint (buildFileIdAddParent bfRootDir $ BuildFileId $ T.pack cookFile) + image <- buildImage rootDir imCache mStreamHook cfg stateManager hashManager fileHashes uploader (cookPrep, bfRootDir) + return (image, files) + (mTar, mkPrepareTar, prepareHash) <- + runPrepareCommands buildTempDir prepareDir bf streamHook cookCopyHm + downloadHashes <- mapM getUrlHash (V.toList $ bf_downloadDeps bf) let (copyPreparedTar, cleanupCmds) = case mTar of Just preparedTar -> - ( V.fromList $ copyTarAndUnpack preparedTar "/_cookpreps" + ( V.fromList $ copyTarAndUnpack OverwriteExisting preparedTar "/_cookpreps" , V.fromList [ DockerCommand "RUN" (T.pack $ "rm -rf /_cookpreps") ] @@ -180,7 +201,7 @@ (_, True) -> [] (Nothing, _) -> [] (Just target, _) -> - copyTarAndUnpack "context.tar.gz" target + copyTarAndUnpack SkipExisting "context.tar.gz" target dockerCommands = V.concat [contextAdd, copyPreparedTar, dockerCommandsBase, cleanupCmds] dockerBS = @@ -192,7 +213,7 @@ buildFileHash = quickHash [BSC.pack (show $ bf { bf_name = BuildFileId "static" })] superHash = B16.encode $ unSha1 $ - concatHash (prepareHash : txHashes : dockerHash : buildFileHash : allFHashes) + 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) @@ -206,10 +227,13 @@ markImage = do markUsingImage stateManager imageName T.forM mUserTagName $ \userTag -> - do _ <- systemStream Nothing ("docker tag " ++ imageTag ++ " " ++ userTag) streamHook + do _ <- systemStream Nothing ("docker tag -f " ++ imageTag ++ " " ++ userTag) streamHook return (DockerImage $ T.pack userTag) announceBegin = - hPutStr stderr (name ++ "... \t\t") + 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 = @@ -228,6 +252,7 @@ ++ ")" ) unless (cc_forceRebuild) $ logDebug' "Image not found!" + mkPrepareTar x <- launchImageBuilder dockerBS imageName buildTempDir mTag <- markImage announceBegin @@ -249,7 +274,12 @@ withRawImageId imageName action = do mImageId <- D.getImageId imageName case mImageId of - Nothing -> logWarn $ "Failed to get the raw image id of " ++ (T.unpack $ unDockerImage $ imageName) + 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 imageId -> action imageId name = dropExtension $ takeFileName $ T.unpack $ unBuildFileId $ bf_name bf logDebug' m = @@ -293,7 +323,7 @@ False -> do let includedFiles = map (FP.encodeString . localName . fst) targetedFiles - compressFilesInDir contextPkg cc_dataDir includedFiles + compressFilesInDir False contextPkg rootDir includedFiles currentDir <- getCurrentDirectory let includedFilesFull = map (FP.encodeString . fst) targetedFiles forM_ includedFilesFull $ \f -> @@ -316,7 +346,7 @@ BS.writeFile (tempDir "Dockerfile") dockerBS logDebug' ("Building " ++ name ++ "...") let tag = T.unpack $ unDockerImage imageName - ecDocker <- systemStream Nothing ("docker build --rm -t " ++ tag ++ " " ++ tempDir) streamHook + ecDocker <- systemStream Nothing ("docker build --no-cache --force-rm --rm -t " ++ tag ++ " " ++ tempDir) streamHook if ecDocker == ExitSuccess then return imageName else do hPutStrLn stderr ("Failed to build " ++ tag ++ "!") @@ -326,35 +356,38 @@ _ <- systemStream Nothing ("rm -rf COOKFAILED; cp -r " ++ tempDir ++ " COOKFAILED") streamHook exitWith ecDocker localName fp = - case FP.stripPrefix (FP.decodeString $ fixTailingSlash cc_dataDir) fp of - Nothing -> error ("Expected " ++ show fp ++ " to start with " ++ cc_dataDir) + 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) fileHashes -cookBuild :: FilePath -> CookConfig -> Uploader -> Maybe StreamHook -> IO [DockerImage] -cookBuild stateDir cfg@(CookConfig{..}) uploader mStreamHook = +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) cc_dataDir + fileHashes <- makeDirectoryFileHashTable hashManager (isBoring boring) rootDir roots <- - mapM ((prepareEntryPoint cfg) . BuildFileId . T.pack) cc_buildEntryPoints + mapM (\entryPointFile -> + (,) <$> (prepareEntryPoint . BuildFileId . T.pack) entryPointFile + <*> return (takeDirectory entryPointFile) + ) cc_buildEntryPoints imCache <- D.newDockerImagesCache - res <- mapM (buildImage imCache mStreamHook cfg stateManager hashManager fileHashes uploader) roots + res <- mapM (buildImage rootDir imCache mStreamHook cfg stateManager hashManager fileHashes uploader) roots waitForWrites stateManager logInfo "Finished building all required images!" return res where parseBoring = - map (mkRegex . T.unpack) . filter (not . ("#" `T.isPrefixOf`) . T.strip) . T.lines + 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 dummyCookConfig fp + do mRes <- parseBuildFile fp case mRes of Left errMsg -> fail ("Failed to parse cook file " ++ show fp ++ ": " ++ errMsg) @@ -362,14 +395,12 @@ do putStrLn $ ("Parsed " ++ show fp ++ ", content: " ++ show ep) return () -prepareEntryPoint :: CookConfig -> BuildFileId -> IO BuildFile -prepareEntryPoint cfg (BuildFileId entryPoint) = - do let buildFileDir = cc_buildFileDir cfg - n = buildFileDir (T.unpack entryPoint) - mRes <- parseBuildFile cfg n +prepareEntryPoint :: BuildFileId -> IO BuildFile +prepareEntryPoint (BuildFileId entryPoint) = + do mRes <- parseBuildFile (T.unpack entryPoint) case mRes of Left errMsg -> - error ("Failed to parse EntryPoint " ++ show n ++ ": " ++ errMsg) + error ("Failed to parse EntryPoint " ++ show entryPoint ++ ": " ++ errMsg) Right ep -> - do logDebug $ ("Parsed " ++ show n ++ ", content: " ++ show ep) + do logDebug $ ("Parsed " ++ show entryPoint ++ ", content: " ++ show ep) return ep diff --git a/src/lib/Cook/BuildFile.hs b/src/lib/Cook/BuildFile.hs --- a/src/lib/Cook/BuildFile.hs +++ b/src/lib/Cook/BuildFile.hs @@ -3,10 +3,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Cook.BuildFile ( BuildFileId(..), BuildFile(..), BuildBase(..), DockerCommand(..), TxRef + , buildFileIdAddParent , dockerCmdToText , parseBuildFile , buildTxScripts, copyTarAndUnpack , FilePattern, matchesFilePattern, parseFilePattern + , UnpackMode(..) -- don't use - only exported for testing , parseBuildFileText ) @@ -22,20 +24,25 @@ import Data.Hashable import Data.List (find) import Data.Maybe +import System.Exit (ExitCode(..)) import System.FilePath import System.IO.Temp import System.Process (readProcessWithExitCode) -import System.Exit (ExitCode(..)) -import qualified Data.Vector as V +import qualified Data.ByteString.Base16 as B16 +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T -import qualified Data.HashMap.Strict as HM +import qualified Data.Vector as V newtype BuildFileId = BuildFileId { unBuildFileId :: T.Text } deriving (Show, Eq) +buildFileIdAddParent :: FilePath -> BuildFileId -> BuildFileId +buildFileIdAddParent fp (BuildFileId f) = + BuildFileId $ T.pack (fp T.unpack f) + newtype TxRef = TxRef { _unTxRef :: Int } deriving (Show, Eq, Hashable) @@ -48,7 +55,9 @@ , bf_dockerCommands :: V.Vector (Either TxRef DockerCommand) , bf_include :: V.Vector FilePattern , bf_prepare :: V.Vector T.Text + , bf_downloadDeps :: V.Vector DownloadUrl , bf_transactions :: HM.HashMap TxRef (V.Vector T.Text) + , bf_cookCopy :: HM.HashMap FilePath [(FilePath, FilePath)] } deriving (Show, Eq) data BuildBase @@ -64,6 +73,8 @@ | ScriptLine FilePath (Maybe T.Text) -- execute a script in cook directory to generate more cook commands | BeginTxLine | CommitTxLine + | DownloadLine DownloadUrl FilePath -- download a file to a location + | CookCopyLine FilePath FilePath FilePath -- copy a file or folder from a cook-image to the _cookprep folder | DockerLine DockerCommand -- regular docker command deriving (Show, Eq) @@ -110,7 +121,10 @@ buildTxScripts :: FilePath -> BuildFile -> IO (V.Vector DockerCommand, SHA1) buildTxScripts dockerFileEnvDir bf = withSystemTempDirectory "cooktx" $ \txDir -> - do txSh <- + do let dirName = + T.unpack $ T.decodeUtf8 $ B16.encode $ unSha1 $ + quickHash $ map T.encodeUtf8 $ V.toList $ V.concat $ HM.elems $ bf_transactions bf + txSh <- forM (HM.toList (bf_transactions bf)) $ \(TxRef refId, actions) -> do let f = "tx_" ++ show refId ++ ".sh" sh = mkScript refId actions @@ -118,38 +132,56 @@ return (f, T.encodeUtf8 sh) case (null txSh) of False -> - do compressFilesInDir tarFile txDir (map fst txSh) - return ( V.concat [pre, V.map mkTxLine (bf_dockerCommands bf), post] - , if null txSh then quickHash ["no-tx"] else quickHash (map snd txSh) + do compressFilesInDir False tarFile txDir (map fst txSh) + return ( V.concat [ pre dirName + , V.map (mkTxLine dirName) (bf_dockerCommands bf) + , post dirName] + , quickHash (map snd txSh) ) True -> - return (V.map mkTxLine (bf_dockerCommands bf), quickHash ["no-tx"]) + do checkedCommands <- + V.forM (bf_dockerCommands bf) $ \c -> + case c of + Left (TxRef refId) -> + fail $ "Found undefined transaction reference: " ++ show refId + Right cmd -> + return cmd + return (checkedCommands, quickHash ["no-tx"]) where - mkTxLine l = + mkTxLine dirName l = case l of Left (TxRef refId) -> - DockerCommand "RUN" (T.pack $ "bash " ++ (dockerTarDir "tx_" ++ show refId ++ ".sh")) + DockerCommand "RUN" (T.pack $ "bash " ++ (dockerTarDir dirName "tx_" ++ show refId ++ ".sh")) Right cmd -> cmd - pre = - V.fromList (copyTarAndUnpack "tx.tar.gz" dockerTarDir) - post = + pre dirName = + V.fromList (copyTarAndUnpack OverwriteExisting "tx.tar.gz" (dockerTarDir dirName)) + post dirName = V.fromList - [ DockerCommand "RUN" (T.pack $ "rm -rf " ++ dockerTarDir) + [ DockerCommand "RUN" (T.pack $ "rm -rf " ++ (dockerTarDir dirName)) ] - dockerTarDir = "/tmp/dockercooktx" + dockerTarDir dirName = "/tmp/tx_" ++ dirName tarFile = dockerFileEnvDir "tx.tar.gz" mkScript txId scriptLines = T.unlines ("#!/bin/bash" : "# auto generated by dockercook" : (T.pack $ "echo 'DockercookTx # " ++ show txId ++ "'") - : "set -e" : "set -x" : V.toList scriptLines + : "set -e" : "set -x" : (map (\ln -> T.concat ["( ", ln, " )"]) $ V.toList scriptLines) ) -copyTarAndUnpack :: FilePath -> FilePath -> [DockerCommand] -copyTarAndUnpack tarName imageDest = +data UnpackMode + = SkipExisting + | OverwriteExisting + +copyTarAndUnpack :: UnpackMode -> FilePath -> FilePath -> [DockerCommand] +copyTarAndUnpack um tarName imageDest = [ DockerCommand "COPY" (T.pack $ tarName ++ " /" ++ tarName) , DockerCommand "RUN" $ T.pack $ "mkdir -p " ++ imageDest - ++ " && /usr/bin/env tar xvk --skip-old-files -f /" ++ tarName ++ " -C " ++ imageDest + ++ " && /usr/bin/env tar xvk " + ++ (case um of + SkipExisting -> "--skip-old-files" + OverwriteExisting -> "--overwrite" + ) + ++ " -f /" ++ tarName ++ " -C " ++ imageDest ++ " && rm -rf /" ++ tarName ] @@ -158,10 +190,22 @@ constructBuildFile cookDir fp theLines = case baseLine of Just (BaseLine base) -> - baseCheck base $ handleLine (Right $ BuildFile myId base Nothing V.empty V.empty V.empty HM.empty) Nothing theLines + baseCheck base $ handleLine (Right (initBuildFile base)) Nothing theLines _ -> return $ Left "Missing BASE line!" where + initBuildFile base = + BuildFile + { bf_name = myId + , bf_base = base + , bf_unpackTarget = Nothing + , bf_dockerCommands = V.empty + , bf_include = V.empty + , bf_prepare = V.empty + , bf_downloadDeps = V.empty + , bf_transactions = HM.empty + , bf_cookCopy = HM.empty + } checkDocker (DockerCommand cmd _) action = let lowerCmd = T.toLower cmd in case lowerCmd of @@ -206,6 +250,10 @@ _ -> return $ Left "Only RUN and SCRIPT commands are allowed in transactions" Nothing -> case line of + CookCopyLine cookFile containerPath hostPath -> + handleLine (cookCopyLine cookFile containerPath hostPath buildFile) inTx rest + DownloadLine url target -> + handleLine (downloadLine url target buildFile) inTx rest ScriptLine scriptLoc mArgs -> handleScriptLine scriptLoc mArgs buildFile inTx rest DockerLine dockerCmd -> @@ -225,6 +273,20 @@ return $ Left "COMMIT is missing a BEGIN!" _ -> handleLine mBuildFile inTx rest + cookCopyLine cookFile containerPath hostPath buildFile = + Right $ + buildFile + { bf_cookCopy = + HM.insertWith (\new old -> new ++ old) cookFile [(containerPath, hostPath)] (bf_cookCopy buildFile) + } + downloadLine url@(DownloadUrl realUrl) target buildFile = + Right $ + buildFile + { bf_downloadDeps = V.snoc (bf_downloadDeps buildFile) url + , bf_dockerCommands = + V.snoc (bf_dockerCommands buildFile) $ + Right (DockerCommand "ADD" (T.concat [realUrl, " ", T.pack target])) + } handleScriptLine scriptLoc mArgs buildFile inTx rest = do let bashCmd = (cookDir scriptLoc) ++ " " ++ T.unpack (fromMaybe "" mArgs) (ec, stdOut, stdErr) <- @@ -250,18 +312,18 @@ } handleLine (Right buildFile') (Just txRef) rest -parseBuildFile :: CookConfig -> FilePath -> IO (Either String BuildFile) -parseBuildFile cfg fp = +parseBuildFile :: FilePath -> IO (Either String BuildFile) +parseBuildFile fp = do t <- T.readFile fp - parseBuildFileText cfg fp t + parseBuildFileText fp t -parseBuildFileText :: CookConfig -> FilePath -> T.Text -> IO (Either String BuildFile) -parseBuildFileText cfg fp t = +parseBuildFileText :: FilePath -> T.Text -> IO (Either String BuildFile) +parseBuildFileText fp t = case parseOnly pBuildFile t of Left err -> return $ Left err Right theLines -> - constructBuildFile (cc_buildFileDir cfg) fp theLines + constructBuildFile (takeDirectory fp) fp theLines parseFilePattern :: T.Text -> Either String FilePattern parseFilePattern pattern = @@ -287,6 +349,8 @@ (pScriptLine <* finish) <|> BeginTxLine <$ (pBeginTx <* finish) <|> CommitTxLine <$ (pCommitTx <* finish) <|> + (pDownloadLine <* finish) <|> + (pCookCopyLine <* finish) <|> DockerLine <$> (pDockerCommand <* finish) pBeginTx :: Parser () @@ -316,6 +380,10 @@ eolOrComment x = isEndOfLine x || x == '#' +eolOrCommentOrSpace :: Char -> Bool +eolOrCommentOrSpace x = + isEndOfLine x || x == '#' || isSpace x + pComment :: Parser () pComment = skipSpace <* optional (char '#' *> skipWhile (not . isEndOfLine)) @@ -323,6 +391,17 @@ pIncludeLine :: Parser FilePattern pIncludeLine = (asciiCI "INCLUDE" *> skipSpace) *> pFilePattern + +pDownloadLine :: Parser BuildFileLine +pDownloadLine = + DownloadLine <$> (DownloadUrl <$> ((asciiCI "DOWNLOAD" *> skipSpace) *> (takeWhile1 (not . isSpace)))) + <*> (T.unpack <$> (skipSpace *> takeWhile1 (not . eolOrCommentOrSpace))) + +pCookCopyLine :: Parser BuildFileLine +pCookCopyLine = + CookCopyLine <$> ((asciiCI "COOKCOPY" *> skipSpace) *> (T.unpack <$> takeWhile1 isValidFileNameChar)) + <*> (T.unpack <$> (skipSpace *> takeWhile1 isValidFileNameChar)) + <*> (T.unpack <$> (skipSpace *> takeWhile1 isValidFileNameChar)) pScriptLine :: Parser BuildFileLine pScriptLine = diff --git a/src/lib/Cook/Docker.hs b/src/lib/Cook/Docker.hs --- a/src/lib/Cook/Docker.hs +++ b/src/lib/Cook/Docker.hs @@ -3,6 +3,8 @@ module Cook.Docker ( DockerImagesCache, newDockerImagesCache , dockerReachable, doesImageExist + , DockerContainer + , dockerRunForCopy, dockerRm, dockerCp , getImageId, tagImage ) where @@ -13,31 +15,64 @@ import Control.Applicative import Control.Concurrent.STM import System.Exit -import System.Process import qualified Data.Text as T newtype DockerImagesCache = DockerImagesCache { _unDockerImagesCache :: TVar (Maybe T.Text) } +data DockerContainer + = DockerContainer { unDockerContainer :: T.Text } + deriving (Show, Eq) + getImageId :: DockerImage -> IO (Maybe DockerImageId) getImageId (DockerImage imageName) = - do (ec, stdOut, _) <- readProcessWithExitCode "docker" ["inspect", "-f", "{{.Id}}", T.unpack imageName] "" + do (ec, stdOut, _) <- readProcessWithExitCode' "docker" ["inspect", "-f", "{{.Id}}", T.unpack imageName] "" if ec /= ExitSuccess then return Nothing else return $ Just $ DockerImageId $ T.strip $ T.pack stdOut tagImage :: DockerImageId -> DockerImage -> IO () tagImage (DockerImageId imageId) (DockerImage imageTag) = - do (ec, _, _) <- readProcessWithExitCode "docker" ["tag", T.unpack imageId, T.unpack imageTag] "" + do (ec, _, _) <- readProcessWithExitCode' "docker" ["tag", "-f", T.unpack imageId, T.unpack imageTag] "" if ec /= ExitSuccess then fail $ "Failed to tag image " ++ show imageId else return () dockerReachable :: IO Bool dockerReachable = - do (ec, _, _) <- readProcessWithExitCode "docker" ["ps"] "" + do (ec, _, _) <- readProcessWithExitCode' "docker" ["ps"] "" return $ ec == ExitSuccess +dockerRunForCopy :: DockerImage -> IO DockerContainer +dockerRunForCopy (DockerImage imageId) = + do logDebug $ "Launching image " ++ T.unpack imageId ++ " for copying files out of it." + (ec, stdout, stderr) <- + readProcessWithExitCode' "docker" ["run", "-d", "--entrypoint=''", T.unpack imageId, "/bin/bash"] "" + if ec /= ExitSuccess + then fail $ "Failed to run image " ++ T.unpack imageId ++ ": " ++ stderr + else do return (DockerContainer (T.strip $ T.pack stdout)) + +dockerRm :: Bool -> DockerContainer -> IO Bool +dockerRm force dc = + do let cid = T.unpack $ unDockerContainer dc + logDebug $ "Removing container " ++ cid + (ec, _, stderr) <- + readProcessWithExitCode' "docker" (["rm"] ++ (if force then ["-f"] else []) ++ [cid]) "" + if ec /= ExitSuccess + then do putStrLn $ "Failed to rm container " ++ cid ++ ": " ++ stderr + return False + else do return True + +dockerCp :: DockerContainer -> FilePath -> FilePath -> IO () +dockerCp dc containerPath hostPath = + do let cid = T.unpack $ unDockerContainer dc + logDebug $ "Copy " ++ cid ++ ":" ++ containerPath ++ " to " ++ hostPath + (ec, _, stderr) <- + readProcessWithExitCode' "docker" ["cp", cid ++ ":" ++ containerPath, hostPath] "" + if ec /= ExitSuccess + then fail $ "Failed to cp from container " ++ cid ++ ": " ++ stderr + else return () + newDockerImagesCache :: IO DockerImagesCache newDockerImagesCache = DockerImagesCache <$> newTVarIO Nothing @@ -52,7 +87,7 @@ return (ExitSuccess, textOut) Nothing -> do logDebug "Using live docker images for doesImageExist" - (ecL, stdOut, _) <- readProcessWithExitCode "docker" ["images"] "" + (ecL, stdOut, _) <- readProcessWithExitCode' "docker" ["images"] "" let textOut = T.pack stdOut atomically $ writeTVar cacheVar (Just textOut) return (ecL, textOut) diff --git a/src/lib/Cook/Downloads.hs b/src/lib/Cook/Downloads.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/Downloads.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +module Cook.Downloads where + +import Cook.Types +import Cook.Util + +import Data.List (foldl') +import Control.Lens ((^.), (^?)) +import Network.Wreq +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +getUrlHash :: DownloadUrl -> IO SHA1 +getUrlHash (DownloadUrl url) = + do r <- head_ (T.unpack url) + let mLocation = r ^? responseHeader "Location" + case mLocation of + Just redir -> + fail ("The download url " ++ T.unpack url ++ " redirected my to " + ++ BSC.unpack redir ++ ". That's not supported yet.") + Nothing -> return () + case foldl' (handleDepTag r) [] depTags of + [] -> + do let allRespH = r ^. responseHeaders + fail ("The download url " ++ T.unpack url + ++ " didn't set any identifying headers (Last-Modified, ETag, Content-MD5). " + ++ "Found headers: " ++ show allRespH + ) + xs -> return $ quickHash (T.encodeUtf8 url : xs) + where + handleDepTag r xs depTag = + case r ^? responseHeader depTag of + Just tagValue -> + tagValue:xs + Nothing -> xs + depTags = + [ "Last-Modified" + , "ETag" + , "Content-MD5" + ] diff --git a/src/lib/Cook/State/Manager.hs b/src/lib/Cook/State/Manager.hs --- a/src/lib/Cook/State/Manager.hs +++ b/src/lib/Cook/State/Manager.hs @@ -16,6 +16,7 @@ import Cook.Util import Cook.State.Model import Cook.Types +import qualified Cook.Docker as D import Control.Applicative import Control.Concurrent @@ -80,7 +81,7 @@ pool <- runNoLoggingT $ createSqlitePool (T.pack sqlLoc) 5 let runSql action = let tryTx = (runResourceT . runNoLoggingT . ((flip runSqlPool) pool)) action - in (recoverAll (exponentialBackoff 500000 <> limitRetries 5) tryTx) `catch` \(e :: SomeException) -> + in (recoverAll (constantDelay microsec <> limitRetries 5) tryTx) `catch` \(e :: SomeException) -> fail $ "Sqlite-Transaction finally failed: " ++ show e runSql (runMigration migrateState) sqlQueue <- newTBQueueIO 100 @@ -121,6 +122,8 @@ } return (stateMgr, hashMgr) where + microsec = + 12 * 1000 * 1000 sqlLoc = stateDirectory "database.db" queueWorker runSql queue = do action <- atomically $ readTBQueue queue @@ -222,16 +225,25 @@ recomputeHash syncImages :: StateManager -> (DockerImage -> IO Bool) -> IO () -syncImages (StateManager{..}) imageStillExists = +syncImages sm@(StateManager{..}) imageStillExists = do x <- sm_runSqlGet $ selectList [] [] forM_ x $ \entity -> do let dockerImage = entityVal entity name = dbDockerImageName dockerImage exists <- imageStillExists (DockerImage name) - unless exists $ - do logInfo ("The image " ++ T.unpack name - ++ " doesn't exist on remote docker server. Removing it from local state.") - sm_runSqlWrite $ delete (entityKey entity) + if exists + then do mRawId <- D.getImageId (DockerImage name) + case mRawId of + Nothing -> + do logInfo ("The image " ++ T.unpack name + ++ " doesn't have a raw id on the docker host. Deleting it from local state") + sm_runSqlWrite $ delete (entityKey entity) + Just rawId -> + do logInfo ("New raw id for " ++ T.unpack name ++ " is " ++ T.unpack (unDockerImageId rawId)) + setImageId sm (DockerImage name) rawId + else do logInfo ("The image " ++ T.unpack name + ++ " doesn't exist on remote docker server. Removing it from local state.") + sm_runSqlWrite $ delete (entityKey entity) sm_waitForWrites isImageKnown :: StateManager -> DockerImage -> IO Bool diff --git a/src/lib/Cook/Types.hs b/src/lib/Cook/Types.hs --- a/src/lib/Cook/Types.hs +++ b/src/lib/Cook/Types.hs @@ -5,30 +5,19 @@ import qualified Data.ByteString as BS import qualified Data.Text as T +newtype DownloadUrl + = DownloadUrl { unDownloadUrl :: T.Text } + deriving (Show, Eq, Hashable) + data CookConfig = CookConfig - { cc_dataDir :: FilePath - , cc_buildFileDir :: FilePath - , cc_boringFile :: Maybe FilePath + { cc_boringFile :: Maybe FilePath , cc_tagprefix :: Maybe String -- additionally tag images using this prefix + cook filename , cc_cookFileDropCount :: Int -- drop this many chars from every cook filename , cc_autoPush :: Bool , cc_forceRebuild :: Bool , cc_buildEntryPoints :: [String] } deriving (Show, Eq) - -dummyCookConfig :: CookConfig -dummyCookConfig = - CookConfig - { cc_dataDir = "DATA_DIR" - , cc_buildFileDir = "BUILD_FILE_DIR" - , cc_boringFile = Nothing - , cc_tagprefix = Nothing - , cc_cookFileDropCount = 0 - , cc_buildEntryPoints = [] - , cc_autoPush = False - , cc_forceRebuild = False - } data ErrorWarningOk = EWOError T.Text diff --git a/src/lib/Cook/Util.hs b/src/lib/Cook/Util.hs --- a/src/lib/Cook/Util.hs +++ b/src/lib/Cook/Util.hs @@ -4,13 +4,15 @@ import Control.Monad import Control.Monad.Trans +import Control.Retry +import Data.List (intercalate) import System.Exit import System.IO import System.Log.Formatter import System.Log.Handler hiding (setLevel) import System.Log.Handler.Simple import System.Log.Logger -import System.Process (system, rawSystem) +import System.Process (system, rawSystem, readProcessWithExitCode) import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as BS @@ -41,6 +43,11 @@ logError :: MonadIO m => String -> m () logError = liftIO . errorM "cook" +readProcessWithExitCode' :: String -> [String] -> String -> IO (ExitCode, String, String) +readProcessWithExitCode' cmd args procIn = + do logDebug ("$ " ++ cmd ++ " " ++ intercalate " " args) + readProcessWithExitCode cmd args procIn + systemStream :: Maybe FilePath -> String -> (BS.ByteString -> IO ()) -> IO ExitCode systemStream mDir cmd _onOutput = let realCmd = @@ -50,11 +57,20 @@ in do logDebug ("$ " ++ realCmd) system realCmd -compressFilesInDir :: FilePath -> FilePath -> [FilePath] -> IO () -compressFilesInDir tarName dirFp files = - do ecTar <- rawSystem tarCmd tarArgs +compressFilesInDir :: Bool -> FilePath -> FilePath -> [FilePath] -> IO () +compressFilesInDir shouldRetry tarName dirFp files = + do ecTar <- + retrying (constantDelay microsec <> limitRetries 5) checkRetry sysAction unless (ecTar == ExitSuccess) $ fail ("Error creating tar:\n" ++ tarCmd ++ " " ++ unwords tarArgs) where - tarCmd = "/usr/bin/env" - tarArgs = ["tar", "cjf", tarName, "-C", dirFp] ++ files + microsec = + 12 * 1000 * 1000 + checkRetry _ ec = + return (shouldRetry && ec /= ExitSuccess) + sysAction = + rawSystem tarCmd tarArgs + tarCmd = + "/usr/bin/env" + tarArgs = + ["tar", "cjf", tarName, "-C", dirFp] ++ files diff --git a/src/prog/Cook/ArgParse.hs b/src/prog/Cook/ArgParse.hs --- a/src/prog/Cook/ArgParse.hs +++ b/src/prog/Cook/ArgParse.hs @@ -5,51 +5,19 @@ data CookCmd = CookBuild CookConfig - | CookParse FilePath + | CookParse [FilePath] | CookSync | CookVersion | CookInit deriving (Show, Eq) -cookFileP = - strOption $ - long "file" <> - short 'f' <> - metavar "FILE" <> - value "FILE" <> - help "File to parse" - cookTagP = optional $ strOption $ long "tag" <> short 't' <> metavar "TAG-PREFIX" <> - help "Additionally tag docker images with this prefix" - -cookDataP = - strOption $ - long "data" <> - short 'd' <> - metavar "DIRECTORY" <> - value "." <> - help "Directory where to find INCLUDED files" - -cookBuildP = - strOption $ - long "buildfiles" <> - short 'b' <> - metavar "DIRECTORY" <> - value "." <> - help "Directory of dockercook files" - - -cookEntryPointP_deprecated = - strOption $ - long "entrypoint" <> - short 'p' <> - metavar "COOKFILE" <> - help "Cookfile to be built" + help "Tag resulting docker images with this prefix" cookFileDropP :: Parser Int cookFileDropP = @@ -57,7 +25,7 @@ long "cookfile-drop-chars" <> value 0 <> metavar "COUNT" <> - help "drop this number of characters from each cook filename for tagging" + help "drop this number of characters from each cook filename before tagging" cookVerboseP :: Parser Int cookVerboseP = @@ -72,25 +40,25 @@ optional $ strOption ( long "ignore" <> short 'i' <> metavar "FILENAME" <> help "File with regex list of ignored files." ) +cookFilesP = + many (argument str (metavar "COOKFILE")) + cookOptions :: Parser CookCmd cookOptions = CookBuild <$> - (CookConfig <$> cookDataP - <*> cookBuildP - <*> cookBoringP + (CookConfig <$> cookBoringP <*> cookTagP <*> cookFileDropP <*> (switch (long "push" <> help "Push built docker containers")) <*> (switch (long "force-rebuild" <> help "Rebuild all docker images regardless of dependency changes")) - <*> ((++) <$> many cookEntryPointP_deprecated - <*> many (argument str (metavar "COOKFILE")))) + <*> cookFilesP) cookSync :: Parser CookCmd cookSync = pure CookSync cookParse :: Parser CookCmd cookParse = - CookParse <$> cookFileP + CookParse <$> cookFilesP argParse :: Parser (Int, CookCmd) argParse = diff --git a/src/prog/Main.hs b/src/prog/Main.hs --- a/src/prog/Main.hs +++ b/src/prog/Main.hs @@ -16,6 +16,7 @@ import System.Exit import System.Log import System.Directory +import System.FilePath import System.Process runProg :: (Int, CookCmd) -> IO () @@ -42,7 +43,8 @@ CookBuild buildCfg -> do uploader <- mkUploader 100 stateDir <- findStateDirectory - _ <- cookBuild stateDir buildCfg uploader Nothing + let rootDir = takeDirectory stateDir + _ <- cookBuild rootDir stateDir buildCfg uploader Nothing when (cc_autoPush buildCfg) $ do logInfo $ "Waiting for all images to finish beeing pushed" waitForCompletion uploader @@ -53,8 +55,8 @@ CookSync -> do stateDir <- findStateDirectory runSync stateDir - CookParse file -> - cookParse file + CookParse files -> + mapM_ cookParse files CookVersion -> putStrLn ("dockercook " ++ showVersion version) CookInit -> diff --git a/src/test/Tests/BuildFile.hs b/src/test/Tests/BuildFile.hs --- a/src/test/Tests/BuildFile.hs +++ b/src/test/Tests/BuildFile.hs @@ -18,6 +18,7 @@ assertBool (matchesFilePattern pattern2 "foo/hellooooo.cabal") assertBool (not $ matchesFilePattern pattern2 "foo/hellooooo.cabal.xzy") assertBool (not $ matchesFilePattern pattern2 "foo/hellooooo.xzy") + assertBool (not $ matchesFilePattern pattern2 "test/foo/hellooooo.xzy") assertBool (matchesFilePattern pattern3 "foo/asdasdas") assertBool (matchesFilePattern pattern3 "foo/bar/asdasdas") where @@ -32,13 +33,12 @@ test_parseBuildFile :: IO () test_parseBuildFile = - do let dummyCfg = dummyCookConfig - parsed1 <- parseBuildFileText dummyCfg "sample1" sampleFile1 >>= assertRight - parsed2 <- parseBuildFileText dummyCfg "sample1" sampleFile2 >>= assertRight - parsed3 <- parseBuildFileText dummyCfg "sample3" sampleFile3 >>= assertRight - parsed4 <- parseBuildFileText dummyCfg "sample3" sampleFile4 >>= assertRight + do parsed1 <- parseBuildFileText "sample1" sampleFile1 >>= assertRight + parsed2 <- parseBuildFileText "sample1" sampleFile2 >>= assertRight + parsed3 <- parseBuildFileText "sample3" sampleFile3 >>= assertRight + parsed4 <- parseBuildFileText "sample3" sampleFile4 >>= assertRight sampleFile5 <- readDataFile "test1.cook" - parsed5 <- parseBuildFileText dummyCfg "test1.cook" sampleFile5 >>= assertRight + parsed5 <- parseBuildFileText "test1.cook" sampleFile5 >>= assertRight assertEqual (BuildBaseDocker $ DockerImage "ubuntu:14.04") (bf_base parsed1) assertEqual parsed1 parsed2 assertEqual (BuildBaseCook $ BuildFileId "foo.build") (bf_base parsed3)