diff --git a/language-docker.cabal b/language-docker.cabal --- a/language-docker.cabal +++ b/language-docker.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack -- --- hash: f800aba94b9f6bbf2894ac78e2f4a135d3e9e89e04d9a7b0549bdd0941e97cbd +-- hash: 37c989b46891ef750c66b64a1dcbdfc30c1ee22a0ed4821aeb27c7c63c02d2a9 name: language-docker -version: 12.0.0 +version: 12.1.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. @@ -94,6 +94,7 @@ Language.Docker.ParseCmdSpec Language.Docker.ParseCopySpec Language.Docker.ParseExposeSpec + Language.Docker.ParseHealthcheckSpec Language.Docker.ParsePragmaSpec Language.Docker.ParserSpec Language.Docker.ParseRunSpec diff --git a/src/Language/Docker/Parser/Arguments.hs b/src/Language/Docker/Parser/Arguments.hs --- a/src/Language/Docker/Parser/Arguments.hs +++ b/src/Language/Docker/Parser/Arguments.hs @@ -22,7 +22,7 @@ toEnd = untilEol "the shell arguments" -- Parse arguments of a command in the heredoc format -argumentsHeredoc :: Parser (Arguments Text) +argumentsHeredoc :: (?esc :: Char) => Parser (Arguments Text) argumentsHeredoc = ArgumentsText <$> heredoc arguments :: (?esc :: Char) => Parser (Arguments Text) diff --git a/src/Language/Docker/Parser/Healthcheck.hs b/src/Language/Docker/Parser/Healthcheck.hs --- a/src/Language/Docker/Parser/Healthcheck.hs +++ b/src/Language/Docker/Parser/Healthcheck.hs @@ -70,12 +70,14 @@ durationFlag :: Text -> Parser Duration durationFlag flagName = do void $ try (string flagName) - scale <- natural + value <- try ( fromRational . realToFrac <$> fractional ) + <|> ( secondsToDiffTime . fromInteger <$> natural ) + "a natural or fractional number" unit <- char 's' <|> char 'm' <|> char 'h' "either 's', 'm' or 'h' as the unit" case unit of - 's' -> return $ Duration (secondsToDiffTime scale) - 'm' -> return $ Duration (secondsToDiffTime (scale * 60)) - 'h' -> return $ Duration (secondsToDiffTime (scale * 60 * 60)) + 's' -> return $ Duration value + 'm' -> return $ Duration (value * 60) + 'h' -> return $ Duration (value * 60 * 60) _ -> fail "only 's', 'm' or 'h' are allowed as the duration" retriesFlag :: Parser Retries diff --git a/src/Language/Docker/Parser/Prelude.hs b/src/Language/Docker/Parser/Prelude.hs --- a/src/Language/Docker/Parser/Prelude.hs +++ b/src/Language/Docker/Parser/Prelude.hs @@ -14,6 +14,8 @@ doubleQuotedString, doubleQuotedStringEscaped, eol, + escapedLineBreaks', + fractional, heredoc, heredocContent, heredocMarker, @@ -133,6 +135,9 @@ natural :: Parser Integer natural = L.decimal "positive number" +fractional :: Parser Float +fractional = L.float "fractional number" + commaSep :: (?esc :: Char) => Parser a -> Parser [a] commaSep p = sepBy (p <* whitespace) (symbol ",") @@ -170,7 +175,7 @@ s <- manyTill anySingle spaceChar return $ T.pack s -heredocMarker :: Parser Text +heredocMarker :: (?esc :: Char) => Parser Text heredocMarker = do void $ string "<<" void $ takeWhileP (Just "dash") (== '-') @@ -178,11 +183,14 @@ optional heredocRedirect pure m -heredocRedirect :: Parser Text +heredocRedirect :: (?esc :: Char) => Parser Text heredocRedirect = do - void $ char '>' - takeWhileP (Just "heredoc path") (/= '\n') + void $ ( string "|" <|> string ">" <|> string ">>" ) *> onlySpaces + untilEol "heredoc path" +-- | This tries to parse everything until there is the just the heredoc marker +-- on its own on a line. Making provisions for the case that the marker is +-- followed by the end of the file rather than another newline. heredocContent :: Text -> Parser Text heredocContent marker = do emptyHeredoc <- observing delimiter @@ -215,17 +223,24 @@ hidden eof pure t -heredoc :: Parser Text +heredoc :: (?esc :: Char) => Parser Text heredoc = do m <- heredocMarker heredocContent m -- | Parses text until a heredoc or newline is found. Will also consume the --- heredoc. -untilHeredoc :: Parser Text +-- heredoc. It will however respect escaped newlines. +untilHeredoc :: (?esc :: Char) => Parser Text untilHeredoc = do - txt <- manyTill (anySingleBut '\n') heredoc - return $ T.strip $ T.pack txt + txt <- manyTill chars heredoc + return $ T.strip $ mconcat txt + where + chars = + choice + [ castToSpace <$> escapedLineBreaks, + charToTxt <$> anySingleBut '\n' + ] + charToTxt c = T.pack [c] onlySpaces :: Parser Text onlySpaces = takeWhileP (Just "spaces") (\c -> c == ' ' || c == '\t') @@ -248,6 +263,17 @@ -- 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 + +-- | This converts escaped line breaks, but keeps _all_ spaces before and after +escapedLineBreaks' :: (?esc :: Char) => Parser Text +escapedLineBreaks' = mconcat <$> breaks + where + breaks = + some $ do + try ( char ?esc *> onlySpaces *> newlines ) + skipMany . try $ onlySpaces *> comment *> newlines + onlySpaces1 newlines = takeWhile1P Nothing isNl foundWhitespace :: (?esc :: Char) => Parser FoundWhitespace diff --git a/src/Language/Docker/Syntax.hs b/src/Language/Docker/Syntax.hs --- a/src/Language/Docker/Syntax.hs +++ b/src/Language/Docker/Syntax.hs @@ -161,7 +161,7 @@ = Duration { durationTime :: DiffTime } - deriving (Show, Eq, Ord, Num) + deriving (Show, Eq, Ord, Num, Fractional) newtype Retries = Retries diff --git a/test/Language/Docker/ParseHealthcheckSpec.hs b/test/Language/Docker/ParseHealthcheckSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Docker/ParseHealthcheckSpec.hs @@ -0,0 +1,81 @@ +module Language.Docker.ParseHealthcheckSpec where + +import Data.Default.Class (def) +import Language.Docker.Syntax +import Test.Hspec +import TestHelper +import qualified Data.Set as Set +import qualified Data.Text as Text + + +spec :: Spec +spec = do + describe "parse HEALTHCHECK" $ do + it "parse healthcheck with interval" $ + assertAst + "HEALTHCHECK --interval=5m \\\nCMD curl -f http://localhost/" + [ Healthcheck $ + Check $ + CheckArgs "curl -f http://localhost/" (Just 300) Nothing Nothing Nothing + ] + it "parse healthcheck with retries" $ + assertAst + "HEALTHCHECK --retries=10 CMD curl -f http://localhost/" + [ Healthcheck $ + Check $ + CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing (Just $ Retries 10) + ] + it "parse healthcheck with timeout" $ + assertAst + "HEALTHCHECK --timeout=10s CMD curl -f http://localhost/" + [ Healthcheck $ + Check $ + CheckArgs "curl -f http://localhost/" Nothing (Just 10) Nothing Nothing + ] + it "parse healthcheck with start-period" $ + assertAst + "HEALTHCHECK --start-period=2m CMD curl -f http://localhost/" + [ Healthcheck $ + Check $ + CheckArgs "curl -f http://localhost/" Nothing Nothing (Just 120) Nothing + ] + it "parse healthcheck with all flags" $ + assertAst + "HEALTHCHECK --start-period=2s --timeout=1m --retries=3 --interval=5s CMD curl -f http://localhost/" + [ Healthcheck $ + Check $ + CheckArgs + "curl -f http://localhost/" + (Just 5) + (Just 60) + (Just 2) + (Just $ Retries 3) + ] + it "parse healthcheck with no flags" $ + assertAst + "HEALTHCHECK CMD curl -f http://localhost/" + [ Healthcheck $ + Check $ + CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing Nothing + ] + + it "fractional arguments to flags" $ + let file = + Text.unlines + [ "HEALTHCHECK \\", + " --interval=0.5s \\", + " --timeout=0.1s \\", + " --start-period=0.2s \\", + " CMD curl -f http://localhost" + ] + in assertAst + file + [ Healthcheck $ + Check $ + CheckArgs + "curl -f http://localhost" + ( Just 0.5 ) + ( Just 0.10000000149 ) + ( Just 0.20000000298 ) + Nothing + ] diff --git a/test/Language/Docker/ParseRunSpec.hs b/test/Language/Docker/ParseRunSpec.hs --- a/test/Language/Docker/ParseRunSpec.hs +++ b/test/Language/Docker/ParseRunSpec.hs @@ -14,6 +14,9 @@ it "escaped with space before" $ let dockerfile = Text.unlines ["RUN yum install -y \\", "imagemagick \\", "mysql"] in assertAst dockerfile [Run "yum install -y imagemagick mysql"] + it "escaped linebreak, indented" $ + let file = Text.unlines [ "RUN foo ; \\", " bar" ] + in assertAst file [ Run "foo ; bar" ] it "does not choke on unmatched brackets" $ let dockerfile = Text.unlines ["RUN [foo"] in assertAst dockerfile [Run "[foo"] @@ -501,17 +504,25 @@ in assertAst file [ Run $ RunArgs (ArgumentsText "foo\nbar EOF") flags ] it "heredoc with redirection to file" $ let file = Text.unlines [ "RUN < /file", "foo", "EOF" ] - flags = def {security = Nothing } + flags = def { security = Nothing } in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ] it "heredoc to program stdin" $ let file = Text.unlines [ "RUN python <'" $ let file = Text.unlines [ "RUN python < /file", "print(\"foo\")", "EOF" ] - flags = def {security = Nothing } + flags = def { security = Nothing } in assertAst file [ Run $ RunArgs (ArgumentsText "python") flags ] - it "heredoc with line continuation" $ + it "heredoc to program stdin with redirect to file with '>>'" $ + let file = Text.unlines [ "RUN python <> /file", "print(\"foo\")", "EOF" ] + flags = def { security = Nothing } + in assertAst file [ Run $ RunArgs (ArgumentsText "python") flags ] + it "heredoc pipe to program" $ + let file = Text.unlines [ "RUN cat <> go.mod && \\", + " tac go.mod", + "replace (", + " github.com/user/repo => ../dir", + ")", + "EOF" + ] + flags = def + + in assertAst + file + [ Run $ RunArgs ( ArgumentsText "ls && cat" ) flags + ] + + it "heredoc in command chain with escaped newlines before heredoc" $ + let file = + Text.unlines + [ "RUN ls && \\", + " cat <> go.mod && tac go.mod", + "replace (", + " github.com/user/repo => ../dir", + ")", + "EOF" + ] + flags = def + + in assertAst + file + [ Run $ RunArgs ( ArgumentsText "ls && cat" ) flags + ] + + it "heredoc in command chain with escaped newlines before and after heredoc" $ + let file = + Text.unlines + [ "RUN ls && \\", + " cat <> go.mod && \\", + " tac go.mod", + "replace (", + " github.com/user/repo => ../dir", + ")", + "EOF" + ] + flags = def + + in assertAst + file + [ Run $ RunArgs ( ArgumentsText "ls && cat" ) flags ] diff --git a/test/Language/Docker/ParserSpec.hs b/test/Language/Docker/ParserSpec.hs --- a/test/Language/Docker/ParserSpec.hs +++ b/test/Language/Docker/ParserSpec.hs @@ -174,54 +174,6 @@ describe "parse SHELL" $ it "quoted shell params" $ assertAst "SHELL [\"/bin/bash\", \"-c\"]" [Shell ["/bin/bash", "-c"]] - describe "parse HEALTHCHECK" $ do - it "parse healthcheck with interval" $ - assertAst - "HEALTHCHECK --interval=5m \\\nCMD curl -f http://localhost/" - [ Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" (Just 300) Nothing Nothing Nothing - ] - it "parse healthcheck with retries" $ - assertAst - "HEALTHCHECK --retries=10 CMD curl -f http://localhost/" - [ Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing (Just $ Retries 10) - ] - it "parse healthcheck with timeout" $ - assertAst - "HEALTHCHECK --timeout=10s CMD curl -f http://localhost/" - [ Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" Nothing (Just 10) Nothing Nothing - ] - it "parse healthcheck with start-period" $ - assertAst - "HEALTHCHECK --start-period=2m CMD curl -f http://localhost/" - [ Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" Nothing Nothing (Just 120) Nothing - ] - it "parse healthcheck with all flags" $ - assertAst - "HEALTHCHECK --start-period=2s --timeout=1m --retries=3 --interval=5s CMD curl -f http://localhost/" - [ Healthcheck $ - Check $ - CheckArgs - "curl -f http://localhost/" - (Just 5) - (Just 60) - (Just 2) - (Just $ Retries 3) - ] - it "parse healthcheck with no flags" $ - assertAst - "HEALTHCHECK CMD curl -f http://localhost/" - [ Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing Nothing - ] describe "parse MAINTAINER" $ do it "maintainer of untagged scratch image" $ assertAst