dockercook 0.1.2.1 → 0.4.0.0

raw patch · 15 files changed

+1196/−446 lines, 15 filesdep +hsloggerdep +retrydep +streaming-commonsdep −cerealdep −graph-coredep −safecopydep ~HTFdep ~attoparsecdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: hslogger, retry, streaming-commons, unix

Dependencies removed: cereal, graph-core, safecopy

Dependency ranges changed: HTF, attoparsec, base, base16-bytestring, bytestring, conduit, conduit-combinators, conduit-extra, cryptohash, directory, filepath, hashable, monad-logger, mtl, optparse-applicative, persistent-sqlite, persistent-template, process, regex-compat, resourcet, stm, system-filepath, temporary, text, time, transformers, unordered-containers, vector

API changes (from Hackage documentation)

Files

• data/test1.cook +32/−0
• dockercook.cabal +61/−41
• src/lib/Cook/Build.hs +260/−92
• src/lib/Cook/BuildFile.hs +195/−30
• src/lib/Cook/Clean.hs +0/−31
• src/lib/Cook/Docker.hs +75/−0
• src/lib/Cook/State/Manager.hs +218/−185
• src/lib/Cook/State/Model.hs +10/−2
• src/lib/Cook/Sync.hs +20/−0
• src/lib/Cook/Types.hs +28/−4
• src/lib/Cook/Uploader.hs +95/−0
• src/lib/Cook/Util.hs +48/−20
• src/prog/Cook/ArgParse.hs +75/−22
• src/prog/Main.hs +60/−11
• src/test/Tests/BuildFile.hs +19/−8

@@ -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

@@ -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 <thiemann@cp-med.com>+maintainer:          Alexander Thiemann <thiemann@cp-med.com> 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

@@ -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

@@ -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 =

@@ -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 ()

@@ -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

@@ -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+                                                           ]

@@ -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 |]

@@ -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!"

@@ -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)

@@ -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

@@ -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

@@ -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" ))     )

@@ -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"+             )

@@ -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 =