docker-build-cacher 1.9.4 → 2.0.0
raw patch · 3 files changed
+262/−154 lines, 3 filesdep ~language-docker
Dependency ranges changed: language-docker
Files
- README.md +27/−0
- app/Main.hs +232/−151
- docker-build-cacher.cabal +3/−3
README.md view
@@ -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
app/Main.hs view
@@ -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
docker-build-cacher.cabal view
@@ -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