diff --git a/data/test1.cook b/data/test1.cook new file mode 100644 --- /dev/null +++ b/data/test1.cook @@ -0,0 +1,32 @@ +BASE COOK 030_dev.cook + +INCLUDE 3rdParty/* +INCLUDE scripts/sbt +INCLUDE scripts/sbt-launch-0.11.1.jar +INCLUDE build.sbt +INCLUDE project/build.properties +INCLUDE project/build.sbt +INCLUDE project/Build.scala +INCLUDE project/plugins.sbt +INCLUDE project/DbMetaSpec.scala +INCLUDE project/DbSpec.scala + +UNPACK /DociData + +# install binary dependencies +RUN apt-get install -y imagemagick + +# dcmtk +RUN cd /tmp && wget -O dcmtk.tar.bz2 ftp://dicom.offis.de/pub/dicom/offis/software/dcmtk/dcmtk360/bin/dcmtk-3.6.0-linux-i686-static.tar.bz2 +RUN cd /tmp && tar -xvf dcmtk.tar.bz2 +RUN cp -R /tmp/dcmtk-3.6.0-linux-i686-static/* /usr/local/ +RUN rm -rf /tmp/dcmtk* + +# build DociData 3rdParty +WORKDIR /DociData +RUN wget -O /tmp/DociCache http://10.20.100.2/DociData-lib.tar.gz +RUN tar xzvf /tmp/DociCache -C . +RUN 3rdParty/build.sh + +# build DociData dependencies +RUN scripts/sbt update diff --git a/dockercook.cabal b/dockercook.cabal --- a/dockercook.cabal +++ b/dockercook.cabal @@ -1,60 +1,79 @@ name: dockercook -version: 0.1.2.1 +version: 0.4.0.0 synopsis: A build tool for multiple docker image layers description: Build and manage multiple docker image layers to speed up deployment license: MIT license-file: LICENSE -author: Alexander Thiemann -maintainer: thiemann@factisresearch.com +author: Alexander Thiemann +maintainer: Alexander Thiemann copyright: (c) 2014 factis research GmbH category: Development build-type: Simple homepage: https://github.com/factisresearch/dockercook bug-reports: https://github.com/factisresearch/dockercook/issues cabal-version: >=1.8 +data-dir: data +data-files: test1.cook library hs-source-dirs: src/lib - exposed-modules: Cook.Build, Cook.BuildFile, Cook.Clean, Cook.Types - other-modules: Cook.Util, Cook.State.Manager, Cook.State.Model - build-depends: base ==4.6.*, - attoparsec >=0.11 && <0.13, - base16-bytestring >=0.1 && <0.2, - bytestring >=0.10 && <0.11, - conduit >=1.1 && <1.2, - cryptohash >=0.11 && <0.12, - directory >=1.2 && <1.3, - filepath >=1.3 && <1.4, - conduit-combinators >=0.2 && <0.3, - conduit-extra >=1.1 && <1.2, - resourcet >=1.1 && <1.2, - regex-compat >=0.95 && <0.96, - process >=1.1 && <1.2, - system-filepath >=0.4 && <0.5, - temporary >=1.2 && <1.3, - text >=1.1 && <1.2, - transformers >= 0.3 && <0.4, - graph-core >= 0.2 && <0.3, - persistent-sqlite >= 1.3 && <1.4, - persistent-template >=1.3 && <1.4, - resourcet >= 0.4 && <1.2, - mtl >=2.1 && <2.2, - monad-logger >=0.3 && <0.4, - cereal >=0.4 && <0.5, - safecopy >=0.8 && <0.9, - time >=1.4 && <1.5, - stm >=2.4 && <2.5, - hashable >=1.2 && <1.3, - vector >=0.10 && <0.11, - unordered-containers >=0.2 && <0.3 + exposed-modules: + Cook.Build, + Cook.BuildFile, + Cook.State.Manager, + Cook.Sync, + Cook.Types, + Cook.Uploader, + Cook.Util + other-modules: + Cook.Docker, + Cook.State.Model + build-depends: + attoparsec >=0.11, + base >=4.6 && <5, + base16-bytestring >=0.1, + bytestring >=0.10, + conduit >=1.1, + conduit-combinators >=0.2, + conduit-extra >=1.1, + cryptohash >=0.11, + directory >=1.2, + filepath >=1.3, + hashable >=1.2, + hslogger >=1.2.6, + monad-logger >=0.3, + mtl >=2.1, + persistent-sqlite >= 1.3, + persistent-template >=1.3, + process >=1.1, + regex-compat >=0.95, + resourcet >= 0.4, + resourcet >=1.1, + retry >=0.5, + stm >=2.4, + streaming-commons >=0.1, + system-filepath >=0.4, + temporary >=1.2, + text >=1.1, + time >=1.4, + transformers >= 0.3, + unix >=2.5, + unordered-containers >=0.2, + vector >=0.10 + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures executable dockercook main-is: Main.hs other-modules: Cook.ArgParse - build-depends: base ==4.6.*, + build-depends: + base >=4.6 && <5, + directory, dockercook, - optparse-applicative >=0.8 && <0.9 + filepath, + hslogger, + optparse-applicative >=0.11.0.1, + process hs-source-dirs: src/prog ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures @@ -63,11 +82,12 @@ hs-source-dirs: src/test main-is: Tests.hs other-modules: Tests.BuildFile - build-depends: base ==4.6.*, + build-depends: + HTF >=0.12.2.3, + base >=4.6 && <5, dockercook, - HTF >=0.11 && <0.13, - text >=1.1 && <1.2, - vector >=0.10 && <0.11 + text, + vector ghc-options: -Wall -fno-warn-orphans source-repository head 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 @@ -3,16 +3,19 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternGuards #-} -module Cook.Build (cookBuild) where +{-# 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 qualified Cook.Docker as D import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Trans.Resource (runResourceT, MonadResource) import Data.Conduit import Data.Maybe (fromMaybe, isJust) import System.Directory @@ -22,11 +25,11 @@ import System.IO.Temp import System.Process import Text.Regex (mkRegex, matchRegex) -import qualified Crypto.Hash.SHA1 as SHA1 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 @@ -34,89 +37,223 @@ import qualified Data.Vector as V import qualified Filesystem.Path.CurrentOS as FP -quickHash :: [BS.ByteString] -> SHA1 -quickHash bsList = - SHA1 $ SHA1.finalize (SHA1.updates SHA1.init bsList) - fixTailingSlash :: FilePath -> FilePath fixTailingSlash s = case reverse s of ('/':_) -> s d -> reverse ('/':d) -makeDirectoryFileHashTable :: (FP.FilePath -> Bool) -> FilePath -> IO [(FP.FilePath, SHA1)] -makeDirectoryFileHashTable ignore (FP.decodeString . fixTailingSlash -> root) = - do logInfo $ "Hashing directory tree at " ++ show root ++ ". This will take some time..." - x <- runResourceT $! C.sourceDirectoryDeep False root =$= C.concatMapM hashFile $$ C.sinkList +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 will take some time..." + x <- runResourceT $! sourceDirectoryDeep' False dirCheck root =$= C.concatMapM (hashFile fullRoot) $$ C.sinkList hPutStr stderr "\n" - logInfo "Done hashing your repo!" + logDebug "Done hashing your repo!" return x where - hashFile relToCurrentF = + 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' relToRootF relToCurrentF - hashFile' relToRootF relToCurrentF + 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) - bs <- C.sourceFile relToCurrentF $$ C.sinkList + 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, quickHash bs) + return $ Just (relToCurrentF, hash) -buildImage :: Maybe StreamHook -> CookConfig -> StateManager -> [(FP.FilePath, SHA1)] -> BuildFile -> IO DockerImage -buildImage mStreamHook cfg@(CookConfig{..}) stateManager fileHashes bf = - do baseImage <- +runPrepareCommands tempDir bf streamHook = + 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) + where + computeHash fp = + do bs <- C.sourceFile fp $$ C.sinkList + logDebug ("PREPARE: Hashing " ++ show fp) + return $ [quickHash bs] + +buildImage :: D.DockerImagesCache + -> Maybe StreamHook + -> CookConfig -> StateManager -> HashManager -> [(FP.FilePath, SHA1)] + -> Uploader -> BuildFile -> IO DockerImage +buildImage imCache mStreamHook cfg@(CookConfig{..}) stateManager hashManager fileHashes uploader bf = + withSystemTempDirectory "cookbuildXXX" $ \buildTempDir -> + do logDebug $ "Inspecting " ++ name ++ "..." + baseImage <- case bf_base bf of (BuildBaseCook parentBuildFile) -> - do parent <- prepareEntryPoint cc_buildFileDir parentBuildFile - buildImage mStreamHook cfg stateManager fileHashes parent + do parent <- prepareEntryPoint cfg parentBuildFile + buildImage imCache mStreamHook cfg stateManager hashManager fileHashes uploader parent (BuildBaseDocker rootImage) -> do baseExists <- dockerImageExists rootImage if baseExists - then do markUsingImage stateManager rootImage Nothing + then do markUsingImage stateManager rootImage return rootImage - else do logInfo' $ "Downloading the root image " ++ show (unDockerImage rootImage) ++ "... " - (ec, stdOut, _) <- + else do logDebug' $ "Downloading the root image " ++ show (unDockerImage rootImage) ++ "... " + (ec, stdOut, stdErr) <- readProcessWithExitCode "docker" ["pull", T.unpack $ unDockerImage rootImage] "" if ec == ExitSuccess - then do markUsingImage stateManager rootImage Nothing + then do markUsingImage stateManager rootImage return rootImage else error ("Can't find provided base docker image " - ++ (show $ unDockerImage rootImage) ++ ": " ++ stdOut) - - logInfo $ "Computing hashes for " ++ (T.unpack $ unBuildFileId $ bf_name bf) - let dockerBS = + ++ (show $ unDockerImage rootImage) ++ ": " ++ stdOut ++ "\n" ++ stdErr) + (dockerCommandsBase, txHashes) <- buildTxScripts buildTempDir bf + (mTar, prepareHash) <- runPrepareCommands buildTempDir bf streamHook + let (copyPreparedTar, cleanupCmds) = + case mTar of + Just preparedTar -> + ( V.fromList $ copyTarAndUnpack 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 "context.tar.gz" target + dockerCommands = + V.concat [contextAdd, copyPreparedTar, dockerCommandsBase, cleanupCmds] + dockerBS = BSC.concat [ "FROM ", T.encodeUtf8 (unDockerImage baseImage), "\n" - , T.encodeUtf8 $ T.unlines $ V.toList $ V.map dockerCmdToText (bf_dockerCommands bf) + , T.encodeUtf8 $ T.unlines $ V.toList $ V.map dockerCmdToText dockerCommands ] dockerHash = quickHash [dockerBS] allFHashes = map snd targetedFiles - buildFileHash = quickHash [BSC.pack (show bf)] - superHash = B16.encode $ unSha1 $ quickHash (map unSha1 (dockerHash : buildFileHash : allFHashes)) + buildFileHash = quickHash [BSC.pack (show $ bf { bf_name = BuildFileId "static" })] + superHash = + B16.encode $ unSha1 $ + concatHash (prepareHash : txHashes : dockerHash : buildFileHash : allFHashes) imageName = DockerImage $ T.concat ["cook-", T.decodeUtf8 superHash] - logInfo $ "Include files: " ++ (show $ length targetedFiles) + imageTag = T.unpack $ unDockerImage imageName + logDebug $ "Include files: " ++ (show $ length targetedFiles) ++ " FileHashCount: " ++ (show $ length allFHashes) - ++ " Docker: " ++ (show $ B16.encode $ unSha1 dockerHash) - ++ " BuildFile: " ++ (show $ B16.encode $ unSha1 buildFileHash) - logInfo' $ "Image name will be " ++ (T.unpack $ unDockerImage imageName) - let markImage = markUsingImage stateManager imageName (Just baseImage) + ++ "\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 stateManager imageName + T.forM mUserTagName $ \userTag -> + do _ <- systemStream Nothing ("docker tag " ++ imageTag ++ " " ++ userTag) streamHook + return (DockerImage $ T.pack userTag) + announceBegin = + hPutStr stderr (name ++ "... \t\t") + tagInfo = + fromMaybe "" $ fmap (\userTag -> " --> " ++ userTag) mUserTagName + nameTagArrow = + imageTag ++ tagInfo + + announceBegin imageExists <- dockerImageExists imageName - if imageExists - then do logInfo' "The image already exists!" - markImage - return imageName - else do logInfo' "Image not found!" - x <- launchImageBuilder dockerBS imageName - markImage - return x + (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!" + x <- launchImageBuilder dockerBS imageName buildTempDir + mTag <- markImage + announceBegin + hPutStrLn stderr ("built " ++ nameTagArrow) + withRawImageId imageName $ \imageId -> + do logDebug' $ "The raw id of " ++ imageTag ++ " is " ++ show imageId + setImageId stateManager 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 - logInfo' m = - do logInfo m + 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) + Just imageId -> action imageId + 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")) @@ -127,48 +264,66 @@ Nothing -> return () Just (StreamHook hook) -> hook bs dockerImageExists localIm@(DockerImage imageName) = - do logInfo' $ "Checking if the image " ++ show imageName ++ " is already present... " + do logDebug' $ "Checking if the image " ++ show imageName ++ " is already present... " known <- isImageKnown stateManager localIm + mRawImageId <- getImageId stateManager localIm + let storeRawId = + unless (isJust mRawImageId) $ + withRawImageId localIm $ \imageId -> + do logDebug' $ "The raw id of " ++ (T.unpack imageName) ++ " is " ++ show imageId + setImageId stateManager localIm imageId if known - then do logInfo' $ "Image " ++ show imageName ++ " is registered in your state directory. Assuming it is present!" + then do logDebug' $ "Image " ++ show imageName ++ " is registered in your state directory. Assuming it is present!" + storeRawId return True - else do (ec, stdOut, _) <- readProcessWithExitCode "docker" ["images"] "" - let imageLines = T.lines $ T.pack stdOut - return $ ec == ExitSuccess && checkLines imageName imageLines - where - checkLines _ [] = False - checkLines im (line:xs) = - let (imageBaseName, vers) = T.break (==':') im - in if T.isPrefixOf imageBaseName line - then if vers == "" - then True - else if T.isInfixOf (T.drop 1 vers) line - then True - else checkLines im xs - else checkLines im xs + else do taggedExists <- D.doesImageExist imCache (Left localIm) + case (taggedExists, mRawImageId) of + (True, _) -> + do storeRawId + return True + (False, Just rawId) -> + do rawExists <- D.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 contextPkg cc_dataDir includedFiles + currentDir <- getCurrentDirectory + let includedFilesFull = map (FP.encodeString . fst) targetedFiles + forM_ includedFilesFull $ \f -> + do didChange <- (hm_didFileChange hashManager) (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 = - withSystemTempDirectory "cook-docker-build" $ \tempDir -> - do mapM_ (\(f,_) -> - do let dirC = tempDir (FP.encodeString $ localName $ FP.directory f) - copySrc = FP.encodeString f - targetSrc = tempDir (FP.encodeString $ localName f) - when (dirC /= "") $ - do putStrLn ("mkdir -p " ++ dirC) - createDirectoryIfMissing True dirC - putStrLn ("cp " ++ copySrc ++ " " ++ targetSrc) - copyFile copySrc targetSrc - ) targetedFiles - logInfo' "Writing Dockerfile ..." + 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 - logInfo' ("Building docker container...") + logDebug' ("Building " ++ name ++ "...") let tag = T.unpack $ unDockerImage imageName - ecDocker <- systemStream ("docker build --rm -t " ++ tag ++ " " ++ tempDir) streamHook + ecDocker <- systemStream Nothing ("docker build --rm -t " ++ tag ++ " " ++ tempDir) streamHook if ecDocker == ExitSuccess then return imageName 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 ("rm -rf COOKFAILED; cp -r " ++ tempDir ++ " COOKFAILED") streamHook + _ <- systemStream Nothing ("rm -rf COOKFAILED; cp -r " ++ tempDir ++ " COOKFAILED") streamHook exitWith ecDocker localName fp = case FP.stripPrefix (FP.decodeString $ fixTailingSlash cc_dataDir) fp of @@ -179,15 +334,17 @@ targetedFiles = filter (\(fp, _) -> isNeededHash fp) fileHashes -cookBuild :: CookConfig -> Maybe StreamHook -> IO [DockerImage] -cookBuild cfg@(CookConfig{..}) mStreamHook = - do stateManager <- createStateManager cc_stateDir +cookBuild :: FilePath -> CookConfig -> Uploader -> Maybe StreamHook -> IO [DockerImage] +cookBuild stateDir cfg@(CookConfig{..}) uploader mStreamHook = + do (stateManager, hashManager) <- createStateManager stateDir boring <- liftM (fromMaybe []) $ T.mapM (liftM parseBoring . T.readFile) cc_boringFile - fileHashes <- makeDirectoryFileHashTable (isBoring boring) cc_dataDir + fileHashes <- makeDirectoryFileHashTable hashManager (isBoring boring) cc_dataDir roots <- - mapM ((prepareEntryPoint cc_buildFileDir) . BuildFileId . T.pack) cc_buildEntryPoints - res <- mapM (buildImage mStreamHook cfg stateManager fileHashes) roots - logInfo "All done!" + mapM ((prepareEntryPoint cfg) . BuildFileId . T.pack) cc_buildEntryPoints + imCache <- D.newDockerImagesCache + res <- mapM (buildImage imCache mStreamHook cfg stateManager hashManager fileHashes uploader) roots + waitForWrites stateManager + logInfo "Finished building all required images!" return res where parseBoring = @@ -195,13 +352,24 @@ isBoring boring fp = any (isJust . flip matchRegex (FP.encodeString fp)) boring -prepareEntryPoint :: FilePath -> BuildFileId -> IO BuildFile -prepareEntryPoint buildFileDir (BuildFileId entryPoint) = - do let n = buildFileDir (T.unpack entryPoint) - mRes <- parseBuildFile n +cookParse :: FilePath -> IO () +cookParse fp = + do mRes <- parseBuildFile dummyCookConfig 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 :: CookConfig -> BuildFileId -> IO BuildFile +prepareEntryPoint cfg (BuildFileId entryPoint) = + do let buildFileDir = cc_buildFileDir cfg + n = buildFileDir (T.unpack entryPoint) + mRes <- parseBuildFile cfg n + case mRes of + Left errMsg -> error ("Failed to parse EntryPoint " ++ show n ++ ": " ++ errMsg) Right ep -> - do logInfo $ "Parsed " ++ show n ++ " ..." + do logDebug $ ("Parsed " ++ show n ++ ", 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 @@ -1,32 +1,54 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Cook.BuildFile - ( BuildFileId(..), BuildFile(..), BuildBase(..), DockerCommand(..) + ( BuildFileId(..), BuildFile(..), BuildBase(..), DockerCommand(..), TxRef , dockerCmdToText - , parseBuildFile, parseBuildFileText + , parseBuildFile + , buildTxScripts, copyTarAndUnpack , FilePattern, matchesFilePattern, parseFilePattern + -- don't use - only exported for testing + , parseBuildFileText ) where import Cook.Types +import Cook.Util import Control.Applicative +import Control.Monad import Data.Attoparsec.Text hiding (take) import Data.Char +import Data.Hashable import Data.List (find) +import Data.Maybe +import System.FilePath +import System.IO.Temp +import System.Process (readProcessWithExitCode) +import System.Exit (ExitCode(..)) import qualified Data.Vector as V 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 newtype BuildFileId = BuildFileId { unBuildFileId :: T.Text } deriving (Show, Eq) +newtype TxRef + = TxRef { _unTxRef :: Int } + deriving (Show, Eq, Hashable) + data BuildFile = BuildFile { bf_name :: BuildFileId , bf_base :: BuildBase - , bf_dockerCommands :: V.Vector DockerCommand + , bf_unpackTarget :: Maybe FilePath + , bf_dockerCommands :: V.Vector (Either TxRef DockerCommand) , bf_include :: V.Vector FilePattern + , bf_prepare :: V.Vector T.Text + , bf_transactions :: HM.HashMap TxRef (V.Vector T.Text) } deriving (Show, Eq) data BuildBase @@ -35,9 +57,14 @@ deriving (Show, Eq) data BuildFileLine - = IncludeLine FilePattern - | BaseLine BuildBase - | DockerLine DockerCommand + = IncludeLine FilePattern -- copy files from data directory to temporary cook directory + | BaseLine BuildBase -- use either cook file or docker image as base + | PrepareLine T.Text -- run shell command in temporary cook directory + | UnpackLine FilePath -- where should the context be unpacked to? + | ScriptLine FilePath (Maybe T.Text) -- execute a script in cook directory to generate more cook commands + | BeginTxLine + | CommitTxLine + | DockerLine DockerCommand -- regular docker command deriving (Show, Eq) data DockerCommand @@ -80,21 +107,79 @@ matchesFilePattern (FilePattern xs) fp [] -> True -constructBuildFile :: FilePath -> [BuildFileLine] -> Either String BuildFile -constructBuildFile fp theLines = +buildTxScripts :: FilePath -> BuildFile -> IO (V.Vector DockerCommand, SHA1) +buildTxScripts dockerFileEnvDir bf = + withSystemTempDirectory "cooktx" $ \txDir -> + do txSh <- + forM (HM.toList (bf_transactions bf)) $ \(TxRef refId, actions) -> + do let f = "tx_" ++ show refId ++ ".sh" + sh = mkScript refId actions + T.writeFile (txDir f) sh + 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) + ) + True -> + return (V.map mkTxLine (bf_dockerCommands bf), quickHash ["no-tx"]) + where + mkTxLine l = + case l of + Left (TxRef refId) -> + DockerCommand "RUN" (T.pack $ "bash " ++ (dockerTarDir "tx_" ++ show refId ++ ".sh")) + Right cmd -> cmd + pre = + V.fromList (copyTarAndUnpack "tx.tar.gz" dockerTarDir) + post = + V.fromList + [ DockerCommand "RUN" (T.pack $ "rm -rf " ++ dockerTarDir) + ] + dockerTarDir = "/tmp/dockercooktx" + 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 + ) + +copyTarAndUnpack :: FilePath -> FilePath -> [DockerCommand] +copyTarAndUnpack 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 + ++ " && rm -rf /" ++ tarName + ] + + +constructBuildFile :: FilePath -> FilePath -> [BuildFileLine] -> IO (Either String BuildFile) +constructBuildFile cookDir fp theLines = case baseLine of Just (BaseLine base) -> - baseCheck base $ foldl handleLine (BuildFile myId base V.empty V.empty) theLines + baseCheck base $ handleLine (Right $ BuildFile myId base Nothing V.empty V.empty V.empty HM.empty) Nothing theLines _ -> - Left "Missing BASE line!" + return $ Left "Missing BASE line!" where + checkDocker (DockerCommand cmd _) action = + let lowerCmd = T.toLower cmd + in case lowerCmd of + "from" -> return $ Left "FROM command is not allowed in dockercook files" + "add" -> + do logWarn "ADD commands are not recommended as the dependencies aren't tracked. Use PREPARE!" + action + "copy" -> + do logWarn "COPY commands are not recommended as the dependencies aren't tracked. Use PREPARE!" + action + _ -> action baseCheck base onSuccess = case base of BuildBaseCook cookId -> if cookId == myId - then Left "Recursive BASE line! You are referencing yourself." - else Right onSuccess - _ -> Right onSuccess + then return $ Left "Recursive BASE line! You are referencing yourself." + else onSuccess + _ -> onSuccess myId = BuildFileId (T.pack fp) baseLine = @@ -102,25 +187,81 @@ case l of BaseLine _ -> True _ -> False - handleLine buildFile line = - case line of - (DockerLine dockerCmd) -> - buildFile { bf_dockerCommands = (V.snoc (bf_dockerCommands buildFile) dockerCmd) } - (IncludeLine pattern) -> - buildFile { bf_include = (V.snoc (bf_include buildFile) pattern) } - _ -> buildFile + handleLine mBuildFile _ [] = + return mBuildFile + handleLine mBuildFile inTx (line : rest) = + case mBuildFile of + Left err -> + return $ Left err + Right buildFile -> + case inTx of + Just currentTx -> + case line of + DockerLine dockerCmd -> + checkDocker dockerCmd $ handleLineTx dockerCmd buildFile currentTx rest + ScriptLine scriptLoc mArgs -> + handleScriptLine scriptLoc mArgs buildFile inTx rest + CommitTxLine -> + handleLine (Right buildFile) Nothing rest + _ -> return $ Left "Only RUN and SCRIPT commands are allowed in transactions" + Nothing -> + case line of + ScriptLine scriptLoc mArgs -> + handleScriptLine scriptLoc mArgs buildFile inTx rest + DockerLine dockerCmd -> + checkDocker dockerCmd $ + handleLine (Right $ buildFile { bf_dockerCommands = V.snoc (bf_dockerCommands buildFile) (Right dockerCmd) }) inTx rest + IncludeLine pattern -> + handleLine (Right $ buildFile { bf_include = V.snoc (bf_include buildFile) pattern }) inTx rest + PrepareLine cmd -> + handleLine (Right $ buildFile { bf_prepare = V.snoc (bf_prepare buildFile) cmd }) inTx rest + UnpackLine unpackTarget -> + handleLine (Right $ buildFile { bf_unpackTarget = Just unpackTarget }) inTx rest + BeginTxLine -> + let nextTxId = TxRef (HM.size (bf_transactions buildFile)) + in handleLine (Right $ buildFile { bf_dockerCommands = V.snoc (bf_dockerCommands buildFile) (Left nextTxId) }) + (Just nextTxId) rest + CommitTxLine -> + return $ Left "COMMIT is missing a BEGIN!" + _ -> + handleLine mBuildFile inTx rest + handleScriptLine scriptLoc mArgs buildFile inTx rest = + do let bashCmd = (cookDir scriptLoc) ++ " " ++ T.unpack (fromMaybe "" mArgs) + (ec, stdOut, stdErr) <- + readProcessWithExitCode "bash" ["-c", bashCmd] "" + logDebug ("SCRIPT " ++ bashCmd ++ " returned: \n" ++ stdOut ++ "\n" ++ stdErr) + if ec == ExitSuccess + then case parseOnly pBuildFile (T.pack stdOut) of + Left parseError -> + return $ Left ("Failed to parse output of SCRIPT line " ++ bashCmd + ++ ": " ++ parseError ++ "\nOutput was:\n" ++ stdOut) + Right moreLines -> + handleLine (Right buildFile) inTx (moreLines ++ rest) + else return $ Left ("Failed to run SCRIPT line " ++ bashCmd + ++ ": " ++ stdOut ++ "\n" ++ stdErr) + handleLineTx (DockerCommand cmd args) buildFile txRef rest = + if (T.toLower cmd /= "run") + then return $ Left ("Only RUN commands are allowed in transaction blocks!") + else do let updateF _ oldV = + V.snoc oldV args + buildFile' = + buildFile + { bf_transactions = HM.insertWith updateF txRef (V.singleton args) (bf_transactions buildFile) + } + handleLine (Right buildFile') (Just txRef) rest -parseBuildFile :: FilePath -> IO (Either String BuildFile) -parseBuildFile fp = +parseBuildFile :: CookConfig -> FilePath -> IO (Either String BuildFile) +parseBuildFile cfg fp = do t <- T.readFile fp - return $ parseBuildFileText fp t + parseBuildFileText cfg fp t -parseBuildFileText :: FilePath -> T.Text -> Either String BuildFile -parseBuildFileText fp t = +parseBuildFileText :: CookConfig -> FilePath -> T.Text -> IO (Either String BuildFile) +parseBuildFileText cfg fp t = case parseOnly pBuildFile t of - Left err -> Left err + Left err -> + return $ Left err Right theLines -> - constructBuildFile fp theLines + constructBuildFile (cc_buildFileDir cfg) fp theLines parseFilePattern :: T.Text -> Either String FilePattern parseFilePattern pattern = @@ -132,17 +273,32 @@ pBuildFile :: Parser [BuildFileLine] pBuildFile = - many1 lineP + many1 lineP <* endOfInput where finish = - (optional pComment) *> ((() <$ many endOfLine) <|> endOfInput) + pComment *> ((() <$ many endOfLine) <|> endOfInput) lineP = (many (pComment <* endOfLine)) *> lineP' lineP' = IncludeLine <$> (pIncludeLine <* finish) <|> BaseLine <$> (pBuildBase <* finish) <|> + PrepareLine <$> (pPrepareLine <* finish) <|> + UnpackLine <$> (pUnpackLine <* finish) <|> + (pScriptLine <* finish) <|> + BeginTxLine <$ (pBeginTx <* finish) <|> + CommitTxLine <$ (pCommitTx <* finish) <|> DockerLine <$> (pDockerCommand <* finish) +pBeginTx :: Parser () +pBeginTx = asciiCI "BEGIN" *> skipSpace + +pCommitTx :: Parser () +pCommitTx = asciiCI "COMMIT" *> skipSpace + +pUnpackLine :: Parser FilePath +pUnpackLine = + T.unpack <$> ((asciiCI "UNPACK" *> skipSpace) *> takeWhile1 isValidFileNameChar) + pBuildBase :: Parser BuildBase pBuildBase = (asciiCI "BASE" *> skipSpace) *> pBase @@ -162,11 +318,20 @@ pComment :: Parser () pComment = - (skipSpace *> char '#' *> skipSpace) *> (skipWhile (not . isEndOfLine)) + skipSpace <* optional (char '#' *> skipWhile (not . isEndOfLine)) pIncludeLine :: Parser FilePattern pIncludeLine = (asciiCI "INCLUDE" *> skipSpace) *> pFilePattern + +pScriptLine :: Parser BuildFileLine +pScriptLine = + ScriptLine <$> (T.unpack <$> ((asciiCI "SCRIPT" *> skipSpace) *> (takeWhile1 isValidFileNameChar))) + <*> (optional $ T.stripEnd <$> takeWhile1 (not . eolOrComment)) + +pPrepareLine :: Parser T.Text +pPrepareLine = + (asciiCI "PREPARE" *> skipSpace) *> takeWhile1 (not . eolOrComment) pFilePattern :: Parser FilePattern pFilePattern = diff --git a/src/lib/Cook/Clean.hs b/src/lib/Cook/Clean.hs deleted file mode 100644 --- a/src/lib/Cook/Clean.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DoAndIfThenElse #-} -module Cook.Clean (cookClean) where - -import Cook.State.Manager -import Cook.State.Model -import Cook.Types -import Cook.Util - -import Data.Time.Clock -import System.Exit -import System.Process -import qualified Data.Text as T - -cookClean :: FilePath -> Int -> IO () -cookClean stateDir daysToKeep = - do stateManager <- createStateManager stateDir - now <- getCurrentTime - let cleanUpPred imageMeta = - now `diffUTCTime` (dbDockerImageLastUsed imageMeta) > (fromIntegral $ daysToKeep * 24 * 60 * 60) - dockerRm (DockerImage imageName) = - do logInfo $ "Deleting image " ++ show imageName - (ec, _, stdErr) <- - readProcessWithExitCode "docker" ["rmi", T.unpack imageName] "" - if (ec /= ExitSuccess) - then do logInfo $ "Error: " ++ stdErr - return False - else return True - - _ <- garbageCollectImages stateManager cleanUpPred dockerRm - return () diff --git a/src/lib/Cook/Docker.hs b/src/lib/Cook/Docker.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/Docker.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse #-} +module Cook.Docker + ( DockerImagesCache, newDockerImagesCache + , dockerReachable, doesImageExist + , getImageId, tagImage + ) +where + +import Cook.Types +import Cook.Util + +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) } + +getImageId :: DockerImage -> IO (Maybe DockerImageId) +getImageId (DockerImage 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] "" + if ec /= ExitSuccess + then fail $ "Failed to tag image " ++ show imageId + else return () + +dockerReachable :: IO Bool +dockerReachable = + do (ec, _, _) <- readProcessWithExitCode "docker" ["ps"] "" + return $ ec == ExitSuccess + +newDockerImagesCache :: IO DockerImagesCache +newDockerImagesCache = + DockerImagesCache <$> newTVarIO Nothing + +doesImageExist :: DockerImagesCache -> Either DockerImage DockerImageId -> IO Bool +doesImageExist (DockerImagesCache cacheVar) eImage = + do mOut <- atomically $ readTVar cacheVar + (ec, imageText) <- + case mOut of + Just textOut -> + do logDebug "Using cached docker images for doesImageExist" + return (ExitSuccess, textOut) + Nothing -> + do logDebug "Using live docker images for doesImageExist" + (ecL, stdOut, _) <- readProcessWithExitCode "docker" ["images"] "" + let textOut = T.pack stdOut + atomically $ writeTVar cacheVar (Just textOut) + return (ecL, textOut) + let imageLines = T.lines imageText + return $ ec == ExitSuccess && checkLines imageName imageLines + where + imageName = + case eImage of + Left (DockerImage n) -> n + Right (DockerImageId n) -> n + checkLines _ [] = False + checkLines im (line:xs) = + let (imageBaseName, vers) = T.break (==':') im + in if T.isPrefixOf imageBaseName line + then if vers == "" + then True + else if T.isInfixOf (T.drop 1 vers) line + then True + else checkLines im xs + else checkLines im xs 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 @@ -4,10 +4,12 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DoAndIfThenElse #-} module Cook.State.Manager - ( StateManager + ( StateManager, HashManager(..) , createStateManager, markUsingImage - , isImageKnown - , garbageCollectImages + , isImageKnown, fastFileHash + , syncImages, waitForWrites + , getImageId, setImageId + , _STATE_DIR_NAME_, findStateDirectory ) where @@ -16,218 +18,249 @@ import Cook.Types import Control.Applicative +import Control.Concurrent import Control.Concurrent.STM -import Control.Monad.Logger hiding (logInfo) +import Control.Exception +import Control.Monad +import Control.Monad.Logger hiding (logInfo, logDebug, logError, logWarn) import Control.Monad.State import Control.Monad.Trans.Resource +import Control.Retry import Data.Maybe -import Data.SafeCopy (safeGet, safePut) -import Data.Serialize.Get (runGet) -import Data.Serialize.Put (runPut) import Data.Time.Clock +import Data.Time.Clock.POSIX import Database.Persist.Sqlite import System.Directory import System.FilePath -import qualified Data.ByteString as BS +import System.Posix.Files import qualified Data.HashMap.Strict as HM -import qualified Data.Graph as G -import qualified Data.Graph.NodeManager as NM -import qualified Data.Graph.Persistence as GP import qualified Data.Text as T -import qualified Data.Traversable as T -import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector as V data StateManager = StateManager - { sm_runSql :: forall a. SqlPersistM a -> IO a - , sm_graph :: TVar G.Graph - , sm_nodeManager :: TVar (NM.NodeManager DockerImage) - , sm_persistGraph :: IO () + { sm_runSqlGet :: forall a. SqlPersistM a -> IO a + , sm_runSqlWrite :: SqlPersistM () -> IO () + , sm_databaseFile :: FilePath + , sm_waitForWrites :: IO () } -createStateManager :: FilePath -> IO StateManager +data HashManager + = HashManager + { hm_lookup :: forall m. MonadIO m => FilePath -> m SHA1 -> m SHA1 + , hm_didFileChange :: forall m. MonadIO m => FilePath -> m Bool + } + +fastFileHash :: forall m. MonadIO m => HashManager -> FilePath -> m SHA1 -> m SHA1 +fastFileHash hm = hm_lookup hm + +_STATE_DIR_NAME_ = ".kitchen" + +findStateDirectory :: IO FilePath +findStateDirectory = + do currentDir <- getCurrentDirectory + checkLoop currentDir + where + checkLoop parentDir = + do logDebug $ "Looking for a " ++ _STATE_DIR_NAME_ ++ " directory in " ++ parentDir + isThere <- doesDirectoryExist (parentDir _STATE_DIR_NAME_) + if isThere + then return (parentDir _STATE_DIR_NAME_) + else do when (normalise parentDir == "/" || normalise parentDir == "") $ + fail "Can't find my kitchen! Did you run dockercook init?" + checkLoop (normalise $ takeDirectory parentDir) + +waitForWrites :: StateManager -> IO () +waitForWrites st = + sm_waitForWrites st + +createStateManager :: FilePath -> IO (StateManager, HashManager) createStateManager stateDirectory = - do pool <- createSqlitePool (T.pack sqlLoc) 5 - let runSql = runResourceT . runNoLoggingT . ((flip runSqlPool) pool) + do logDebug $ "Creating state manager with directory " ++ stateDirectory + 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) -> + fail $ "Sqlite-Transaction finally failed: " ++ show e runSql (runMigration migrateState) - exists <- doesFileExist graphFile - (g, nm) <- - case exists of - True -> - do bs <- BS.readFile graphFile - case runGet safeGet bs of - Left errMsg -> - error ("Failed to read " ++ graphFile ++ ": " ++ errMsg) - Right persistedGraph -> - let (lnm, lg) = GP.loadGraph persistedGraph - in (,) <$> newTVarIO lg <*> newTVarIO lnm - False -> - (,) <$> newTVarIO G.empty <*> newTVarIO NM.emptyNodeManager - return $ StateManager - { sm_runSql = runSql - , sm_graph = g - , sm_nodeManager = nm - , sm_persistGraph = persistGraph g nm - } + sqlQueue <- newTBQueueIO 100 + allHashes <- runSql $ selectList [] [] + logDebug $ "Initializing hash manager" + let hashMap = + foldl (\hm entity -> + let v = entityVal entity + in HM.insert (dbHashCacheFullPath v) (dbHashCacheMtime v, SHA1 $ dbHashCacheHash v) hm + ) HM.empty allHashes + hashMapV <- newTVarIO hashMap + hashWriteChan <- newTBQueueIO 1000 + workV <- newTVarIO False + let waitWrites = + atomically $ + do emptyQ <- isEmptyTBQueue sqlQueue + unless emptyQ $ retry + stateMgr = + StateManager + { sm_runSqlGet = + \action -> + do liftIO waitWrites + runSql action + , sm_runSqlWrite = + \writeReq -> + atomically $ writeTBQueue sqlQueue writeReq + , sm_databaseFile = stateDirectory "database.db" + , sm_waitForWrites = + do waitForHashes workV hashWriteChan + waitWrites + } + _ <- forkIO (hashManagerPersistWorker stateMgr workV hashWriteChan) + _ <- forkIO (queueWorker runSql sqlQueue) + let hashMgr = + HashManager + { hm_lookup = hashManagerLookup stateMgr hashMapV hashWriteChan + , hm_didFileChange = didFileChange stateMgr hashMapV + } + return (stateMgr, hashMgr) where sqlLoc = stateDirectory "database.db" - graphFile = stateDirectory "graph.bin" - persistGraph gVar nmVar = - do nm <- atomically $ readTVar nmVar - g <- atomically $ readTVar gVar - BS.writeFile graphFile $ runPut (safePut $ GP.persistGraph nm g) - -data GCState - = GCState - { gc_canTrash :: !(HM.HashMap NM.Node (Bool, DockerImage)) - , gc_trashCount :: !Int - , gc_cache :: !(HM.HashMap DockerImage DbDockerImage) - } deriving (Show) + queueWorker runSql queue = + do action <- atomically $ readTBQueue queue + _ <- runSql action + queueWorker runSql queue -data SweepState - = SweepState - { ss_graph :: !(G.Graph) - , ss_removedImages :: [DockerImage] - } deriving (Show) +waitForHashes :: TVar Bool -> TBQueue DbHashCache -> IO () +waitForHashes workEnqueuedVar hashWriteChan = + atomically $ + do queueEmpty <- isEmptyTBQueue hashWriteChan + workEnqueued <- readTVar workEnqueuedVar + when ((not queueEmpty) || workEnqueued) retry -garbageCollectImages :: StateManager - -> (DbDockerImage -> Bool) - -> (DockerImage -> IO Bool) - -> IO [DockerImage] -garbageCollectImages (StateManager{..}) deletePred deleteFun = - do graph <- atomically $ readTVar sm_graph - nodeManager <- atomically $ readTVar sm_nodeManager - let graphLeafs = filter (\n -> VU.null $ G.parents graph n) (G.nodes graph) - logInfo ("Found " ++ (show (length graphLeafs)) ++ " toplevel image(s). Starting mark and sweep") - gcState <- execStateT (mapM (markNode graph nodeManager) graphLeafs) (GCState HM.empty 0 HM.empty) - logInfo ("Found " ++ (show (gc_trashCount gcState)) ++ " deletable image(s).") - sweepState <- execStateT (sweepNodes gcState nodeManager graphLeafs) (SweepState graph []) - return (reverse $ ss_removedImages sweepState) +hashManagerPersistWorker :: StateManager -> TVar Bool -> TBQueue DbHashCache -> IO () +hashManagerPersistWorker (StateManager{..}) workEnqueuedVar hashWriteChan = + do batchV <- newTVarIO V.empty + _ <- forkIO (batchBuilder batchV) + loop batchV where - sweepNodes :: GCState -> NM.NodeManager DockerImage -> [NM.Node] -> StateT SweepState IO () - sweepNodes gcState nodeManager [] = - do currentGraph <- gets ss_graph - alreadyRemoved <- gets ss_removedImages - let nextLeafs = - filter (\n -> - let isLeaf = VU.null $ G.parents currentGraph n - trashable = - case HM.lookup n (gc_canTrash gcState) of - Just (True, imageName) -> - not $ imageName `elem` alreadyRemoved - _ -> False - in isLeaf && trashable - ) (G.nodes currentGraph) - if length nextLeafs == 0 - then return () - else sweepNodes gcState nodeManager nextLeafs - sweepNodes gcState nodeManager (node:rest) = - do currentGraph <- gets ss_graph - case HM.lookup node (gc_canTrash gcState) of - Just (True, imageName) -> - do let g' = G.removeNode node currentGraph - nm' = NM.removeNodeHandle node nodeManager - liftIO $ - do deleteOk <- deleteFun imageName - when (not deleteOk) $ - error ("Failed to delete " ++ (T.unpack $ unDockerImage imageName) ++ ". Aborting!") - atomically $ - do writeTVar sm_nodeManager nm' - writeTVar sm_graph g' - sm_persistGraph - sm_runSql $ deleteBy (UniqueGraphNodeId node) - modify $ \st -> - st - { ss_graph = g' - , ss_removedImages = (imageName : ss_removedImages st) - } - sweepNodes gcState nm' rest - _ -> - sweepNodes gcState nodeManager rest + batchBuilder :: TVar (V.Vector DbHashCache) -> IO () + batchBuilder batchV = + do writeOp <- + atomically $ + do writeTVar workEnqueuedVar True + readTBQueue hashWriteChan + atomically $ modifyTVar' batchV (\v -> V.snoc v writeOp) + batchBuilder batchV + loop :: TVar (V.Vector DbHashCache) -> IO () + loop batchV = + do logDebug $ "Waiting for next hash batch to arrive" + writeBatch <- + atomically $ + do v <- readTVar batchV + when (V.null v) retry + writeTVar batchV V.empty + return v + let sqlAction = + sm_runSqlWrite $ + do let xs = V.toList writeBatch + mapM_ (\oldHash -> deleteWhere [DbHashCacheFullPath ==. oldHash]) (map dbHashCacheFullPath xs) + _ <- insertMany xs + logDebug $ "Stored " ++ (show $ V.length writeBatch) ++ " hashes" + return () + logDebug $ "Storing " ++ (show $ V.length writeBatch) ++ " hashes in database." + atomically $ writeTVar workEnqueuedVar False + sqlAction `catch` \(e :: SomeException) -> + do logError $ "Hash persist error: " ++ show e + atomically $ + do modifyTVar' batchV (\newV -> V.concat [writeBatch, newV]) + writeTVar workEnqueuedVar True + threadDelay 1000000 -- 1 sec + loop batchV - markNode :: G.Graph -> NM.NodeManager DockerImage -> NM.Node -> StateT GCState IO Bool - markNode graph nodeManager node = - do let dockerImage = - case NM.lookupNode node nodeManager of - Nothing -> - error ("dockercook inconsistency: found node in image graph without any dockerimage!") - Just d -> d - children = G.children graph node - trashCheck (Just False) _ = return (Just False) - trashCheck x [] = return x - trashCheck _ (x:xs) = - do trashState <- gets gc_canTrash - r <- - case HM.lookup x trashState of - Nothing -> markNode graph nodeManager x - Just (v, _) -> return v - trashCheck (Just r) xs - markAs x = - do modify $ \s -> - s { gc_canTrash = HM.insert node (x, dockerImage) (gc_canTrash s) - , gc_trashCount = (if x then 1 else 0) + (gc_trashCount s) - } - return x - mCanTrash <- trashCheck Nothing $ VU.toList children - case mCanTrash of - Just False -> - markAs False - _ -> - do cacheMap <- gets gc_cache - dbInfo <- - case HM.lookup dockerImage cacheMap of - Nothing -> - do mDbInfo <- liftIO $ sm_runSql $ getBy (UniqueGraphNodeId node) - case mDbInfo of - Nothing -> - error ("dockercook inconsistency: found node in image graph without any meta data!") - Just someInfo -> - do let e = entityVal someInfo - modify $ \s -> - s { gc_cache = HM.insert dockerImage e (gc_cache s) } - return e - Just info -> - return info - markAs $ deletePred dbInfo +didFileChange :: MonadIO m + => StateManager + -> TVar (HM.HashMap FilePath (UTCTime, SHA1)) + -> FilePath + -> m Bool +didFileChange (StateManager{..}) hashMapV fullFilePath = + liftIO $ + do fileExists <- doesFileExist fullFilePath + if not fileExists + then return True + else do currModTime <- getModTime fullFilePath + mEntry <- liftIO $ atomically $ HM.lookup fullFilePath <$> readTVar hashMapV + case mEntry of + Nothing -> + return True + Just (oldMtime, _) -> + return (oldMtime /= currModTime) +getModTime :: FilePath -> IO UTCTime +getModTime fullFilePath = + do stat <- liftIO $ getFileStatus fullFilePath + return $ (\t -> posixSecondsToUTCTime (realToFrac t :: POSIXTime)) $ modificationTime stat + +hashManagerLookup :: MonadIO m + => StateManager + -> TVar (HM.HashMap FilePath (UTCTime, SHA1)) + -> TBQueue DbHashCache + -> FilePath + -> m SHA1 + -> m SHA1 +hashManagerLookup (StateManager{..}) hashMapV hashWriteChan fullFilePath computeHash = + do modTime <- liftIO $ getModTime fullFilePath + mEntry <- liftIO $ atomically $ HM.lookup fullFilePath <$> readTVar hashMapV + let recomputeHash = + do newHash <- computeHash + liftIO $ atomically $ + do modifyTVar' hashMapV (HM.insert fullFilePath (modTime, newHash)) + writeTBQueue hashWriteChan (DbHashCache fullFilePath modTime (unSha1 newHash)) + return newHash + case mEntry of + Just (mtime, oldHash) -> + if mtime == modTime + then return oldHash + else recomputeHash + Nothing -> + recomputeHash + +syncImages :: StateManager -> (DockerImage -> IO Bool) -> IO () +syncImages (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) + sm_waitForWrites + isImageKnown :: StateManager -> DockerImage -> IO Bool isImageKnown (StateManager{..}) (DockerImage imageName) = - do x <- sm_runSql $ getBy (UniqueDbDockerImage imageName) + do x <- sm_runSqlGet $ getBy (UniqueDbDockerImage imageName) return (isJust x) -markUsingImage :: StateManager -> DockerImage -> Maybe DockerImage -> IO () -markUsingImage (StateManager{..}) img@(DockerImage imageName) mParentImage = - do parentEntity <- - T.mapM (sm_runSql . findParentImage) mParentImage - mImageEntity <- sm_runSql $ getBy (UniqueDbDockerImage imageName) +getImageId :: StateManager -> DockerImage -> IO (Maybe DockerImageId) +getImageId (StateManager{..}) (DockerImage imageName) = + do x <- sm_runSqlGet $ getBy (UniqueDbDockerImage imageName) + case x of + Nothing -> return Nothing + Just entity -> + return $ fmap DockerImageId (dbDockerImageRawImageId $ entityVal entity) + +setImageId :: StateManager -> DockerImage -> DockerImageId -> IO () +setImageId (StateManager{..}) (DockerImage imageName) (DockerImageId imageId) = + sm_runSqlWrite $ updateWhere [ DbDockerImageName ==. imageName ] [ DbDockerImageRawImageId =. (Just imageId) ] + +markUsingImage :: StateManager -> DockerImage -> IO () +markUsingImage (StateManager{..}) (DockerImage imageName) = + do mImageEntity <- sm_runSqlGet $ getBy (UniqueDbDockerImage imageName) now <- getCurrentTime case mImageEntity of Nothing -> - do newNodeId <- - atomically $ - do nm <- readTVar sm_nodeManager - (nodeId, newNm) <- - runStateT (NM.getNodeHandle img) nm - writeTVar sm_nodeManager newNm - modifyTVar sm_graph $ \g -> - case parentEntity of - Nothing -> - G.addNode nodeId g - Just pe -> - G.addEdge nodeId (dbDockerImageNodeId $ entityVal pe) g - return nodeId - _ <- sm_runSql $ insert $ DbDockerImage imageName now now 1 newNodeId - sm_persistGraph + sm_runSqlWrite $ + do _ <- insert $ DbDockerImage imageName Nothing now now 1 return () Just imageEntity -> - sm_runSql $ update (entityKey imageEntity) [ DbDockerImageUsageCount +=. 1 - , DbDockerImageLastUsed =. now - ] - where - findParentImage (DockerImage parentImageName) = - do mParentEntity <- getBy (UniqueDbDockerImage parentImageName) - case mParentEntity of - Just entity -> return entity - Nothing -> - error ("dockercook inconsistency: parent image " - ++ show parentImageName ++ " referenced but unknown to database.") + sm_runSqlGet $ update (entityKey imageEntity) [ DbDockerImageUsageCount +=. 1 + , DbDockerImageLastUsed =. now + ] diff --git a/src/lib/Cook/State/Model.hs b/src/lib/Cook/State/Model.hs --- a/src/lib/Cook/State/Model.hs +++ b/src/lib/Cook/State/Model.hs @@ -5,20 +5,28 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Cook.State.Model where import Data.Time.Clock import Database.Persist.TH import qualified Data.Text as T +import qualified Data.ByteString as BS share [mkPersist sqlSettings, mkMigrate "migrateState"] [persistLowerCase| DbDockerImage name T.Text + rawImageId T.Text Maybe creationDate UTCTime lastUsed UTCTime usageCount Int - nodeId Int UniqueDbDockerImage name - UniqueGraphNodeId nodeId + deriving Show +DbHashCache + fullPath FilePath + mtime UTCTime + hash BS.ByteString + UniqueHashCacheEntry fullPath mtime deriving Show |] diff --git a/src/lib/Cook/Sync.hs b/src/lib/Cook/Sync.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/Sync.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DoAndIfThenElse #-} +module Cook.Sync where + +import Cook.Util +import Cook.State.Manager +import qualified Cook.Docker as D + +import System.Directory + +runSync :: FilePath -> IO () +runSync stateDir = + do createDirectoryIfMissing True stateDir + reachable <- D.dockerReachable + if reachable + then do logInfo "Sync started, please wait..." + (stateManager, _) <- createStateManager stateDir + imCache <- D.newDockerImagesCache + syncImages stateManager (\v -> D.doesImageExist imCache (Left v)) + logInfo "Sync complete." + else logError "Docker daemon not reachable!" 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 @@ -2,19 +2,39 @@ module Cook.Types where import Data.Hashable -import Data.SafeCopy import qualified Data.ByteString as BS import qualified Data.Text as T data CookConfig = CookConfig - { cc_stateDir :: FilePath - , cc_dataDir :: FilePath + { cc_dataDir :: FilePath , cc_buildFileDir :: 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 + | EWOWarning T.Text + | EWOOk + newtype StreamHook = StreamHook { unStreamHook :: BS.ByteString -> IO () } @@ -24,4 +44,8 @@ newtype DockerImage = DockerImage { unDockerImage :: T.Text } - deriving (Show, Eq, Hashable, SafeCopy) + deriving (Show, Eq, Hashable) + +newtype DockerImageId + = DockerImageId { unDockerImageId :: T.Text } + deriving (Show, Eq, Hashable) diff --git a/src/lib/Cook/Uploader.hs b/src/lib/Cook/Uploader.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/Uploader.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DoAndIfThenElse #-} +module Cook.Uploader + ( Uploader + , mkUploader + , killUploader + , enqueueImage + , waitForCompletion + ) +where + +import Cook.Types +import Cook.Util + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Data.Maybe +import System.Process +import System.Exit +import qualified Data.Text as T + +data Uploader + = Uploader + { _u_threadId :: ThreadId + , _u_queue :: TBQueue DockerImage + , _u_task :: TVar (Maybe DockerImage) + } + +mkUploader :: Int -> IO Uploader +mkUploader queueSize = + do q <- newTBQueueIO queueSize + v <- newTVarIO Nothing + tid <- forkIO (uploader q v) + return (Uploader tid q v) + +enqueueImage :: Uploader -> DockerImage -> IO () +enqueueImage (Uploader _ queue _) im = + atomically $ writeTBQueue queue im + +killUploader :: Uploader -> IO [DockerImage] +killUploader (Uploader tid queue taskV) = + do (queueVals, currentTask) <- + atomically $ ((,) <$> readAll <*> readTVar taskV) + killThread tid + return $ queueVals ++ (maybeToList currentTask) + where + readAll :: STM [DockerImage] + readAll = + do qr <- tryReadTBQueue queue + case qr of + Just val -> + do more <- readAll + return (val : more) + Nothing -> + return [] + +waitForCompletion :: Uploader -> IO () +waitForCompletion (Uploader _ q v) = + atomically $ + do isEmpty <- isEmptyTBQueue q + mTask <- readTVar v + when ((not isEmpty) || (isJust mTask)) $ retry + +uploadImage :: DockerImage -> IO (Either String ()) +uploadImage (DockerImage imName') = + do let imName = T.unpack imName' + logInfo ("Pushing " ++ imName ++ " to the registry") + (ec, stdOut, stdErr) <- + readProcessWithExitCode "docker" + ["push" + , imName] "" + if ec == ExitSuccess + then return $ Right () + else return $ Left ("Failed to upload " ++ imName + ++ "\n" + ++ stdOut + ++ "\n" + ++ stdErr + ) + +uploader :: TBQueue DockerImage -> TVar (Maybe DockerImage) -> IO () +uploader q v = + do nextImage <- + atomically $ + do t <- readTBQueue q + writeTVar v (Just t) + return t + uploadStatus <- uploadImage nextImage + atomically $ writeTVar v Nothing + case uploadStatus of + Left err -> logWarn (err ++ "\n Uploader quit.") + Right _ -> + do atomically $ writeTVar v Nothing + uploader q v 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 @@ -1,32 +1,60 @@ module Cook.Util where -import Data.Conduit -import Data.Conduit.Process +import Cook.Types + +import Control.Monad import Control.Monad.Trans import System.Exit -import System.IO (hPutStrLn, stderr) +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 qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC +quickHash :: [BS.ByteString] -> SHA1 +quickHash bsList = + SHA1 $ SHA1.finalize (SHA1.updates SHA1.init bsList) + +concatHash :: [SHA1] -> SHA1 +concatHash sha1List = quickHash $ map unSha1 sha1List + +initLoggingFramework :: Priority -> IO () +initLoggingFramework prio = + do myStreamHandler <- streamHandler stdout prio + let myStreamHandler' = setFormatter myStreamHandler (simpleLogFormatter "[$prio $time $loggername] $msg") + root <- getRootLogger + saveGlobalLogger (setLevel DEBUG $ setHandlers [myStreamHandler'] root) + logInfo :: MonadIO m => String -> m () -logInfo = liftIO . hPutStrLn stderr +logInfo = liftIO . infoM "cook" logDebug :: MonadIO m => String -> m () -logDebug _ = return () +logDebug = liftIO . debugM "cook" -systemStream :: String -> (BS.ByteString -> IO ()) -> IO ExitCode -systemStream cmd onOutput = - do onOutput (BSC.pack $ "$> " ++ cmd ++ "\n") - (ec, _) <- sourceCmdWithConsumer cmd conduitRead - onOutput (BSC.pack $ "ExitCode: " ++ show ec ++ "\n") - return ec +logWarn :: MonadIO m => String -> m () +logWarn = liftIO . warningM "cook" + +logError :: MonadIO m => String -> m () +logError = liftIO . errorM "cook" + +systemStream :: Maybe FilePath -> String -> (BS.ByteString -> IO ()) -> IO ExitCode +systemStream mDir cmd _onOutput = + let realCmd = + case mDir of + Just dir -> "(cd " ++ dir ++ "; " ++ cmd ++ ")" + Nothing -> cmd + in do logDebug ("$ " ++ realCmd) + system realCmd + +compressFilesInDir :: FilePath -> FilePath -> [FilePath] -> IO () +compressFilesInDir tarName dirFp files = + do ecTar <- rawSystem tarCmd tarArgs + unless (ecTar == ExitSuccess) $ + fail ("Error creating tar:\n" ++ tarCmd ++ " " ++ unwords tarArgs) where - conduitRead = - do mBS <- await - case mBS of - Just bs -> - do liftIO $ onOutput bs - conduitRead - Nothing -> - return () + 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,25 +5,69 @@ data CookCmd = CookBuild CookConfig - | CookClean FilePath Int - | CookList + | CookParse FilePath + | CookSync + | CookVersion + | CookInit deriving (Show, Eq) -cookKeepDaysP = - option ( long "keep" <> short 'k' <> metavar "DAYS" <> help "Days of docker images to keep") +cookFileP = + strOption $ + long "file" <> + short 'f' <> + metavar "FILE" <> + value "FILE" <> + help "File to parse" -cookStateP = - strOption ( long "state" <> short 's' <> metavar "DIRECTORY" <> help "Directory where dockercook stores its meta info") +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" <> help "Directory where to find source files") + strOption $ + long "data" <> + short 'd' <> + metavar "DIRECTORY" <> + value "." <> + help "Directory where to find INCLUDED files" cookBuildP = - strOption ( long "buildfiles" <> short 'b' <> metavar "DIRECTORY" <> help "Directory of dockercook files") + strOption $ + long "buildfiles" <> + short 'b' <> + metavar "DIRECTORY" <> + value "." <> + help "Directory of dockercook files" -cookEntryPointP = - some $ strOption ( long "entrypoint" <> short 'p' <> metavar "ENTRYPOINT" <> help "dockercook targets") +cookEntryPointP_deprecated = + strOption $ + long "entrypoint" <> + short 'p' <> + metavar "COOKFILE" <> + help "Cookfile to be built" + +cookFileDropP :: Parser Int +cookFileDropP = + option auto $ + long "cookfile-drop-chars" <> + value 0 <> + metavar "COUNT" <> + help "drop this number of characters from each cook filename for tagging" + +cookVerboseP :: Parser Int +cookVerboseP = + option auto $ + long "verbosity" <> + short 'v' <> + metavar "INT" <> + value 2 <> + help "log levels for 0 - 3" + cookBoringP = optional $ strOption ( long "ignore" <> short 'i' <> metavar "FILENAME" <> help "File with regex list of ignored files." ) @@ -31,24 +75,33 @@ cookOptions :: Parser CookCmd cookOptions = CookBuild <$> - (CookConfig <$> cookStateP - <*> cookDataP + (CookConfig <$> cookDataP <*> cookBuildP <*> cookBoringP - <*> cookEntryPointP) + <*> 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")))) -cookClean :: Parser CookCmd -cookClean = - CookClean <$> cookStateP <*> cookKeepDaysP +cookSync :: Parser CookCmd +cookSync = pure CookSync -cookHelp :: Parser CookCmd -cookHelp = - pure CookList +cookParse :: Parser CookCmd +cookParse = + CookParse <$> cookFileP -argParse :: Parser CookCmd +argParse :: Parser (Int, CookCmd) argParse = + (,) <$> cookVerboseP <*> argParse' + +argParse' :: Parser CookCmd +argParse' = subparser ( command "cook" (info cookOptions ( progDesc "Cook docker images" )) - <> command "clean" (info cookClean ( progDesc "Cleanup docker images that are no longer needed" )) - <> command "help" (info cookHelp ( progDesc "List cook commands" )) + <> command "check" (info cookParse ( progDesc "Validate a Dockercook file" )) + <> command "sync" (info cookSync ( progDesc "Sync local state with remote docker server" )) + <> command "version" (info (pure CookVersion) ( progDesc "Show programs version" )) + <> command "init" (info (pure CookInit) ( progDesc "Enable dockercook for current project / directory" )) ) diff --git a/src/prog/Main.hs b/src/prog/Main.hs --- a/src/prog/Main.hs +++ b/src/prog/Main.hs @@ -1,23 +1,72 @@ module Main where +import Paths_dockercook (version) +import Data.Version (showVersion) + import Cook.ArgParse import Cook.Build -import Cook.Clean +import Cook.Sync +import Cook.Types +import Cook.Uploader +import Cook.Util +import Cook.State.Manager + +import Control.Monad import Options.Applicative +import System.Exit +import System.Log +import System.Directory +import System.Process -runProg :: CookCmd -> IO () -runProg cmd = +runProg :: (Int, CookCmd) -> IO () +runProg (verb, cmd) = + do initLoggingFramework logLevel + ec <- system "command -v docker >/dev/null 2>&1" + case ec of + ExitSuccess -> + runProg' cmd + ExitFailure _ -> + error "dockercook requires docker. Install from http://docker.com" + where + logLevel = + case verb of + 0 -> ERROR + 1 -> WARNING + 2 -> INFO + 3 -> DEBUG + _ -> error "Invalid verbosity! Pick 0-3" + +runProg' :: CookCmd -> IO () +runProg' cmd = case cmd of CookBuild buildCfg -> - do _ <- cookBuild buildCfg Nothing + do uploader <- mkUploader 100 + stateDir <- findStateDirectory + _ <- cookBuild stateDir buildCfg uploader Nothing + when (cc_autoPush buildCfg) $ + do logInfo $ "Waiting for all images to finish beeing pushed" + waitForCompletion uploader + missingImages <- killUploader uploader + unless (null missingImages) $ + logError "Uploader confirmed completion but still had images in the pipeline!" return () - CookClean stateDir daysToKeep -> - cookClean stateDir daysToKeep - CookList -> - do putStrLn "Available commands:" - putStrLn "- cook" - putStrLn "- clean" + CookSync -> + do stateDir <- findStateDirectory + runSync stateDir + CookParse file -> + cookParse file + CookVersion -> + putStrLn ("dockercook " ++ showVersion version) + CookInit -> + do createDirectoryIfMissing True _STATE_DIR_NAME_ + _ <- createStateManager _STATE_DIR_NAME_ + putStrLn "My kitchen is ready for cooking!" main :: IO () main = - execParser (info argParse idm) >>= runProg + execParser opts >>= runProg + where + opts = info (helper <*> argParse) + ( fullDesc + <> progDesc "Speed up docker image building" + ) 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 @@ -4,10 +4,12 @@ import Cook.BuildFile import Cook.Types +import Paths_dockercook import Test.Framework import qualified Data.Vector as V import qualified Data.Text as T +import qualified Data.Text.IO as T test_matchFilePattern :: IO () test_matchFilePattern = @@ -23,23 +25,32 @@ Right pattern2 = parseFilePattern "foo/*.cabal" Right pattern3 = parseFilePattern "foo/*" +readDataFile :: String -> IO T.Text +readDataFile name = + do fp <- getDataFileName name + T.readFile fp + test_parseBuildFile :: IO () test_parseBuildFile = - do assertEqual (BuildBaseDocker $ DockerImage "ubuntu:14.04") (bf_base parsed1) + 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 + sampleFile5 <- readDataFile "test1.cook" + parsed5 <- parseBuildFileText dummyCfg "test1.cook" sampleFile5 >>= assertRight + assertEqual (BuildBaseDocker $ DockerImage "ubuntu:14.04") (bf_base parsed1) assertEqual parsed1 parsed2 assertEqual (BuildBaseCook $ BuildFileId "foo.build") (bf_base parsed3) assertEqual commands (bf_dockerCommands parsed3) assertEqual parsed3 parsed4 + assertEqual 10 (V.length (bf_include parsed5)) + assertEqual (Just "/DociData") (bf_unpackTarget parsed5) where commands = - V.fromList [ DockerCommand "RUN" "apt-get -y install node" - , DockerCommand "ADD" ". /foo" + V.fromList [ Right $ DockerCommand "RUN" "apt-get -y install node" + , Right $ DockerCommand "ADD" ". /foo" ] - Right parsed1 = parseBuildFileText "sample1" sampleFile1 - Right parsed2 = parseBuildFileText "sample1" sampleFile2 - Right parsed3 = parseBuildFileText "sample3" sampleFile3 - Right parsed4 = parseBuildFileText "sample3" sampleFile4 - sampleFile1 = "BASE DOCKER ubuntu:14.04" sampleFile2 =