dockercook 0.4.0.0 → 0.4.3.0
raw patch · 11 files changed
+340/−164 lines, 11 filesdep +lensdep +wreqdep ~conduit-combinators
Dependencies added: lens, wreq
Dependency ranges changed: conduit-combinators
Files
- dockercook.cabal +7/−4
- src/lib/Cook/Build.hs +82/−51
- src/lib/Cook/BuildFile.hs +105/−26
- src/lib/Cook/Docker.hs +40/−5
- src/lib/Cook/Downloads.hs +41/−0
- src/lib/Cook/State/Manager.hs +18/−6
- src/lib/Cook/Types.hs +5/−16
- src/lib/Cook/Util.hs +22/−6
- src/prog/Cook/ArgParse.hs +9/−41
- src/prog/Main.hs +5/−3
- src/test/Tests/BuildFile.hs +6/−6
dockercook.cabal view
@@ -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
src/lib/Cook/Build.hs view
@@ -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
src/lib/Cook/BuildFile.hs view
@@ -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 =
src/lib/Cook/Docker.hs view
@@ -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)
+ src/lib/Cook/Downloads.hs view
@@ -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"+ ]
src/lib/Cook/State/Manager.hs view
@@ -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
src/lib/Cook/Types.hs view
@@ -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
src/lib/Cook/Util.hs view
@@ -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
src/prog/Cook/ArgParse.hs view
@@ -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 =
src/prog/Main.hs view
@@ -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 ->
src/test/Tests/BuildFile.hs view
@@ -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)