diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -82,8 +82,13 @@ This utility has two modes, `Build` and `Cache`. Both modes should be invoked for the cache to work: ```bash +# APP_NAME ispassed as argument in the build process, you can use it as an env var in your Dockerfile export APP_NAME=fancyapp + +# GIT_BRANCH is used as part of the named for the resulting cached image export GIT_BRANCH=master + +# DOCKER_TAG corresponds to the -t argument in docker build, that will be the resulting image name export DOCKER_TAG=fancyapp:latest docker-build-cacher build # This will build the docker file @@ -99,6 +104,28 @@ At the end of the process you can call `docker images` and see that it has created `fancyapp:latest`, and if you are using multi-stage builds, it should have created an image tag for each of the stages in your Dockerfile + +### Fallback Cache Keys + + +As mentioned before the `GIT_BRANCH` env variable is used as part of the name for the generated cached image, this means that +the generated cache is scope to that name. This is done so you can keep different caches where you can experiment with widly +different requirements and libraries in the dockerfile. + +This has the unfortunate side effect that building other branches will require building the cache from scratch. In order to solve this +you can use the `FALLBACK_BRANCH` environment variable like this: + +```bash +export APP_NAME=fancyapp +export GIT_BRANCH=my-feature +export FALLBACK_BRANCH=master +export DOCKER_TAG=fancyapp:latest + +docker-build-cacher build +docker-build-cacher cache +``` + +The above will make the cached image for the `my-feature` branch to be based on the one from the `master` branch. ## How It Works diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,12 +1,3 @@ -#!/usr/bin/env stack -{- stack - runghc - --resolver lts-10.2 - --install-ghc - --package turtle - --package language-dockerfile - --package containers --} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} @@ -21,8 +12,10 @@ import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.Text as Text import Data.Text (Text) +import qualified Data.Text.Lazy as LT import Filesystem.Path (FilePath) -import Language.Docker hiding (Tag, workdir) +import Language.Docker hiding (workdir) +import Language.Docker.Syntax (Tag(..)) import Prelude hiding (FilePath) import Text.ParserCombinators.ReadP import Text.Read @@ -48,28 +41,42 @@ data CachedImage = CachedImage -newtype Tag a = - Tag Text +newtype ImageName a = + ImageName Text deriving (Show, Eq) newtype BuildOptions = BuildOptions Text deriving (Show) +newtype CacheLabels = + CacheLabels [(Text, Text)] + deriving (Show) + -- | A Stage is one of the FROM directives ina dockerfile -- data Stage a = Stage - { stageName :: Text -- The image name - , stageTag :: Tag a -- The image tag - , stagePos :: Linenumber -- Where in the docker file this line is found - , stageAlias :: Text -- The alias in the FROM instruction - , buildTag :: Tag a - , directives :: Dockerfile -- Dockerfile is an alias for [InstructionPos] + { stageName :: !Text -- ^ The image name, for example ubuntu in "ubuntu:16" + , stageTag :: !Text -- ^ The image tag, for example latest in "python:latest" + , stageImageName :: !(ImageName a) -- ^ The name of the docker image to generate a separate cache for + -- this is pretty much the "template" image to use for 'buildImageName' + -- + , stageFallbackImage :: !(Maybe (ImageName a)) -- ^ If the stageImageName does not exist, then we can try building + -- from another template, usually the one from the master branch + -- + , stagePos :: !Linenumber -- ^ Where in the docker file this line is found + , stageAlias :: !Text -- ^ The alias in the FROM instruction, for example "builder" in "FROM ubuntu:16.10 AS builder" + , buildImageName :: !(ImageName a) -- ^ The resulting image image, after caching all assets + , directives :: !Dockerfile -- ^ Dockerfile is an alias for [InstructionPos] } deriving (Show, Eq) -data InspectedStage +newtype NotInspectedCache = + NotInspectedCache StageCache + +data StageCache = NotCached (Stage SourceImage) -- When the image has not yet been built separetely - | CacheNotInspected (Stage SourceImage) -- When the image is cached but not yet inspected + | FallbackCache (Stage SourceImage) -- When the cache was not present but we looked at a falback key + StageCache -- The fallback cache | Cached { stage :: Stage CachedImage -- When the image was built and tagged as a separate image , cacheBusters :: [(SourcePath, TargetPath)] -- List of files that are able to bust the cache } @@ -92,7 +99,7 @@ , ("cache", Cache) ] where - strValMap = map (\(x, y) -> lift $ string x >> return y) + strValMap = map (\(flag, result) -> lift $ string flag >> return result) data Args = Args { mode :: Mode @@ -117,6 +124,7 @@ options "Builds a docker file and caches its stages" parser -- Parse the CLI arguments as a Mode app <- App <$> needEnv "APP_NAME" -- Get the APP environment variable and then wrap it in App branch <- Branch <$> needEnv "GIT_BRANCH" + fallbackBranch <- fmap Branch <$> need "FALLBACK_BRANCH" maybeFile <- do file <- need "DOCKERFILE" -- Get the dockerfile path if any return (fmap fromText file) -- And transform it to a FilePath @@ -134,9 +142,9 @@ Cache -> if noCacheStages then echo "Skipping... I was told not to cache any stages separetely" - else sh (cacheBuild app branch ast) + else sh (cacheBuild app branch fallbackBranch ast) Build -> do - tag <- Tag <$> needEnv "DOCKER_TAG" + name <- ImageName <$> needEnv "DOCKER_TAG" buildOPtions <- do opts <- need "DOCKER_BUILD_OPTIONS" if noBuildCache @@ -144,31 +152,42 @@ Just (opts & fromMaybe "" & (<> " --no-cache") & BuildOptions) -- Append the docker --no-cache option else return (fmap BuildOptions opts) if noCacheStages - then sh (build app tag buildOPtions ast) - else sh (buildFromCache app branch tag buildOPtions ast) + then sh (build app name buildOPtions ast) + else sh (buildFromCache app branch fallbackBranch name buildOPtions ast) -- | Builds the provided Dockerfile. If it is a multi-stage build, check if those stages are already cached -- and change the dockerfile to take advantage of that. -buildFromCache :: App -> Branch -> Tag SourceImage -> Maybe BuildOptions -> Dockerfile -> Shell () -buildFromCache app branch tag buildOptions ast = do - changedStages <- getChangedStages app branch ast -- Inspect the dockerfile and return - -- the stages that got their cache invalidated. We need - -- them to rewrite the docker file and replace the stages - -- with the ones we have in local cache. - let bustedStages = replaceStages (mapMaybe alreadyCached changedStages) ast -- We replace the busted stages +buildFromCache :: + App + -> Branch + -> Maybe Branch + -> ImageName SourceImage + -> Maybe BuildOptions + -> Dockerfile + -> Shell () +buildFromCache app branch fallbackBranch imageName buildOptions ast = do + changedStages <- getChangedStages app branch fallbackBranch ast -- Inspect the dockerfile and return + -- the stages that got their cache invalidated. We need + -- them to rewrite the docker file and replace the stages + -- with the ones we have in local cache. + let cachedStages = replaceStages (mapMaybe alreadyCached changedStages) ast -- We replace the busted stages -- with cached primed ones - build app tag buildOptions bustedStages + build app imageName buildOptions cachedStages where - alreadyCached (CacheInvalidated stage) = Just stage -- We only want to replace stages where the cache + alreadyCached :: StageCache -> Maybe (Stage CachedImage) + alreadyCached (CacheInvalidated stage) = Just stage -- We want to replace stages where the cache -- was invalidated by any file changes. alreadyCached (Cached stage _) = Just stage -- Likewise, once we have a cached stage, we need to keep using it -- in succesive builds, so the cache is not invalidated again. + alreadyCached (FallbackCache _ (CacheInvalidated stage)) = Just stage -- Finally, if we are using a fallback, we apply + -- the same rules as above for the fallback key + alreadyCached (FallbackCache _ (Cached stage _)) = Just stage alreadyCached _ = Nothing -build :: App -> Tag SourceImage -> Maybe BuildOptions -> Dockerfile -> Shell () -build app tag buildOptions ast = do +build :: App -> ImageName SourceImage -> Maybe BuildOptions -> Dockerfile -> Shell () +build app imageName buildOptions ast = do echo "I'll start building now the main Dockerfile" - status <- buildDockerfile app tag buildOptions ast -- Build the main docker file + status <- buildDockerfile app imageName buildOptions ast -- Build the main docker file -- which may already have been rewritten to use the -- cached stages. case status of @@ -177,37 +196,38 @@ "I built the main dockerfile without a problem. Now call this same script with the `Cache` mode" ExitFailure _ -> die "Boo, I could not build the project" --- | One a dockefile is built, we can extrac each of the stages separately and then tag them, so the cache +-- | One a dockefile is built, we can extract each of the stages separately and then tag them, so the cache -- can be retreived at a later point. -cacheBuild :: App -> Branch -> Dockerfile -> Shell () -cacheBuild app branch ast = do - inspectedStages <- getChangedStages app branch ast -- Compare the current dockerfile with whatever we have - -- in the cache. If there are any chages, then we will need - -- to rebuild the cache for each of the changed stages. - let stagesToBuildFresh = [s | NotCached s <- inspectedStages] - let stagesToReBuild = [s | CacheInvalidated s <- inspectedStages] +cacheBuild :: App -> Branch -> Maybe Branch -> Dockerfile -> Shell () +cacheBuild app branch fallbackBranch ast = do + inspectedStages <- getChangedStages app branch fallbackBranch ast -- Compare the current dockerfile with whatever we have + -- in the cache. If there are any chages, then we will need + -- to rebuild the cache for each of the changed stages. + let stagesToBuildFresh = [stage | NotCached stage <- inspectedStages] + let stagesToReBuild = [stage | CacheInvalidated stage <- inspectedStages] + let stagesToBuildFromFallback = + [(uncached, cached) | FallbackCache uncached (Cached cached _) <- inspectedStages] when (stagesToBuildFresh /= []) $ do echo "--> Let's build the cache for the first time" mapM_ (buildAssetStage app) stagesToBuildFresh -- Build cached images for the first time + when (stagesToBuildFromFallback /= []) $ do + echo "--> Let's build the cache for the first time using a fallback" + mapM_ (uncurry (reBuildFromFallback app)) stagesToBuildFromFallback when (stagesToReBuild /= []) $ do - echo "--> Let's make the cache great again" + echo "--> Let's re-build the cache for stages that changed" mapM_ (reBuildAssetStage app) stagesToReBuild -- Build each of the stages so they can be reused later -- | Returns a list of stages which needs to either be built separately or that did not have their cached busted -- by the introduction of new code. -getChangedStages :: App -> Branch -> Dockerfile -> Shell [InspectedStage] -getChangedStages app branch ast = do - let mainFile = last (getStages ast) -- Parse all the FROM instructions in the dockerfile and only - -- keep the last FROM, which is the main stage. Anything before that - -- is considered a cacheable stage. - assetStages = takeWhile (/= mainFile) (getStages ast) -- Filter out the main FROM at the end and only - -- keep the contents of the file before that instruction. - stages = mapMaybe (toStage app branch) assetStages -- For each the for found stages, before the main - -- FROM instruction, convert them to Stage records +getChangedStages :: App -> Branch -> Maybe Branch -> Dockerfile -> Shell [StageCache] +getChangedStages app branch fallbackBranch ast = do + let assetStages = init (getStages ast) -- Filter out the main FROM at the end and only + -- keep the contents of the file before that instruction. + stages = mapMaybe (toStage app branch fallbackBranch) assetStages -- For each the for found stages, before the main + -- FROM instruction, convert them to Stage records when (length assetStages > length stages) showAliasesWarning fold (getAlreadyCached stages >>= -- Find the stages that we already have in local cache - inspectCache >>= -- Gather information to determine whether or not the cache was invalidated shouldBustCache -- Determine whether or not the cache was invalidated ) Fold.list @@ -220,34 +240,55 @@ echo "" echo "Please always write your FROM directives as `FROM image:tag as myalias`" --- | Check whehther or not the tag exists for each of the passed stages +-- | Check whehther or not the imageName exists for each of the passed stages -- and return only those that already exist. -getAlreadyCached :: [Stage SourceImage] -> Shell InspectedStage +getAlreadyCached :: [Stage SourceImage] -> Shell StageCache getAlreadyCached stages = do echo "--> I'm checking whether or not the stage exists as a docker image already" - stage@Stage {buildTag} <- select stages -- foreach stages as stage - let Tag tag = buildTag -- Get the raw text value for the build tag - printLn ("----> Looking for image " %s) tag - existent <- - fold - (inproc "docker" ["image", "ls", tag, "--format", "{{.Repository}}"] empty) - Fold.list -- Get the output of the command as a list of lines - if existent == mempty + stage@Stage {buildImageName, stageFallbackImage} <- select stages -- foreach stages as stage + exists <- cacheKeyExists stage buildImageName + if exists then do - echo "------> It does not exist, so I will need to build it myself later" - return (NotCached stage) - else do echo "------> It already exists, so I will then check if the cache files changed" - return (CacheNotInspected stage) + inspectCache stage + else do + echo "------> It does not exist, so I will need to build it myself later" + maybe (return (NotCached stage)) (getFallbackCache stage) stageFallbackImage + where + cacheKeyExists stage (ImageName imageName) = do + printLn ("----> Looking for image " %s) imageName + existent <- + fold + (inproc "docker" ["image", "ls", imageName, "--format", "{{.Repository}}"] empty) + Fold.list -- Get the output of the command as a list of lines + if existent == mempty + then return False + -- For the cache to be valid, we need to make sure that the stored image is based on the same + -- base image and tag. Otherwise we will need to rebuild the cache anyway + else imageAndTagMatches (ImageName (stageName stage)) (Tag (stageTag stage)) imageName + -- + -- + getFallbackCache stage fallbackName = do + exists <- cacheKeyExists stage fallbackName + if exists + then do + echo "------> The fallback image exists, using it to build the initial cache" + cachedStage <- + inspectCache + (stage {stageImageName = fallbackName, buildImageName = fallbackName}) + return (FallbackCache stage cachedStage) + else do + echo "------> There is not fallback cache image" + return (NotCached stage) -- | This will inspect how an image was build and extrack the ONBUILD directives. If any of those -- instructions are copying or adding files to the build, they are considered "cache busters". -inspectCache :: InspectedStage -> Shell InspectedStage -inspectCache (CacheNotInspected sourceStage@Stage {..}) = do - history <- imageHistory buildTag +inspectCache :: Stage SourceImage -> Shell StageCache +inspectCache sourceStage@Stage {..} = do + history <- imageHistory buildImageName let onBuildLines = extractOnBuild history workdir = extractWorkdir history - parsedDirectivesWithErrors = fmap (parseString . Text.unpack) onBuildLines -- Parse each of the lines + parsedDirectivesWithErrors = fmap parseText onBuildLines -- Parse each of the lines parsedDirectives = (getFirst . rights) parsedDirectivesWithErrors -- We only keep the good lines cacheBusters = extractCachePaths workdir parsedDirectives return $ Cached (toCachedStage sourceStage) cacheBusters @@ -258,8 +299,8 @@ -- -- | Prepend a given target dir to the target path prependWorkdir workdir (source, TargetPath target) = - let dest = fromString target - prependedDest = Text.unpack . format fp $ collapse (workdir dest) + let dest = fromText target + prependedDest = format fp (collapse (workdir dest)) in if relative dest -- If the target path is relative, we need to prepend the workdir then (source, TargetPath prependedDest) -- Remove the ./ prefix and prepend workdir else (source, TargetPath target) @@ -274,24 +315,24 @@ doExtract _ = Nothing getFirst (first:_) = first getFirst [] = [] --- In any other case return the same inspected stage -inspectCache c@(NotCached _) = return c -inspectCache c@(Cached _ _) = return c -inspectCache c@(CacheInvalidated _) = return c toCachedStage :: Stage SourceImage -> Stage CachedImage toCachedStage Stage {..} = let stage = Stage {..} - Tag sTag = stageTag - Tag bTag = buildTag - in stage {stageTag = Tag sTag, buildTag = Tag bTag} + ImageName sImageName = stageImageName + ImageName bImageName = buildImageName + in stage + { stageImageName = ImageName sImageName + , stageFallbackImage = Nothing + , buildImageName = ImageName bImageName + } -- | Here check each of the cache buster from the image and compare them with those we have locally, -- if the files do not match, then we return the stage back as a result, otherwise return Nothing. -shouldBustCache :: InspectedStage -> Shell InspectedStage +shouldBustCache :: StageCache -> Shell StageCache shouldBustCache cached@Cached {..} = do printLn ("----> Checking cache buster files for stage " %s) (stageName stage) - withContainer (buildTag stage) checkFiles -- Create a container to inspect the files + withContainer (buildImageName stage) checkFiles -- Create a container to inspect the files where checkFiles containerId = do hasChanged <- fold (mfilter isJust (checkFileChanged containerId cacheBusters)) Fold.head @@ -307,8 +348,8 @@ -- | checkFileChanged containerId files = do (SourcePath src, TargetPath dest) <- select files - let file = fromText $ Text.pack src - let targetDir = fromText $ Text.pack dest + let file = fromText src + let targetDir = fromText dest printLn ("------> Checking file '" %fp % "' in directory " %fp) file targetDir currentDirectory <- pwd tempFile <- mktempfile currentDirectory "comp" @@ -325,15 +366,15 @@ then return Nothing else return (Just file) -- In any other case return the same inspected stage -shouldBustCache c@(NotCached _) = return c -shouldBustCache c@(CacheNotInspected _) = return c -shouldBustCache c@(CacheInvalidated _) = return c +shouldBustCache c@NotCached {} = return c +shouldBustCache c@CacheInvalidated {} = return c +shouldBustCache c@FallbackCache {} = return c -- | Creates a container from a stage and passes the container id to the -- given shell as an argument -withContainer :: Tag a -> (Text -> Shell b) -> Shell b -withContainer (Tag tag) action = do - containerId <- inproc "docker" ["create", tag] empty +withContainer :: ImageName a -> (Text -> Shell b) -> Shell b +withContainer (ImageName imageName) action = do + containerId <- inproc "docker" ["create", imageName] empty result <- fold (action (format l containerId)) Fold.list _ <- removeContainer containerId -- Ignore the return code of this command select result -- yield each result as a separate line @@ -349,8 +390,13 @@ ("\n--> Building asset stage " %s % " at line " %d % " for the first time") stageName stagePos - let filteredDirectives = filter isFrom directives - doStageBuild app stageTag buildTag filteredDirectives + let fromInstruction = filter isFrom directives + cacheLabels = [("cached_image", stageName <> ":" <> stageTag)] + newDockerfile = + toDockerfile $ do + embed fromInstruction + label cacheLabels + doStageBuild app stageImageName buildImageName (CacheLabels cacheLabels) newDockerfile where isFrom (InstructionPos (From _) _ _) = True isFrom _ = False @@ -361,44 +407,71 @@ reBuildAssetStage :: App -> Stage CachedImage -> Shell () reBuildAssetStage app Stage {..} = do printLn ("\n--> Rebuilding asset stage " %s % " at line " %d) stageName stagePos - let fromInstruction = + let cacheLabels = [("cached_image", stageName <> ":" <> stageTag)] + newDockerfile = toDockerfile $ do - let Tag t = buildTag + let ImageName t = stageImageName from $ toImage t `tagged` "latest" -- Use the cached image as base for the new one - doStageBuild app stageTag buildTag fromInstruction + label cacheLabels + doStageBuild app stageImageName buildImageName (CacheLabels cacheLabels) newDockerfile -doStageBuild :: App -> Tag a -> Tag b -> Dockerfile -> Shell () -doStageBuild app sourceTag targetTag directives = do - status <- buildDockerfile app sourceTag Nothing directives -- Only build the FROM +reBuildFromFallback :: App -> Stage SourceImage -> Stage CachedImage -> Shell () +reBuildFromFallback app uncached cached = do + let cacheLabels = [("cached_image", stageName uncached <> ":" <> stageTag uncached)] + newDockerfile = + toDockerfile $ do + let ImageName t = buildImageName cached + from $ toImage t `tagged` "latest" -- Use the cached image as base for the new one + label cacheLabels + doStageBuild + app + (stageImageName uncached) + (buildImageName uncached) + (CacheLabels cacheLabels) + newDockerfile + +doStageBuild :: App -> ImageName a -> ImageName b -> CacheLabels -> Dockerfile -> Shell () +doStageBuild app sourceImageName targetImageName cacheLabels directives = do + status <- buildDockerfile app sourceImageName Nothing directives -- Only build the FROM guard (status == ExitSuccess) -- Break if previous command failed - history <- imageHistory sourceTag -- Get the commands used to build the docker image - newDockerfile <- createDockerfile sourceTag (extractOnBuild history) -- Append the ONBUILD lines to the new file - finalStatus <- buildDockerfile app targetTag Nothing newDockerfile -- Now build it + history <- imageHistory sourceImageName -- Get the commands used to build the docker image + newDockerfile <- createDockerfile sourceImageName cacheLabels (extractOnBuild history) -- Append the ONBUILD lines to the new file + finalStatus <- buildDockerfile app targetImageName Nothing newDockerfile -- Now build it guard (finalStatus == ExitSuccess) -- Stop here if previous command failed echo "" echo "--> I have tagged a cache container that I can use next time to speed builds!" -- | Simply call docker build for the passed arguments -buildDockerfile :: App -> Tag a -> Maybe BuildOptions -> Dockerfile -> Shell ExitCode -buildDockerfile (App app) (Tag tag) buildOPtions directives = do +buildDockerfile :: App -> ImageName a -> Maybe BuildOptions -> Dockerfile -> Shell ExitCode +buildDockerfile (App app) (ImageName imageName) buildOPtions directives = do currentDirectory <- pwd tmpFile <- mktempfile currentDirectory "Dockerfile." let BuildOptions opts = fromMaybe (BuildOptions "") buildOPtions let allBuildOptions = - ["build", "--build-arg", "APP_NAME=" <> app, "-f", format fp tmpFile, "-t", tag, "."] <> + [ "build" + , "--build-arg" + , "APP_NAME=" <> app + , "-f" + , format fp tmpFile + , "-t" + , imageName + , "." + ] <> [opts] - liftIO (writeTextFile tmpFile (Text.pack (prettyPrint directives))) -- Put the Dockerfile contents in the tmp file + liftIO (writeTextFile tmpFile (LT.toStrict (prettyPrint directives))) -- Put the Dockerfile contents in the tmp file shell ("docker " <> Text.intercalate " " allBuildOptions) empty -- Build the generated dockerfile --- | Given a list of instructions, build a dockerfile where the tag is the FROM for the file and +-- | Given a list of instructions, build a dockerfile where the imageName is the FROM for the file and -- the list of instructions are wrapped with ONBUILD -createDockerfile :: Tag a -> [Text] -> Shell Dockerfile -createDockerfile (Tag tag) onBuildLines = do - let eitherDirectives = map (parseString . Text.unpack) onBuildLines +createDockerfile :: ImageName a -> CacheLabels -> [Text] -> Shell Dockerfile +createDockerfile (ImageName imageName) (CacheLabels cacheLabels) onBuildLines = do + let eitherDirectives = map parseText onBuildLines + validDirectives = rights eitherDirectives -- Just in case, filter out bad directives file = toDockerfile $ do - from $ toImage tag `tagged` "latest" - mapM (onBuildRaw . toInstruction) (rights eitherDirectives) -- Append each of the ONBUILD instructions + from $ toImage imageName `tagged` "latest" + label cacheLabels + mapM (onBuildRaw . toInstruction) validDirectives -- Append each of the ONBUILD instructions return file where toInstruction [InstructionPos inst _ _] = inst @@ -406,7 +479,7 @@ -- | Extracts the list of instructions appearing in ONBUILD for a given docker history for a tag extractOnBuild :: [Line] -> [Text] -extractOnBuild lines = doExtract lines +extractOnBuild = doExtract where onBuildPrefix = "/bin/sh -c #(nop) ONBUILD " -- @@ -419,6 +492,22 @@ findOnBuildLines = takeWhile isOnBuild . dropWhile (not . isOnBuild) isOnBuild line = Text.isPrefixOf onBuildPrefix (lineToText line) +-- | Extracts the label from the cached image passed in the last argument and checks +-- if it matches the passeed image name and tag name. This is used to avoid using a +-- cached image tht was built using a different base iamge +imageAndTagMatches :: ImageName Text -> Tag -> Text -> Shell Bool +imageAndTagMatches (ImageName imageName) (Tag tagName) cachedImage = do + printLn ("------> Checking the stored cached key in a label for " %s) cachedImage + value <- fold getCacheLabel Fold.head -- Get the only line + let expected = unsafeTextToLine (imageName <> ":" <> tagName) + return (Just expected == value) + where + getCacheLabel = + inproc + "docker" + ["inspect", "--format", "{{ index .Config.Labels \"cached_image\"}}", cachedImage] + empty + extractWorkdir :: [Line] -> FilePath extractWorkdir instructions = case reverse (doExtract instructions) of @@ -437,14 +526,14 @@ isOnBuild line = Text.isPrefixOf onBuildPrefix (lineToText line) -- | Calls docker history for the given image name and returns the output as a list -imageHistory :: Tag a -> Shell [Line] -imageHistory (Tag tag) = do - printLn ("----> Checking the docker image history for " %s) tag +imageHistory :: ImageName a -> Shell [Line] +imageHistory (ImageName name) = do + printLn ("----> Checking the docker image history for " %s) name out <- fold fetchHistory Fold.list -- Buffer all the output of the imageHistory shell return (reverse out) -- The history comes in reverse order, sort it naturally where fetchHistory = - inproc "docker" ["history", "--no-trunc", "--format", "{{.CreatedBy}}", tag] empty + inproc "docker" ["history", "--no-trunc", "--format", "{{.CreatedBy}}", name] empty -- -- | Returns a list of directives grouped by the appeareance of the FROM directive @@ -462,50 +551,39 @@ startsWithFROM _ = False -- | Converts a list of instructions into a Stage record -toStage :: App -> Branch -> Dockerfile -> Maybe (Stage a) -toStage (App app) (Branch branch) directives = do - (stageName, stagePos, stageAlias) <- extractInfo directives -- If getStageInfo returns Nothing, skip the rest - let sanitized = sanitize stageName - tagName = app <> "__branch__" <> branch <> "__stage__" <> sanitized - stageTag = Tag tagName - buildTag = Tag (tagName <> "-build") +toStage :: App -> Branch -> Maybe Branch -> Dockerfile -> Maybe (Stage a) +toStage (App app) branch fallback directives = do + (stageName, stageTag, stagePos, stageAlias) <- extractInfo directives -- If getStageInfo returns Nothing, skip the rest + let newImageName (Branch branchName) = + app <> "__branch__" <> branchName <> "__stage__" <> sanitize stageName + stageImageName = ImageName (newImageName branch) + buildImageName = ImageName (newImageName branch <> "-build") + stageFallbackImage = fmap (\br -> ImageName (newImageName br <> "-build")) fallback return Stage {..} where - extractInfo :: Dockerfile -> Maybe (Text, Linenumber, Text) + extractInfo :: Dockerfile -> Maybe (Text, Text, Linenumber, Text) extractInfo (InstructionPos {instruction, lineNumber}:_) = getStageInfo instruction lineNumber extractInfo _ = Nothing - getStageInfo :: Instruction -> Linenumber -> Maybe (Text, Linenumber, Text) - getStageInfo (From (TaggedImage Image {imageName} _ (Just (ImageAlias alias)))) pos = - Just (Text.pack imageName, pos, Text.pack alias) + getStageInfo :: Instruction Text -> Linenumber -> Maybe (Text, Text, Linenumber, Text) + getStageInfo (From (TaggedImage Image {imageName} (Tag tag) (Just (ImageAlias alias)))) pos = + Just (imageName, tag, pos, alias) getStageInfo (From (UntaggedImage Image {imageName} (Just (ImageAlias alias)))) pos = - Just (Text.pack imageName, pos, Text.pack alias) - getStageInfo (From (DigestedImage Image {imageName} _ (Just (ImageAlias alias)))) pos = - Just (Text.pack imageName, pos, Text.pack alias) + Just (imageName, "latest", pos, alias) + getStageInfo (From (DigestedImage Image {imageName} tag (Just (ImageAlias alias)))) pos = + Just (imageName, tag, pos, alias) getStageInfo _ _ = Nothing -- -- | Makes a string safe to use it as a file name sanitize = Text.replace "/" "-" . Text.replace ":" "-" --- | Extracts the stage alias out of the FROM directive -parseAlias :: String -> Text -parseAlias = - Text.strip . - Text.replace "as " "" . -- Remove the alias - snd . - Text.breakOn " as " . -- Split by the alias name and get the second in the tuple - Text.replace " AS " " as " . -- Normalize AS with as - Text.pack - -- | Given a list of stages and the AST for a Dockerfile, replace all the FROM instructions -- with their corresponding images as described in the Stage record. replaceStages :: [Stage CachedImage] -> Dockerfile -> Dockerfile -replaceStages stages dockerLines = - fmap - (\InstructionPos {..} -> InstructionPos {instruction = replaceStage instruction, ..}) - dockerLines +replaceStages stages = + fmap (\InstructionPos {..} -> InstructionPos {instruction = replaceStage instruction, ..}) where stagesMap = Map.fromList (map createStagePairs stages) - createStagePairs stage@(Stage {..}) = (stageAlias, stage) + createStagePairs stage@Stage {..} = (stageAlias, stage) -- -- | Find whehter or not we have extracted a stage with the same alias -- If we did, then replace the FROM directive with our own version @@ -517,17 +595,20 @@ replaceKnownAlias directive imageAlias replaceStage directive = directive replaceKnownAlias directive imageAlias = - case Map.lookup (Text.pack imageAlias) stagesMap of + case Map.lookup imageAlias stagesMap of Nothing -> directive - Just Stage {buildTag, stageAlias} -> - let Tag t = buildTag + Just Stage {buildImageName, stageAlias} -> + let ImageName t = buildImageName in From (TaggedImage (toImage t) "latest" (formatAlias stageAlias)) formatAlias = Just . fromString . Text.unpack +printLn :: MonadIO io => Format (io ()) r -> r printLn message = printf (message % "\n") +toImage :: Text -> Image toImage = fromString . Text.unpack +needEnv :: MonadIO m => Text -> m Text needEnv varName = do value <- need varName case value of diff --git a/docker-build-cacher.cabal b/docker-build-cacher.cabal --- a/docker-build-cacher.cabal +++ b/docker-build-cacher.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 72ca9cf99c0613a7ff7f5e94617f58aa0526aa5f65f481b4095ce18e45346bb0 +-- hash: f120fac96a3eefa303b680da84064f52ab16c7ef931ad7da0b9094624fe2891c name: docker-build-cacher -version: 1.9.4 +version: 2.0.0 synopsis: Builds a services with docker and caches all of its intermediate stages description: A CLI tool to speed up multi-stage docker file builds by caching intermediate category: Operations @@ -34,7 +34,7 @@ base >=4.9.1.0 && <5 , containers , foldl - , language-docker >=5.0.1 && <6.0 + , language-docker >=6.0.1 && <7.0 , system-filepath , text , turtle