module Cook.BuildFile
( BuildFileId(..), BuildFile(..), BuildBase(..), DockerCommand(..), TxRef
, dockerCmdToText
, parseBuildFile
, buildTxScripts, copyTarAndUnpack
, FilePattern, matchesFilePattern, parseFilePattern
, 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
| BaseLine BuildBase
| PrepareLine T.Text
| UnpackLine FilePath
| ScriptLine FilePath (Maybe T.Text)
| BeginTxLine
| CommitTxLine
| 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
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)))