diff --git a/dockercook.cabal b/dockercook.cabal --- a/dockercook.cabal +++ b/dockercook.cabal @@ -1,5 +1,5 @@ name: dockercook -version: 0.1.1.0 +version: 0.1.2.0 synopsis: A build tool for multiple docker image layers description: Build and manage multiple docker image layers to speed up deployment license: MIT 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 @@ -18,7 +18,7 @@ import System.Directory import System.Exit import System.FilePath -import System.IO (hPutStr, hPutStrLn, stderr) +import System.IO (hPutStr, hPutStrLn, hFlush, stderr) import System.IO.Temp import System.Process import Text.Regex (mkRegex, matchRegex) @@ -68,19 +68,19 @@ liftIO $ hPutStr stderr "." return $ Just (relToCurrentF, quickHash bs) -buildImage :: CookConfig -> StateManager -> [(FP.FilePath, SHA1)] -> BuildFile -> IO DockerImage -buildImage cfg@(CookConfig{..}) stateManager fileHashes bf = +buildImage :: Maybe StreamHook -> CookConfig -> StateManager -> [(FP.FilePath, SHA1)] -> BuildFile -> IO DockerImage +buildImage mStreamHook cfg@(CookConfig{..}) stateManager fileHashes bf = do baseImage <- case bf_base bf of (BuildBaseCook parentBuildFile) -> do parent <- prepareEntryPoint cc_buildFileDir parentBuildFile - buildImage cfg stateManager fileHashes parent + buildImage mStreamHook cfg stateManager fileHashes parent (BuildBaseDocker rootImage) -> do baseExists <- dockerImageExists rootImage if baseExists then do markUsingImage stateManager rootImage Nothing return rootImage - else do logInfo $ "Downloading the root image " ++ show (unDockerImage rootImage) ++ "... " + else do logInfo' $ "Downloading the root image " ++ show (unDockerImage rootImage) ++ "... " (ec, stdOut, _) <- readProcessWithExitCode "docker" ["pull", T.unpack $ unDockerImage rootImage] "" if ec == ExitSuccess @@ -99,23 +99,38 @@ buildFileHash = quickHash [BSC.pack (show bf)] superHash = B16.encode $ unSha1 $ quickHash (map unSha1 (dockerHash : buildFileHash : allFHashes)) imageName = DockerImage $ T.concat ["cook-", T.decodeUtf8 superHash] - logInfo $ "Image name will be " ++ (T.unpack $ unDockerImage imageName) + logInfo $ "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) imageExists <- dockerImageExists imageName if imageExists - then do logInfo "The image already exists!" + then do logInfo' "The image already exists!" markImage return imageName - else do logInfo "Image not found!" + else do logInfo' "Image not found!" x <- launchImageBuilder dockerBS imageName markImage return x where + logInfo' m = + do logInfo m + case mStreamHook of + Nothing -> return () + Just (StreamHook hook) -> hook (BSC.pack (m ++ "\n")) + streamHook bs = + do hPutStr stderr (BSC.unpack bs) + hFlush stderr + case mStreamHook of + Nothing -> return () + Just (StreamHook hook) -> hook bs dockerImageExists localIm@(DockerImage imageName) = - do logInfo $ "Checking if the image " ++ show imageName ++ " is already present... " + do logInfo' $ "Checking if the image " ++ show imageName ++ " is already present... " known <- isImageKnown stateManager localIm if known - then do logInfo $ "Image " ++ show imageName ++ " is registered in your state directory. Assuming it is present!" + then do logInfo' $ "Image " ++ show imageName ++ " is registered in your state directory. Assuming it is present!" return True else do (ec, stdOut, _) <- readProcessWithExitCode "docker" ["images"] "" let imageLines = T.lines $ T.pack stdOut @@ -144,16 +159,16 @@ putStrLn ("cp " ++ copySrc ++ " " ++ targetSrc) copyFile copySrc targetSrc ) targetedFiles - logInfo "Writing Dockerfile ..." + logInfo' "Writing Dockerfile ..." BS.writeFile (tempDir "Dockerfile") dockerBS - logInfo ("Building docker container...") + logInfo' ("Building docker container...") let tag = T.unpack $ unDockerImage imageName - ecDocker <- system $ "docker build --rm -t " ++ tag ++ " " ++ tempDir + ecDocker <- systemStream ("docker build --rm -t " ++ tag ++ " " ++ tempDir) streamHook if ecDocker == ExitSuccess then return imageName else do hPutStrLn stderr ("Failed to build " ++ tag ++ "!") hPutStrLn stderr ("Saving temp directory to COOKFAILED.") - _ <- system $ "rm -rf COOKFAILED; cp -r " ++ tempDir ++ " COOKFAILED" + _ <- systemStream ("rm -rf COOKFAILED; cp -r " ++ tempDir ++ " COOKFAILED") streamHook exitWith ecDocker localName fp = case FP.stripPrefix (FP.decodeString $ fixTailingSlash cc_dataDir) fp of @@ -164,14 +179,14 @@ targetedFiles = filter (\(fp, _) -> isNeededHash fp) fileHashes -cookBuild :: CookConfig -> IO [DockerImage] -cookBuild cfg@(CookConfig{..}) = +cookBuild :: CookConfig -> Maybe StreamHook -> IO [DockerImage] +cookBuild cfg@(CookConfig{..}) mStreamHook = do stateManager <- createStateManager cc_stateDir boring <- liftM (fromMaybe []) $ T.mapM (liftM parseBoring . T.readFile) cc_boringFile fileHashes <- makeDirectoryFileHashTable (isBoring boring) cc_dataDir roots <- mapM ((prepareEntryPoint cc_buildFileDir) . BuildFileId . T.pack) cc_buildEntryPoints - res <- mapM (buildImage cfg stateManager fileHashes) roots + res <- mapM (buildImage mStreamHook cfg stateManager fileHashes) roots logInfo "All done!" return res where 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 @@ -15,6 +15,9 @@ , cc_buildEntryPoints :: [String] } deriving (Show, Eq) +newtype StreamHook = + StreamHook { unStreamHook :: BS.ByteString -> IO () } + newtype SHA1 = SHA1 { unSha1 :: BS.ByteString } deriving (Show, Eq) 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,10 +1,29 @@ module Cook.Util where +import Data.Conduit +import Data.Conduit.Process import Control.Monad.Trans +import System.Exit import System.IO (hPutStrLn, stderr) +import qualified Data.ByteString as BS + logInfo :: MonadIO m => String -> m () logInfo = liftIO . hPutStrLn stderr logDebug :: MonadIO m => String -> m () logDebug _ = return () + +systemStream :: String -> (BS.ByteString -> IO ()) -> IO ExitCode +systemStream cmd onOutput = + do (ec, _) <- sourceCmdWithConsumer cmd conduitRead + return ec + where + conduitRead = + do mBS <- await + case mBS of + Just bs -> + do liftIO $ onOutput bs + conduitRead + Nothing -> + return () diff --git a/src/prog/Main.hs b/src/prog/Main.hs --- a/src/prog/Main.hs +++ b/src/prog/Main.hs @@ -9,7 +9,7 @@ runProg cmd = case cmd of CookBuild buildCfg -> - do _ <- cookBuild buildCfg + do _ <- cookBuild buildCfg Nothing return () CookClean stateDir daysToKeep -> cookClean stateDir daysToKeep