From 6b92272ca7c5a7d570b3a828b0fa870135c52062 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Moritz=20R=C3=B6hrich?= Date: Sat, 24 Apr 2021 18:02:37 +0200 Subject: [PATCH 1/2] parser: handle parser directives - Add handling for parser directives (pragmas) to the parser: `escape`, `index` - Split off tests into separate modules - Version bump to 9.4.0 See also: https://docs.docker.com/engine/reference/builder/#parser-directives fixes: https://github.com/hadolint/hadolint/issues/371 fixes: https://github.com/hadolint/language-docker/issues/48 --- language-docker.cabal | 8 ++- package.yaml | 10 ++- src/Language/Docker/Parser.hs | 43 +++++++++--- src/Language/Docker/Parser/Arguments.hs | 6 +- src/Language/Docker/Parser/Cmd.hs | 4 +- src/Language/Docker/Parser/Copy.hs | 20 +++--- src/Language/Docker/Parser/Expose.hs | 10 ++- src/Language/Docker/Parser/From.hs | 20 +++--- src/Language/Docker/Parser/Healthcheck.hs | 7 +- src/Language/Docker/Parser/Instruction.hs | 73 ++++++++++++++------ src/Language/Docker/Parser/Pairs.hs | 18 +++-- src/Language/Docker/Parser/Prelude.hs | 68 ++++++++++++------- src/Language/Docker/Parser/Run.hs | 32 +++++---- src/Language/Docker/PrettyPrint.hs | 8 ++- src/Language/Docker/Syntax.hs | 25 ++++++- test/Language/Docker/IntegrationSpec.hs | 83 ++++++++++++++++++++--- test/Language/Docker/ParsePragmaSpec.hs | 73 ++++++++++++++++++++ test/Language/Docker/ParserSpec.hs | 24 +------ test/Language/Docker/PrettyPrintSpec.hs | 23 ++++++- test/TestHelper.hs | 38 +++++++++++ test/fixtures/3.Dockerfile | 6 ++ test/fixtures/4.Dockerfile | 8 +++ test/fixtures/5.Dockerfile | 8 +++ 23 files changed, 454 insertions(+), 161 deletions(-) create mode 100644 test/Language/Docker/ParsePragmaSpec.hs create mode 100644 test/TestHelper.hs create mode 100644 test/fixtures/3.Dockerfile create mode 100644 test/fixtures/4.Dockerfile create mode 100644 test/fixtures/5.Dockerfile diff --git a/language-docker.cabal b/language-docker.cabal index 6886e78..780dcc0 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: 4c166335e4f8bb1979bf3b9b406bb34b47d9c7f6a89f165a58ba5c696e84e54e name: language-docker -version: 9.3.0 +version: 9.4.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 OverloadedStrings OverloadedLists build-depends: HUnit >=1.2 , QuickCheck diff --git a/package.yaml b/package.yaml index aad39ff..4270f95 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: language-docker -version: '9.3.0' +version: '9.4.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,8 @@ extra-source-files: - README.md - test/fixtures/1.Dockerfile - test/fixtures/2.Dockerfile +default-extensions: + - OverloadedStrings dependencies: - base >=4.8 && <5 @@ -46,6 +48,9 @@ library: - -Wredundant-constraints - -fno-warn-unused-do-bind - -fno-warn-orphans + default-extensions: + - ImplicitParams + - Rank2Types exposed-modules: - Language.Docker - Language.Docker.Parser @@ -56,6 +61,9 @@ tests: hspec: main: Spec.hs source-dirs: test + default-extensions: + - OverloadedStrings + - OverloadedLists dependencies: - hspec - QuickCheck diff --git a/src/Language/Docker/Parser.hs b/src/Language/Docker/Parser.hs index add0d4e..d17a857 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,19 +32,42 @@ 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 - doParse = parse (contents dockerfile) "/dev/stdin" . dos2unix . E.decodeUtf8With E.lenientDecode + ?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 + src = dos2unix (E.decodeUtf8With E.lenientDecode txt) -- | Changes crlf line endings to simple line endings dos2unix :: T.Text -> T.Text dos2unix = T.replace "\r\n" "\n" + +defaultEsc :: Char +defaultEsc = '\\' 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..08de49d 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 #-} @@ -232,6 +231,10 @@ prettyPrintRunSecurity Nothing = mempty prettyPrintRunSecurity (Just Sandbox) = "--security=sandbox" prettyPrintRunSecurity (Just Insecure) = "--security=insecure" +prettyPrintPragma :: PragmaDirective -> Doc ann +prettyPrintPragma (Escape (EscapeChar esc)) = "escape = " <> pretty esc +prettyPrintPragma (Syntax (SyntaxImage img)) = "syntax = " <> prettyPrintImage img + prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann prettyPrintInstruction i = case i of @@ -283,6 +286,9 @@ prettyPrintInstruction i = User u -> do "USER" pretty u + Pragma p -> do + pretty '#' + prettyPrintPragma p Comment s -> do pretty '#' pretty s diff --git a/src/Language/Docker/Syntax.hs b/src/Language/Docker/Syntax.hs index 32b75ad..1b27bdb 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) diff --git a/test/Language/Docker/IntegrationSpec.hs b/test/Language/Docker/IntegrationSpec.hs index eb17cfd..d2cfbab 100644 --- a/test/Language/Docker/IntegrationSpec.hs +++ b/test/Language/Docker/IntegrationSpec.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} - module Language.Docker.IntegrationSpec where import qualified Data.Text as Text @@ -14,30 +11,94 @@ 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 "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..1920250 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 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 From e872906a9da39f1fe8b843096fa6a04baaaa991f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Moritz=20R=C3=B6hrich?= Date: Sun, 2 May 2021 14:28:12 +0200 Subject: [PATCH 2/2] pretty printer: detect escape character from AST - Add escape character detection logic to the pretty printer - Replace the escape character on demand for printing - Add tests ensuring correct default behaviour - Version bump to 10.0.0 due to API change When pretty printing, look ahead into the AST to be printed to determine which escape character to choose. Then use that character during printing. This is possibly a major breaking change in the API, because `Arguments Text` is no longer an instance of `Pretty`. Instead the pretty printer expects all instructions to be of type `Instruction Text` and not `Instruction args`. This allows the arguments to the instructions to be printed with the correct escape character. --- language-docker.cabal | 6 +-- package.yaml | 8 ++-- src/Language/Docker/Parser.hs | 3 -- src/Language/Docker/PrettyPrint.hs | 56 ++++++++++++++----------- src/Language/Docker/Syntax.hs | 3 ++ test/Language/Docker/IntegrationSpec.hs | 30 ++++++++++++- test/Language/Docker/PrettyPrintSpec.hs | 5 ++- test/fixtures/6.Dockerfile | 3 ++ test/fixtures/7.Dockerfile | 3 ++ test/fixtures/8.Dockerfile | 4 ++ 10 files changed, 83 insertions(+), 38 deletions(-) create mode 100644 test/fixtures/6.Dockerfile create mode 100644 test/fixtures/7.Dockerfile create mode 100644 test/fixtures/8.Dockerfile diff --git a/language-docker.cabal b/language-docker.cabal index 780dcc0..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: 4c166335e4f8bb1979bf3b9b406bb34b47d9c7f6a89f165a58ba5c696e84e54e +-- hash: 2c9caaab990151b5cf17795136674a3655d2422f22f1e4c84806741c1309e5bd name: language-docker -version: 9.4.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. @@ -79,7 +79,7 @@ test-suite hspec Paths_language_docker hs-source-dirs: test - default-extensions: OverloadedStrings OverloadedStrings OverloadedLists + default-extensions: OverloadedStrings ImplicitParams Rank2Types OverloadedLists build-depends: HUnit >=1.2 , QuickCheck diff --git a/package.yaml b/package.yaml index 4270f95..1a58fb6 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: language-docker -version: '9.4.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 @@ -26,6 +26,8 @@ extra-source-files: - test/fixtures/2.Dockerfile default-extensions: - OverloadedStrings + - ImplicitParams + - Rank2Types dependencies: - base >=4.8 && <5 @@ -48,9 +50,6 @@ library: - -Wredundant-constraints - -fno-warn-unused-do-bind - -fno-warn-orphans - default-extensions: - - ImplicitParams - - Rank2Types exposed-modules: - Language.Docker - Language.Docker.Parser @@ -62,7 +61,6 @@ tests: main: Spec.hs source-dirs: test default-extensions: - - OverloadedStrings - OverloadedLists dependencies: - hspec diff --git a/src/Language/Docker/Parser.hs b/src/Language/Docker/Parser.hs index d17a857..cc783fe 100644 --- a/src/Language/Docker/Parser.hs +++ b/src/Language/Docker/Parser.hs @@ -68,6 +68,3 @@ doParse path txt = do -- | Changes crlf line endings to simple line endings dos2unix :: T.Text -> T.Text dos2unix = T.replace "\r\n" "\n" - -defaultEsc :: Char -defaultEsc = '\\' diff --git a/src/Language/Docker/PrettyPrint.hs b/src/Language/Docker/PrettyPrint.hs index 08de49d..d9e8b83 100644 --- a/src/Language/Docker/PrettyPrint.hs +++ b/src/Language/Docker/PrettyPrint.hs @@ -27,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 @@ -75,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 @@ -159,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 @@ -235,7 +241,7 @@ prettyPrintPragma :: PragmaDirective -> Doc ann prettyPrintPragma (Escape (EscapeChar esc)) = "escape = " <> pretty esc prettyPrintPragma (Syntax (SyntaxImage img)) = "syntax = " <> prettyPrintImage img -prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann +prettyPrintInstruction :: (?esc :: Char) => Instruction Text -> Doc ann prettyPrintInstruction i = case i of Maintainer m -> do @@ -249,7 +255,7 @@ prettyPrintInstruction i = pretty k <> "=" <> pretty v Entrypoint e -> do "ENTRYPOINT" - pretty e + prettyPrintArguments e Stopsignal s -> do "STOPSIGNAL" pretty s @@ -267,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 @@ -276,7 +282,7 @@ prettyPrintInstruction i = prettyPrintFileList sourcePaths targetPath Cmd c -> do "CMD" - pretty c + prettyPrintArguments c Label l -> do "LABEL" prettyPrintPairs l @@ -305,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" @@ -314,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 1b27bdb..91538ea 100644 --- a/src/Language/Docker/Syntax.hs +++ b/src/Language/Docker/Syntax.hs @@ -371,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 d2cfbab..04c01dc 100644 --- a/test/Language/Docker/IntegrationSpec.hs +++ b/test/Language/Docker/IntegrationSpec.hs @@ -4,7 +4,7 @@ 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) @@ -42,6 +42,34 @@ spec = do 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" diff --git a/test/Language/Docker/PrettyPrintSpec.hs b/test/Language/Docker/PrettyPrintSpec.hs index 1920250..3f73045 100644 --- a/test/Language/Docker/PrettyPrintSpec.hs +++ b/test/Language/Docker/PrettyPrintSpec.hs @@ -145,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/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