diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/docker-build-cacher.cabal b/docker-build-cacher.cabal --- a/docker-build-cacher.cabal +++ b/docker-build-cacher.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 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 diff --git a/src/Docker/Cacher.hs b/src/Docker/Cacher.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Cacher.hs @@ -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 diff --git a/src/Docker/Cacher/Inspect.hs b/src/Docker/Cacher/Inspect.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Cacher/Inspect.hs @@ -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 diff --git a/src/Docker/Cacher/Internal.hs b/src/Docker/Cacher/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Docker/Cacher/Internal.hs @@ -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")