{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Cook.BuildFile ( BuildFileId(..), BuildFile(..), BuildBase(..), DockerCommand(..), TxRef , dockerCmdToText , parseBuildFile , buildTxScripts, copyTarAndUnpack , FilePattern, matchesFilePattern, parseFilePattern -- don't use - only exported for testing , parseBuildFileText ) where import Cook.Types import Cook.Util import Control.Applicative import Control.Monad import Data.Attoparsec.Text hiding (take) import Data.Char import Data.Hashable import Data.List (find) import Data.Maybe import System.FilePath import System.IO.Temp import System.Process (readProcessWithExitCode) import System.Exit (ExitCode(..)) import qualified Data.Vector as V import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HM newtype BuildFileId = BuildFileId { unBuildFileId :: T.Text } deriving (Show, Eq) newtype TxRef = TxRef { _unTxRef :: Int } deriving (Show, Eq, Hashable) data BuildFile = BuildFile { bf_name :: BuildFileId , bf_base :: BuildBase , bf_unpackTarget :: Maybe FilePath , bf_dockerCommands :: V.Vector (Either TxRef DockerCommand) , bf_include :: V.Vector FilePattern , bf_prepare :: V.Vector T.Text , bf_transactions :: HM.HashMap TxRef (V.Vector T.Text) } deriving (Show, Eq) data BuildBase = BuildBaseDocker DockerImage | BuildBaseCook BuildFileId deriving (Show, Eq) data BuildFileLine = IncludeLine FilePattern -- copy files from data directory to temporary cook directory | BaseLine BuildBase -- use either cook file or docker image as base | PrepareLine T.Text -- run shell command in temporary cook directory | UnpackLine FilePath -- where should the context be unpacked to? | ScriptLine FilePath (Maybe T.Text) -- execute a script in cook directory to generate more cook commands | BeginTxLine | CommitTxLine | DockerLine DockerCommand -- regular docker command 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 buildTxScripts :: FilePath -> BuildFile -> IO (V.Vector DockerCommand, SHA1) buildTxScripts dockerFileEnvDir bf = withSystemTempDirectory "cooktx" $ \txDir -> do txSh <- forM (HM.toList (bf_transactions bf)) $ \(TxRef refId, actions) -> do let f = "tx_" ++ show refId ++ ".sh" sh = mkScript refId actions T.writeFile (txDir f) sh return (f, T.encodeUtf8 sh) case (null txSh) of False -> do compressFilesInDir tarFile txDir (map fst txSh) return ( V.concat [pre, V.map mkTxLine (bf_dockerCommands bf), post] , if null txSh then quickHash ["no-tx"] else quickHash (map snd txSh) ) True -> return (V.map mkTxLine (bf_dockerCommands bf), quickHash ["no-tx"]) where mkTxLine l = case l of Left (TxRef refId) -> DockerCommand "RUN" (T.pack $ "bash " ++ (dockerTarDir "tx_" ++ show refId ++ ".sh")) Right cmd -> cmd pre = V.fromList (copyTarAndUnpack "tx.tar.gz" dockerTarDir) post = V.fromList [ DockerCommand "RUN" (T.pack $ "rm -rf " ++ dockerTarDir) ] dockerTarDir = "/tmp/dockercooktx" tarFile = dockerFileEnvDir "tx.tar.gz" mkScript txId scriptLines = T.unlines ("#!/bin/bash" : "# auto generated by dockercook" : (T.pack $ "echo 'DockercookTx # " ++ show txId ++ "'") : "set -e" : "set -x" : V.toList scriptLines ) copyTarAndUnpack :: FilePath -> FilePath -> [DockerCommand] copyTarAndUnpack tarName imageDest = [ DockerCommand "COPY" (T.pack $ tarName ++ " /" ++ tarName) , DockerCommand "RUN" $ T.pack $ "mkdir -p " ++ imageDest ++ " && /usr/bin/env tar xvk --skip-old-files -f /" ++ tarName ++ " -C " ++ imageDest ++ " && rm -rf /" ++ tarName ] constructBuildFile :: FilePath -> FilePath -> [BuildFileLine] -> IO (Either String BuildFile) constructBuildFile cookDir fp theLines = case baseLine of Just (BaseLine base) -> baseCheck base $ handleLine (Right $ BuildFile myId base Nothing V.empty V.empty V.empty HM.empty) Nothing theLines _ -> return $ Left "Missing BASE line!" where checkDocker (DockerCommand cmd _) action = let lowerCmd = T.toLower cmd in case lowerCmd of "from" -> return $ Left "FROM command is not allowed in dockercook files" "add" -> do logWarn "ADD commands are not recommended as the dependencies aren't tracked. Use PREPARE!" action "copy" -> do logWarn "COPY commands are not recommended as the dependencies aren't tracked. Use PREPARE!" action _ -> action baseCheck base onSuccess = case base of BuildBaseCook cookId -> if cookId == myId then return $ Left "Recursive BASE line! You are referencing yourself." else onSuccess _ -> onSuccess myId = BuildFileId (T.pack fp) baseLine = flip find theLines $ \l -> case l of BaseLine _ -> True _ -> False handleLine mBuildFile _ [] = return mBuildFile handleLine mBuildFile inTx (line : rest) = case mBuildFile of Left err -> return $ Left err Right buildFile -> case inTx of Just currentTx -> case line of DockerLine dockerCmd -> checkDocker dockerCmd $ handleLineTx dockerCmd buildFile currentTx rest ScriptLine scriptLoc mArgs -> handleScriptLine scriptLoc mArgs buildFile inTx rest CommitTxLine -> handleLine (Right buildFile) Nothing rest _ -> return $ Left "Only RUN and SCRIPT commands are allowed in transactions" Nothing -> case line of ScriptLine scriptLoc mArgs -> handleScriptLine scriptLoc mArgs buildFile inTx rest DockerLine dockerCmd -> checkDocker dockerCmd $ handleLine (Right $ buildFile { bf_dockerCommands = V.snoc (bf_dockerCommands buildFile) (Right dockerCmd) }) inTx rest IncludeLine pattern -> handleLine (Right $ buildFile { bf_include = V.snoc (bf_include buildFile) pattern }) inTx rest PrepareLine cmd -> handleLine (Right $ buildFile { bf_prepare = V.snoc (bf_prepare buildFile) cmd }) inTx rest UnpackLine unpackTarget -> handleLine (Right $ buildFile { bf_unpackTarget = Just unpackTarget }) inTx rest BeginTxLine -> let nextTxId = TxRef (HM.size (bf_transactions buildFile)) in handleLine (Right $ buildFile { bf_dockerCommands = V.snoc (bf_dockerCommands buildFile) (Left nextTxId) }) (Just nextTxId) rest CommitTxLine -> return $ Left "COMMIT is missing a BEGIN!" _ -> handleLine mBuildFile inTx rest handleScriptLine scriptLoc mArgs buildFile inTx rest = do let bashCmd = (cookDir scriptLoc) ++ " " ++ T.unpack (fromMaybe "" mArgs) (ec, stdOut, stdErr) <- readProcessWithExitCode "bash" ["-c", bashCmd] "" logDebug ("SCRIPT " ++ bashCmd ++ " returned: \n" ++ stdOut ++ "\n" ++ stdErr) if ec == ExitSuccess then case parseOnly pBuildFile (T.pack stdOut) of Left parseError -> return $ Left ("Failed to parse output of SCRIPT line " ++ bashCmd ++ ": " ++ parseError ++ "\nOutput was:\n" ++ stdOut) Right moreLines -> handleLine (Right buildFile) inTx (moreLines ++ rest) else return $ Left ("Failed to run SCRIPT line " ++ bashCmd ++ ": " ++ stdOut ++ "\n" ++ stdErr) handleLineTx (DockerCommand cmd args) buildFile txRef rest = if (T.toLower cmd /= "run") then return $ Left ("Only RUN commands are allowed in transaction blocks!") else do let updateF _ oldV = V.snoc oldV args buildFile' = buildFile { bf_transactions = HM.insertWith updateF txRef (V.singleton args) (bf_transactions buildFile) } handleLine (Right buildFile') (Just txRef) rest parseBuildFile :: CookConfig -> FilePath -> IO (Either String BuildFile) parseBuildFile cfg fp = do t <- T.readFile fp parseBuildFileText cfg fp t parseBuildFileText :: CookConfig -> FilePath -> T.Text -> IO (Either String BuildFile) parseBuildFileText cfg fp t = case parseOnly pBuildFile t of Left err -> return $ Left err Right theLines -> constructBuildFile (cc_buildFileDir cfg) 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 <* endOfInput where finish = pComment *> ((() <$ many endOfLine) <|> endOfInput) lineP = (many (pComment <* endOfLine)) *> lineP' lineP' = IncludeLine <$> (pIncludeLine <* finish) <|> BaseLine <$> (pBuildBase <* finish) <|> PrepareLine <$> (pPrepareLine <* finish) <|> UnpackLine <$> (pUnpackLine <* finish) <|> (pScriptLine <* finish) <|> BeginTxLine <$ (pBeginTx <* finish) <|> CommitTxLine <$ (pCommitTx <* finish) <|> DockerLine <$> (pDockerCommand <* finish) pBeginTx :: Parser () pBeginTx = asciiCI "BEGIN" *> skipSpace pCommitTx :: Parser () pCommitTx = asciiCI "COMMIT" *> skipSpace pUnpackLine :: Parser FilePath pUnpackLine = T.unpack <$> ((asciiCI "UNPACK" *> skipSpace) *> takeWhile1 isValidFileNameChar) 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 <* optional (char '#' *> skipWhile (not . isEndOfLine)) pIncludeLine :: Parser FilePattern pIncludeLine = (asciiCI "INCLUDE" *> skipSpace) *> pFilePattern pScriptLine :: Parser BuildFileLine pScriptLine = ScriptLine <$> (T.unpack <$> ((asciiCI "SCRIPT" *> skipSpace) *> (takeWhile1 isValidFileNameChar))) <*> (optional $ T.stripEnd <$> takeWhile1 (not . eolOrComment)) pPrepareLine :: Parser T.Text pPrepareLine = (asciiCI "PREPARE" *> skipSpace) *> takeWhile1 (not . eolOrComment) pFilePattern :: Parser FilePattern pFilePattern = FilePattern <$> many1 pPatternPart where pPatternPart = PatternWildCard <$ char '*' <|> PatternText <$> (T.unpack <$> takeWhile1 (\x -> x /= '*' && (not $ isSpace x)))