diff --git a/language-docker.cabal b/language-docker.cabal index 6886e78..ab78b01 100644 --- a/language-docker.cabal +++ b/language-docker.cabal @@ -4,10 +4,10 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 16d9c4402444a128ff719c0f88b1de7b2465020a9f4a721a18aeebf3ef5f276d +-- hash: 2c9caaab990151b5cf17795136674a3655d2422f22f1e4c84806741c1309e5bd name: language-docker -version: 9.3.0 +version: 10.0.0 synopsis: Dockerfile parser, pretty-printer and embedded DSL description: All functions for parsing and pretty-printing Dockerfiles are exported through @Language.Docker@. For more fine-grained operations look for specific modules that implement a certain functionality. See the for the source-code and examples. @@ -53,6 +53,7 @@ library Paths_language_docker hs-source-dirs: src + default-extensions: OverloadedStrings ImplicitParams Rank2Types ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-unused-do-bind -fno-warn-orphans build-depends: base >=4.8 && <5 @@ -71,11 +72,14 @@ test-suite hspec main-is: Spec.hs other-modules: Language.Docker.IntegrationSpec + Language.Docker.ParsePragmaSpec Language.Docker.ParserSpec Language.Docker.PrettyPrintSpec + TestHelper Paths_language_docker hs-source-dirs: test + default-extensions: OverloadedStrings ImplicitParams Rank2Types OverloadedLists build-depends: HUnit >=1.2 , QuickCheck diff --git a/package.yaml b/package.yaml index aad39ff..1a58fb6 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: language-docker -version: '9.3.0' +version: '10.0.0' synopsis: Dockerfile parser, pretty-printer and embedded DSL description: 'All functions for parsing and pretty-printing Dockerfiles are exported through @Language.Docker@. For more fine-grained operations look for @@ -24,6 +24,10 @@ extra-source-files: - README.md - test/fixtures/1.Dockerfile - test/fixtures/2.Dockerfile +default-extensions: + - OverloadedStrings + - ImplicitParams + - Rank2Types dependencies: - base >=4.8 && <5 @@ -56,6 +60,8 @@ tests: hspec: main: Spec.hs source-dirs: test + default-extensions: + - OverloadedLists dependencies: - hspec - QuickCheck diff --git a/src/Language/Docker/Parser.hs b/src/Language/Docker/Parser.hs index add0d4e..cc783fe 100644 --- a/src/Language/Docker/Parser.hs +++ b/src/Language/Docker/Parser.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.Parser ( parseText, parseFile, @@ -14,18 +12,18 @@ import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E -import Language.Docker.Parser.Instruction (parseInstruction) +import Language.Docker.Parser.Instruction (parseInstruction, parseComment) import Language.Docker.Parser.Prelude import Language.Docker.Syntax contents :: Parser a -> Parser a contents p = do - void $ takeWhileP Nothing (\c -> c == '\r' || c == '\n' || c == ' ' || c == '\t') + void onlyWhitespaces r <- p eof return r -dockerfile :: Parser Dockerfile +dockerfile :: (?esc :: Char) => Parser Dockerfile dockerfile = many $ do pos <- getSourcePos @@ -34,18 +32,38 @@ dockerfile = return $ InstructionPos i (T.pack . sourceName $ pos) (unPos . sourceLine $ pos) parseText :: Text -> Either Error Dockerfile -parseText = parse (contents dockerfile) "" . dos2unix +parseText txt = do + let ?esc = findEscapePragma (T.lines (dos2unix txt)) + in parse (contents dockerfile) "" (dos2unix txt) parseFile :: FilePath -> IO (Either Error Dockerfile) -parseFile file = doParse <$> B.readFile file - where - doParse = parse (contents dockerfile) file . dos2unix . E.decodeUtf8With E.lenientDecode +parseFile file = doParse file <$> B.readFile file -- | Reads the standard input until the end and parses the contents as a Dockerfile parseStdin :: IO (Either Error Dockerfile) -parseStdin = doParse <$> B.getContents +parseStdin = doParse "/dev/stdin" <$> B.getContents + +-- | Parses a list of lines from a dockerfile one by one until either the escape +-- | pragma has been found, or pragmas are no longer expected. +-- | Pragmas can occur only until a comment, an empty line or another +-- | instruction occurs (i.e. they have to be the first lines of a Dockerfile). +findEscapePragma :: [Text] -> Char +findEscapePragma [] = defaultEsc +findEscapePragma (l:ls) = + case parse (contents parseComment) "" l of + Left _ -> defaultEsc + Right (Pragma (Escape (EscapeChar c))) -> c + Right (Pragma _) -> findEscapePragma ls + Right _ -> defaultEsc + where + ?esc = defaultEsc + +doParse :: FilePath -> B.ByteString -> Either Error Dockerfile +doParse path txt = do + let ?esc = findEscapePragma (T.lines src) + in parse (contents dockerfile) path src where - doParse = parse (contents dockerfile) "/dev/stdin" . dos2unix . E.decodeUtf8With E.lenientDecode + src = dos2unix (E.decodeUtf8With E.lenientDecode txt) -- | Changes crlf line endings to simple line endings dos2unix :: T.Text -> T.Text diff --git a/src/Language/Docker/Parser/Arguments.hs b/src/Language/Docker/Parser/Arguments.hs index 7069430..2438ee2 100644 --- a/src/Language/Docker/Parser/Arguments.hs +++ b/src/Language/Docker/Parser/Arguments.hs @@ -8,16 +8,16 @@ import Language.Docker.Parser.Prelude import Language.Docker.Syntax -- Parse arguments of a command in the exec form -argumentsExec :: Parser (Arguments Text) +argumentsExec :: (?esc :: Char) => Parser (Arguments Text) argumentsExec = do args <- brackets $ commaSep stringLiteral return $ ArgumentsList (T.unwords args) -- Parse arguments of a command in the shell form -argumentsShell :: Parser (Arguments Text) +argumentsShell :: (?esc :: Char) => Parser (Arguments Text) argumentsShell = ArgumentsText <$> toEnd where toEnd = untilEol "the shell arguments" -arguments :: Parser (Arguments Text) +arguments :: (?esc :: Char) => Parser (Arguments Text) arguments = try argumentsExec <|> try argumentsShell diff --git a/src/Language/Docker/Parser/Cmd.hs b/src/Language/Docker/Parser/Cmd.hs index e9e84cf..3a1739b 100644 --- a/src/Language/Docker/Parser/Cmd.hs +++ b/src/Language/Docker/Parser/Cmd.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.Parser.Cmd ( parseCmd, ) @@ -9,7 +7,7 @@ import Language.Docker.Parser.Arguments import Language.Docker.Parser.Prelude import Language.Docker.Syntax -parseCmd :: Parser (Instruction Text) +parseCmd :: (?esc :: Char) => Parser (Instruction Text) parseCmd = do reserved "CMD" Cmd <$> arguments diff --git a/src/Language/Docker/Parser/Copy.hs b/src/Language/Docker/Parser/Copy.hs index 0ffa7ae..2aee2ca 100644 --- a/src/Language/Docker/Parser/Copy.hs +++ b/src/Language/Docker/Parser/Copy.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.Parser.Copy ( parseCopy, parseAdd, @@ -17,7 +15,7 @@ data CopyFlag | FlagSource CopySource | FlagInvalid (Text, Text) -parseCopy :: Parser (Instruction Text) +parseCopy :: (?esc :: Char) => Parser (Instruction Text) parseCopy = do reserved "COPY" flags <- copyFlag `sepEndBy` requiredWhitespace @@ -46,7 +44,7 @@ parseCopy = do f : _ -> f fileList "COPY" (\src dest -> Copy (CopyArgs src dest cho chm fr)) -parseAdd :: Parser (Instruction Text) +parseAdd :: (?esc :: Char) => Parser (Instruction Text) parseAdd = do reserved "ADD" flags <- copyFlag `sepEndBy` requiredWhitespace @@ -68,7 +66,9 @@ parseAdd = do c : _ -> c fileList "ADD" (\src dest -> Add (AddArgs src dest cho chm)) -fileList :: Text -> (NonEmpty SourcePath -> TargetPath -> Instruction Text) -> Parser (Instruction Text) +fileList :: (?esc :: Char) => Text -> + (NonEmpty SourcePath -> TargetPath -> Instruction Text) -> + Parser (Instruction Text) fileList name constr = do paths <- (try stringList "an array of strings [\"src_file\", \"dest_file\"]") @@ -85,32 +85,32 @@ unexpectedFlag :: Text -> Text -> Parser a unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name) unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name) -copyFlag :: Parser CopyFlag +copyFlag :: (?esc :: Char) => Parser CopyFlag copyFlag = (FlagChown <$> try chown "only one --chown") <|> (FlagChmod <$> try chmod "only one --chmod") <|> (FlagSource <$> try copySource "only one --from") <|> (FlagInvalid <$> try anyFlag "no other flags") -chown :: Parser Chown +chown :: (?esc :: Char) => Parser Chown chown = do void $ string "--chown=" cho <- someUnless "the user and group for chown" (== ' ') return $ Chown cho -chmod :: Parser Chmod +chmod :: (?esc :: Char) => Parser Chmod chmod = do void $ string "--chmod=" chm <- someUnless "the mode for chmod" (== ' ') return $ Chmod chm -copySource :: Parser CopySource +copySource :: (?esc :: Char) => Parser CopySource copySource = do void $ string "--from=" src <- someUnless "the copy source path" isNl return $ CopySource src -anyFlag :: Parser (Text, Text) +anyFlag :: (?esc :: Char) => Parser (Text, Text) anyFlag = do void $ string "--" name <- someUnless "the flag value" (== '=') diff --git a/src/Language/Docker/Parser/Expose.hs b/src/Language/Docker/Parser/Expose.hs index 4db976c..8de3c32 100644 --- a/src/Language/Docker/Parser/Expose.hs +++ b/src/Language/Docker/Parser/Expose.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.Parser.Expose ( parseExpose, ) @@ -9,19 +7,19 @@ import qualified Data.Text as T import Language.Docker.Parser.Prelude import Language.Docker.Syntax -parseExpose :: Parser (Instruction Text) +parseExpose :: (?esc :: Char) => Parser (Instruction Text) parseExpose = do reserved "EXPOSE" Expose <$> ports -port :: Parser Port +port :: (?esc :: Char) => Parser Port port = (try portVariable "a variable") <|> (try portRange "a port range optionally followed by the protocol (udp/tcp)") -- There a many valid representations of ports <|> (try portWithProtocol "a port with its protocol (udp/tcp)") <|> (try portInt "a valid port number") -ports :: Parser Ports +ports :: (?esc :: Char) => Parser Ports ports = Ports <$> port `sepEndBy` requiredWhitespace portRange :: Parser Port @@ -51,7 +49,7 @@ portWithProtocol = do portNumber <- natural Port (fromIntegral portNumber) <$> protocol -portVariable :: Parser Port +portVariable :: (?esc :: Char) => Parser Port portVariable = do void (char '$') variable <- someUnless "the variable name" (== '$') diff --git a/src/Language/Docker/Parser/From.hs b/src/Language/Docker/Parser/From.hs index 79745fe..1e14de1 100644 --- a/src/Language/Docker/Parser/From.hs +++ b/src/Language/Docker/Parser/From.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.Parser.From ( parseFrom, ) @@ -9,7 +7,7 @@ import qualified Data.Text as T import Language.Docker.Parser.Prelude import Language.Docker.Syntax -parseRegistry :: Parser Registry +parseRegistry :: (?esc :: Char) => Parser Registry parseRegistry = do domain <- someUnless "a domain name" (== '.') void $ char '.' @@ -17,14 +15,14 @@ parseRegistry = do void $ char '/' return $ Registry (domain <> "." <> tld) -parsePlatform :: Parser Platform +parsePlatform :: (?esc :: Char) => Parser Platform parsePlatform = do void $ string "--platform=" p <- someUnless "the platform for the FROM image" (== ' ') requiredWhitespace return p -parseBaseImage :: (Text -> Parser (Maybe Tag)) -> Parser BaseImage +parseBaseImage :: (?esc :: Char) => (Text -> Parser (Maybe Tag)) -> Parser BaseImage parseBaseImage tagParser = do maybePlatform <- (Just <$> try parsePlatform) <|> return Nothing notFollowedBy (string "--") @@ -35,7 +33,7 @@ parseBaseImage tagParser = do maybeAlias <- (Just <$> try (requiredWhitespace *> imageAlias)) <|> return Nothing return $ BaseImage (Image regName name) maybeTag maybeDigest maybeAlias maybePlatform -taggedImage :: Parser BaseImage +taggedImage :: (?esc :: Char) => Parser BaseImage taggedImage = parseBaseImage tagParser where tagParser _ = do @@ -43,13 +41,13 @@ taggedImage = parseBaseImage tagParser t <- someUnless "the image tag" (\c -> c == '@' || c == ':') return (Just . Tag $ t) -parseDigest :: Parser Digest +parseDigest :: (?esc :: Char) => Parser Digest parseDigest = do void $ char '@' d <- someUnless "the image digest" (== '@') return $ Digest d -untaggedImage :: Parser BaseImage +untaggedImage :: (?esc :: Char) => Parser BaseImage untaggedImage = parseBaseImage notInvalidTag where notInvalidTag :: Text -> Parser (Maybe Tag) @@ -59,16 +57,16 @@ untaggedImage = parseBaseImage notInvalidTag ++ ":valid-tag)" return Nothing -imageAlias :: Parser ImageAlias +imageAlias :: (?esc :: Char) => Parser ImageAlias imageAlias = do void (try (reserved "AS") "'AS' followed by the image alias") aka <- someUnless "the image alias" (== '\n') return $ ImageAlias aka -baseImage :: Parser BaseImage +baseImage :: (?esc :: Char) => Parser BaseImage baseImage = try taggedImage <|> untaggedImage -parseFrom :: Parser (Instruction Text) +parseFrom :: (?esc :: Char) => Parser (Instruction Text) parseFrom = do reserved "FROM" From <$> baseImage diff --git a/src/Language/Docker/Parser/Healthcheck.hs b/src/Language/Docker/Parser/Healthcheck.hs index 76fb27d..add4279 100644 --- a/src/Language/Docker/Parser/Healthcheck.hs +++ b/src/Language/Docker/Parser/Healthcheck.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Language.Docker.Parser.Healthcheck @@ -20,7 +19,7 @@ data CheckFlag | FlagRetries Retries | CFlagInvalid (Text, Text) -parseHealthcheck :: Parser (Instruction Text) +parseHealthcheck :: (?esc :: Char) => Parser (Instruction Text) parseHealthcheck = do reserved "HEALTHCHECK" Healthcheck <$> (fullCheck <|> noCheck) @@ -60,7 +59,7 @@ parseHealthcheck = do let retries = listToMaybe retriesD return $ Check CheckArgs {..} -checkFlag :: Parser CheckFlag +checkFlag :: (?esc :: Char) => Parser CheckFlag checkFlag = (FlagInterval <$> durationFlag "--interval=" "--interval") <|> (FlagTimeout <$> durationFlag "--timeout=" "--timeout") @@ -85,7 +84,7 @@ retriesFlag = do n <- try natural "the number of retries" return $ Retries (fromIntegral n) -anyFlag :: Parser (Text, Text) +anyFlag :: (?esc :: Char) => Parser (Text, Text) anyFlag = do void $ string "--" name <- someUnless "the flag value" (== '=') diff --git a/src/Language/Docker/Parser/Instruction.hs b/src/Language/Docker/Parser/Instruction.hs index 4acf9c7..e0e08b6 100644 --- a/src/Language/Docker/Parser/Instruction.hs +++ b/src/Language/Docker/Parser/Instruction.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.Parser.Instruction - ( parseInstruction, + ( parseArg, + parseComment, + parseEntryPoint, + parseEscapePragma, + parseInstruction, + parseMaintainer, + parseOnbuild, + parsePragma, parseShell, parseStopSignal, - parseArg, + parseSyntaxPragma, parseUser, - parseWorkdir, parseVolume, - parseEntryPoint, - parseMaintainer, - parseOnbuild, - parseComment, + parseWorkdir, ) where @@ -26,18 +27,18 @@ import Language.Docker.Parser.Prelude import Language.Docker.Parser.Run (parseRun) import Language.Docker.Syntax -parseShell :: Parser (Instruction Text) +parseShell :: (?esc :: Char) => Parser (Instruction Text) parseShell = do reserved "SHELL" Shell <$> arguments -parseStopSignal :: Parser (Instruction Text) +parseStopSignal :: (?esc :: Char) => Parser (Instruction Text) parseStopSignal = do reserved "STOPSIGNAL" args <- untilEol "the stop signal" return $ Stopsignal args -parseArg :: Parser (Instruction Text) +parseArg :: (?esc :: Char) => Parser (Instruction Text) parseArg = do reserved "ARG" (try nameWithDefault "the arg name") @@ -54,44 +55,74 @@ parseArg = do df <- untilEol "the argument value" return $ Arg name (Just df) -parseUser :: Parser (Instruction Text) +parseUser :: (?esc :: Char) => Parser (Instruction Text) parseUser = do reserved "USER" username <- untilEol "the user" return $ User username -parseWorkdir :: Parser (Instruction Text) +parseWorkdir :: (?esc :: Char) => Parser (Instruction Text) parseWorkdir = do reserved "WORKDIR" directory <- untilEol "the workdir path" return $ Workdir directory -parseVolume :: Parser (Instruction Text) +parseVolume :: (?esc :: Char) => Parser (Instruction Text) parseVolume = do reserved "VOLUME" directory <- untilEol "the volume path" return $ Volume directory -parseMaintainer :: Parser (Instruction Text) +parseMaintainer :: (?esc :: Char) => Parser (Instruction Text) parseMaintainer = do reserved "MAINTAINER" name <- untilEol "the maintainer name" return $ Maintainer name -parseEntryPoint :: Parser (Instruction Text) +parseEntryPoint :: (?esc :: Char) => Parser (Instruction Text) parseEntryPoint = do reserved "ENTRYPOINT" Entrypoint <$> arguments -parseOnbuild :: Parser (Instruction Text) +parseOnbuild :: (?esc :: Char) => Parser (Instruction Text) parseOnbuild = do reserved "ONBUILD" OnBuild <$> parseInstruction -parseComment :: Parser (Instruction Text) -parseComment = Comment <$> comment +parsePragma :: (?esc :: Char) => Parser (Instruction Text) +parsePragma = do + void $ lexeme' (char '#') + choice + [ parseEscapePragma "an escape", + parseSyntaxPragma "a syntax" + ] + +parseEscapePragma :: Parser (Instruction Text) +parseEscapePragma = do + void $ lexeme' (string "escape") + void $ lexeme' (string "=") + Pragma . Escape . EscapeChar <$> charLiteral + +parseSyntaxPragma :: (?esc :: Char) => Parser (Instruction Text) +parseSyntaxPragma = do + void $ lexeme' (string "syntax") + void $ lexeme' (string "=") + img <- untilEol "the syntax" + return $ Pragma + ( Syntax + ( SyntaxImage + ( Image + { registryName = Nothing, + imageName = img + } + ) + ) + ) + +parseComment :: (?esc :: Char) => Parser (Instruction Text) +parseComment = (try parsePragma "a pragma") <|> Comment <$> comment -parseInstruction :: Parser (Instruction Text) +parseInstruction :: (?esc :: Char) => Parser (Instruction Text) parseInstruction = choice [ parseOnbuild, diff --git a/src/Language/Docker/Parser/Pairs.hs b/src/Language/Docker/Parser/Pairs.hs index 72dee3a..862c266 100644 --- a/src/Language/Docker/Parser/Pairs.hs +++ b/src/Language/Docker/Parser/Pairs.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.Parser.Pairs ( parseEnv, parseLabel, @@ -12,13 +10,13 @@ import Language.Docker.Syntax -- We cannot use string literal because it swallows space -- and therefore have to implement quoted values by ourselves -doubleQuotedValue :: Parser Text +doubleQuotedValue :: (?esc :: Char) => Parser Text doubleQuotedValue = between (string "\"") (string "\"") (stringWithEscaped ['"'] Nothing) -singleQuotedValue :: Parser Text +singleQuotedValue :: (?esc :: Char) => Parser Text singleQuotedValue = between (string "'") (string "'") (stringWithEscaped ['\''] Nothing) -unquotedString :: (Char -> Bool) -> Parser Text +unquotedString :: (?esc :: Char) => (Char -> Bool) -> Parser Text unquotedString acceptCondition = do str <- stringWithEscaped [' ', '\t'] (Just (\c -> acceptCondition c && c /= '"' && c /= '\'')) checkFaults str @@ -29,7 +27,7 @@ unquotedString acceptCondition = do | T.head str == '\"' = customError $ QuoteError "double" (T.unpack str) | otherwise = return str -singleValue :: (Char -> Bool) -> Parser Text +singleValue :: (?esc :: Char) => (Char -> Bool) -> Parser Text singleValue acceptCondition = mconcat <$> variants where variants = @@ -40,7 +38,7 @@ singleValue acceptCondition = mconcat <$> variants unquotedString acceptCondition "a string with no quotes" ] -pair :: Parser (Text, Text) +pair :: (?esc :: Char) => Parser (Text, Text) pair = do key <- singleValue (/= '=') value <- withEqualSign <|> withoutEqualSign @@ -53,15 +51,15 @@ pair = do requiredWhitespace untilEol "value" -pairs :: Parser Pairs +pairs :: (?esc :: Char) => Parser Pairs pairs = (pair "a key value pair (key=value)") `sepEndBy1` requiredWhitespace -parseLabel :: Parser (Instruction Text) +parseLabel :: (?esc :: Char) => Parser (Instruction Text) parseLabel = do reserved "LABEL" Label <$> pairs -parseEnv :: Parser (Instruction Text) +parseEnv :: (?esc :: Char) => Parser (Instruction Text) parseEnv = do reserved "ENV" Env <$> pairs diff --git a/src/Language/Docker/Parser/Prelude.hs b/src/Language/Docker/Parser/Prelude.hs index 6df6611..209f337 100644 --- a/src/Language/Docker/Parser/Prelude.hs +++ b/src/Language/Docker/Parser/Prelude.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} module Language.Docker.Parser.Prelude ( customError, @@ -14,9 +13,12 @@ module Language.Docker.Parser.Prelude requiredWhitespace, untilEol, symbol, + onlySpaces, + onlyWhitespaces, caseInsensitiveString, stringWithEscaped, lexeme, + lexeme', isNl, isSpaceNl, anyUnless, @@ -26,6 +28,7 @@ module Language.Docker.Parser.Prelude DockerfileError (..), module Megaparsec, char, + L.charLiteral, string, void, when, @@ -103,20 +106,24 @@ castToSpace :: FoundWhitespace -> Text castToSpace FoundWhitespace = " " castToSpace MissingWhitespace = "" -eol :: Parser () +eol :: (?esc :: Char) => Parser () eol = void ws "end of line" where ws = some $ - choice [void onlySpaces1, void $ takeWhile1P Nothing (== '\n'), void escapedLineBreaks] + choice + [ void onlySpaces1, + void $ takeWhile1P Nothing (== '\n'), + void escapedLineBreaks + ] -reserved :: Text -> Parser () +reserved :: (?esc :: Char) => Text -> Parser () reserved name = void (lexeme (string' name) T.unpack name) natural :: Parser Integer natural = L.decimal "positive number" -commaSep :: Parser a -> Parser [a] +commaSep :: (?esc :: Char) => Parser a -> Parser [a] commaSep p = sepBy (p <* whitespace) (symbol ",") stringLiteral :: Parser Text @@ -125,7 +132,7 @@ stringLiteral = do lit <- manyTill L.charLiteral (char '"') return (T.pack lit) -brackets :: Parser a -> Parser a +brackets :: (?esc :: Char) => Parser a -> Parser a brackets = between (symbol "[" *> whitespace) (whitespace *> symbol "]") onlySpaces :: Parser Text @@ -134,27 +141,32 @@ onlySpaces = takeWhileP (Just "spaces") (\c -> c == ' ' || c == '\t') onlySpaces1 :: Parser Text onlySpaces1 = takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t') -escapedLineBreaks :: Parser FoundWhitespace +onlyWhitespaces :: Parser Text +onlyWhitespaces = takeWhileP + (Just "whitespaces") + (\c -> c == ' ' || c == '\t' || c == '\n' || c == '\r') + +escapedLineBreaks :: (?esc :: Char) => Parser FoundWhitespace escapedLineBreaks = mconcat <$> breaks where breaks = some $ do - try (char '\\' *> onlySpaces *> newlines) + try (char ?esc *> onlySpaces *> newlines) skipMany . try $ onlySpaces *> comment *> newlines -- Spaces before the next '\' have a special significance -- so we remembeer the fact that we found some FoundWhitespace <$ onlySpaces1 <|> pure MissingWhitespace newlines = takeWhile1P Nothing isNl -foundWhitespace :: Parser FoundWhitespace +foundWhitespace :: (?esc :: Char) => Parser FoundWhitespace foundWhitespace = mconcat <$> found where found = many $ choice [FoundWhitespace <$ onlySpaces1, escapedLineBreaks] -whitespace :: Parser () +whitespace :: (?esc :: Char) => Parser () whitespace = void foundWhitespace -requiredWhitespace :: Parser () +requiredWhitespace :: (?esc :: Char) => Parser () requiredWhitespace = do ws <- foundWhitespace case ws of @@ -163,7 +175,7 @@ requiredWhitespace = do -- Parse value until end of line is reached -- after consuming all escaped newlines -untilEol :: String -> Parser Text +untilEol :: (?esc :: Char) => String -> Parser Text untilEol name = do res <- mconcat <$> predicate when (res == "") $ fail ("expecting " ++ name) @@ -173,11 +185,11 @@ untilEol name = do many $ choice [ castToSpace <$> escapedLineBreaks, - takeWhile1P (Just name) (\c -> c /= '\n' && c /= '\\'), - takeWhile1P Nothing (== '\\') <* notFollowedBy (char '\n') + takeWhile1P (Just name) (\c -> c /= '\n' && c /= ?esc), + takeWhile1P Nothing (== ?esc) <* notFollowedBy (char '\n') ] -symbol :: Text -> Parser Text +symbol :: (?esc :: Char) => Text -> Parser Text symbol name = do x <- string name whitespace @@ -186,15 +198,15 @@ symbol name = do caseInsensitiveString :: Text -> Parser Text caseInsensitiveString = string' -stringWithEscaped :: [Char] -> Maybe (Char -> Bool) -> Parser Text +stringWithEscaped :: (?esc :: Char) => [Char] -> Maybe (Char -> Bool) -> Parser Text stringWithEscaped quoteChars maybeAcceptCondition = mconcat <$> sequences where sequences = many $ choice [ mconcat <$> inner, - try $ takeWhile1P Nothing (== '\\') <* notFollowedBy quoteParser, - string "\\" *> quoteParser + try $ takeWhile1P Nothing (== ?esc) <* notFollowedBy quoteParser, + string (T.singleton ?esc) *> quoteParser ] inner = some $ @@ -202,27 +214,33 @@ stringWithEscaped quoteChars maybeAcceptCondition = mconcat <$> sequences [ castToSpace <$> escapedLineBreaks, takeWhile1P Nothing - (\c -> c /= '\\' && c /= '\n' && c `notElem` quoteChars && acceptCondition c) + (\c -> c /= ?esc && c /= '\n' && c `notElem` quoteChars && acceptCondition c) ] quoteParser = T.singleton <$> choice (fmap char quoteChars) acceptCondition = fromMaybe (const True) maybeAcceptCondition -lexeme :: Parser a -> Parser a +lexeme :: (?esc :: Char) => Parser a -> Parser a lexeme p = do x <- p requiredWhitespace return x +lexeme' :: Parser a -> Parser a +lexeme' p = do + x <- p + void onlySpaces + return x + isNl :: Char -> Bool isNl c = c == '\n' -isSpaceNl :: Char -> Bool -isSpaceNl c = c == ' ' || c == '\t' || c == '\n' || c == '\\' +isSpaceNl :: (?esc :: Char) => Char -> Bool +isSpaceNl c = c == ' ' || c == '\t' || c == '\n' || c == ?esc -anyUnless :: (Char -> Bool) -> Parser Text +anyUnless :: (?esc :: Char) => (Char -> Bool) -> Parser Text anyUnless predicate = someUnless "" predicate <|> pure "" -someUnless :: String -> (Char -> Bool) -> Parser Text +someUnless :: (?esc :: Char) => String -> (Char -> Bool) -> Parser Text someUnless name predicate = do res <- applyPredicate case res of @@ -234,7 +252,7 @@ someUnless name predicate = do choice [ castToSpace <$> escapedLineBreaks, takeWhile1P (Just name) (\c -> not (isSpaceNl c || predicate c)), - takeWhile1P Nothing (\c -> c == '\\' && not (predicate c)) + takeWhile1P Nothing (\c -> c == ?esc && not (predicate c)) <* notFollowedBy (char '\n') ] diff --git a/src/Language/Docker/Parser/Run.hs b/src/Language/Docker/Parser/Run.hs index f0b3ea7..938648c 100644 --- a/src/Language/Docker/Parser/Run.hs +++ b/src/Language/Docker/Parser/Run.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} module Language.Docker.Parser.Run ( parseRun, @@ -40,18 +39,18 @@ data MountType | Secret | Ssh -parseRun :: Parser (Instruction Text) +parseRun :: (?esc :: Char) => Parser (Instruction Text) parseRun = do reserved "RUN" Run <$> runArguments -runArguments :: Parser (RunArgs Text) +runArguments :: (?esc :: Char) => Parser (RunArgs Text) runArguments = do presentFlags <- choice [runFlags <* requiredWhitespace, pure (RunFlags Nothing Nothing Nothing)] args <- arguments return $ RunArgs args presentFlags -runFlags :: Parser RunFlags +runFlags :: (?esc :: Char) => Parser RunFlags runFlags = do flags <- runFlag `sepBy` flagSeparator return $ foldr toRunFlags emptyFlags flags @@ -62,10 +61,13 @@ runFlags = do toRunFlags (RunFlagNetwork n) rf = rf {network = Just n} toRunFlags (RunFlagSecurity s) rf = rf {security = Just s} -runFlag :: Parser RunFlag +runFlag :: (?esc :: Char) => Parser RunFlag runFlag = choice - [RunFlagMount <$> runFlagMount, RunFlagSecurity <$> runFlagSecurity, RunFlagNetwork <$> runFlagNetwork] + [ RunFlagMount <$> runFlagMount, + RunFlagSecurity <$> runFlagSecurity, + RunFlagNetwork <$> runFlagNetwork + ] runFlagSecurity :: Parser RunSecurity runFlagSecurity = do @@ -77,7 +79,7 @@ runFlagNetwork = do void $ string "--network=" choice [NetworkNone <$ string "none", NetworkHost <$ string "host", NetworkDefault <$ string "default"] -runFlagMount :: Parser RunMount +runFlagMount :: (?esc :: Char) => Parser RunMount runFlagMount = do void $ string "--mount=" maybeType <- @@ -104,7 +106,7 @@ runFlagMount = do Secret -> SecretMount <$> (secretMount =<< args) Ssh -> SshMount <$> (secretMount =<< args) -argsParser :: MountType -> Parser [RunMountArg] +argsParser :: (?esc :: Char) => MountType -> Parser [RunMountArg] argsParser mountType = mountChoices mountType `sepBy1` string "," bindMount :: [RunMountArg] -> Parser BindOpts @@ -192,7 +194,7 @@ validArgs typeName allowed required args = (_, True) -> (Left (DuplicateArgument name), seen) (True, False) -> (Right (a : as), Set.insert name seen) -mountChoices :: MountType -> Parser RunMountArg +mountChoices :: (?esc :: Char) => MountType -> Parser RunMountArg mountChoices mountType = choice $ case mountType of @@ -226,7 +228,7 @@ mountChoices mountType = mountArgGid ] -stringArg :: Parser Text +stringArg :: (?esc :: Char) => Parser Text stringArg = choice [stringLiteral, someUnless "a string" (== ',')] key :: Text -> Parser a -> Parser a @@ -236,16 +238,16 @@ cacheSharing :: Parser CacheSharing cacheSharing = choice [Private <$ string "private", Shared <$ string "shared", Locked <$ string "locked"] -mountArgFromImage :: Parser RunMountArg +mountArgFromImage :: (?esc :: Char) => Parser RunMountArg mountArgFromImage = MountArgFromImage <$> key "from" stringArg mountArgGid :: Parser RunMountArg mountArgGid = MountArgGid <$> key "gid" natural -mountArgId :: Parser RunMountArg +mountArgId :: (?esc :: Char) => Parser RunMountArg mountArgId = MountArgId <$> key "id" stringArg -mountArgMode :: Parser RunMountArg +mountArgMode :: (?esc :: Char) => Parser RunMountArg mountArgMode = MountArgMode <$> key "mode" stringArg mountArgReadOnly :: Parser RunMountArg @@ -268,12 +270,12 @@ mountArgRequired = MountArgRequired <$> choice mountArgSharing :: Parser RunMountArg mountArgSharing = MountArgSharing <$> key "sharing" cacheSharing -mountArgSource :: Parser RunMountArg +mountArgSource :: (?esc :: Char) => Parser RunMountArg mountArgSource = do label "source=" $ choice [string "source=", string "src="] MountArgSource . SourcePath <$> stringArg -mountArgTarget :: Parser RunMountArg +mountArgTarget :: (?esc :: Char) => Parser RunMountArg mountArgTarget = do label "target=" $ choice [string "target=", string "dst=", string "destination="] MountArgTarget . TargetPath <$> stringArg diff --git a/src/Language/Docker/PrettyPrint.hs b/src/Language/Docker/PrettyPrint.hs index 53617f1..d9e8b83 100644 --- a/src/Language/Docker/PrettyPrint.hs +++ b/src/Language/Docker/PrettyPrint.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoMonomorphismRestriction #-} @@ -28,22 +27,29 @@ data EscapeAccum escaping :: !Bool } -instance Pretty (Arguments Text) where - pretty = prettyPrintArguments - -- | Pretty print a 'Dockerfile' to a 'Text' prettyPrint :: Dockerfile -> L.Text prettyPrint = renderLazy . layoutPretty opts . prettyPrintDockerfile where opts = LayoutOptions Unbounded -prettyPrintDockerfile :: Pretty (Arguments args) => [InstructionPos args] -> Doc ann +prettyPrintDockerfile :: [InstructionPos Text] -> Doc ann prettyPrintDockerfile instr = doPrint instr <> "\n" where - doPrint = vsep . fmap prettyPrintInstructionPos + doPrint ips = + let ?esc = findEscapeChar ips + in (vsep . fmap prettyPrintInstructionPos ) ips + +findEscapeChar :: [InstructionPos args] -> Char +findEscapeChar [] = defaultEsc +findEscapeChar (i:is) = + case i of + InstructionPos {instruction = (Pragma (Escape (EscapeChar c)))} -> c + InstructionPos {instruction = (Pragma _)} -> findEscapeChar is + _ -> defaultEsc -- | Pretty print a 'InstructionPos' to a 'Doc' -prettyPrintInstructionPos :: Pretty (Arguments args) => InstructionPos args -> Doc ann +prettyPrintInstructionPos :: (?esc :: Char) => InstructionPos Text -> Doc ann prettyPrintInstructionPos (InstructionPos i _ _) = prettyPrintInstruction i prettyPrintImage :: Image -> Doc ann @@ -76,42 +82,41 @@ prettyPrintBaseImage BaseImage {..} = do Nothing -> mempty Just (Digest d) -> "@" <> pretty d -prettyPrintPairs :: Pairs -> Doc ann +prettyPrintPairs :: (?esc :: Char) => Pairs -> Doc ann prettyPrintPairs ps = align $ sepLine $ fmap prettyPrintPair ps where - sepLine = concatWith (\x y -> x <> " \\" <> line <> y) + sepLine = concatWith (\x y -> x <> " " <> pretty ?esc <> line <> y) -prettyPrintPair :: (Text, Text) -> Doc ann +prettyPrintPair :: (?esc :: Char) => (Text, Text) -> Doc ann prettyPrintPair (k, v) = pretty k <> pretty '=' <> doubleQoute v -prettyPrintArguments :: Arguments Text -> Doc ann +prettyPrintArguments :: (?esc :: Char) => Arguments Text -> Doc ann prettyPrintArguments (ArgumentsList as) = prettyPrintJSON (Text.words as) prettyPrintArguments (ArgumentsText as) = hsep (fmap helper (Text.words as)) where - helper "&&" = "\\\n &&" + helper "&&" = pretty ?esc <> "\n &&" helper a = pretty a -prettyPrintJSON :: [Text] -> Doc ann +prettyPrintJSON :: (?esc :: Char) => [Text] -> Doc ann prettyPrintJSON args = list (fmap doubleQoute args) -doubleQoute :: Text -> Doc ann +doubleQoute :: (?esc :: Char) => Text -> Doc ann doubleQoute w = enclose dquote dquote (pretty (escapeQuotes w)) -escapeQuotes :: Text -> L.Text +escapeQuotes :: (?esc :: Char) => Text -> L.Text escapeQuotes text = case Text.foldr accumulate (EscapeAccum mempty 0 False) text of EscapeAccum buffer _ False -> B.toLazyText buffer EscapeAccum buffer count True -> case count `mod` 2 of - 0 -> B.toLazyText (B.singleton '\\' <> buffer) + 0 -> B.toLazyText (B.singleton ?esc <> buffer) _ -> B.toLazyText buffer where accumulate '"' EscapeAccum {buffer, escaping = False} = EscapeAccum (B.singleton '"' <> buffer) 0 True - accumulate '\\' EscapeAccum {buffer, escaping = True, count} = - EscapeAccum (B.singleton '\\' <> buffer) (count + 1) True accumulate c EscapeAccum {buffer, escaping = True, count} - | even count = EscapeAccum (B.singleton c <> B.singleton '\\' <> buffer) 0 False + | c == ?esc = EscapeAccum (B.singleton ?esc <> buffer) (count + 1) True + | even count = EscapeAccum (B.singleton c <> B.singleton ?esc <> buffer) 0 False | otherwise = EscapeAccum (B.singleton c <> buffer) 0 False -- It was already escaped accumulate c EscapeAccum {buffer, escaping = False} = EscapeAccum (B.singleton c <> buffer) 0 False @@ -160,7 +165,7 @@ prettyPrintRetries = maybe mempty pp where pp (Retries r) = "--retries=" <> pretty r -prettyPrintRunMount :: Maybe RunMount -> Doc ann +prettyPrintRunMount :: (?esc :: Char) => Maybe RunMount -> Doc ann prettyPrintRunMount Nothing = mempty prettyPrintRunMount (Just mount) = "--mount=" <> case mount of @@ -232,7 +237,11 @@ prettyPrintRunSecurity Nothing = mempty prettyPrintRunSecurity (Just Sandbox) = "--security=sandbox" prettyPrintRunSecurity (Just Insecure) = "--security=insecure" -prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann +prettyPrintPragma :: PragmaDirective -> Doc ann +prettyPrintPragma (Escape (EscapeChar esc)) = "escape = " <> pretty esc +prettyPrintPragma (Syntax (SyntaxImage img)) = "syntax = " <> prettyPrintImage img + +prettyPrintInstruction :: (?esc :: Char) => Instruction Text -> Doc ann prettyPrintInstruction i = case i of Maintainer m -> do @@ -246,7 +255,7 @@ prettyPrintInstruction i = pretty k <> "=" <> pretty v Entrypoint e -> do "ENTRYPOINT" - pretty e + prettyPrintArguments e Stopsignal s -> do "STOPSIGNAL" pretty s @@ -264,7 +273,7 @@ prettyPrintInstruction i = prettyPrintRunMount mount prettyPrintRunNetwork network prettyPrintRunSecurity security - pretty c + prettyPrintArguments c Copy CopyArgs {sourcePaths, targetPath, chownFlag, chmodFlag, sourceFlag} -> do "COPY" prettyPrintChown chownFlag @@ -273,7 +282,7 @@ prettyPrintInstruction i = prettyPrintFileList sourcePaths targetPath Cmd c -> do "CMD" - pretty c + prettyPrintArguments c Label l -> do "LABEL" prettyPrintPairs l @@ -283,6 +292,9 @@ prettyPrintInstruction i = User u -> do "USER" pretty u + Pragma p -> do + pretty '#' + prettyPrintPragma p Comment s -> do pretty '#' pretty s @@ -299,7 +311,7 @@ prettyPrintInstruction i = prettyPrintFileList sourcePaths targetPath Shell args -> do "SHELL" - pretty args + prettyPrintArguments args Healthcheck NoCheck -> "HEALTHCHECK NONE" Healthcheck (Check CheckArgs {..}) -> do "HEALTHCHECK" @@ -308,7 +320,7 @@ prettyPrintInstruction i = prettyPrintDuration "--start-period=" startPeriod prettyPrintRetries retries "CMD" - pretty checkCommand + prettyPrintArguments checkCommand where (>>) = spaceCat diff --git a/src/Language/Docker/Syntax.hs b/src/Language/Docker/Syntax.hs index 32b75ad..91538ea 100644 --- a/src/Language/Docker/Syntax.hs +++ b/src/Language/Docker/Syntax.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Language.Docker.Syntax where @@ -16,6 +15,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock (DiffTime) import GHC.Exts (IsList (..)) +import Text.Printf data Image = Image @@ -310,6 +310,28 @@ instance IsString (RunArgs Text) where mount = Nothing } +newtype EscapeChar + = EscapeChar + { escape :: Char + } + deriving (Show, Eq, Ord) + +instance IsChar EscapeChar where + fromChar c = + EscapeChar {escape = c} + toChar e = escape e + +newtype SyntaxImage + = SyntaxImage + { syntax :: Image + } + deriving (Show, Eq, Ord) + +data PragmaDirective + = Escape !EscapeChar + | Syntax !SyntaxImage + deriving (Show, Eq, Ord) + -- | All commands available in Dockerfiles data Instruction args = From !BaseImage @@ -331,6 +353,7 @@ data Instruction args !Text !(Maybe Text) | Healthcheck !(Check args) + | Pragma !PragmaDirective | Comment !Text | OnBuild !(Instruction args) deriving (Eq, Ord, Show, Functor) @@ -348,3 +371,6 @@ data InstructionPos args lineNumber :: !Linenumber } deriving (Eq, Ord, Show, Functor) + +defaultEsc :: Char +defaultEsc = '\\' diff --git a/test/Language/Docker/IntegrationSpec.hs b/test/Language/Docker/IntegrationSpec.hs index eb17cfd..04c01dc 100644 --- a/test/Language/Docker/IntegrationSpec.hs +++ b/test/Language/Docker/IntegrationSpec.hs @@ -1,43 +1,132 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.IntegrationSpec where import qualified Data.Text as Text import qualified Data.Text.IO import qualified Data.Text.Lazy.IO as L import Language.Docker.Parser -import Language.Docker.PrettyPrint (prettyPrint) +import Language.Docker.PrettyPrint (prettyPrint, prettyPrintDockerfile) import Test.HUnit hiding (Label) import Test.Hspec import Text.Megaparsec hiding (Label) spec :: Spec spec = do - describe "first" $ do - it "no erors" $ do + describe "parse file" $ do + it "1.Dockerfile" $ do parsed <- parseFile "test/fixtures/1.Dockerfile" case parsed of Right a -> L.putStr $ prettyPrint a Left err -> assertFailure $ errorBundlePretty err - describe "second" $ do - it "no erors" $ do + it "2.Dockerfile" $ do parsed <- parseFile "test/fixtures/2.Dockerfile" case parsed of Right a -> L.putStr $ prettyPrint a Left err -> assertFailure $ errorBundlePretty err - describe "first clrf" $ do - it "no erors" $ do + it "3.Dockerfile" $ do + parsed <- parseFile "test/fixtures/3.Dockerfile" + case parsed of + Right a -> L.putStr $ prettyPrint a + Left err -> assertFailure $ errorBundlePretty err + + it "4.Dockerfile" $ do + parsed <- parseFile "test/fixtures/4.Dockerfile" + case parsed of + Right a -> L.putStr $ prettyPrint a + Left err -> assertFailure $ errorBundlePretty err + + it "5.Dockerfile" $ do + parsed <- parseFile "test/fixtures/5.Dockerfile" + case parsed of + Right a -> L.putStr $ prettyPrint a + Left err -> assertFailure $ errorBundlePretty err + + describe "escape character detection logic" $ do + it "ensure the pretty printer respects escape pragmas" $ do + fromDisk <- Data.Text.IO.readFile "test/fixtures/6.Dockerfile" + let ast = parseText fromDisk + in case ast of + Right a -> + let fromAst = prettyPrintDockerfile a + in assertEqual "error" fromDisk (Text.pack . show $ fromAst) + Left err -> assertFailure $ errorBundlePretty err + + it "ensure escape character '\\' is used as default" $ do + fromDisk <- Data.Text.IO.readFile "test/fixtures/7.Dockerfile" + let ast = parseText fromDisk + in case ast of + Right a -> + let fromAst = prettyPrintDockerfile a + in assertEqual "error" fromDisk (Text.pack . show $ fromAst) + Left err -> assertFailure $ errorBundlePretty err + + it "ensure the printer ignores escape pragmas in the wrong place" $ do + fromDisk <- Data.Text.IO.readFile "test/fixtures/8.Dockerfile" + let ast = parseText fromDisk + in case ast of + Right a -> + let fromAst = prettyPrintDockerfile a + in assertEqual "error" fromDisk (Text.pack . show $ fromAst) + Left err -> assertFailure $ errorBundlePretty err + + describe "parse text" $ do + it "1.Dockerfile" $ do contents <- Data.Text.IO.readFile "test/fixtures/1.Dockerfile" case parseText (Text.replace "\n" "\r\n" contents) of Right _ -> return () Left err -> assertFailure $ errorBundlePretty err - describe "second clrf" $ do - it "no erors" $ do + it "2.Dockerfile" $ do contents <- Data.Text.IO.readFile "test/fixtures/2.Dockerfile" + case parseText contents of + Right _ -> return () + Left err -> assertFailure $ errorBundlePretty err + + it "3.Dockerfile" $ do + contents <- Data.Text.IO.readFile "test/fixtures/3.Dockerfile" + case parseText contents of + Right _ -> return () + Left err -> assertFailure $ errorBundlePretty err + + it "4.Dockerfile" $ do + contents <- Data.Text.IO.readFile "test/fixtures/4.Dockerfile" + case parseText contents of + Right _ -> return () + Left err -> assertFailure $ errorBundlePretty err + + it "5.Dockerfile" $ do + contents <- Data.Text.IO.readFile "test/fixtures/5.Dockerfile" + case parseText contents of + Right _ -> return () + Left err -> assertFailure $ errorBundlePretty err + + it "1.Dockerfile crlf" $ do + contents <- Data.Text.IO.readFile "test/fixtures/1.Dockerfile" + case parseText contents of + Right _ -> return () + Left err -> assertFailure $ errorBundlePretty err + + it "2.Dockerfile crlf" $ do + contents <- Data.Text.IO.readFile "test/fixtures/2.Dockerfile" + case parseText (Text.replace "\n" "\r\n" contents) of + Right _ -> return () + Left err -> assertFailure $ errorBundlePretty err + + it "3.Dockerfile crlf" $ do + contents <- Data.Text.IO.readFile "test/fixtures/3.Dockerfile" + case parseText (Text.replace "\n" "\r\n" contents) of + Right _ -> return () + Left err -> assertFailure $ errorBundlePretty err + + it "4.Dockerfile crlf" $ do + contents <- Data.Text.IO.readFile "test/fixtures/4.Dockerfile" + case parseText (Text.replace "\n" "\r\n" contents) of + Right _ -> return () + Left err -> assertFailure $ errorBundlePretty err + + it "5.Dockerfile crlf" $ do + contents <- Data.Text.IO.readFile "test/fixtures/5.Dockerfile" case parseText (Text.replace "\n" "\r\n" contents) of Right _ -> return () Left err -> assertFailure $ errorBundlePretty err diff --git a/test/Language/Docker/ParsePragmaSpec.hs b/test/Language/Docker/ParsePragmaSpec.hs new file mode 100644 index 0000000..fef932d --- /dev/null +++ b/test/Language/Docker/ParsePragmaSpec.hs @@ -0,0 +1,73 @@ +module Language.Docker.ParsePragmaSpec where + +import qualified Data.Text as Text +import Language.Docker.Parser +import Language.Docker.Syntax +import TestHelper +import Test.HUnit hiding (Label) +import Test.Hspec + + +spec :: Spec +spec = do + describe "parse # pragma" $ do + it "# escape = \\" $ + let dockerfile = Text.unlines ["# escape = \\\\"] -- this need double escaping for some reason. + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '\\'})] + it "#escape=`" $ + let dockerfile = Text.unlines ["#escape=`"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "# escape=`" $ + let dockerfile = Text.unlines ["# escape=`"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "#escape =`" $ + let dockerfile = Text.unlines ["#escape =`"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "#escape= `" $ + let dockerfile = Text.unlines ["#escape= `"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "# escape =`" $ + let dockerfile = Text.unlines ["# escape =`"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "#escape = `" $ + let dockerfile = Text.unlines ["#escape = `"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "# escape = `" $ + let dockerfile = Text.unlines ["# escape = `"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "# Escape = `" $ + let dockerfile = Text.unlines ["# escape = `"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "# ESCAPE = `" $ + let dockerfile = Text.unlines ["# escape = `"] + in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})] + it "#syntax=docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["#syntax=docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "# syntax=docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["# syntax=docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "#syntax =docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["#syntax =docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "#syntax= docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["#syntax= docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "# syntax =docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["# syntax =docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "#syntax = docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["#syntax = docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "# syntax= docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["# syntax= docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "# syntax = docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "# Syntax = docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] + it "# SYNTAX = docker/dockerfile:1.0" $ + let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"] + in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})] diff --git a/test/Language/Docker/ParserSpec.hs b/test/Language/Docker/ParserSpec.hs index 17a2f72..ee7cf9b 100644 --- a/test/Language/Docker/ParserSpec.hs +++ b/test/Language/Docker/ParserSpec.hs @@ -1,30 +1,14 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.ParserSpec where import Data.Default.Class (def) import qualified Data.Text as Text import Language.Docker.Parser import Language.Docker.Syntax +import TestHelper import Test.HUnit hiding (Label) import Test.Hspec import Text.Megaparsec hiding (Label) -untaggedImage :: Image -> BaseImage -untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing - -taggedImage :: Image -> Tag -> BaseImage -taggedImage n t = BaseImage n (Just t) Nothing Nothing Nothing - -withDigest :: BaseImage -> Digest -> BaseImage -withDigest i d = i {digest = Just d} - -withAlias :: BaseImage -> ImageAlias -> BaseImage -withAlias i a = i {alias = Just a} - -withPlatform :: BaseImage -> Platform -> BaseImage -withPlatform i p = i {platform = Just p} spec :: Spec spec = do @@ -731,9 +715,3 @@ spec = do file [ Run $ RunArgs (ArgumentsText "echo foo") flags ] - -assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion -assertAst s ast = - case parseText s of - Left err -> assertFailure $ errorBundlePretty err - Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile diff --git a/test/Language/Docker/PrettyPrintSpec.hs b/test/Language/Docker/PrettyPrintSpec.hs index 666bac4..3f73045 100644 --- a/test/Language/Docker/PrettyPrintSpec.hs +++ b/test/Language/Docker/PrettyPrintSpec.hs @@ -1,7 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} module Language.Docker.PrettyPrintSpec where @@ -118,7 +116,26 @@ spec = do (CopySource "baseimage") ) in assertPretty "COPY --chown=root:root --chmod=751 --from=baseimage foo bar" copy - + describe "pretty print # escape" $ do + it "# escape = \\" $ do + let esc = Pragma (Escape (EscapeChar '\\')) + in assertPretty "# escape = \\" esc + it "# escape = `" $ do + let esc = Pragma (Escape (EscapeChar '`')) + in assertPretty "# escape = `" esc + describe "pretty print # syntax" $ do + it "# syntax = docker/dockerfile:1.0" $ do + let img = Pragma + ( Syntax + ( SyntaxImage + ( Image + { registryName = Nothing, + imageName = "docker/dockerfile:1.0" + } + ) + ) + ) + in assertPretty "# syntax = docker/dockerfile:1.0" img assertPretty :: Text.Text -> Instruction Text.Text -> Assertion assertPretty expected instruction = assertEqual @@ -128,4 +145,7 @@ assertPretty expected instruction = assertEqual prettyPrintStrict :: Instruction Text.Text -> Text.Text prettyPrintStrict = - renderStrict . layoutPretty (LayoutOptions Unbounded) . prettyPrintInstruction + let ?esc = defaultEsc + in renderStrict + . layoutPretty (LayoutOptions Unbounded) + . prettyPrintInstruction diff --git a/test/TestHelper.hs b/test/TestHelper.hs new file mode 100644 index 0000000..12f87cd --- /dev/null +++ b/test/TestHelper.hs @@ -0,0 +1,38 @@ +module TestHelper + ( assertAst, + taggedImage, + withAlias, + withDigest, + withPlatform, + untaggedImage + ) + where + +import qualified Data.Text as Text +import Language.Docker.Parser +import Language.Docker.Syntax +import Test.HUnit hiding (Label) +import Test.Hspec +import Text.Megaparsec hiding (Label) + + +untaggedImage :: Image -> BaseImage +untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing + +taggedImage :: Image -> Tag -> BaseImage +taggedImage n t = BaseImage n (Just t) Nothing Nothing Nothing + +withDigest :: BaseImage -> Digest -> BaseImage +withDigest i d = i {digest = Just d} + +withAlias :: BaseImage -> ImageAlias -> BaseImage +withAlias i a = i {alias = Just a} + +withPlatform :: BaseImage -> Platform -> BaseImage +withPlatform i p = i {platform = Just p} + +assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion +assertAst s ast = + case parseText s of + Left err -> assertFailure $ errorBundlePretty err + Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile diff --git a/test/fixtures/3.Dockerfile b/test/fixtures/3.Dockerfile new file mode 100644 index 0000000..6f77ce2 --- /dev/null +++ b/test/fixtures/3.Dockerfile @@ -0,0 +1,6 @@ +# escape = ` + +FROM debian:10 + +RUN first cmd ` + && second cmd diff --git a/test/fixtures/4.Dockerfile b/test/fixtures/4.Dockerfile new file mode 100644 index 0000000..14a1c6c --- /dev/null +++ b/test/fixtures/4.Dockerfile @@ -0,0 +1,8 @@ +#syntax=docker/dockerfile:1.0 +# escape = ` + +FROM debian:10 + +RUN first cmd ` + && second cmd ` + && command C:\some\windows\style\path diff --git a/test/fixtures/5.Dockerfile b/test/fixtures/5.Dockerfile new file mode 100644 index 0000000..a8c7813 --- /dev/null +++ b/test/fixtures/5.Dockerfile @@ -0,0 +1,8 @@ +# this will prevent the pragma from taking effect +#syntax=docker/dockerfile:1.0 +# escape = ` + +FROM debian:10 + +RUN first cmd \ + && second cmd diff --git a/test/fixtures/6.Dockerfile b/test/fixtures/6.Dockerfile new file mode 100644 index 0000000..da55d14 --- /dev/null +++ b/test/fixtures/6.Dockerfile @@ -0,0 +1,3 @@ +# escape = ` +RUN cmd a ` + && cmd b diff --git a/test/fixtures/7.Dockerfile b/test/fixtures/7.Dockerfile new file mode 100644 index 0000000..cdbfb55 --- /dev/null +++ b/test/fixtures/7.Dockerfile @@ -0,0 +1,3 @@ +FROM debian:buster +RUN cmd a \ + && cmd b diff --git a/test/fixtures/8.Dockerfile b/test/fixtures/8.Dockerfile new file mode 100644 index 0000000..2e4de4f --- /dev/null +++ b/test/fixtures/8.Dockerfile @@ -0,0 +1,4 @@ +FROM debian:buster +# escape = ` +RUN cmd a \ + && cmd b