diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2014 factis research GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dockercook.cabal b/dockercook.cabal new file mode 100644 --- /dev/null +++ b/dockercook.cabal @@ -0,0 +1,69 @@ +name: dockercook +version: 0.1.0.0 +synopsis: A build tool for multiple docker image layers +description: Build and manage multiple docker image layers to speed up deployment +license: MIT +license-file: LICENSE +author: Alexander Thiemann +maintainer: thiemann@factisresearch.com +copyright: (c) 2014 factis research GmbH +category: Development +build-type: Simple +cabal-version: >=1.8 + +library + hs-source-dirs: src/lib + exposed-modules: Cook.Build, Cook.BuildFile, Cook.Clean, Cook.Types + other-modules: Cook.Util, Cook.State.Manager, Cook.State.Model + build-depends: base ==4.6.*, + attoparsec >=0.11 && <0.12, + base16-bytestring >=0.1 && <0.2, + bytestring >=0.10 && <0.11, + conduit >=1.1 && <1.2, + cryptohash >=0.11 && <0.12, + directory >=1.2 && <1.3, + filepath >=1.3 && <1.4, + conduit-combinators >=0.2 && <0.3, + conduit-extra >=1.1 && <1.2, + resourcet >=1.1 && <1.2, + regex-compat >=0.95 && <0.96, + process >=1.1 && <1.2, + system-filepath >=0.4 && <0.5, + temporary >=1.2 && <1.3, + text >=1.1 && <1.2, + transformers >= 0.3 && <0.4, + graph-core >= 0.2 && <0.3, + persistent-sqlite >= 1.3 && <1.4, + persistent-template >=1.3 && <1.4, + resourcet >= 0.4 && <1.2, + mtl >=2.1 && <2.2, + monad-logger >=0.3 && <0.4, + cereal >=0.4 && <0.5, + safecopy >=0.8 && <0.9, + time >=1.4 && <1.5, + stm >=2.4 && <2.5, + hashable >=1.2 && <1.3, + vector >=0.10 && <0.11, + unordered-containers >=0.2 && <0.3 + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + +executable dockercook + main-is: Main.hs + other-modules: Cook.ArgParse + build-depends: base ==4.6.*, + dockercook, + optparse-applicative >=0.8 && <0.9 + hs-source-dirs: src/prog + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + +test-suite dockercook-test + type: exitcode-stdio-1.0 + hs-source-dirs: src/test + main-is: Tests.hs + other-modules: Tests.BuildFile + build-depends: base ==4.6.*, + dockercook, + HTF >=0.11 && <0.13, + text >=1.1 && <1.2, + vector >=0.10 && <0.11 + ghc-options: -Wall -fno-warn-orphans diff --git a/src/lib/Cook/Build.hs b/src/lib/Cook/Build.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/Build.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} +module Cook.Build (cookBuild) where + +import Cook.BuildFile +import Cook.State.Manager +import Cook.Types +import Cook.Util + +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Conduit +import Data.Maybe (fromMaybe, isJust) +import System.Directory +import System.Exit +import System.FilePath +import System.IO (hPutStr, hPutStrLn, stderr) +import System.IO.Temp +import System.Process +import Text.Regex (mkRegex, matchRegex) +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Conduit.Combinators as C +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Traversable as T +import qualified Data.Vector as V +import qualified Filesystem.Path.CurrentOS as FP + +quickHash :: [BS.ByteString] -> SHA1 +quickHash bsList = + SHA1 $ SHA1.finalize (SHA1.updates SHA1.init bsList) + +fixTailingSlash :: FilePath -> FilePath +fixTailingSlash s = + case reverse s of + ('/':_) -> s + d -> reverse ('/':d) + +makeDirectoryFileHashTable :: (FP.FilePath -> Bool) -> FilePath -> IO [(FP.FilePath, SHA1)] +makeDirectoryFileHashTable ignore (FP.decodeString . fixTailingSlash -> root) = + do logInfo $ "Hashing directory tree at " ++ show root ++ ". This will take some time..." + x <- runResourceT $! C.sourceDirectoryDeep False root =$= C.concatMapM hashFile $$ C.sinkList + hPutStr stderr "\n" + logInfo "Done hashing your repo!" + return x + where + hashFile relToCurrentF = + case FP.stripPrefix root relToCurrentF of + Nothing -> + let cd = show $ FP.commonPrefix [root, relToCurrentF] + in fail ("Expected " ++ show relToCurrentF ++ " to start with " ++ show root ++ ". Common dirs:" ++ cd) + Just relToRootF -> hashFile' relToRootF relToCurrentF + hashFile' relToRootF relToCurrentF + | ignore relToRootF = + do logDebug ("Ignored " ++ show relToRootF) + return Nothing + | otherwise = + do logDebug ("Hashed " ++ show relToRootF) + bs <- C.sourceFile relToCurrentF $$ C.sinkList + liftIO $ hPutStr stderr "." + return $ Just (relToCurrentF, quickHash bs) + +buildImage :: CookConfig -> StateManager -> [(FP.FilePath, SHA1)] -> BuildFile -> IO DockerImage +buildImage cfg@(CookConfig{..}) stateManager fileHashes bf = + do baseImage <- + case bf_base bf of + (BuildBaseCook parentBuildFile) -> + do parent <- prepareEntryPoint cc_buildFileDir parentBuildFile + buildImage cfg stateManager fileHashes parent + (BuildBaseDocker rootImage) -> + do baseExists <- dockerImageExists rootImage + if baseExists + then do markUsingImage stateManager rootImage Nothing + return rootImage + else do logInfo $ "Downloading the root image " ++ show (unDockerImage rootImage) ++ "... " + (ec, stdOut, _) <- + readProcessWithExitCode "docker" ["pull", T.unpack $ unDockerImage rootImage] "" + if ec == ExitSuccess + then do markUsingImage stateManager rootImage Nothing + return rootImage + else error ("Can't find provided base docker image " + ++ (show $ unDockerImage rootImage) ++ ": " ++ stdOut) + + logInfo $ "Computing hashes for " ++ (T.unpack $ unBuildFileId $ bf_name bf) + let dockerBS = + BSC.concat [ "FROM ", T.encodeUtf8 (unDockerImage baseImage), "\n" + , T.encodeUtf8 $ T.unlines $ V.toList $ V.map dockerCmdToText (bf_dockerCommands bf) + ] + dockerHash = quickHash [dockerBS] + allFHashes = map snd targetedFiles + buildFileHash = quickHash [BSC.pack (show bf)] + superHash = B16.encode $ unSha1 $ quickHash (map unSha1 (dockerHash : buildFileHash : allFHashes)) + imageName = DockerImage $ T.concat ["cook-", T.decodeUtf8 superHash] + logInfo $ "Image name will be " ++ (T.unpack $ unDockerImage imageName) + let markImage = markUsingImage stateManager imageName (Just baseImage) + imageExists <- dockerImageExists imageName + if imageExists + then do logInfo "The image already exists!" + markImage + return imageName + else do logInfo "Image not found!" + x <- launchImageBuilder dockerBS imageName + markImage + return x + where + dockerImageExists localIm@(DockerImage imageName) = + do logInfo $ "Checking if the image " ++ show imageName ++ " is already present... " + known <- isImageKnown stateManager localIm + if known + then do logInfo $ "Image " ++ show imageName ++ " is registered in your state directory. Assuming it is present!" + return True + else do (ec, stdOut, _) <- readProcessWithExitCode "docker" ["images"] "" + let imageLines = T.lines $ T.pack stdOut + return $ ec == ExitSuccess && checkLines imageName imageLines + where + checkLines _ [] = False + checkLines im (line:xs) = + let (imageBaseName, vers) = T.break (==':') im + in if T.isPrefixOf imageBaseName line + then if vers == "" + then True + else if T.isInfixOf (T.drop 1 vers) line + then True + else checkLines im xs + else checkLines im xs + + launchImageBuilder dockerBS imageName = + withSystemTempDirectory "cook-docker-build" $ \tempDir -> + do mapM_ (\(f,_) -> + do let dirC = tempDir (FP.encodeString $ localName $ FP.directory f) + copySrc = FP.encodeString f + targetSrc = tempDir (FP.encodeString $ localName f) + when (dirC /= "") $ + do putStrLn ("mkdir -p " ++ dirC) + createDirectoryIfMissing True dirC + putStrLn ("cp " ++ copySrc ++ " " ++ targetSrc) + copyFile copySrc targetSrc + ) targetedFiles + logInfo "Writing Dockerfile ..." + BS.writeFile (tempDir "Dockerfile") dockerBS + logInfo ("Building docker container...") + let tag = T.unpack $ unDockerImage imageName + ecDocker <- system $ "docker build --rm -t " ++ tag ++ " " ++ tempDir + if ecDocker == ExitSuccess + then return imageName + else do hPutStrLn stderr ("Failed to build " ++ tag ++ "!") + hPutStrLn stderr ("Saving temp directory to COOKFAILED.") + _ <- system $ "rm -rf COOKFAILED; cp -r " ++ tempDir ++ " COOKFAILED" + exitWith ecDocker + localName fp = + case FP.stripPrefix (FP.decodeString $ fixTailingSlash cc_dataDir) fp of + Nothing -> error ("Expected " ++ show fp ++ " to start with " ++ cc_dataDir) + Just x -> x + matchesFile fp pattern = matchesFilePattern pattern (FP.encodeString (localName fp)) + isNeededHash fp = or (map (matchesFile fp) (V.toList (bf_include bf))) + targetedFiles = filter (\(fp, _) -> isNeededHash fp) fileHashes + + +cookBuild :: CookConfig -> IO () +cookBuild cfg@(CookConfig{..}) = + do stateManager <- createStateManager cc_stateDir + boring <- liftM (fromMaybe []) $ T.mapM (liftM parseBoring . T.readFile) cc_boringFile + fileHashes <- makeDirectoryFileHashTable (isBoring boring) cc_dataDir + roots <- + mapM ((prepareEntryPoint cc_buildFileDir) . BuildFileId . T.pack) cc_buildEntryPoints + mapM_ (buildImage cfg stateManager fileHashes) roots + logInfo "All done!" + return () + where + parseBoring = + map (mkRegex . T.unpack) . filter (not . ("#" `T.isPrefixOf`) . T.strip) . T.lines + isBoring boring fp = + any (isJust . flip matchRegex (FP.encodeString fp)) boring + +prepareEntryPoint :: FilePath -> BuildFileId -> IO BuildFile +prepareEntryPoint buildFileDir (BuildFileId entryPoint) = + do let n = buildFileDir (T.unpack entryPoint) + mRes <- parseBuildFile n + case mRes of + Left errMsg -> + error ("Failed to parse EntryPoint " ++ show n ++ ": " ++ errMsg) + Right ep -> + do logInfo $ "Parsed " ++ show n ++ " ..." + return ep diff --git a/src/lib/Cook/BuildFile.hs b/src/lib/Cook/BuildFile.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/BuildFile.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +module Cook.BuildFile + ( BuildFileId(..), BuildFile(..), BuildBase(..), DockerCommand(..) + , dockerCmdToText + , parseBuildFile, parseBuildFileText + , FilePattern, matchesFilePattern, parseFilePattern + ) +where + +import Cook.Types + +import Control.Applicative +import Data.Attoparsec.Text hiding (take) +import Data.Char +import Data.List (find) +import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.IO as T + +newtype BuildFileId + = BuildFileId { unBuildFileId :: T.Text } + deriving (Show, Eq) + +data BuildFile + = BuildFile + { bf_name :: BuildFileId + , bf_base :: BuildBase + , bf_dockerCommands :: V.Vector DockerCommand + , bf_include :: V.Vector FilePattern + } deriving (Show, Eq) + +data BuildBase + = BuildBaseDocker DockerImage + | BuildBaseCook BuildFileId + deriving (Show, Eq) + +data BuildFileLine + = IncludeLine FilePattern + | BaseLine BuildBase + | DockerLine DockerCommand + deriving (Show, Eq) + +data DockerCommand + = DockerCommand + { dc_command :: T.Text + , dc_args :: T.Text + } deriving (Show, Eq) + +newtype FilePattern + = FilePattern { _unFilePattern :: [PatternPart] } + deriving (Show, Eq) + +data PatternPart + = PatternText String + | PatternWildCard + deriving (Show, Eq) + +dockerCmdToText :: DockerCommand -> T.Text +dockerCmdToText (DockerCommand cmd args) = + T.concat [cmd, " ", args] + +matchesFilePattern :: FilePattern -> FilePath -> Bool +matchesFilePattern (FilePattern []) [] = True +matchesFilePattern (FilePattern []) _ = False +matchesFilePattern (FilePattern _) [] = False +matchesFilePattern (FilePattern (x : xs)) fp = + case x of + PatternText t -> + if all (uncurry (==)) (zip t fp) + then matchesFilePattern (FilePattern xs) (drop (length t) fp) + else False + PatternWildCard -> + case xs of + (PatternText nextToken : _) -> + case T.breakOn (T.pack nextToken) (T.pack fp) of + (_, "") -> False + (_, rest) -> + matchesFilePattern (FilePattern xs) (T.unpack rest) + (PatternWildCard : _) -> + matchesFilePattern (FilePattern xs) fp + [] -> True + +constructBuildFile :: FilePath -> [BuildFileLine] -> Either String BuildFile +constructBuildFile fp theLines = + case baseLine of + Just (BaseLine base) -> + baseCheck base $ foldl handleLine (BuildFile myId base V.empty V.empty) theLines + _ -> + Left "Missing BASE line!" + where + baseCheck base onSuccess = + case base of + BuildBaseCook cookId -> + if cookId == myId + then Left "Recursive BASE line! You are referencing yourself." + else Right onSuccess + _ -> Right onSuccess + myId = + BuildFileId (T.pack fp) + baseLine = + flip find theLines $ \l -> + case l of + BaseLine _ -> True + _ -> False + handleLine buildFile line = + case line of + (DockerLine dockerCmd) -> + buildFile { bf_dockerCommands = (V.snoc (bf_dockerCommands buildFile) dockerCmd) } + (IncludeLine pattern) -> + buildFile { bf_include = (V.snoc (bf_include buildFile) pattern) } + _ -> buildFile + +parseBuildFile :: FilePath -> IO (Either String BuildFile) +parseBuildFile fp = + do t <- T.readFile fp + return $ parseBuildFileText fp t + +parseBuildFileText :: FilePath -> T.Text -> Either String BuildFile +parseBuildFileText fp t = + case parseOnly pBuildFile t of + Left err -> Left err + Right theLines -> + constructBuildFile fp theLines + +parseFilePattern :: T.Text -> Either String FilePattern +parseFilePattern pattern = + parseOnly pFilePattern pattern + +isValidFileNameChar :: Char -> Bool +isValidFileNameChar c = + c /= ' ' && c /= '\n' && c /= '\t' + +pBuildFile :: Parser [BuildFileLine] +pBuildFile = + many1 lineP + where + finish = + (optional pComment) *> ((() <$ many endOfLine) <|> endOfInput) + lineP = + (many (pComment <* endOfLine)) *> lineP' + lineP' = + IncludeLine <$> (pIncludeLine <* finish) <|> + BaseLine <$> (pBuildBase <* finish) <|> + DockerLine <$> (pDockerCommand <* finish) + +pBuildBase :: Parser BuildBase +pBuildBase = + (asciiCI "BASE" *> skipSpace) *> pBase + where + pBase = + BuildBaseDocker <$> (asciiCI "DOCKER" *> skipSpace *> (DockerImage <$> takeWhile1 (not . eolOrComment))) <|> + BuildBaseCook <$> (asciiCI "COOK" *> skipSpace *> (BuildFileId <$> takeWhile1 isValidFileNameChar)) + +pDockerCommand :: Parser DockerCommand +pDockerCommand = + DockerCommand <$> (takeWhile1 isAlpha <* skipSpace) + <*> (T.stripEnd <$> takeWhile1 (not . eolOrComment)) + +eolOrComment :: Char -> Bool +eolOrComment x = + isEndOfLine x || x == '#' + +pComment :: Parser () +pComment = + (skipSpace *> char '#' *> skipSpace) *> (skipWhile (not . isEndOfLine)) + +pIncludeLine :: Parser FilePattern +pIncludeLine = + (asciiCI "INCLUDE" *> skipSpace) *> pFilePattern + +pFilePattern :: Parser FilePattern +pFilePattern = + FilePattern <$> many1 pPatternPart + where + pPatternPart = + PatternWildCard <$ char '*' <|> + PatternText <$> (T.unpack <$> takeWhile1 (\x -> x /= '*' && (not $ isSpace x))) diff --git a/src/lib/Cook/Clean.hs b/src/lib/Cook/Clean.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/Clean.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse #-} +module Cook.Clean (cookClean) where + +import Cook.State.Manager +import Cook.State.Model +import Cook.Types +import Cook.Util + +import Data.Time.Clock +import System.Exit +import System.Process +import qualified Data.Text as T + +cookClean :: FilePath -> Int -> IO () +cookClean stateDir daysToKeep = + do stateManager <- createStateManager stateDir + now <- getCurrentTime + let cleanUpPred imageMeta = + now `diffUTCTime` (dbDockerImageLastUsed imageMeta) > (fromIntegral $ daysToKeep * 24 * 60 * 60) + dockerRm (DockerImage imageName) = + do logInfo $ "Deleting image " ++ show imageName + (ec, _, stdErr) <- + readProcessWithExitCode "docker" ["rmi", T.unpack imageName] "" + if (ec /= ExitSuccess) + then do logInfo $ "Error: " ++ stdErr + return False + else return True + + _ <- garbageCollectImages stateManager cleanUpPred dockerRm + return () diff --git a/src/lib/Cook/State/Manager.hs b/src/lib/Cook/State/Manager.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/State/Manager.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DoAndIfThenElse #-} +module Cook.State.Manager + ( StateManager + , createStateManager, markUsingImage + , isImageKnown + , garbageCollectImages + ) +where + +import Cook.Util +import Cook.State.Model +import Cook.Types + +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad.Logger hiding (logInfo) +import Control.Monad.State +import Control.Monad.Trans.Resource +import Data.Maybe +import Data.SafeCopy (safeGet, safePut) +import Data.Serialize.Get (runGet) +import Data.Serialize.Put (runPut) +import Data.Time.Clock +import Database.Persist.Sqlite +import System.Directory +import System.FilePath +import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HM +import qualified Data.Graph as G +import qualified Data.Graph.NodeManager as NM +import qualified Data.Graph.Persistence as GP +import qualified Data.Text as T +import qualified Data.Traversable as T +import qualified Data.Vector.Unboxed as VU + +data StateManager + = StateManager + { sm_runSql :: forall a. SqlPersistM a -> IO a + , sm_graph :: TVar G.Graph + , sm_nodeManager :: TVar (NM.NodeManager DockerImage) + , sm_persistGraph :: IO () + } + +createStateManager :: FilePath -> IO StateManager +createStateManager stateDirectory = + do pool <- createSqlitePool (T.pack sqlLoc) 5 + let runSql = runResourceT . runNoLoggingT . ((flip runSqlPool) pool) + runSql (runMigration migrateState) + exists <- doesFileExist graphFile + (g, nm) <- + case exists of + True -> + do bs <- BS.readFile graphFile + case runGet safeGet bs of + Left errMsg -> + error ("Failed to read " ++ graphFile ++ ": " ++ errMsg) + Right persistedGraph -> + let (lnm, lg) = GP.loadGraph persistedGraph + in (,) <$> newTVarIO lg <*> newTVarIO lnm + False -> + (,) <$> newTVarIO G.empty <*> newTVarIO NM.emptyNodeManager + return $ StateManager + { sm_runSql = runSql + , sm_graph = g + , sm_nodeManager = nm + , sm_persistGraph = persistGraph g nm + } + where + sqlLoc = stateDirectory "database.db" + graphFile = stateDirectory "graph.bin" + persistGraph gVar nmVar = + do nm <- atomically $ readTVar nmVar + g <- atomically $ readTVar gVar + BS.writeFile graphFile $ runPut (safePut $ GP.persistGraph nm g) + +data GCState + = GCState + { gc_canTrash :: !(HM.HashMap NM.Node (Bool, DockerImage)) + , gc_trashCount :: !Int + , gc_cache :: !(HM.HashMap DockerImage DbDockerImage) + } deriving (Show) + +data SweepState + = SweepState + { ss_graph :: !(G.Graph) + , ss_removedImages :: [DockerImage] + } deriving (Show) + +garbageCollectImages :: StateManager + -> (DbDockerImage -> Bool) + -> (DockerImage -> IO Bool) + -> IO [DockerImage] +garbageCollectImages (StateManager{..}) deletePred deleteFun = + do graph <- atomically $ readTVar sm_graph + nodeManager <- atomically $ readTVar sm_nodeManager + let graphLeafs = filter (\n -> VU.null $ G.parents graph n) (G.nodes graph) + logInfo ("Found " ++ (show (length graphLeafs)) ++ " toplevel image(s). Starting mark and sweep") + gcState <- execStateT (mapM (markNode graph nodeManager) graphLeafs) (GCState HM.empty 0 HM.empty) + logInfo ("Found " ++ (show (gc_trashCount gcState)) ++ " deletable image(s).") + sweepState <- execStateT (sweepNodes gcState nodeManager graphLeafs) (SweepState graph []) + return (reverse $ ss_removedImages sweepState) + where + sweepNodes :: GCState -> NM.NodeManager DockerImage -> [NM.Node] -> StateT SweepState IO () + sweepNodes gcState nodeManager [] = + do currentGraph <- gets ss_graph + alreadyRemoved <- gets ss_removedImages + let nextLeafs = + filter (\n -> + let isLeaf = VU.null $ G.parents currentGraph n + trashable = + case HM.lookup n (gc_canTrash gcState) of + Just (True, imageName) -> + not $ imageName `elem` alreadyRemoved + _ -> False + in isLeaf && trashable + ) (G.nodes currentGraph) + if length nextLeafs == 0 + then return () + else sweepNodes gcState nodeManager nextLeafs + sweepNodes gcState nodeManager (node:rest) = + do currentGraph <- gets ss_graph + case HM.lookup node (gc_canTrash gcState) of + Just (True, imageName) -> + do let g' = G.removeNode node currentGraph + nm' = NM.removeNodeHandle node nodeManager + liftIO $ + do deleteOk <- deleteFun imageName + when (not deleteOk) $ + error ("Failed to delete " ++ (T.unpack $ unDockerImage imageName) ++ ". Aborting!") + atomically $ + do writeTVar sm_nodeManager nm' + writeTVar sm_graph g' + sm_persistGraph + sm_runSql $ deleteBy (UniqueGraphNodeId node) + modify $ \st -> + st + { ss_graph = g' + , ss_removedImages = (imageName : ss_removedImages st) + } + sweepNodes gcState nm' rest + _ -> + sweepNodes gcState nodeManager rest + + markNode :: G.Graph -> NM.NodeManager DockerImage -> NM.Node -> StateT GCState IO Bool + markNode graph nodeManager node = + do let dockerImage = + case NM.lookupNode node nodeManager of + Nothing -> + error ("dockercook inconsistency: found node in image graph without any dockerimage!") + Just d -> d + children = G.children graph node + trashCheck (Just False) _ = return (Just False) + trashCheck x [] = return x + trashCheck _ (x:xs) = + do trashState <- gets gc_canTrash + r <- + case HM.lookup x trashState of + Nothing -> markNode graph nodeManager x + Just (v, _) -> return v + trashCheck (Just r) xs + markAs x = + do modify $ \s -> + s { gc_canTrash = HM.insert node (x, dockerImage) (gc_canTrash s) + , gc_trashCount = (if x then 1 else 0) + (gc_trashCount s) + } + return x + mCanTrash <- trashCheck Nothing $ VU.toList children + case mCanTrash of + Just False -> + markAs False + _ -> + do cacheMap <- gets gc_cache + dbInfo <- + case HM.lookup dockerImage cacheMap of + Nothing -> + do mDbInfo <- liftIO $ sm_runSql $ getBy (UniqueGraphNodeId node) + case mDbInfo of + Nothing -> + error ("dockercook inconsistency: found node in image graph without any meta data!") + Just someInfo -> + do let e = entityVal someInfo + modify $ \s -> + s { gc_cache = HM.insert dockerImage e (gc_cache s) } + return e + Just info -> + return info + markAs $ deletePred dbInfo + +isImageKnown :: StateManager -> DockerImage -> IO Bool +isImageKnown (StateManager{..}) (DockerImage imageName) = + do x <- sm_runSql $ getBy (UniqueDbDockerImage imageName) + return (isJust x) + +markUsingImage :: StateManager -> DockerImage -> Maybe DockerImage -> IO () +markUsingImage (StateManager{..}) img@(DockerImage imageName) mParentImage = + do parentEntity <- + T.mapM (sm_runSql . findParentImage) mParentImage + mImageEntity <- sm_runSql $ getBy (UniqueDbDockerImage imageName) + now <- getCurrentTime + case mImageEntity of + Nothing -> + do newNodeId <- + atomically $ + do nm <- readTVar sm_nodeManager + (nodeId, newNm) <- + runStateT (NM.getNodeHandle img) nm + writeTVar sm_nodeManager newNm + modifyTVar sm_graph $ \g -> + case parentEntity of + Nothing -> + G.addNode nodeId g + Just pe -> + G.addEdge nodeId (dbDockerImageNodeId $ entityVal pe) g + return nodeId + _ <- sm_runSql $ insert $ DbDockerImage imageName now now 1 newNodeId + sm_persistGraph + return () + Just imageEntity -> + sm_runSql $ update (entityKey imageEntity) [ DbDockerImageUsageCount +=. 1 + , DbDockerImageLastUsed =. now + ] + where + findParentImage (DockerImage parentImageName) = + do mParentEntity <- getBy (UniqueDbDockerImage parentImageName) + case mParentEntity of + Just entity -> return entity + Nothing -> + error ("dockercook inconsistency: parent image " + ++ show parentImageName ++ " referenced but unknown to database.") diff --git a/src/lib/Cook/State/Model.hs b/src/lib/Cook/State/Model.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/State/Model.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Cook.State.Model where + +import Data.Time.Clock +import Database.Persist.TH +import qualified Data.Text as T + +share [mkPersist sqlSettings, mkMigrate "migrateState"] [persistLowerCase| +DbDockerImage + name T.Text + creationDate UTCTime + lastUsed UTCTime + usageCount Int + nodeId Int + UniqueDbDockerImage name + UniqueGraphNodeId nodeId + deriving Show +|] diff --git a/src/lib/Cook/Types.hs b/src/lib/Cook/Types.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/Types.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Cook.Types where + +import Data.Hashable +import Data.SafeCopy +import qualified Data.ByteString as BS +import qualified Data.Text as T + +data CookConfig + = CookConfig + { cc_stateDir :: FilePath + , cc_dataDir :: FilePath + , cc_buildFileDir :: FilePath + , cc_boringFile :: Maybe FilePath + , cc_buildEntryPoints :: [String] + } deriving (Show, Eq) + +newtype SHA1 = + SHA1 { unSha1 :: BS.ByteString } + deriving (Show, Eq) + +newtype DockerImage = + DockerImage { unDockerImage :: T.Text } + deriving (Show, Eq, Hashable, SafeCopy) diff --git a/src/lib/Cook/Util.hs b/src/lib/Cook/Util.hs new file mode 100644 --- /dev/null +++ b/src/lib/Cook/Util.hs @@ -0,0 +1,10 @@ +module Cook.Util where + +import Control.Monad.Trans +import System.IO (hPutStrLn, stderr) + +logInfo :: MonadIO m => String -> m () +logInfo = liftIO . hPutStrLn stderr + +logDebug :: MonadIO m => String -> m () +logDebug _ = return () diff --git a/src/prog/Cook/ArgParse.hs b/src/prog/Cook/ArgParse.hs new file mode 100644 --- /dev/null +++ b/src/prog/Cook/ArgParse.hs @@ -0,0 +1,54 @@ +module Cook.ArgParse (argParse, CookCmd(..)) where + +import Cook.Types +import Options.Applicative + +data CookCmd + = CookBuild CookConfig + | CookClean FilePath Int + | CookList + deriving (Show, Eq) + +cookKeepDaysP = + option ( long "keep" <> short 'k' <> metavar "DAYS" <> help "Days of docker images to keep") + +cookStateP = + strOption ( long "state" <> short 's' <> metavar "DIRECTORY" <> help "Directory where dockercook stores its meta info") + +cookDataP = + strOption ( long "data" <> short 'd' <> metavar "DIRECTORY" <> help "Directory where to find source files") + +cookBuildP = + strOption ( long "buildfiles" <> short 'b' <> metavar "DIRECTORY" <> help "Directory of dockercook files") + +cookEntryPointP = + some $ strOption ( long "entrypoint" <> short 'p' <> metavar "ENTRYPOINT" <> help "dockercook targets") + +cookBoringP = + optional $ strOption ( long "ignore" <> short 'i' <> metavar "FILENAME" + <> help "File with regex list of ignored files." ) + +cookOptions :: Parser CookCmd +cookOptions = + CookBuild <$> + (CookConfig <$> cookStateP + <*> cookDataP + <*> cookBuildP + <*> cookBoringP + <*> cookEntryPointP) + +cookClean :: Parser CookCmd +cookClean = + CookClean <$> cookStateP <*> cookKeepDaysP + +cookHelp :: Parser CookCmd +cookHelp = + pure CookList + +argParse :: Parser CookCmd +argParse = + subparser + ( command "cook" (info cookOptions ( progDesc "Cook docker images" )) + <> command "clean" (info cookClean ( progDesc "Cleanup docker images that are no longer needed" )) + <> command "help" (info cookHelp ( progDesc "List cook commands" )) + ) diff --git a/src/prog/Main.hs b/src/prog/Main.hs new file mode 100644 --- /dev/null +++ b/src/prog/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import Cook.ArgParse +import Cook.Build +import Cook.Clean +import Options.Applicative + +runProg :: CookCmd -> IO () +runProg cmd = + case cmd of + CookBuild buildCfg -> + cookBuild buildCfg + CookClean stateDir daysToKeep -> + cookClean stateDir daysToKeep + CookList -> + do putStrLn "Available commands:" + putStrLn "- cook" + putStrLn "- clean" + +main :: IO () +main = + execParser (info argParse idm) >>= runProg diff --git a/src/test/Tests.hs b/src/test/Tests.hs new file mode 100644 --- /dev/null +++ b/src/test/Tests.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Main where + +import Test.Framework +import {-@ HTF_TESTS @-} Tests.BuildFile + +main :: IO () +main = htfMain htf_importedTests diff --git a/src/test/Tests/BuildFile.hs b/src/test/Tests/BuildFile.hs new file mode 100644 --- /dev/null +++ b/src/test/Tests/BuildFile.hs @@ -0,0 +1,67 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE OverloadedStrings #-} +module Tests.BuildFile (htf_thisModulesTests) where + +import Cook.BuildFile +import Cook.Types + +import Test.Framework +import qualified Data.Vector as V +import qualified Data.Text as T + +test_matchFilePattern :: IO () +test_matchFilePattern = + do assertBool (matchesFilePattern pattern1 "foo/bar.cabal") + assertBool (not $ matchesFilePattern pattern1 "foo/baz.cabal") + assertBool (matchesFilePattern pattern2 "foo/hellooooo.cabal") + assertBool (not $ matchesFilePattern pattern2 "foo/hellooooo.cabal.xzy") + assertBool (not $ matchesFilePattern pattern2 "foo/hellooooo.xzy") + assertBool (matchesFilePattern pattern3 "foo/asdasdas") + assertBool (matchesFilePattern pattern3 "foo/bar/asdasdas") + where + Right pattern1 = parseFilePattern "foo/bar.cabal" + Right pattern2 = parseFilePattern "foo/*.cabal" + Right pattern3 = parseFilePattern "foo/*" + +test_parseBuildFile :: IO () +test_parseBuildFile = + do assertEqual (BuildBaseDocker $ DockerImage "ubuntu:14.04") (bf_base parsed1) + assertEqual parsed1 parsed2 + assertEqual (BuildBaseCook $ BuildFileId "foo.build") (bf_base parsed3) + assertEqual commands (bf_dockerCommands parsed3) + assertEqual parsed3 parsed4 + where + commands = + V.fromList [ DockerCommand "RUN" "apt-get -y install node" + , DockerCommand "ADD" ". /foo" + ] + Right parsed1 = parseBuildFileText "sample1" sampleFile1 + Right parsed2 = parseBuildFileText "sample1" sampleFile2 + Right parsed3 = parseBuildFileText "sample3" sampleFile3 + Right parsed4 = parseBuildFileText "sample3" sampleFile4 + + sampleFile1 = + "BASE DOCKER ubuntu:14.04" + sampleFile2 = + "BASE DOCKER ubuntu:14.04#asdf" + sampleFile3 = + T.concat + [ "BASE COOK foo.build\n" + , "INCLUDE server/foo.cabal\n" + , "INCLUDE server/*.js\n" + , "RUN apt-get -y install node\n" + , "ADD . /foo" + ] + sampleFile4 = + T.concat + [ "# Comment!\n" + , "#Comment\n" + , " # Comment\n" + , "BASE COOK foo.build\n\n" + , "INCLUDE server/foo.cabal # comment\n" + , "INCLUDE server/*.js\n" + , "RUN apt-get -y install node # comment\n" + , "ADD . /foo\n" + , "# comment\n" + , "\n" + ]