dockercook (empty) → 0.1.0.0
raw patch · 14 files changed
+932/−0 lines, 14 filesdep +HTFdep +attoparsecdep +basesetup-changed
Dependencies added: HTF, attoparsec, base, base16-bytestring, bytestring, cereal, conduit, conduit-combinators, conduit-extra, cryptohash, directory, dockercook, filepath, graph-core, hashable, monad-logger, mtl, optparse-applicative, persistent-sqlite, persistent-template, process, regex-compat, resourcet, safecopy, stm, system-filepath, temporary, text, time, transformers, unordered-containers, vector
Files
- LICENSE +19/−0
- Setup.hs +2/−0
- dockercook.cabal +69/−0
- src/lib/Cook/Build.hs +192/−0
- src/lib/Cook/BuildFile.hs +177/−0
- src/lib/Cook/Clean.hs +31/−0
- src/lib/Cook/State/Manager.hs +233/−0
- src/lib/Cook/State/Model.hs +24/−0
- src/lib/Cook/Types.hs +24/−0
- src/lib/Cook/Util.hs +10/−0
- src/prog/Cook/ArgParse.hs +54/−0
- src/prog/Main.hs +22/−0
- src/test/Tests.hs +8/−0
- src/test/Tests/BuildFile.hs +67/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dockercook.cabal view
@@ -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
+ src/lib/Cook/Build.hs view
@@ -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
+ src/lib/Cook/BuildFile.hs view
@@ -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)))
+ src/lib/Cook/Clean.hs view
@@ -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 ()
+ src/lib/Cook/State/Manager.hs view
@@ -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.")
+ src/lib/Cook/State/Model.hs view
@@ -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+|]
+ src/lib/Cook/Types.hs view
@@ -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)
+ src/lib/Cook/Util.hs view
@@ -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 ()
+ src/prog/Cook/ArgParse.hs view
@@ -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" ))+ )
+ src/prog/Main.hs view
@@ -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
+ src/test/Tests.hs view
@@ -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
+ src/test/Tests/BuildFile.hs view
@@ -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"+ ]