Merge pull request #62 from m-ildefons/escape-character

parser: handle parser directives

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 <https://github.com/hadolint/language-docker GitHub project> 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

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

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) "<string>" . dos2unix
+parseText txt = do
+  let ?esc = findEscapePragma (T.lines (dos2unix txt))
+   in parse (contents dockerfile) "<string>" (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) "<line>" 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

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

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

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" (== '=')

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" (== '$')

src/Language/Docker/Parser/From.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Language.Docker.Parser.From
   ( parseFrom,
   )
@@ -9,22 +7,22 @@ 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 '.'
   tld <- someUnless "a TLD" (== '/')
   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,21 +33,21 @@ 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
       void $ char ':'
       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

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" (== '=')