docker-build-cacher 2.0.0 → 2.1.0
raw patch · 6 files changed
+984/−578 lines, 6 filesdep +aesondep +docker-build-cacherdep ~language-docker
Dependencies added: aeson, docker-build-cacher
Dependency ranges changed: language-docker
Files
- README.md +64/−7
- app/Main.hs +71/−567
- docker-build-cacher.cabal +29/−4
- src/Docker/Cacher.hs +473/−0
- src/Docker/Cacher/Inspect.hs +308/−0
- src/Docker/Cacher/Internal.hs +39/−0
README.md view
@@ -70,6 +70,17 @@ There are binaries provided for `linux-x86_64` and MacOS, check [the releases page](https://github.com/seatgeek/docker-build-cacher/releases) for downloads. +## How It Works++This works by parsing the Dockerfile and extracting the `COPY` or `ADD` instructions nested inside `ONBUILD` for each of+the stages found in the file.++It will compare the source files present in such `COPY` or `ADD` instructions to check for changes. If it can detect changes,+it rewrites your Dockerfile on the fly so that the `FROM` directives in each of the stages use the locally cached images instead+of the original base image.++The effect this `FROM` swap has, is that disk state for the image is preserved between builds.+ ## Usage `docker-build-cacher` requires the following environment variables to be present in order to correctly build@@ -127,16 +138,62 @@ 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+### Caching Intermediate Images -This works by parsing the Dockerfile and extracting the `COPY` or `ADD` instructions nested inside `ONBUILD` for each of-the stages found in the file.+In some circumstances, you may want to execute additional instructions after+including the base builder image. For instance, building an executable or+bundle using all the dependencies already downloaded: -It will compare the source files present in such `COPY` or `ADD` instructions to check for changes. If it can detect changes,-it rewrites your Dockerfile on the fly so that the `FROM` directives in each of the stages use the locally cached images instead-of the original base image.+```Dockerfile+# Automatically build haskell stack dependencies+FROM haskell-stack as builder -The effect this `FROM` swap has, is that disk state for the image is preserved between builds.+COPY . .+RUN stack install++# Build the final container image+FROM scratch++COPY --from=builder /root/.local/bin/my-app+```++This very typical example has a shortcoming now, each time we do `COPY . .` we+are also invalidating the compiling artifacts created in `stack install`, that+is, we are losing the benefits of incremental compilation.++If you want to keep incremental compilation, or any files generated in between+the builder image and the final `FROM`, you can label the intermediate image so+that `docker-build-cacher` will include that into the cached artifacts:++```Dockerfile+# Automatically build haskell stack dependencies+FROM haskell-stack as builder++# Instructs the cacher to also copy the files generated in this stage+LABEL cache_instructions=cache++COPY . .+RUN stack install++# Build the final container image+FROM scratch++COPY --from=builder /root/.local/bin/my-app+```++**Warning:**++The files copied in `COPY . .` will also be cached! This not only increases the+cache size, but also has a potentially dangerous inconvenient:++Any files you delete from one build to the other will be restored again by the+cacher. For example, if you delete one file in your source tree because you+don't use it anymore or you did a refactoring, it will pop up again in the build!++This may be a problem for compilers or build tools that scan all the files in+the folder, like the Go compiler. If you are certain that keeping old files+around is not a problem, then it is safe to use this feature. The Haskell+compiler, for instance, does not care at all about extra cruft in the folder. ## Passing extra arguments to docker build
app/Main.hs view
@@ -1,88 +1,21 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} module Main where -import qualified Control.Foldl as Fold-import Control.Monad (guard, when)-import Data.Either (rights)-import Data.List.NonEmpty (toList)-import qualified Data.Map.Strict as Map-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 (workdir)-import Language.Docker.Syntax (Tag(..))-import Prelude hiding (FilePath)-import Text.ParserCombinators.ReadP-import Text.Read-import Turtle+import Data.Maybe ( fromMaybe )+import qualified Data.Text as Text+import Data.Text ( Text )+import Language.Docker+import Prelude hiding ( FilePath )+import Text.ParserCombinators.ReadP+import Text.Read+import Turtle -{- Glossary:- - InstructionPos: in the AST for a docker file, each of the lines are described with the type InstructionPos- - Dockerfile: A list of InstructionPos- - stage: Each of the FROM instructions in a Dockerfile- - cache buster: Files inside a docker image that can be compared with files locally under the same path--}-newtype App =- App Text- deriving (Show)+import qualified Docker.Cacher+import qualified Docker.Cacher.Internal -newtype Branch =- Branch Text- deriving (Show) -data SourceImage =- SourceImage--data CachedImage =- CachedImage--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, 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)--newtype NotInspectedCache =- NotInspectedCache StageCache--data StageCache- = NotCached (Stage SourceImage) -- When the image has not yet been built separetely- | 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- }- | CacheInvalidated (Stage CachedImage)- deriving (Show)- -- | This script has 2 modes. One for building the Dockerfile, and another for caching its stages data Mode = Build@@ -107,510 +40,81 @@ , noBuildCache :: Bool } + -- | Describes the arguments this script takes from the command line parser :: Parser Args parser =- Args <$> -- Pass the parsed arguments into the Args data container- argRead "mode" "Whether to build or to cache (options: build | cache)" <*>- switch- "no-cache-stages"- 's'- "Each of the FROM instruction will be cached in separate images if this flag is not set" <*>- switch "no-cache-build" 'n' "Skip the internal docker cache when building the image"+ Args -- Pass the parsed arguments into the Args data container+ <$> argRead "mode" "Whether to build or to cache (options: build | cache)"+ <*> switch+ "no-cache-stages"+ 's'+ "Each of the FROM instruction will be cached in separate images if this flag is not set"+ <*> switch "no-cache-build"+ 'n'+ "Skip the internal docker cache when building the image" + main :: IO () main = do- Args {mode, noCacheStages, noBuildCache} <-- 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- --- -- if DOCKERFILE is not present, we assume is in the current directory- currentDirectory <- pwd- let Just file = maybeFile <|> Just (currentDirectory </> "Dockerfile")- --- -- Now we try to parse the dockefile- dockerFile <- parseFile (Text.unpack (format fp file)) -- Convert the dockerfile to an AST- case dockerFile of- Left message -> error ("There was an error parsing the docker file: " <> show message)- Right ast ->- case mode of- Cache ->- if noCacheStages- then echo "Skipping... I was told not to cache any stages separetely"- else sh (cacheBuild app branch fallbackBranch ast)- Build -> do- name <- ImageName <$> needEnv "DOCKER_TAG"- buildOPtions <-- do opts <- need "DOCKER_BUILD_OPTIONS"- if noBuildCache- then return $- Just (opts & fromMaybe "" & (<> " --no-cache") & BuildOptions) -- Append the docker --no-cache option- else return (fmap BuildOptions opts)- if noCacheStages- then sh (build app name buildOPtions ast)- else sh (buildFromCache app branch fallbackBranch name buildOPtions ast)+ Args { mode, noCacheStages, noBuildCache } <- options -- Parse the CLI arguments as a Mode+ "Builds a docker file and caches its stages"+ parser --- | 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- -> 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 imageName buildOptions cachedStages- where- 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+ app <- Docker.Cacher.App <$> needEnv "APP_NAME" -- Get the APP environment variable and then wrap it in App+ branch <- Docker.Cacher.Branch <$> needEnv "GIT_BRANCH"+ fallbackBranch <- fmap Docker.Cacher.Branch <$> need "FALLBACK_BRANCH" -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 imageName buildOptions ast -- Build the main docker file- -- which may already have been rewritten to use the- -- cached stages.- case status of- ExitSuccess ->- echo- "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"+ maybeFile <- do+ file <- need "DOCKERFILE" -- Get the dockerfile path if any+ return (fmap fromText file) -- And transform it to a FilePath --- | 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 -> 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 re-build the cache for stages that changed"- mapM_ (reBuildAssetStage app) stagesToReBuild -- Build each of the stages so they can be reused later+ -- if DOCKERFILE is not present, we assume is in the current directory+ currentDirectory <- pwd+ let Just file = maybeFile <|> Just (currentDirectory </> "Dockerfile") --- | 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 -> 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- shouldBustCache -- Determine whether or not the cache was invalidated- )- Fold.list- where- showAliasesWarning = do- echo "::::::WARNING::::::"- echo "I found some FROM directives in the dockerfile that did not have an `as` alias"- echo "I'm not smart enough to build multi-stage docker files without aliases."- echo "While this is safe to do, you will get no cache benefits"- echo ""- echo "Please always write your FROM directives as `FROM image:tag as myalias`"+ -- Now we try to parse the dockefile+ dockerFile <- parseFile (Text.unpack (format fp file)) -- Convert the dockerfile to an AST+ case dockerFile of+ Left message ->+ error ("There was an error parsing the docker file: " <> show message) --- | Check whehther or not the imageName exists for each of the passed stages--- and return only those that already exist.-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 {buildImageName, stageFallbackImage} <- select stages -- foreach stages as stage- exists <- cacheKeyExists stage buildImageName- if exists- then do- echo "------> It already exists, so I will then check if the cache files changed"- 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)+ Right ast -> case mode of+ Cache -> if noCacheStages+ then echo "Skipping... I was told not to cache any stages separetely"+ else sh (Docker.Cacher.cacheBuild app branch fallbackBranch ast) --- | 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 :: Stage SourceImage -> Shell StageCache-inspectCache sourceStage@Stage {..} = do- history <- imageHistory buildImageName- let onBuildLines = extractOnBuild history- workdir = extractWorkdir history- 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- where- extractCachePaths workdir dir =- let filePairs = concat (mapMaybe doExtract dir) -- Get the (source, target) pairs of files copied- in fmap (prependWorkdir workdir) filePairs -- Some target paths need to have the WORKDIR prepended- --- -- | Prepend a given target dir to the target path- prependWorkdir workdir (source, TargetPath target) =- 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)- --- -- | COPY allows multiple paths in the same line, we need to convert each to a separate path- doExtract (InstructionPos (Copy CopyArgs {sourcePaths, targetPath}) _ _) =- Just (zip (toList sourcePaths) (repeat targetPath))- --- -- | This case is simpler, we only need to convert the source and target from ADD- doExtract (InstructionPos (Add AddArgs {sourcePaths, targetPath}) _ _) =- Just (zip (toList sourcePaths) (repeat targetPath))- doExtract _ = Nothing- getFirst (first:_) = first- getFirst [] = []+ Build -> do+ name <- Docker.Cacher.Internal.ImageName <$> needEnv "DOCKER_TAG"+ buildOPtions <- do+ opts <- need "DOCKER_BUILD_OPTIONS"+ if noBuildCache+ then+ return+ $ Just+ ( opts+ & fromMaybe ""+ & (<> " --no-cache") -- Append the docker --no-cache option+ & Docker.Cacher.BuildOptions+ )+ else return (fmap Docker.Cacher.BuildOptions opts) -toCachedStage :: Stage SourceImage -> Stage CachedImage-toCachedStage Stage {..} =- let stage = Stage {..}- ImageName sImageName = stageImageName- ImageName bImageName = buildImageName- in stage- { stageImageName = ImageName sImageName- , stageFallbackImage = Nothing- , buildImageName = ImageName bImageName- }+ if noCacheStages+ then sh (Docker.Cacher.build app name buildOPtions ast)+ else sh+ (Docker.Cacher.buildFromCache app+ branch+ fallbackBranch+ name+ buildOPtions+ ast+ ) --- | 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 :: StageCache -> Shell StageCache-shouldBustCache cached@Cached {..} = do- printLn ("----> Checking cache buster files for stage " %s) (stageName stage)- withContainer (buildImageName stage) checkFiles -- Create a container to inspect the files- where- checkFiles containerId = do- hasChanged <- fold (mfilter isJust (checkFileChanged containerId cacheBusters)) Fold.head- -- ^ Get the cache buster files that have changed since last time- -- The following is executed for each of the files found- if isJust hasChanged- then do- printLn ("----> The stage " %s % " changed") (stageName stage)- return (CacheInvalidated stage)- else do- printLn ("----> The stage " %s % " did not change") (stageName stage)- return cached- -- |- checkFileChanged containerId files = do- (SourcePath src, TargetPath dest) <- select files- let file = fromText src- let targetDir = fromText dest- printLn ("------> Checking file '" %fp % "' in directory " %fp) file targetDir- currentDirectory <- pwd- tempFile <- mktempfile currentDirectory "comp"- let targetFile = targetDir </> file- status <-- proc- "docker"- ["cp", format (s % ":" %fp) containerId targetFile, format fp tempFile]- empty- guard (status == ExitSuccess)- local <- liftIO (readTextFile file)- remote <- liftIO (readTextFile tempFile)- if local == remote- then return Nothing- else return (Just file)--- In any other case return the same inspected stage-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 :: 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- where- removeContainer containerId = proc "docker" ["rm", format l containerId] empty---- | The goal is to create a temporary dockefile in this same folder with the contents--- if the stage variable, call docker build with the generated file and tag the image--- so we can find it later.-buildAssetStage :: App -> Stage SourceImage -> Shell ()-buildAssetStage app Stage {..} = do- printLn- ("\n--> Building asset stage " %s % " at line " %d % " for the first time")- stageName- stagePos- 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---- | The goal is to create a temporary dockefile in this same folder with the contents--- if the stage variable, call docker build with the generated file and tag the image--- so we can find it later.-reBuildAssetStage :: App -> Stage CachedImage -> Shell ()-reBuildAssetStage app Stage {..} = do- printLn ("\n--> Rebuilding asset stage " %s % " at line " %d) stageName stagePos- let cacheLabels = [("cached_image", stageName <> ":" <> stageTag)]- newDockerfile =- toDockerfile $ do- let ImageName t = stageImageName- from $ toImage t `tagged` "latest" -- Use the cached image as base for the new one- label cacheLabels- doStageBuild app stageImageName buildImageName (CacheLabels cacheLabels) newDockerfile--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 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 -> 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"- , imageName- , "."- ] <>- [opts]- 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 imageName is the FROM for the file and--- the list of instructions are wrapped with ONBUILD-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 imageName `tagged` "latest"- label cacheLabels- mapM (onBuildRaw . toInstruction) validDirectives -- Append each of the ONBUILD instructions- return file- where- toInstruction [InstructionPos inst _ _] = inst- toInstruction _ = error "This is not possible"---- | Extracts the list of instructions appearing in ONBUILD for a given docker history for a tag-extractOnBuild :: [Line] -> [Text]-extractOnBuild = doExtract- where- onBuildPrefix = "/bin/sh -c #(nop) ONBUILD "- --- -- | First get the ONBUILD lines then strip the common prefix out of each.- -- Arguments flow from right to left in the functions chain- doExtract = mapMaybe (Text.stripPrefix onBuildPrefix . lineToText) . findOnBuildLines- --- -- | First drop the lines not starting with ONBUILD, then take only those.- -- Arguments flow from right to left in the functions chain- 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- [] -> fromText "/"- lastWorkdir:_ -> fromText lastWorkdir -- We are on;y intereted in the latest WORKDIR declared- where- onBuildPrefix = "/bin/sh -c #(nop) ONBUILD " -- Curiously, ONBUILD is lead by 2 spaces- workdirPrefix = "/bin/sh -c #(nop) WORKDIR " -- Whereas WORKDIR only by one space- --- -- | First find all relevant instructions, then keep the lines starting with the workdir prefix- doExtract = mapMaybe (Text.stripPrefix workdirPrefix . lineToText) . findRelevantLines- --- -- | Take lines until a ONBUILD is found- -- Arguments flow from right to left in the functions chain- findRelevantLines = takeWhile (not . isOnBuild)- isOnBuild line = Text.isPrefixOf onBuildPrefix (lineToText line)---- | Calls docker history for the given image name and returns the output as a list-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}}", name] empty------- | Returns a list of directives grouped by the appeareance of the FROM directive--- This will return the group of all stages found in the Dockerfile-getStages :: Dockerfile -> [Dockerfile]-getStages ast = filter startsWithFROM (group ast [])- where- group [] acc = reverse acc -- End of recursion- group (directive@(InstructionPos (From _) _ _):rest) acc = group rest ([directive] : acc) -- Append a new group- group (directive:rest) [] = group rest [[directive]] -- Create a new group- group (directive:rest) (current:prev) = group rest ((current ++ [directive]) : prev) -- Continue the currently open group- --- -- | Returns true if the first element in the list is a FROM directive- startsWithFROM (InstructionPos (From _) _ _:_) = True- startsWithFROM _ = False---- | Converts a list of instructions into a Stage record-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, Text, Linenumber, Text)- extractInfo (InstructionPos {instruction, lineNumber}:_) = getStageInfo instruction lineNumber- extractInfo _ = Nothing- 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 (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 ":" "-"---- | 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 =- fmap (\InstructionPos {..} -> InstructionPos {instruction = replaceStage instruction, ..})- where- stagesMap = Map.fromList (map createStagePairs stages)- 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- replaceStage directive@(From (TaggedImage _ _ (Just (ImageAlias imageAlias)))) =- replaceKnownAlias directive imageAlias- replaceStage directive@(From (UntaggedImage _ (Just (ImageAlias imageAlias)))) =- replaceKnownAlias directive imageAlias- replaceStage directive@(From (DigestedImage _ _ (Just (ImageAlias imageAlias)))) =- replaceKnownAlias directive imageAlias- replaceStage directive = directive- replaceKnownAlias directive imageAlias =- case Map.lookup imageAlias stagesMap of- Nothing -> directive- 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- Nothing -> error ("I was expecting the " <> show varName <> " env var to be present.")- Just val -> return val+ value <- need varName+ case value of+ Nothing -> error+ ("I was expecting the " <> show varName <> " env var to be present.")+ Just val -> return val
docker-build-cacher.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f120fac96a3eefa303b680da84064f52ab16c7ef931ad7da0b9094624fe2891c+-- hash: bba2ebc1d94e53e264f8fc6617af435725332ab983d4665a9360298eed6f98e5 name: docker-build-cacher-version: 2.0.0+version: 2.1.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@@ -25,19 +25,44 @@ type: git location: https://github.com/seatgeek/docker-build-cacher +library+ exposed-modules:+ Docker.Cacher+ Docker.Cacher.Inspect+ Docker.Cacher.Internal+ other-modules:+ Paths_docker_build_cacher+ hs-source-dirs:+ src+ ghc-options: -Wall -fno-warn-unused-do-bind+ build-depends:+ aeson+ , base >=4.9.1.0 && <5+ , containers+ , foldl+ , language-docker >=6.0.4 && <7.0+ , system-filepath+ , text+ , turtle+ default-language: Haskell2010+ executable docker-build-cacher main-is: Main.hs hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind build-depends:- base >=4.9.1.0 && <5+ aeson+ , base >=4.9.1.0 && <5 , containers+ , docker-build-cacher , foldl- , language-docker >=6.0.1 && <7.0+ , language-docker >=6.0.4 && <7.0 , system-filepath , text , turtle+ if !(os(osx))+ ld-options: -static -pthread other-modules: Paths_docker_build_cacher default-language: Haskell2010
+ src/Docker/Cacher.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module Docker.Cacher where++import qualified Control.Foldl as Fold+import Control.Monad ( guard+ , when+ )+import Data.Either ( rights )+import qualified Data.Map.Strict as Map+import Data.Maybe ( fromMaybe+ , mapMaybe+ )+import qualified Data.Text as Text+import Data.Text ( Text )+import qualified Data.Text.Lazy as LT+import Language.Docker+import Language.Docker.Syntax ( Tag(..) )+import Prelude hiding ( FilePath )+import Turtle++import qualified Docker.Cacher.Inspect+import Docker.Cacher.Inspect ( ImageConfig(..)+ , StageCache(..)+ )+import Docker.Cacher.Internal+import qualified Data.List.NonEmpty+import qualified Data.Aeson.Text+import qualified Data.Coerce++{- Glossary:+ - InstructionPos: in the AST for a docker file, each of the lines are described with the type InstructionPos+ - Dockerfile: A list of InstructionPos+ - stage: Each of the FROM instructions in a Dockerfile+ - cache buster: Files inside a docker image that can be compared with files locally under the same path+-}+newtype App =+ App Text+ deriving (Show)++newtype Branch =+ Branch Text+ deriving (Show)++newtype BuildOptions =+ BuildOptions Text+ deriving (Show)++newtype CacheLabels =+ CacheLabels [(Text, Text)]+ deriving (Show)+++-- | 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+ -> Maybe Branch+ -> ImageName SourceImage+ -> Maybe BuildOptions+ -> Dockerfile+ -> Shell ()+buildFromCache app branch fallbackBranch imageName buildOptions ast = do+ -- 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.+ changedStages <- getChangedStages app branch fallbackBranch ast++ -- We replace the busted stages with cached primed ones+ let cachedStages = replaceStages+ (mapMaybe Docker.Cacher.Inspect.alreadyCached changedStages)+ ast++ build app imageName buildOptions cachedStages+++build+ :: App+ -> ImageName SourceImage+ -> Maybe BuildOptions+ -> Dockerfile+ -> Shell ()+build app imageName buildOptions ast = do+ echo "I'll start building now the main Dockerfile"++ -- Build the main docker file which may already have been rewritten to use the+ -- cached stages.+ status <- buildDockerfile app imageName buildOptions ast++ case status of+ ExitSuccess ->+ echo+ "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 extract each of the stages separately and then tag them, so the cache+-- can be retreived at a later point.+cacheBuild :: App -> Branch -> Maybe Branch -> Dockerfile -> Shell ()+cacheBuild app branch fallbackBranch ast = do+ -- 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.+ inspectedStages <- getChangedStages app branch fallbackBranch ast++ let stagesToBuildFresh = [ stage | NotCached stage <- inspectedStages ]+ let stagesToReBuild =+ [ (uncached, stage)+ | CacheInvalidated uncached 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 re-build the cache for stages that changed"+ mapM_ (uncurry (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 -> Maybe Branch -> Dockerfile -> Shell [StageCache]+getChangedStages app branch fallbackBranch ast = do+ let+ -- Filter out the main FROM at the end and only+ -- keep the contents of the file before that instruction.+ assetStages = init (getStages ast)++ -- For each of the found stages, before the main+ -- FROM instruction, convert them to Stage records+ stages = mapMaybe (toStage app branch fallbackBranch) assetStages++ when (length assetStages > length stages) showAliasesWarning+ fold+ (+ -- Find the stages that we already have in local cache+ Docker.Cacher.Inspect.getAlreadyCached stages+ -- Determine whether or not the cache was invalidated+ >>= uncurry Docker.Cacher.Inspect.shouldBustCache+ )+ Fold.list+ where+ showAliasesWarning = do+ echo "::::::WARNING::::::"+ echo+ "I found some FROM directives in the dockerfile that did not have an `as` alias"+ echo+ "I'm not smart enough to build multi-stage docker files without aliases."+ echo "While this is safe to do, you will get no cache benefits"+ echo ""+ echo+ "Please always write your FROM directives as `FROM image:tag as myalias`"+++-- | The goal is to create a temporary dockefile in this same folder with the contents+-- if the stage variable, call docker build with the generated file and tag the image+-- so we can find it later.+buildAssetStage :: App -> Stage SourceImage -> Shell ()+buildAssetStage app Stage {..} = do+ printLn+ ("\n--> Building asset stage " % s % " at line " % d % " for the first time"+ )+ stageName+ stagePos+ let+ fromInstruction = filter isFrom directives+ sourceImage = ImageName (extractFullName fromInstruction)+ cacheEverything = canCacheDirectives directives+ embeddedFiles =+ if cacheEverything then extractCopiedFiles directives else []++ cacheLabels = buildCacheLabels stageName stageTag embeddedFiles++ newDockerfile = toDockerfile $ do+ if cacheEverything then embed directives else embed fromInstruction+ label (Data.Coerce.coerce cacheLabels)++ doStageBuild app+ sourceImage+ stageImageName+ buildImageName+ cacheLabels+ newDockerfile+ where+ extractFullName (instr : _) = extractFromInstr (instruction instr)+ extractFullName _ = ""++ extractFromInstr (From (DigestedImage img digest _)) =+ prettyImage img <> "@" <> digest+ extractFromInstr (From (UntaggedImage img _)) = prettyImage img+ extractFromInstr (From (TaggedImage img (Tag tag) _)) =+ prettyImage img <> ":" <> tag+ extractFromInstr _ = ""++ prettyImage (Image Nothing img) = img+ prettyImage (Image (Just (Registry reg)) img) = reg <> "/" <> img+++-- | The goal is to create a temporary dockefile in this same folder with the contents+-- if the stage variable, call docker build with the generated file and tag the image+-- so we can find it later.+reBuildAssetStage :: App -> Stage SourceImage -> Stage CachedImage -> Shell ()+reBuildAssetStage app uncached cached = do+ printLn ("\n--> Rebuilding asset stage " % s % " at line " % d)+ (stageName cached)+ (stagePos cached)+ let embeddedFiles = if canCacheDirectives (directives uncached)+ then extractCopiedFiles (directives uncached)+ else []+ cacheLabels = buildCacheLabels (stageName uncached)+ (stageTag uncached)+ embeddedFiles+ let ImageName t = stageImageName cached+ newDockerfile = cacheableDockerFile t (directives uncached) cacheLabels+ doStageBuild app+ (buildImageName cached) -- The source image is the one having the ONBUILD lines+ (stageImageName cached)+ (buildImageName cached)+ cacheLabels+ newDockerfile+++reBuildFromFallback :: App -> Stage SourceImage -> Stage CachedImage -> Shell ()+reBuildFromFallback app uncached cached = do+ let embeddedFiles = extractCopiedFiles (directives uncached)+ cacheLabels =+ buildCacheLabels (stageName uncached) (stageTag uncached) embeddedFiles+ let sourceImage@(ImageName t) = buildImageName cached+ newDockerfile = cacheableDockerFile t (directives uncached) cacheLabels+ doStageBuild app+ sourceImage+ (stageImageName uncached)+ (buildImageName uncached)+ cacheLabels+ newDockerfile+++doStageBuild+ :: App+ -> ImageName source -- ^ This is the image potentially containing the ONBUILD lines, this image needs to exist+ -> ImageName intermediate -- ^ This is the image name to build as intermediate with no ONBUILD+ -> ImageName target -- ^ This is the final image name to build, after appending the ONBUILD lines to intermediate+ -> CacheLabels+ -> Dockerfile+ -> Shell ()+doStageBuild app sourceImageName intermediateImage targetImageName cacheLabels directives+ = do+ -- Only build the FROM+ status <- buildDockerfile app intermediateImage Nothing directives++ -- Break if previous command failed+ guard (status == ExitSuccess)++ ImageConfig _ onBuildLines _ <- Docker.Cacher.Inspect.imageConfig+ sourceImageName++ -- Append the ONBUILD lines to the new file+ newDockerfile <- createDockerfile intermediateImage cacheLabels onBuildLines++ -- Now build it+ finalStatus <- buildDockerfile app targetImageName Nothing newDockerfile++ -- Stop here if previous command failed+ guard (finalStatus == ExitSuccess)+ 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 -> 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"+ , imageName+ , "."+ ]+ <> [opts]++ -- Put the Dockerfile contents in the tmp file+ liftIO (writeTextFile tmpFile (LT.toStrict (prettyPrint directives)))++ -- Build the generated dockerfile+ shell ("docker " <> Text.intercalate " " allBuildOptions) empty+++-- | 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 :: 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 imageName `tagged` "latest"+ label cacheLabels+ -- Append each of the ONBUILD instructions+ mapM (onBuildRaw . toInstruction) validDirectives+ return file+ where+ toInstruction [InstructionPos inst _ _] = inst+ toInstruction _ = error "This is not possible"+++--+-- | Returns a list of directives grouped by the appeareance of the FROM directive+-- This will return the group of all stages found in the Dockerfile+getStages :: Dockerfile -> [Dockerfile]+getStages ast = filter startsWithFROM (group ast [])+ where+ group [] acc = reverse acc -- End of recursion+ group (directive@(InstructionPos (From _) _ _) : rest) acc =+ group rest ([directive] : acc) -- Append a new group+ group (directive : rest) [] = group rest [[directive]] -- Create a new group+ group (directive : rest) (current : prev) =+ group rest ((current ++ [directive]) : prev) -- Continue the currently open group++ --+ -- | Returns true if the first element in the list is a FROM directive+ startsWithFROM (InstructionPos (From _) _ _ : _) = True+ startsWithFROM _ = False+++-- | Converts a list of instructions into a Stage record+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, Text, Linenumber, Text)+ extractInfo (InstructionPos { instruction, lineNumber } : _) =+ getStageInfo instruction lineNumber+ extractInfo _ = Nothing++ 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 (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 ":" "-"+++-- | 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 = fmap+ (\InstructionPos {..} ->+ InstructionPos {instruction = replaceStage instruction, ..}+ )+ where+ stagesMap = Map.fromList (map createStagePairs stages)++ 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+ replaceStage directive@(From (TaggedImage _ _ (Just (ImageAlias imageAlias))))+ = replaceKnownAlias directive imageAlias+ replaceStage directive@(From (UntaggedImage _ (Just (ImageAlias imageAlias))))+ = replaceKnownAlias directive imageAlias+ replaceStage directive@(From (DigestedImage _ _ (Just (ImageAlias imageAlias))))+ = replaceKnownAlias directive imageAlias+ replaceStage directive = directive++ replaceKnownAlias directive imageAlias =+ case Map.lookup imageAlias stagesMap of+ Nothing -> directive+ Just Stage { buildImageName, stageAlias } ->+ let ImageName t = buildImageName+ in From (TaggedImage (toImage t) "latest" (formatAlias stageAlias))++ formatAlias = Just . fromString . Text.unpack+++-- | Finds all COPY and ADD instructions in the dockerfile and returns+-- a concatenated list of all the source paths collected+extractCopiedFiles :: Dockerfile -> [(SourcePath, TargetPath)]+extractCopiedFiles = concatMap (extractFiles . instruction)+ where+ extractFiles (Copy CopyArgs { sourcePaths, sourceFlag = NoSource, targetPath })+ = zip (Data.List.NonEmpty.toList sourcePaths) (repeat targetPath)+ extractFiles (Copy CopyArgs { sourceFlag = _ }) = []+ extractFiles (Add AddArgs { sourcePaths, targetPath }) =+ zip (Data.List.NonEmpty.toList sourcePaths) (repeat targetPath)+ extractFiles _ = []+++buildCacheLabels :: Text -> Text -> [(SourcePath, TargetPath)] -> CacheLabels+buildCacheLabels imageName imageTag files =+ CacheLabels $ ("cached_image", imageName <> ":" <> imageTag) : case files of+ [] -> []+ _ -> [("cached_files", encodedFiles)]+ where+ encodedFiles = LT.toStrict (Data.Aeson.Text.encodeToLazyText plainTextList)++ plainTextList :: [(Text, Text)]+ plainTextList = Data.Coerce.coerce files+++canCacheDirectives :: Dockerfile -> Bool+canCacheDirectives df = not (null cacheLabels)+ where+ cacheLabels =+ [ True+ | Label pairs <- map instruction df+ , (key, val) <- pairs+ , key == "cache_instructions"+ , val == "cache"+ ]+++cacheableDirectives :: Dockerfile -> Dockerfile+cacheableDirectives df = if canCacheDirectives df+ then filter (not . isFrom) . filter (not . isOnBuild) $ df+ else []+++cacheableDockerFile :: Text -> Dockerfile -> CacheLabels -> Dockerfile+cacheableDockerFile t directives (CacheLabels cacheLabels) = toDockerfile $ do+ -- Use the cached image as base for the new one+ from (toImage t `tagged` "latest")+ -- But we want the contents of the original one+ -- without the ONBUILD+ embed (cacheableDirectives directives)+ label cacheLabels+++isFrom :: InstructionPos args -> Bool+isFrom (InstructionPos From{} _ _) = True+isFrom _ = False+++isOnBuild :: InstructionPos args -> Bool+isOnBuild (InstructionPos OnBuild{} _ _) = True+isOnBuild _ = False+++toImage :: Text -> Image+toImage = fromString . Text.unpack
+ src/Docker/Cacher/Inspect.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++module Docker.Cacher.Inspect where++import qualified Control.Foldl as Fold+import qualified Data.Aeson as Aeson+import Data.Aeson ( (.:) )+import qualified Data.Coerce+import Data.Either ( rights )+import Data.List.NonEmpty ( toList )+import Data.Maybe ( fromMaybe+ , isJust+ , mapMaybe+ )+import qualified Data.Map as Map+import qualified Data.Text as Text+import Data.Text ( Text )+import qualified Data.Text.Encoding+import Language.Docker hiding ( workdir )+import Language.Docker.Syntax ( Tag(..) )+import Prelude hiding ( FilePath )+import Turtle++import Docker.Cacher.Internal++-- | This represents the image config as stored on disk by the docker daemon. We only care here+-- about the .Config.WorkingDir and .Config.OnBuild properties+data ImageConfig = ImageConfig+ { workingDir :: !Text+ , onBuildInstructions :: ![Text]+ , storedLabels :: !(Map.Map Text Text)+ } deriving (Show, Eq)++data StageCache+ = NotCached (Stage SourceImage) -- When the image has not yet been built separetely+ | 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+ }+ | CacheInvalidated (Stage SourceImage) (Stage CachedImage)+ deriving (Show)++instance Aeson.FromJSON ImageConfig where+ parseJSON =+ Aeson.withObject "ImageConfig" $ \ic -> do+ workingDir <- ic .: "WorkingDir"+ onBuildInstructions <- fromMaybe [] <$> ic .: "OnBuild"+ storedLabels <- fromMaybe Map.empty <$> ic .: "Labels"+ return $ ImageConfig {..}+++-- | Calls docker inspect for the given image name and returns the config+imageConfig :: ImageName a -> Shell ImageConfig+imageConfig (ImageName name) = do+ printLn ("----> Inspecting the config for the docker image: " % s) name+ out <- fmap lineToText <$> fold fetchConfig Fold.list -- Buffer all the output in the out variable++ case decodeJSON out of+ Left decodeErr -> do+ error+ $ "----> Could not decode the response of docker inspect: "+ ++ decodeErr+ return (ImageConfig "" [] Map.empty)++ Right ic -> return ic+ where+ fetchConfig =+ inproc "docker" ["inspect", "--format", "{{.Config | json}}", name] empty+ decodeJSON =+ Aeson.eitherDecodeStrict . Data.Text.Encoding.encodeUtf8 . Text.unlines+++-- | Check whether or not the imageName exists for each of the passed stages+-- and return only those that already exist.+getAlreadyCached :: [Stage SourceImage] -> Shell (Stage SourceImage, StageCache)+getAlreadyCached stages = do+ echo+ "--> I'm checking whether or not the stage exists as a docker image already"++ stage@Stage { buildImageName, stageFallbackImage } <- select stages -- foreach stages as stage+ exists <- cacheKeyExists stage buildImageName++ if exists+ then do+ echo+ "------> It already exists, so I will then check if the cache files changed"+ inspected <- inspectCache stage+ return (stage, inspected)+ else do+ echo "------> It does not exist, so I will need to build it myself later"+ maybe (return (stage, 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 (stage, FallbackCache stage cachedStage)+ else do+ echo "------> There is not fallback cache image"+ return (stage, NotCached stage)+++-- | 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 :: Stage SourceImage -> StageCache -> Shell StageCache+shouldBustCache sourceStage cached@Cached {..} = do+ printLn ("----> Checking cache buster files for stage " % s) (stageName stage)+ withContainer (buildImageName stage) checkFiles -- Create a container to inspect the files+ where+ checkFiles containerId = do+ hasChanged <- fold+ (mfilter isJust (checkFileChanged containerId cacheBusters))+ Fold.head+ -- ^ Get the cache buster files that have changed since last time++ -- The following is executed for each of the files found+ if isJust hasChanged+ then do+ printLn ("----> The stage " % s % " changed") (stageName stage)+ return (CacheInvalidated sourceStage stage)+ else do+ printLn ("----> The stage " % s % " did not change") (stageName stage)+ return cached++ -- |+ checkFileChanged containerId files = do+ (SourcePath src, TargetPath dest) <- select files+ let file = fromText src+ fileStat <- stat file++ if isDirectory fileStat+ then do+ printLn+ ("------>'" % fp % "' is a directory, assuming files inside it changed")+ file+ return $ Just file+ else do+ let targetDir = fromText dest+ printLn ("------> Checking file '" % fp % "' in directory " % fp)+ file+ targetDir+ currentDirectory <- pwd+ tempFile <- mktempfile currentDirectory "comp"+ let targetFile = targetDir </> file+ status <- proc+ "docker"+ [ "cp"+ , format (s % ":" % fp) containerId targetFile+ , format fp tempFile+ ]+ empty++ guard (status == ExitSuccess)++ local <- liftIO (readTextFile file)+ remote <- liftIO (readTextFile tempFile)+ if local == remote then return Nothing else return (Just file)++-- In any other case return the same inspected stage+shouldBustCache _ c@NotCached{} = return c+shouldBustCache _ c@CacheInvalidated{} = return c+shouldBustCache _ c@FallbackCache{} = return c+++-- | 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 :: Stage SourceImage -> Shell StageCache+inspectCache sourceStage@Stage {..} = do+ ImageConfig workdir onBuildLines foundLabels <- imageConfig buildImageName+ let parsedDirectivesWithErrors = fmap parseText onBuildLines -- Parse each of the lines+ parsedDirectives = (getFirst . rights) parsedDirectivesWithErrors -- We only keep the good lines+ workPath = fromText workdir+ onBuildBusters = extractCachePaths workPath parsedDirectives+ cacheBusters = onBuildBusters ++ bustersFromLabels workPath foundLabels+ return $ Cached (toCachedStage sourceStage) cacheBusters+ where+ extractCachePaths workdir dir =+ let filePairs = concat (mapMaybe doExtract dir) -- Get the (source, target) pairs of files copied+ in fmap (prependWorkdir workdir) filePairs -- Some target paths need to have the WORKDIR prepended++ --+ -- | Prepend a given target dir to the target path+ prependWorkdir workdir (source, TargetPath target) =+ 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)++ --+ -- | COPY allows multiple paths in the same line, we need to convert each to a separate path+ doExtract (InstructionPos (Copy CopyArgs { sourcePaths, targetPath }) _ _) =+ Just (zip (toList sourcePaths) (repeat targetPath))+ --+ -- | This case is simpler, we only need to convert the source and target from ADD+ doExtract (InstructionPos (Add AddArgs { sourcePaths, targetPath }) _ _) =+ Just (zip (toList sourcePaths) (repeat targetPath))+ doExtract _ = Nothing++ getFirst (first : _) = first+ getFirst [] = []++ bustersFromLabels workdir labelList =+ case Map.lookup "cached_files" labelList of+ Nothing -> []+ Just fs ->+ case+ Aeson.decodeStrict . Data.Text.Encoding.encodeUtf8 $ fs :: Maybe+ [(Text, Text)]+ of+ Nothing -> []+ Just busters ->+ fmap (prependWorkdir workdir) (Data.Coerce.coerce busters)+++toCachedStage :: Stage SourceImage -> Stage CachedImage+toCachedStage Stage {..} =+ let stage = Stage {..}+ ImageName sImageName = stageImageName+ ImageName bImageName = buildImageName+ in stage { stageImageName = ImageName sImageName+ , stageFallbackImage = Nothing+ , buildImageName = ImageName bImageName+ }+++-- | 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+++alreadyCached :: StageCache -> Maybe (Stage CachedImage)+-- We want to replace stages where the cache+-- was invalidated by any file changes.+alreadyCached (CacheInvalidated _ 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 (Cached stage _) = Just stage++-- Finally, if we are using a fallback, we apply+-- the same rules as above for the fallback key+alreadyCached (FallbackCache _ (CacheInvalidated _ stage)) = Just stage++alreadyCached (FallbackCache _ (Cached stage _)) = Just stage++alreadyCached _ = Nothing+++-- | Creates a container from a stage and passes the container id to the+-- given shell as an argument+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+ where+ removeContainer containerId =+ proc "docker" ["rm", format l containerId] empty
+ src/Docker/Cacher/Internal.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}++module Docker.Cacher.Internal where++import Data.Text ( Text )+import Language.Docker+import Turtle++newtype ImageName a =+ ImageName Text+ deriving (Show, Eq)++data SourceImage =+ SourceImage++data CachedImage =+ CachedImage++-- | A Stage is one of the FROM directives ina dockerfile+--+data Stage a = Stage+ { 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)+++printLn :: MonadIO io => Format (io ()) r -> r+printLn message = printf (message % "\n")