language-docker 1.0.0 → 2.0.0

raw patch · 18 files changed

+1006/−315 lines, 18 filesdep +semigroupsdep +timedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: semigroups, time

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +25/−8
• language-docker.cabal +36/−32
• src/Language/Docker.hs +18/−5
• src/Language/Docker/EDSL.hs +75/−14
• src/Language/Docker/EDSL/Quasi.hs +2/−10
• src/Language/Docker/EDSL/Types.hs +18/−11
• src/Language/Docker/Lexer.hs +53/−36
• src/Language/Docker/Normalize.hs +69/−30
• src/Language/Docker/Parser.hs +270/−72
• src/Language/Docker/Predef.hs +14/−10
• src/Language/Docker/PrettyPrint.hs +70/−17
• src/Language/Docker/Syntax.hs +91/−33
• src/Language/Docker/Syntax/Lift.hs +35/−0
• test/Language/Docker/EDSL/PluginsSpec.hs +1/−1
• test/Language/Docker/EDSL/QuasiSpec.hs +5/−5
• test/Language/Docker/EDSLSpec.hs +21/−5
• test/Language/Docker/ExamplesSpec.hs +1/−1
• test/Language/Docker/ParserSpec.hs +202/−25

@@ -1,11 +1,13 @@+[![Build Status][travis-img]][travis]+[![Hackage][hackage-img]][hackage]+[![GPL-3 licensed][license-img]][license]+ # haskell-language-docker-[Hackage](https://hackage.haskell.org/package/language-docker) -- - - Dockerfile parser, pretty-printer and embedded DSL -Provides de ability to parse docker files, a pretty-printer and EDSL for writting Dockerfiles in-Haskell.+Provides de ability to parse docker files, a pretty-printer and EDSL for+writting Dockerfiles in Haskell.  - [Parsing files](#parsing-files) - [Parsing strings](#parsing-strings)@@ -16,6 +18,7 @@ - [Using IO in the DSL](#using-io-in-the-dsl)  ## Parsing files+ ```haskell import Language.Docker main = do@@ -24,6 +27,7 @@ ```  ## Parsing strings+ ```haskell import Language.Docker main = do@@ -32,6 +36,7 @@ ```  ## Pretty-printing files+ ```haskell import Language.Docker main = do@@ -40,6 +45,7 @@ ```  ## Writing Dockerfiles in Haskell+ ```haskell {-# LANGUAGE OverloadedStrings #-} import Language.Docker@@ -51,6 +57,7 @@ ```  ## Using the QuasiQuoter+ ```haskell {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}@@ -66,17 +73,21 @@ ```  ## Templating Dockerfiles in Haskell+ ```haskell {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} import Control.Monad import Language.Docker+import Data.String (fromString)+ tags = ["7.8", "7.10", "8"] cabalSandboxBuild packageName = do     let cabalFile = packageName ++ ".cabal"     run "cabal sandbox init"     run "cabal update"-    add cabalFile ("/app/" ++ cabalFile)+    add [fromString cabalFile] (fromString $ "/app/" ++ cabalFile)     run "cabal install --only-dep -j"     add "." "/app/"     run "cabal build"@@ -94,10 +105,12 @@  ```haskell {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} import           Language.Docker import qualified System.Directory     as Directory import qualified System.FilePath      as FilePath import qualified System.FilePath.Glob as Glob+import Data.String (fromString) main = do     str <- toDockerfileStrIO $ do         fs <- liftIO $ do@@ -105,9 +118,13 @@             fs <- Glob.glob "./test/*.hs"             return (map (FilePath.makeRelative cwd) fs)         from "ubuntu"-        mapM_ (\f -> add f ("/app/" ++ FilePath.takeFileName f)) fs+	mapM_ (\f -> add [fromString f] (fromString $ "/app/" ++ takeFileName f)) fs     putStr str ``` -## License-GPLv3+[hackage-img]: https://img.shields.io/hackage/v/language-docker.svg+[hackage]: https://hackage.haskell.org/package/language-docker+[travis-img]: https://travis-ci.org/hadolint/language-docker.svg?branch=master+[travis]: https://travis-ci.org/hadolint/language-docker+[license-img]: https://img.shields.io/badge/license-GPL--3-blue.svg+[license]: https://tldrlegal.com/license/gnu-general-public-license-v3-(gpl-3)

@@ -1,12 +1,14 @@--- This file has been generated from package.yaml by hpack version 0.17.1.+-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack+--+-- hash: 36a6870b23b3361a5461b7bc8d6898e79dbe2fbba21bd305461ca8433e1dda3d  name:           language-docker-version:        1.0.0+version:        2.0.0 synopsis:       Dockerfile parser, pretty-printer and embedded DSL-description:     All functions for parsing, printing and writting 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-dockerfile GitHub project> for the source-code and examples. +description:    All functions for parsing, printing and writting 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. category:       Development homepage:       https://github.com/hadolint/language-docker#readme bug-reports:    https://github.com/hadolint/language-docker/issues@@ -35,24 +37,26 @@       src   ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans   build-depends:-      base >=4.8 && <5+      Glob+    , aeson+    , base >=4.8 && <5     , bytestring >=0.10+    , directory+    , filepath+    , free+    , mtl     , parsec >=3.1     , pretty+    , semigroups     , split >=0.2-    , free-    , mtl-    , transformers     , template-haskell+    , text     , th-lift     , th-lift-instances-    , text-    , yaml-    , aeson-    , Glob+    , time+    , transformers     , unordered-containers-    , directory-    , filepath+    , yaml   exposed-modules:       Language.Docker       Language.Docker.Parser@@ -76,36 +80,36 @@   hs-source-dirs:       test   build-depends:-      base >=4.8 && <5+      Glob+    , HUnit >=1.2+    , QuickCheck+    , aeson+    , base >=4.8 && <5     , bytestring >=0.10+    , directory+    , filepath+    , free+    , hspec+    , language-docker+    , mtl     , parsec >=3.1     , pretty+    , process+    , semigroups     , split >=0.2-    , free-    , mtl-    , transformers     , template-haskell+    , text     , th-lift     , th-lift-instances-    , text-    , yaml-    , aeson-    , Glob+    , time+    , transformers     , unordered-containers-    , directory-    , filepath-    , hspec-    , QuickCheck-    , language-docker-    , Glob-    , directory-    , filepath-    , process-    , HUnit >=1.2+    , yaml   other-modules:       Language.Docker.EDSL.PluginsSpec       Language.Docker.EDSL.QuasiSpec       Language.Docker.EDSLSpec       Language.Docker.ExamplesSpec       Language.Docker.ParserSpec+      Paths_language_docker   default-language: Haskell2010

@@ -18,6 +18,7 @@     , Language.Docker.EDSL.tagged     , Language.Docker.EDSL.untagged     , Language.Docker.EDSL.digested+    , Language.Docker.EDSL.aliased       -- ** Syntax     , Language.Docker.EDSL.add     , Language.Docker.EDSL.user@@ -28,10 +29,18 @@     , Language.Docker.EDSL.runArgs     , Language.Docker.EDSL.cmd     , Language.Docker.EDSL.cmdArgs+    , Language.Docker.EDSL.healthcheck+    , Language.Docker.EDSL.check+    , Language.Docker.EDSL.interval+    , Language.Docker.EDSL.timeout+    , Language.Docker.EDSL.startPeriod+    , Language.Docker.EDSL.retries     , Language.Docker.EDSL.workdir     , Language.Docker.EDSL.expose     , Language.Docker.EDSL.ports-    , Language.Docker.EDSL.port+    , Language.Docker.EDSL.tcpPort+    , Language.Docker.EDSL.udpPort+    , Language.Docker.EDSL.variablePort     , Language.Docker.EDSL.volume     , Language.Docker.EDSL.entrypoint     , Language.Docker.EDSL.entrypointArgs@@ -53,12 +62,18 @@     , Language.Docker.Syntax.Instruction(..)     , Language.Docker.Syntax.InstructionPos(..)     , Language.Docker.Syntax.BaseImage(..)+    , Language.Docker.Syntax.SourcePath(..)+    , Language.Docker.Syntax.TargetPath(..)+    , Language.Docker.Syntax.Chown(..)+    , Language.Docker.Syntax.CopySource(..)+    , Language.Docker.Syntax.CopyArgs(..)+    , Language.Docker.Syntax.AddArgs(..)+    , Language.Docker.Syntax.Check(..)+    , Language.Docker.Syntax.CheckArgs(..)     , Language.Docker.Syntax.Image     , Language.Docker.Syntax.Tag     , Language.Docker.Syntax.Ports     , Language.Docker.Syntax.Directory-    , Language.Docker.Syntax.Source-    , Language.Docker.Syntax.Destination     , Language.Docker.Syntax.Arguments     , Language.Docker.Syntax.Pairs     , Language.Docker.Syntax.Filename@@ -66,9 +81,7 @@     -- * Re-exports from @parsec@     , ParseError     -- * Instruction and InstructionPos helpers-    , Language.Docker.Syntax.instruction     , Language.Docker.EDSL.instructionPos-    , Language.Docker.Syntax.sourcename     ) where  import qualified Control.Monad.IO.Class

@@ -9,6 +9,7 @@ import Control.Monad.Trans.Free (FreeT, iterTM) import Control.Monad.Writer import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty)  import qualified Language.Docker.PrettyPrint as PrettyPrint import qualified Language.Docker.Syntax as Syntax@@ -45,16 +46,16 @@ runD :: MonadWriter [Syntax.Instruction] m => EInstruction (m b) -> m b runD (From bi n) =     case bi of-        EUntaggedImage bi' -> runDef Syntax.From (Syntax.UntaggedImage bi') n-        ETaggedImage bi' tg -> runDef Syntax.From (Syntax.TaggedImage bi' tg) n-        EDigestedImage bi' d -> runDef Syntax.From (Syntax.DigestedImage bi' d) n+        EUntaggedImage bi' alias -> runDef Syntax.From (Syntax.UntaggedImage bi' alias) n+        ETaggedImage bi' tg alias -> runDef Syntax.From (Syntax.TaggedImage bi' tg alias) n+        EDigestedImage bi' d alias -> runDef Syntax.From (Syntax.DigestedImage bi' d alias) n runD (CmdArgs as n) = runDef Syntax.Cmd as n runD (Shell as n) = runDef Syntax.Shell as n-runD (Add s d n) = runDef2 Syntax.Add s d n+runD (AddArgs s d c n) = runDef Syntax.Add (Syntax.AddArgs s d c) n runD (User u n) = runDef Syntax.User u n runD (Label ps n) = runDef Syntax.Label ps n runD (StopSignal s n) = runDef Syntax.Stopsignal s n-runD (Copy s d n) = runDef2 Syntax.Copy s d n+runD (CopyArgs s d c f n) = runDef Syntax.Copy (Syntax.CopyArgs s d c f) n runD (RunArgs as n) = runDef Syntax.Run as n runD (Workdir d n) = runDef Syntax.Workdir d n runD (Expose ps n) = runDef Syntax.Expose ps n@@ -62,7 +63,7 @@ runD (EntrypointArgs e n) = runDef Syntax.Entrypoint e n runD (Maintainer m n) = runDef Syntax.Maintainer m n runD (Env ps n) = runDef Syntax.Env ps n-runD (Arg s n) = runDef Syntax.Arg s n+runD (Arg k v n) = runDef2 Syntax.Arg k v n runD (Comment c n) = runDef Syntax.Comment c n runD (Healthcheck c n) = runDef Syntax.Healthcheck c n runD (OnBuildRaw i n) = runDef Syntax.OnBuild i n@@ -89,8 +90,8 @@ -- main :: IO () -- main = writeFile "something.dockerfile" $ toDockerfileStr $ do --     from (tagged "fpco/stack-build" "lts-6.9")---     add "." "/app/language-dockerfile"---     workdir "/app/language-dockerfile"+--     add ["."] "/app/language-docker"+--     workdir "/app/language-docker" --     run (words "stack build --test --only-dependencies") --     cmd (words "stack test") -- @@@ -98,20 +99,36 @@ toDockerfileStr = PrettyPrint.prettyPrint . toDockerfile  untagged :: String -> EBaseImage-untagged = EUntaggedImage+untagged = flip EUntaggedImage Nothing  tagged :: String -> String -> EBaseImage-tagged = ETaggedImage+tagged imageName tag = ETaggedImage imageName tag Nothing  digested :: String -> ByteString -> EBaseImage-digested = EDigestedImage+digested imageName hash = EDigestedImage imageName hash Nothing -ports :: [Integer] -> Syntax.Ports+aliased :: EBaseImage -> String -> EBaseImage+aliased image alias =+    case image of+        EUntaggedImage n _ -> EUntaggedImage n (Just $ Syntax.ImageAlias alias)+        ETaggedImage n t _ -> ETaggedImage n t (Just $ Syntax.ImageAlias alias)+        EDigestedImage n h _ -> EDigestedImage n h (Just $ Syntax.ImageAlias alias)++ports :: [Syntax.Port] -> Syntax.Ports ports = Syntax.Ports -port :: Integer -> Syntax.Ports-port = Syntax.Ports . (: [])+tcpPort :: Integer -> Syntax.Port+tcpPort = flip Syntax.Port Syntax.TCP +udpPort :: Integer -> Syntax.Port+udpPort = flip Syntax.Port Syntax.UDP++variablePort :: String -> Syntax.Port+variablePort varName = Syntax.PortStr ('$' : varName)++portRange :: Integer -> Integer -> Syntax.Port+portRange = Syntax.PortRange+ run :: MonadFree EInstruction m => String -> m () run = runArgs . words @@ -120,6 +137,50 @@  cmd :: MonadFree EInstruction m => String -> m () cmd = cmdArgs . words++copy :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m ()+copy sources dest = copyArgs sources dest Syntax.NoChown Syntax.NoSource++add :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m ()+add sources dest = addArgs sources dest Syntax.NoChown++check :: String -> Syntax.Check+check command =+    Syntax.Check+        Syntax.CheckArgs+        { Syntax.checkCommand = words command+        , Syntax.interval = Nothing+        , Syntax.timeout = Nothing+        , Syntax.startPeriod = Nothing+        , Syntax.retries = Nothing+        }++interval :: Syntax.Check -> Integer -> Syntax.Check+interval ch secs =+    case ch of+        Syntax.NoCheck -> Syntax.NoCheck+        Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.interval = Just $ fromInteger secs}++timeout :: Syntax.Check -> Integer -> Syntax.Check+timeout ch secs =+    case ch of+        Syntax.NoCheck -> Syntax.NoCheck+        Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.timeout = Just $ fromInteger secs}++startPeriod :: Syntax.Check -> Integer -> Syntax.Check+startPeriod ch secs =+    case ch of+        Syntax.NoCheck -> Syntax.NoCheck+        Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.startPeriod = Just $ fromInteger secs}++retries :: Syntax.Check -> Integer -> Syntax.Check+retries ch tries =+    case ch of+        Syntax.NoCheck -> Syntax.NoCheck+        Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.retries = Just $ fromInteger tries}++noCheck :: Syntax.Check+noCheck = Syntax.NoCheck  -- | ONBUILD Dockerfile instruction --

@@ -9,7 +9,6 @@  import Language.Docker.EDSL import qualified Language.Docker.Parser as Parser-import Language.Docker.Syntax import Language.Docker.Syntax.Lift ()  -- | Quasiquoter for embedding dockerfiles on the EDSL@@ -30,9 +29,7 @@ edockerfileE e =     case Parser.parseString e of         Left err -> fail (show err)-        Right d ->-            let d' = filterEOL d-            in [|embed d'|]+        Right d -> [|embed d|]  dockerfile :: QuasiQuoter dockerfile =@@ -47,9 +44,4 @@ dockerfileE e =     case Parser.parseString e of         Left err -> fail (show err)-        Right d ->-            let d' = filterEOL d-            in lift d'--filterEOL :: [InstructionPos] -> [InstructionPos]-filterEOL = filter (\(InstructionPos i _ _) -> i /= EOL)+        Right d -> lift d

@@ -3,41 +3,48 @@ module Language.Docker.EDSL.Types where  import Data.ByteString.Char8 (ByteString)+import Data.List.NonEmpty (NonEmpty) import Data.String import qualified Language.Docker.Syntax as Syntax  data EBaseImage     = EUntaggedImage String+                     (Maybe Syntax.ImageAlias)     | ETaggedImage String                    String+                   (Maybe Syntax.ImageAlias)     | EDigestedImage String                      ByteString+                     (Maybe Syntax.ImageAlias)     deriving (Show, Eq, Ord)  instance IsString EBaseImage where-    fromString = EUntaggedImage+    fromString = flip EUntaggedImage Nothing  data EInstruction next     = From EBaseImage            next-    | Add Syntax.Source-          Syntax.Destination-          next+    | AddArgs (NonEmpty Syntax.SourcePath)+              Syntax.TargetPath+              Syntax.Chown+              next     | User String            next     | Label Syntax.Pairs             next     | StopSignal String                  next-    | Copy Syntax.Source-           Syntax.Destination-           next+    | CopyArgs (NonEmpty Syntax.SourcePath)+               Syntax.TargetPath+               Syntax.Chown+               Syntax.CopySource+               next     | RunArgs Syntax.Arguments               next     | CmdArgs Syntax.Arguments               next     | Shell Syntax.Arguments-              next+            next     | Workdir Syntax.Directory               next     | Expose Syntax.Ports@@ -50,12 +57,12 @@                  next     | Env Syntax.Pairs           next-    | Arg String+    | Arg String (Maybe String)           next     | Comment String               next-    | Healthcheck String-              next+    | Healthcheck Syntax.Check+                  next     | OnBuildRaw Syntax.Instruction                  next     | Embed [Syntax.InstructionPos]

@@ -1,53 +1,70 @@ module Language.Docker.Lexer where -import Text.Parsec.Language (emptyDef)+import Control.Monad (void)+import Data.Char+import Text.Parsec hiding (spaces)+import Text.Parsec.Language (haskell) import Text.Parsec.String (Parser) import qualified Text.Parsec.Token as Token -lexer :: Token.TokenParser ()-lexer = Token.makeTokenParser style -- style-  where-    names =-        [ "FROM"-        , "ADD"-        , "RUN"-        , "WORKDIR"-        , "EXPOSE"-        , "VOLUME"-        , "ENTRYPOINT"-        , "MAINTAINER"-        , "ENV"-        , "LABEL"-        , "USER"-        , "SHELL"-        , "STOPSIGNAL"-        , "CMD"-        , "ONBUILD"-        , "ARG"-        , "HEALTHCHECK"-        ]-    style = emptyDef {Token.caseSensitive = False, Token.reservedNames = names}- reserved :: String -> Parser ()-reserved = Token.reserved lexer--reservedOp :: String -> Parser ()-reservedOp = Token.reservedOp lexer+reserved name =+    void $ do+        _ <- try (caseInsensitiveString name) <?> name+        spaces1 <?> "at least one space after '" ++ name ++ "' followed by its arguments"  natural :: Parser Integer-natural = Token.natural lexer+natural = zeroNumber <|> Token.decimal haskell <?> "positive number"+  where+    zeroNumber = char '0' >> return 0  commaSep :: Parser a -> Parser [a]-commaSep = Token.commaSep lexer+commaSep p = sepBy p (symbol ",")  stringLiteral :: Parser String-stringLiteral = Token.stringLiteral lexer+stringLiteral = Token.stringLiteral haskell  brackets :: Parser a -> Parser a-brackets = Token.brackets lexer+brackets = between (symbol "[") (symbol "]") -identifier :: Parser String-identifier = Token.identifier lexer+whiteSpace :: Parser ()+whiteSpace = void (char ' ' <|> char '\t') <?> "space" +space :: Parser ()+space = whiteSpace++spaces1 :: Parser ()+spaces1 = void (many1 whiteSpace <?> "at least one space")++spaces :: Parser ()+spaces = void (many whiteSpace <?> "spaces")++symbol :: String -> Parser String+symbol name = lexeme (string name)++caseInsensitiveChar :: Char -> Parser Char+caseInsensitiveChar c = char (toUpper c) <|> char (toLower c)++caseInsensitiveString :: String -> Parser String+caseInsensitiveString s = mapM caseInsensitiveChar s <?> "\"" ++ s ++ "\""++charsWithEscapedSpaces :: String -> Parser String+charsWithEscapedSpaces stopChars = do+    buf <- many1 $ noneOf ("\n\t\\ " ++ stopChars)+    try (jumpEscapeSequence buf) <|> try (backslashFollowedByChars buf) <|> return buf+  where+    backslashFollowedByChars buf = do+        backslashes <- many1 (char '\\')+        notFollowedBy (char ' ')+        rest <- charsWithEscapedSpaces stopChars+        return $ buf ++ backslashes ++ rest+    jumpEscapeSequence buf = do+        void $ string "\\ "+        rest <- charsWithEscapedSpaces stopChars+        return $ buf ++ ' ' : rest+ lexeme :: Parser a -> Parser a-lexeme = Token.lexeme lexer+lexeme p = do+    x <- p+    spaces+    return x

@@ -1,46 +1,85 @@-{-# LANGUAGE FlexibleContexts #-}- module Language.Docker.Normalize     ( normalizeEscapedLines     ) where -import Data.List (intercalate)-import Data.List.Split (splitOn)--escapePlaceHolder :: String-escapePlaceHolder = "\\\\"--escapeSeq :: String-escapeSeq = "\\\n"--replace :: Eq a => [a] -> [a] -> [a] -> [a]-replace old new = intercalate new . splitOn old+import Data.List (dropWhileEnd, mapAccumL)+import Data.Maybe (catMaybes) -count :: Eq a => [a] -> [a] -> Int-count s x = length (splitOn x s) - 1+data NormalizedLine+    = Continue+    | Joined !String+             !Int -trimLines :: String -> String-trimLines s = unlines $ map strip $ lines s+trimLines :: [String] -> [String]+trimLines = map strip   where     strip = lstrip . rstrip-    lstrip = dropWhile (`elem` (" \t" :: String))+    lstrip = dropWhile (`elem` " \t\r")     rstrip = reverse . lstrip . reverse -replaceEscapeSigns :: String -> String-replaceEscapeSigns = replace escapeSeq escapePlaceHolder--removeEscapePlaceholder :: String -> String-removeEscapePlaceholder = replace escapePlaceHolder " "--compensateLinebreaks :: String -> String-compensateLinebreaks s = concatMap compensate $ lines s+-- Finds all lines ending with \ and joins them with the next line using+-- a single space. If the next line is a comment, then the comment line is+-- deleted. It finally adds the same amount of new lines for each of the+-- lines it joined, in order to preserve the line count in the document.+normalize :: [String] -> [String]+normalize allLines =+    let (lastState, res) -- mapAccumL is the idea of a for loop with a variable holding+                         -- some state and another variable where we append the final result+                         -- of the looping operation. For each line in lines, apply the transform+                         -- function. This function always returns a new state, and another element+                         -- to append to the final result. The ending result of mapAccumL is the final+                         -- state variale and the resulting list of values. We initialize the loop with+                         -- the 'Continue' state, which means "no special action to do next"+         = mapAccumL transform Continue allLines+    in case lastState of+           Continue -- The last line of the document is a normal line, cleanup and return+            -> catMaybes res+           Joined l times -- The last line contains a \, so we need to add the buffered+                          -- line back to the result, pad with newlines and cleanup+            -> catMaybes res ++ [l ++ padNewlines times]   where-    compensate line = line ++ "\n" ++ genLinebreaks line-    genLinebreaks line = concat $ replicate (count line escapePlaceHolder) "\n"+    normalizeLast = dropWhileEnd (== '\\')+    -- | Checks the result of the previous operation in the loop (first argument)+    --+    -- If the previous result is a 'Joined' operation, then we merge the previous+    -- and the current line in a single line and return it.+    --+    -- If the current line ends with a \, then we produce a 'Joined' state as result+    -- of this looping operation.+    --+    -- If the previous 2 conditions are true at the same time, then we produce a new+    -- 'Joined' state holding the concatenation of the Joined buffer and the previous line+    -- and we return 'Nothing' as an indication that this line does not form part of the+    -- final result.+    transform :: NormalizedLine -> String -> (NormalizedLine, Maybe String)+    -- If we are buffering lines, and the next line is a comment,+    -- we simply ignore the comment and remember to add a newline+    transform (Joined prev times) ('#':_) = (Joined prev (times + 1), Nothing)+    -- We do the same if we are buffering lines and the next one is empty+    transform (Joined prev times) "" = (Joined prev (times + 1), Nothing)+    -- If we are buffering lines, then we check whether the current line end with \,+    -- if it does, then we merged it into the buffered state, otherwise we just yield+    -- the concatanation of the buffer and the current line as result, after padding with+    -- newlines+    transform (Joined prev times) l =+        if endsWithEscape l+            then (Joined (prev ++ ' ' : normalizeLast l) (times + 1), Nothing)+            else (Continue, Just (prev ++ ' ' : l ++ padNewlines times))+    -- When not buffering lines, then we just check if we need to start doing it by checking+    -- whether or not the current line ends with \. If it does not, then we just yield the+    -- current line as part of the result+    transform Continue l =+        if endsWithEscape l+            then (Joined (normalizeLast l) 1, Nothing)+            else (Continue, Just l)+    --+    endsWithEscape "" = False+    endsWithEscape s = last s == '\\'+    --+    padNewlines times = replicate times '\n'  -- | Remove new line escapes and join escaped lines together on one line --   to simplify parsing later on. Escapes are replaced with line breaks --   to not alter the line numbers. normalizeEscapedLines :: String -> String-normalizeEscapedLines s =-    removeEscapePlaceholder $ compensateLinebreaks $ replaceEscapeSigns $ trimLines s+normalizeEscapedLines = unlines . normalize . trimLines . lines

@@ -1,43 +1,82 @@+{-# LANGUAGE RecordWildCards #-}+ module Language.Docker.Parser where  import Control.Monad (void) import Data.ByteString.Char8 (pack)-import Data.String-import Text.Parsec hiding (label)+import Data.List.NonEmpty (NonEmpty, fromList)+import Data.Maybe (listToMaybe)+import Data.Time.Clock (secondsToDiffTime)+import Text.Parsec hiding (label, space, spaces) import Text.Parsec.String (Parser)-import qualified Text.Parsec.Token as Token  import Language.Docker.Lexer import Language.Docker.Normalize import Language.Docker.Syntax +data CopyFlag+    = FlagChown Chown+    | FlagSource CopySource+    | FlagInvalid (String, String)++data CheckFlag+    = FlagInterval Duration+    | FlagTimeout Duration+    | FlagStartPeriod Duration+    | FlagRetries Retries+    | CFlagInvalid (String, String)+ comment :: Parser Instruction comment = do     void $ char '#'-    text <- untilEol+    text <- many (noneOf "\n")     return $ Comment text  taggedImage :: Parser BaseImage taggedImage = do-    name <- untilOccurrence ":\n"-    void $ oneOf ":"-    tag <- untilEol-    return $ TaggedImage name tag+    name <- many (noneOf "\t\n: ")+    void $ char ':'+    tag <- many1 (noneOf "\t\n: ")+    maybeAlias <- maybeImageAlias+    return $ TaggedImage name tag maybeAlias  digestedImage :: Parser BaseImage digestedImage = do-    name <- untilOccurrence "@\n"-    void $ oneOf "@"-    digest <- untilEol-    return $ DigestedImage name (pack digest)+    name <- many (noneOf "\t\n@ ")+    void $ char '@'+    digest <- many1 (noneOf "\t\n@ ")+    maybeAlias <- maybeImageAlias+    return $ DigestedImage name (pack digest) maybeAlias  untaggedImage :: Parser BaseImage untaggedImage = do-    name <- many (noneOf "\n")-    return $ UntaggedImage name+    name <- many (noneOf "\n\t:@ ")+    notInvalidTag name+    notInvalidDigest name+    maybeAlias <- maybeImageAlias+    return $ UntaggedImage name maybeAlias+  where+    notInvalidTag :: String -> Parser ()+    notInvalidTag name =+        try (notFollowedBy $ oneOf ":") <?> "no ':' or a valid image tag string (example: " +++        name ++ ":valid-tag)"+    notInvalidDigest :: String -> Parser ()+    notInvalidDigest name =+        try (notFollowedBy $ oneOf "@") <?> "no '@' or a valid digest hash (example: " +++        name ++ "@a3f42f2de)" +maybeImageAlias :: Parser (Maybe ImageAlias)+maybeImageAlias = Just <$> try (spaces >> imageAlias) <|> return Nothing++imageAlias :: Parser ImageAlias+imageAlias = do+    void $ caseInsensitiveString "AS"+    spaces1 <?> "a space followed by the image alias"+    alias <- untilOccurrence "\t\n "+    return $ ImageAlias alias+ baseImage :: Parser BaseImage-baseImage = try taggedImage <|> try digestedImage <|> try untaggedImage+baseImage = try digestedImage <|> try taggedImage <|> untaggedImage  from :: Parser Instruction from = do@@ -54,11 +93,68 @@ copy :: Parser Instruction copy = do     reserved "COPY"-    src <- many (noneOf " ")-    Token.whiteSpace lexer-    dst <- many (noneOf "\n")-    return $ Copy src dst+    flags <- copyFlag `sepEndBy` spaces1+    let chownFlags = [c | FlagChown c <- flags]+    let sourceFlags = [f | FlagSource f <- flags]+    let invalid = [i | FlagInvalid i <- flags]+    -- Let's do some validation on the flags+    case (invalid, chownFlags, sourceFlags) of+        ((k, v):_, _, _) -> unexpectedFlag k v+        (_, _:_:_, _) -> unexpected "duplicate flag: --chown"+        (_, _, _:_:_) -> unexpected "duplicate flag: --from"+        _ -> do+            let ch =+                    case chownFlags of+                        [] -> NoChown+                        c:_ -> c+            let fr =+                    case sourceFlags of+                        [] -> NoSource+                        f:_ -> f+            fileList "COPY" (\src dest -> Copy (CopyArgs src dest ch fr)) +copyFlag :: Parser CopyFlag+copyFlag =+    (FlagChown <$> try chown <?> "only one --chown") <|>+    (FlagSource <$> try copySource <?> "only one --from") <|>+    (FlagInvalid <$> try anyFlag <?> "no other flags")++chown :: Parser Chown+chown = do+    void $ string "--chown="+    ch <- many1 (noneOf "\t\n ")+    return $ Chown ch++copySource :: Parser CopySource+copySource = do+    void $ string "--from="+    src <- many1 (noneOf "\t\n ")+    return $ CopySource src++anyFlag :: Parser (String, String)+anyFlag = do+    void $ string "--"+    name <- many1 $ noneOf "\t\n= "+    void $ char '='+    val <- many $ noneOf "\t\n "+    return ("--" ++ name, val)++fileList :: String -> (NonEmpty SourcePath -> TargetPath -> Instruction) -> Parser Instruction+fileList name constr = do+    paths <-+        (try stringList <?> "an array of strings [\"src_file\", \"dest_file\"]") <|>+        (try spaceSeparated <?> "a space separated list of file paths")+    case paths of+        [_] -> unexpected $ "end of line. At least two arguments are required for " ++ name+        _ -> return $ constr (SourcePath <$> fromList (init paths)) (TargetPath $ last paths)+  where+    spaceSeparated = many (noneOf "\t\n ") `sepBy1` (try spaces1 <?> "at least another file path")+    stringList = brackets $ commaSep stringLiteral++unexpectedFlag :: String -> String -> Parser a+unexpectedFlag name "" = unexpected $ "flag " ++ name ++ " with no value"+unexpectedFlag name _ = unexpected $ "invalid flag " ++ name+ shell :: Parser Instruction shell = do     reserved "SHELL"@@ -68,41 +164,42 @@ stopsignal :: Parser Instruction stopsignal = do     reserved "STOPSIGNAL"-    args <- many (noneOf "\n")+    args <- many1 (noneOf "\n")     return $ Stopsignal args  -- We cannot use string literal because it swallows space -- and therefore have to implement quoted values by ourselves-quotedValue :: Parser String-quotedValue = do-    void $ char '"'-    literal <- untilOccurrence "\""-    void $ char '"'-    return literal+doubleQuotedValue :: Parser String+doubleQuotedValue = between (char '"') (char '"') (many $ noneOf "\n\"") -rawValue :: Parser String-rawValue = many1 (noneOf [' ', '=', '\n'])+singleQuotedValue :: Parser String+singleQuotedValue = between (void $ char '\'') (void $ char '\'') (many $ noneOf "\n'") -singleValue :: Parser String-singleValue = try quotedValue <|> try rawValue+unquotedString :: String -> Parser String+unquotedString stopChars = do+    str <- charsWithEscapedSpaces stopChars+    case str of+        '\'':_ -> unexpected $ errMsg "single" str+        '"':_ -> unexpected $ errMsg "double" str+        _ -> return str+  where+    errMsg t str = "end of " ++ t ++ " quoted string " ++ str ++ " (unmatched quote)" +singleValue :: String -> Parser String+singleValue stopChars =+    try doubleQuotedValue <|> -- Quotes or no quotes are fine+    try singleQuotedValue <|>+    (try (unquotedString stopChars) <?> "a string with no quotes")+ pair :: Parser (String, String) pair = do-    key <- rawValue-    void $ oneOf "= "-    spaces-    value <- singleValue+    key <- singleValue "="+    void $ char '='+    value <- singleValue ""     return (key, value) -pairs :: Parser Pairs-pairs = do-    _ <- many (char ' ')-    first <- pair-    next <- remainingPairs-    return (first : next)--remainingPairs :: Parser Pairs-remainingPairs = try (char ' ' >> pairs) <|> try (return [])+pairsList :: Parser Pairs+pairsList = pair `sepBy1` spaces1  label :: Parser Instruction label = do@@ -113,8 +210,13 @@ arg :: Parser Instruction arg = do     reserved "ARG"-    p <- untilEol-    return $ Arg p+    (try nameWithDefault <?> "the arg name") <|> Arg <$> untilEol <*> pure Nothing+  where+    nameWithDefault = do+        name <- many1 $ noneOf "\t\n= "+        void $ char '='+        def <- untilEol+        return $ Arg name (Just def)  env :: Parser Instruction env = do@@ -122,6 +224,16 @@     p <- pairs     return $ Env p +pairs :: Parser Pairs+pairs = try pairsList <|> try singlePair++singlePair :: Parser Pairs+singlePair = do+    key <- many (noneOf "\t\n= ")+    spaces1 <?> "a space followed by the value for the variable '" ++ key ++ "'"+    val <- untilEol+    return [(key, val)]+ user :: Parser Instruction user = do     reserved "USER"@@ -131,18 +243,57 @@ add :: Parser Instruction add = do     reserved "ADD"-    src <- untilOccurrence " "-    Token.whiteSpace lexer-    dst <- untilOccurrence "\n"-    return $ Add src dst+    flag <- lexeme copyFlag <|> return (FlagChown NoChown)+    notFollowedBy (string "--") <?> "only the --chown flag or the src and dest paths"+    case flag of+        FlagChown ch -> fileList "ADD" (\src dest -> Add (AddArgs src dest ch))+        FlagSource _ -> unexpected "flag --from"+        FlagInvalid (k, v) -> unexpectedFlag k v  expose :: Parser Instruction expose = do     reserved "EXPOSE"-    sports <- untilEol-    let port = fromString sports-    return $ Expose port+    ps <- ports+    return $ Expose ps +port :: Parser Port+port =+    (try portVariable <?> "a variable") <|> -- There a many valid representations of ports+    (try portRange <?> "a port range") <|>+    (try portWithProtocol <?> "a port with its protocol (udp/tcp)") <|>+    (try portInt <?> "a valid port number")++ports :: Parser Ports+ports = Ports <$> port `sepEndBy1` space++portRange :: Parser Port+portRange = do+    start <- natural+    void $ char '-'+    finish <- try natural+    return $ PortRange start finish++portInt :: Parser Port+portInt = do+    portNumber <- natural+    notFollowedBy (oneOf "/-")+    return $ Port portNumber TCP++portWithProtocol :: Parser Port+portWithProtocol = do+    portNumber <- natural+    void (char '/')+    proto <-+        (caseInsensitiveString "tcp" >> return TCP) <|> -- Either tcp or udp+        (caseInsensitiveString "udp" >> return UDP)+    return $ Port portNumber proto++portVariable :: Parser Port+portVariable = do+    void $ lookAhead (char '$')+    variable <- untilOccurrence "\t\n- "+    return $ PortStr variable+ run :: Parser Instruction run = do     reserved "RUN"@@ -151,7 +302,7 @@  -- Parse value until end of line is reached untilEol :: Parser String-untilEol = many (noneOf "\n")+untilEol = many1 (noneOf "\n")  untilOccurrence :: String -> Parser String untilOccurrence t = many $ noneOf t@@ -159,13 +310,13 @@ workdir :: Parser Instruction workdir = do     reserved "WORKDIR"-    directory <- many (noneOf "\n")+    directory <- untilEol     return $ Workdir directory  volume :: Parser Instruction volume = do     reserved "VOLUME"-    directory <- many (noneOf "\n")+    directory <- untilEol     return $ Volume directory  maintainer :: Parser Instruction@@ -199,17 +350,70 @@     i <- parseInstruction     return $ OnBuild i -eolInstruction :: Parser Instruction-eolInstruction = do-    eol-    return EOL- healthcheck :: Parser Instruction healthcheck = do     reserved "HEALTHCHECK"-    args <- untilEol-    return $ Healthcheck args+    Healthcheck <$> (fullCheck <|> noCheck)+  where+    noCheck = string "NONE" >> return NoCheck+    allFlags = do+        flags <- someFlags+        spaces1 <?> "another flag"+        return flags+    someFlags = do+        x <- checkFlag+        cont <- try (spaces1 >> lookAhead (string "--") >> return True) <|> return False+        if cont+            then do+                xs <- someFlags+                return (x : xs)+            else return [x]+    fullCheck = do+        flags <- allFlags <|> return []+        let intervals = [x | FlagInterval x <- flags]+        let timeouts = [x | FlagTimeout x <- flags]+        let startPeriods = [x | FlagStartPeriod x <- flags]+        let retriesD = [x | FlagRetries x <- flags]+        let invalid = [x | CFlagInvalid x <- flags]+      -- Let's do some validation on the flags+        case (invalid, intervals, timeouts, startPeriods, retriesD) of+            ((k, v):_, _, _, _, _) -> unexpectedFlag k v+            (_, _:_:_, _, _, _) -> unexpected "duplicate flag: --interval"+            (_, _, _:_:_, _, _) -> unexpected "duplicate flag: --timeout"+            (_, _, _, _:_:_, _) -> unexpected "duplicate flag: --start-period"+            (_, _, _, _, _:_:_) -> unexpected "duplicate flag: --retries"+            _ -> do+                Cmd checkCommand <- cmd+                let interval = listToMaybe intervals+                let timeout = listToMaybe timeouts+                let startPeriod = listToMaybe startPeriods+                let retries = listToMaybe retriesD+                return $ Check CheckArgs {..} +checkFlag :: Parser CheckFlag+checkFlag =+    (FlagInterval <$> durationFlag "--interval=" <?> "--interval") <|>+    (FlagTimeout <$> durationFlag "--timeout=" <?> "--timeout") <|>+    (FlagStartPeriod <$> durationFlag "--start-period=" <?> "--start-period") <|>+    (FlagRetries <$> retriesFlag <?> "--retries") <|>+    (CFlagInvalid <$> anyFlag <?> "no flags")++durationFlag :: String -> Parser Duration+durationFlag flagName = do+    void $ try (string flagName)+    scale <- natural+    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))+        _ -> return $ Duration (secondsToDiffTime (scale * 60 * 60))++retriesFlag :: Parser Retries+retriesFlag = do+    void $ try (string "--retries=")+    n <- try natural <?> "the number of retries"+    return $ Retries (fromIntegral n)+ parseInstruction :: Parser Instruction parseInstruction =     try onbuild <|> -- parse all main instructions@@ -230,12 +434,11 @@     try maintainer <|>     try add <|>     try comment <|>-    try healthcheck <|>-    try eolInstruction+    try healthcheck  contents :: Parser a -> Parser a contents p = do-    Token.whiteSpace lexer+    void $ many (space <|> void (char '\n'))     r <- p     eof     return r@@ -245,15 +448,10 @@  dockerfile :: Parser Dockerfile dockerfile =-    many $-    -- deal with empty lines that only contain spaces or tabs-    -- skipMany space-    -- skipMany $ char '\t'-     do+    many $ do         pos <- getPosition         i <- parseInstruction-        optional eol-        -- skipMany eol+        void (many1 eol) <|> eof <?> "a new line followed by the next instruction"         return $ InstructionPos i (sourceName pos) (sourceLine pos)  parseString :: String -> Either ParseError Dockerfile

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}  module Language.Docker.Predef where @@ -9,6 +10,7 @@ import Control.Monad.IO.Class import Data.Aeson (Value(..)) import qualified Data.HashMap.Strict as HashMap+import Data.List.NonEmpty (fromList) import Data.Maybe import Data.Monoid import Data.Text (Text)@@ -32,7 +34,7 @@ dockerIgnore :: Text -> IO () dockerIgnore = appendLnIfMissing ".dockerignore" -addGlob :: (MonadIO m, MonadFree EInstruction m) => String -> Destination -> m ()+addGlob :: (MonadIO m, MonadFree EInstruction m) => String -> TargetPath -> m () addGlob pattern dest = do     fs <-         liftIO $ do@@ -43,11 +45,13 @@                 isdir <- doesDirectoryExist f                 return $                     if isdir-                        then (f <> "/", dest <> takeBaseName f)-                        else (f, dest <> takeBaseName f)-    forM_ fs (uncurry add)+                        then (SourcePath $ f <> "/")+                        else (SourcePath f)+    case fs of+      [] -> return ()+      _ -> add (fromList fs) dest -copyGlob :: (MonadIO m, MonadFree EInstruction m) => String -> Destination -> m ()+copyGlob :: (MonadIO m, MonadFree EInstruction m) => String -> TargetPath -> m () copyGlob = addGlob  stackBuild :: (Monad m, MonadIO m, MonadFree EInstruction m) => m ()@@ -76,12 +80,12 @@     liftIO $ dockerIgnore ".cabal-sandbox"     from ("fpco" `tagged` tag)     extra-    add "./package.yaml" "/app/package.yaml"+    add ["./package.yaml"] "/app/package.yaml"     addGlob "./*.cabal" "/app/"-    add "./stack.yaml" "/app/stack.yaml"+    add ["./stack.yaml"] "/app/stack.yaml"     workdir "/app/"     run "stack build --only-dependencies"-    add "." "/app/stack.yaml"+    add ["."] "/app/stack.yaml"     run "stack build"  nodejs :: (Monad m, MonadIO m, MonadFree EInstruction m) => m ()@@ -93,8 +97,8 @@     liftIO $ dockerIgnore "bower_components"     from ("node" `tagged` tag)     extra-    add "./package.json" "/app/package.json"+    add ["./package.json"] "/app/package.json"     workdir "/app/"     run "npm install"-    add "." "/app/"+    add ["."] "/app/"     cmd "npm start"

@@ -1,10 +1,14 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}  module Language.Docker.PrettyPrint where  import qualified Data.ByteString.Char8 as ByteString (unpack)-import Data.List (intersperse)+import Data.List (foldl', intersperse)+import Data.List.NonEmpty (NonEmpty, toList) import Data.String import Language.Docker.Syntax import Prelude hiding ((>>), (>>=), return)@@ -15,7 +19,7 @@ prettyPrint =     unlines .     reverse .-    snd . foldl removeDoubleBlank (False, []) . lines . unlines . map prettyPrintInstructionPos+    snd . foldl' removeDoubleBlank (False, []) . lines . unlines . map prettyPrintInstructionPos   where     removeDoubleBlank (True, m) "" = (True, m)     removeDoubleBlank (False, m) "" = (True, "" : m)@@ -28,18 +32,26 @@ prettyPrintBaseImage :: BaseImage -> Doc prettyPrintBaseImage b =     case b of-        DigestedImage name digest -> do+        DigestedImage name digest alias -> do             text name             char '@'             text (ByteString.unpack digest)-        UntaggedImage name -> text name-        TaggedImage name tag -> do+            prettyAlias alias+        UntaggedImage name alias -> do             text name+            prettyAlias alias+        TaggedImage name tag alias -> do+            text name             char ':'             text tag+            prettyAlias alias   where     (>>) = (<>)     return = (mempty <>)+    prettyAlias maybeAlias =+        case maybeAlias of+            Nothing -> mempty+            Just (ImageAlias alias) -> text " AS " <> text alias  prettyPrintPairs :: Pairs -> Doc prettyPrintPairs ps = hsep $ map prettyPrintPair ps@@ -56,15 +68,50 @@ prettyPrintJSON :: Arguments -> Doc prettyPrintJSON as = brackets $ hsep $ intersperse comma $ map (doubleQuotes . text) as +prettyPrintPort :: Port -> Doc+prettyPrintPort (PortStr str) = text str+prettyPrintPort (PortRange start stop) = integer start <> text "-" <> integer stop+prettyPrintPort (Port num TCP) = integer num <> char '/' <> text "tcp"+prettyPrintPort (Port num UDP) = integer num <> char '/' <> text "udp"++prettyPrintFileList :: NonEmpty SourcePath -> TargetPath -> Doc+prettyPrintFileList sources (TargetPath dest) =+    hsep $ [text s | SourcePath s <- toList sources] ++ [text dest]++prettyPrintChown :: Chown -> Doc+prettyPrintChown chown =+    case chown of+        Chown c -> text "--chown=" <> text c+        NoChown -> mempty++prettyPrintCopySource :: CopySource -> Doc+prettyPrintCopySource source =+    case source of+        CopySource c -> text "--from=" <> text c+        NoSource -> mempty++prettyPrintDuration :: String -> Maybe Duration -> Doc+prettyPrintDuration flagName = maybe mempty pp+  where+    pp (Duration d) = text flagName <> text (show d)++prettyPrintRetries :: Maybe Retries -> Doc+prettyPrintRetries = maybe mempty pp+  where+    pp (Retries r) = text "--retries=" <> int r+ prettyPrintInstruction :: Instruction -> Doc prettyPrintInstruction i =     case i of         Maintainer m -> do             text "MAINTAINER"             text m-        Arg a -> do+        Arg a Nothing -> do             text "ARG"             text a+        Arg k (Just v) -> do+            text "ARG"+            text k <> text "=" <> text v         Entrypoint e -> do             text "ENTRYPOINT"             prettyPrintArguments e@@ -76,17 +123,18 @@             text w         Expose (Ports ps) -> do             text "EXPOSE"-            hsep (map (text . show) ps)-        Expose (PortStr p) -> do-            text "EXPOSE"-            text p+            hsep (map prettyPrintPort ps)         Volume dir -> do             text "VOLUME"             text dir         Run c -> do             text "RUN"             prettyPrintArguments c-        Copy s d -> hsep [text "COPY", text s, text d]+        Copy CopyArgs {sourcePaths, targetPath, chownFlag, sourceFlag} -> do+            text "COPY"+            prettyPrintChown chownFlag+            prettyPrintCopySource sourceFlag+            prettyPrintFileList sourcePaths targetPath         Cmd c -> do             text "CMD"             prettyPrintArguments c@@ -108,17 +156,22 @@         From b -> do             text "FROM"             prettyPrintBaseImage b-        Add s d -> do+        Add AddArgs {sourcePaths, targetPath, chownFlag} -> do             text "ADD"-            text s-            text d+            prettyPrintChown chownFlag+            prettyPrintFileList sourcePaths targetPath         Shell args -> do             text "SHELL"             prettyPrintJSON args-        Healthcheck c -> do+        Healthcheck NoCheck -> text "HEALTHCHECK NONE"+        Healthcheck (Check CheckArgs {..}) -> do             text "HEALTHCHECK"-            text c-        EOL -> mempty+            prettyPrintDuration "--interval=" interval+            prettyPrintDuration "--timeout=" timeout+            prettyPrintDuration "--start-period=" startPeriod+            prettyPrintRetries retries+            text "CMD"+            prettyPrintArguments checkCommand   where     (>>) = (<+>)     return = (mempty <>)

@@ -1,46 +1,112 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies,+  DuplicateRecordFields #-}+ module Language.Docker.Syntax where  import Data.ByteString.Char8 (ByteString)-import Data.Maybe-import Data.String-import Text.Read+import Data.List.NonEmpty (NonEmpty)+import Data.String (IsString)+import Data.Time.Clock (DiffTime)+import GHC.Exts (IsList(..))  type Image = String  type Tag = String -data Ports-    = Ports [Integer]+data Protocol+    = TCP+    | UDP+    deriving (Show, Eq, Ord)++data Port+    = Port Integer+           Protocol     | PortStr String+    | PortRange Integer+                Integer     deriving (Show, Eq, Ord) -instance IsString Ports where-    fromString p =-        case readMaybe p of-            Just i -> Ports [i]-            Nothing ->-                let rs = map readMaybe (words p)-                in if all isJust rs-                       then Ports (catMaybes rs)-                       else PortStr p+newtype Ports = Ports+    { unPorts :: [Port]+    } deriving (Show, Eq, Ord) +instance IsList Ports where+    type Item Ports = Port+    fromList = Ports+    toList (Ports ps) = ps+ type Directory = String +newtype ImageAlias = ImageAlias+    { unImageAlias :: String+    } deriving (Show, Eq, Ord, IsString)+ data BaseImage     = UntaggedImage Image+                    (Maybe ImageAlias)     | TaggedImage Image                   Tag+                  (Maybe ImageAlias)     | DigestedImage Image                     ByteString+                    (Maybe ImageAlias)     deriving (Eq, Ord, Show)  -- | Type of the Dockerfile AST type Dockerfile = [InstructionPos] -type Source = String+newtype SourcePath = SourcePath+    { unSourcePath :: String+    } deriving (Show, Eq, Ord, IsString) -type Destination = String+newtype TargetPath = TargetPath+    { unTargetPath :: String+    } deriving (Show, Eq, Ord, IsString) +data Chown+    = Chown String+    | NoChown+    deriving (Show, Eq, Ord)++data CopySource+    = CopySource String+    | NoSource+    deriving (Show, Eq, Ord)++newtype Duration = Duration+    { durationTime :: DiffTime+    } deriving (Show, Eq, Ord, Num)++newtype Retries = Retries+    { times :: Int+    } deriving (Show, Eq, Ord, Num)++data CopyArgs = CopyArgs+    { sourcePaths :: NonEmpty SourcePath+    , targetPath :: TargetPath+    , chownFlag :: Chown+    , sourceFlag :: CopySource+    } deriving (Show, Eq, Ord)++data AddArgs = AddArgs+    { sourcePaths :: NonEmpty SourcePath+    , targetPath :: TargetPath+    , chownFlag :: Chown+    } deriving (Show, Eq, Ord)++data Check+    = Check CheckArgs+    | NoCheck+    deriving (Show, Eq, Ord)++data CheckArgs = CheckArgs+    { checkCommand :: Arguments+    , interval :: Maybe Duration+    , timeout :: Maybe Duration+    , startPeriod :: Maybe Duration+    , retries :: Maybe Retries+    } deriving (Show, Eq, Ord)+ type Arguments = [String]  type Pairs = [(String, String)]@@ -48,13 +114,11 @@ -- | All commands available in Dockerfiles data Instruction     = From BaseImage-    | Add Source-          Destination+    | Add AddArgs     | User String     | Label Pairs     | Stopsignal String-    | Copy Source-           Destination+    | Copy CopyArgs     | Run Arguments     | Cmd Arguments     | Shell Arguments@@ -65,10 +129,10 @@     | Maintainer String     | Env Pairs     | Arg String-    | Healthcheck String+          (Maybe String)+    | Healthcheck Check     | Comment String     | OnBuild Instruction-    | EOL     deriving (Eq, Ord, Show)  type Filename = String@@ -77,14 +141,8 @@  -- | 'Instruction' with additional location information required for creating -- good check messages-data InstructionPos =-    InstructionPos Instruction-                   Filename-                   Linenumber-    deriving (Eq, Ord, Show)--instruction :: InstructionPos -> Instruction-instruction (InstructionPos i _ _) = i--sourcename :: InstructionPos -> Filename-sourcename (InstructionPos _ fn _) = fn+data InstructionPos = InstructionPos+    { instruction :: Instruction+    , sourcename :: Filename+    , lineNumber :: Linenumber+    } deriving (Eq, Ord, Show)

@@ -2,16 +2,51 @@  module Language.Docker.Syntax.Lift where +import Data.Fixed (Fixed)+import Data.List.NonEmpty (NonEmpty)+import Data.Time.Clock (DiffTime) import Instances.TH.Lift () import Language.Haskell.TH.Lift import Language.Haskell.TH.Syntax ()  import Language.Docker.Syntax +deriveLift ''NonEmpty++deriveLift ''Fixed++deriveLift ''DiffTime++deriveLift ''Protocol++deriveLift ''Port+ deriveLift ''Ports +deriveLift ''ImageAlias+ deriveLift ''BaseImage  deriveLift ''Instruction  deriveLift ''InstructionPos++deriveLift ''SourcePath++deriveLift ''TargetPath++deriveLift ''Chown++deriveLift ''CopySource++deriveLift ''CopyArgs++deriveLift ''AddArgs++deriveLift ''Duration++deriveLift ''Retries++deriveLift ''CheckArgs++deriveLift ''Check

@@ -7,7 +7,7 @@  spec =     describe "listPlugins" $-        it "lists docker images matching language-dockerfile-*" pending+        it "lists docker images matching language-docker-*" pending             -- str <- toDockerFileStrIO $ do             --     ds <- liftIO (glob "./test/*.hs")             --     from "ubuntu"

@@ -17,7 +17,7 @@                                                 RUN apt-get update                                                 CMD node something.js                                                 |]-            df `shouldBe` [ From (UntaggedImage "node")+            df `shouldBe` [ From (UntaggedImage "node" Nothing)                           , Run ["apt-get", "update"]                           , Cmd ["node", "something.js"]                           ]@@ -25,15 +25,15 @@     describe "edockerfile" $         it "lets us use parsed dockerfiles seamlessly in our DSL" $ do             let d = do-                    from "node"-                    expose "8080"+                    from ("node" `aliased` "node-build")+                    expose (ports [tcpPort 8080, variablePort "PORT"])                     [edockerfile|                                 RUN apt-get update                                 CMD node something.js                                 |]                 df = map instruction (toDockerfile d)-            df `shouldBe` [ From (UntaggedImage "node")-                          , Expose (Ports [8080])+            df `shouldBe` [ From (UntaggedImage "node" (Just $ ImageAlias "node-build"))+                          , Expose (Ports [Port 8080 TCP, PortStr "$PORT"])                           , Run ["apt-get", "update"]                           , Cmd ["node", "something.js"]                           ]

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Language.Docker.EDSLSpec where  import           Control.Monad.IO.Class@@ -18,7 +19,7 @@             let r = map Syntax.instruction $ toDockerfile (do                         from "node"                         cmdArgs ["node", "-e", "'console.log(\'hey\')'"])-            r `shouldBe` [ Syntax.From (Syntax.UntaggedImage "node")+            r `shouldBe` [ Syntax.From $ (Syntax.UntaggedImage "node") Nothing                          , Syntax.Cmd ["node", "-e", "'console.log(\'hey\')'"]                          ] @@ -28,12 +29,21 @@                         from "node"                         shell ["cmd", "/S"]                         cmdArgs ["node", "-e", "'console.log(\'hey\')'"]-                        healthcheck "--interval=5m CMD curl -f http://localhost/ || exit 1")+                        healthcheck $ check "curl -f http://localhost/ || exit 1" `interval` 300)             r `shouldBe` unlines [ "FROM node"                                  , "SHELL [\"cmd\" , \"/S\"]"                                  , "CMD node -e 'console.log(\'hey\')'"-                                 , "HEALTHCHECK --interval=5m CMD curl -f http://localhost/ || exit 1"+                                 , "HEALTHCHECK --interval=300s CMD curl -f http://localhost/ || exit 1"                                  ]+        it "print expose instructions correctly" $ do+            let r = prettyPrint $ toDockerfile (do+                        from "scratch"+                        expose $ ports [variablePort "PORT", tcpPort 80, udpPort 51]+                        expose $ ports [portRange 90 100])+            r `shouldBe` unlines [ "FROM scratch"+                                 , "EXPOSE $PORT 80/tcp 51/udp"+                                 , "EXPOSE 90-100"+                                 ]          it "onBuild let's us nest statements" $ do             let r = prettyPrint $ toDockerfile $ do@@ -48,7 +58,13 @@                                  , "ONBUILD RUN echo \"hello world2\""                                  ] -        it "onBuild disallows unallowed instructions" pending+        it "parses and prints from aliases correctly" $ do+            let r = prettyPrint $ toDockerfile $ do+                        from ("node" `tagged` "10.1" `aliased` "node-build")+                        run "echo foo"+            r `shouldBe` unlines [ "FROM node:10.1 AS node-build"+                                 , "RUN echo foo"+                                 ]      describe "toDockerfileStrIO" $         it "let's us run in the IO monad" $ do@@ -59,7 +75,7 @@                     fs <- glob "./test/Language/Docker/*.hs"                     return (map (makeRelative cwd) (sort fs))                 from "ubuntu"-                mapM_ (\f -> add f ("/app/" ++ takeFileName f)) fs+                mapM_ (\f -> add [Syntax.SourcePath f] (Syntax.TargetPath $ "/app/" ++ takeFileName f)) fs             str `shouldBe` unlines [ "FROM ubuntu"                                    , "ADD ./test/Language/Docker/EDSLSpec.hs /app/EDSLSpec.hs"                                    , "ADD ./test/Language/Docker/ExamplesSpec.hs /app/ExamplesSpec.hs"

@@ -8,7 +8,7 @@ import           System.Process import           Test.Hspec -stackRunGhc e = callProcess "stack" ["runghc", "--package", "language-dockerfile", e]+stackRunGhc e = callProcess "stack" ["runghc", "--package", "language-docker", e]  spec :: Spec spec = do

@@ -1,26 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Language.Docker.ParserSpec where -import Data.List (find)-import Data.Maybe (fromMaybe, isJust)- import Language.Docker.Normalize import Language.Docker.Parser import Language.Docker.Syntax + import Test.HUnit hiding (Label) import Test.Hspec import Text.Parsec  spec :: Spec spec = do-        describe "parse FROM" $-            it "parse untagged image" $ assertAst "FROM busybox" [From (UntaggedImage "busybox")]+        describe "parse ARG" $ do+            it "no default" $+                assertAst "ARG FOO" [Arg "FOO" Nothing]+            it "with default" $+                assertAst "ARG FOO=bar" [Arg "FOO" (Just "bar")] +        describe "parse FROM" $ do+            it "parse untagged image" $+                assertAst "FROM busybox" [From (UntaggedImage "busybox" Nothing)]+            it "parse tagged image" $+                assertAst+                    "FROM busybox:5.12-dev"+                    [From (TaggedImage "busybox" "5.12-dev" Nothing)]+            it "parse digested image" $+                assertAst+                    "FROM ubuntu@sha256:0ef2e08ed3fab"+                    [From (DigestedImage "ubuntu" "sha256:0ef2e08ed3fab" Nothing)]++        describe "parse aliased FROM" $ do+            it "parse untagged image" $+                assertAst "FROM busybox as foo" [From (UntaggedImage "busybox" (Just $ ImageAlias "foo"))]+            it "parse tagged image" $+                assertAst "FROM busybox:5.12-dev AS foo-bar" [From (TaggedImage "busybox" "5.12-dev" (Just $ ImageAlias "foo-bar"))]+            it "parse diggested image" $+                assertAst "FROM ubuntu@sha256:0ef2e08ed3fab AS foo" [From (DigestedImage "ubuntu" "sha256:0ef2e08ed3fab" (Just $ ImageAlias "foo"))]+         describe "parse LABEL" $ do             it "parse label" $ assertAst "LABEL foo=bar" [Label[("foo", "bar")]]+            it "parse space separated label" $ assertAst "LABEL foo bar baz" [Label[("foo", "bar baz")]]+            it "parse quoted labels" $ assertAst "LABEL \"foo bar\"=baz" [Label[("foo bar", "baz")]]             it "parses multiline labels" $                 let dockerfile = unlines [ "LABEL foo=bar \\", "hobo=mobo"]-                    ast = [ Label [("foo", "bar"), ("hobo", "mobo")], EOL ]+                    ast = [ Label [("foo", "bar"), ("hobo", "mobo")] ]                 in assertAst dockerfile ast          describe "parse ENV" $ do@@ -47,9 +72,8 @@                                  , "ENV NODE_VERSION=v5.7.1 \\"                                  , "DEBIAN_FRONTEND=noninteractive"                                  ]-                    ast = [ From (UntaggedImage "busybox")+                    ast = [ From (UntaggedImage "busybox" Nothing)                           , Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")]-                          , EOL                           ]                 in assertAst dockerfile ast             it "parses long env over multiple lines" $@@ -59,50 +83,132 @@                                ,("APACHE_RUN_USER", "www-data")                                ,("APACHE_RUN_GROUP", "www-data")                                ]-                          , EOL                           ]                 in assertAst dockerfile ast-+            it "parse single var list" $+                assertAst "ENV foo val1 val2 val3 val4" [Env [("foo", "val1 val2 val3 val4")]]+            it "parses many env lines with an equal sign in the value" $+                let dockerfile = unlines [ "ENV TOMCAT_VERSION 9.0.2"+                                         , "ENV TOMCAT_URL foo.com?q=1"+                                         ]+                    ast = [ Env [("TOMCAT_VERSION", "9.0.2")]+                          , Env [("TOMCAT_URL", "foo.com?q=1")]+                          ]+                in assertAst dockerfile ast+            it "parses many env lines in mixed style" $+                let dockerfile = unlines [ "ENV myName=\"John Doe\" myDog=Rex\\ The\\ Dog \\"+                                         , "    myCat=fluffy"+                                         ]+                    ast = [ Env [("myName", "John Doe")+                                ,("myDog", "Rex The Dog")+                                ,("myCat", "fluffy")+                                ]+                          ]+                in assertAst dockerfile ast+            it "parses many env with backslashes" $+                let dockerfile = unlines [ "ENV JAVA_HOME=C:\\\\jdk1.8.0_112"+                                         ]+                    ast = [ Env [("JAVA_HOME", "C:\\\\jdk1.8.0_112")]+                          ]+                in assertAst dockerfile ast -        describe "parse RUN" $+        describe "parse RUN" $ do             it "escaped with space before" $-            let dockerfile = unlines ["RUN yum install -y \\ ", "imagemagick \\ ", "mysql"]-            in assertAst dockerfile [Run ["yum", "install", "-y", "imagemagick", "mysql"], EOL, EOL]+                let dockerfile = unlines ["RUN yum install -y \\ ", "imagemagick \\ ", "mysql"]+                in assertAst dockerfile [Run ["yum", "install", "-y", "imagemagick", "mysql"]] +            it "does not choke on unmatched brackets" $+                let dockerfile = unlines ["RUN [foo"]+                in assertAst dockerfile [Run ["[foo"]]+         describe "parse CMD" $ do             it "one line cmd" $ assertAst "CMD true" [Cmd ["true"]]             it "cmd over several lines" $-                assertAst "CMD true \\\n && true" [Cmd ["true", "&&", "true"], EOL]+                assertAst "CMD true \\\n && true" [Cmd ["true", "&&", "true"]]             it "quoted command params" $ assertAst "CMD [\"echo\",  \"1\"]" [Cmd ["echo", "1"]]          describe "parse SHELL" $ do             it "quoted shell params" $                 assertAst "SHELL [\"/bin/bash\",  \"-c\"]" [Shell ["/bin/bash", "-c"]] -        describe "parse HEALTHCHECK" $-            it "parse healthcheck without args" $-              assertAst "HEALTHCHECK --interval=5m \\nCMD curl -f http://localhost/" [Healthcheck "--interval=5m \\nCMD curl -f http://localhost/"]+        describe "parse HEALTHCHECK" $ do+            it "parse healthcheck with interval" $+              assertAst+                "HEALTHCHECK --interval=5m \\\nCMD curl -f http://localhost/"+                [Healthcheck $+                    Check $+                      CheckArgs (words "curl -f http://localhost/") (Just $ fromInteger 300) Nothing Nothing Nothing+                ] +            it "parse healthcheck with retries" $+              assertAst+                "HEALTHCHECK --retries=10 CMD curl -f http://localhost/"+                [Healthcheck $+                    Check $+                      CheckArgs (words "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 (words "curl -f http://localhost/") Nothing (Just $ fromInteger 10) Nothing Nothing+                ]++            it "parse healthcheck with start-period" $+              assertAst+                "HEALTHCHECK --start-period=2m CMD curl -f http://localhost/"+                [Healthcheck $+                    Check $+                      CheckArgs (words "curl -f http://localhost/") Nothing Nothing (Just $ fromInteger 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+                        (words "curl -f http://localhost/")+                        (Just $ fromInteger 5)+                        (Just $ fromInteger 60)+                        (Just $ fromInteger 2)+                        (Just $ Retries 3)+                ]++            it "parse healthcheck with no flags" $+              assertAst+                "HEALTHCHECK CMD curl -f http://localhost/"+                [Healthcheck $+                    Check $+                      CheckArgs (words "curl -f http://localhost/") Nothing Nothing Nothing Nothing+                ]+         describe "parse MAINTAINER" $ do             it "maintainer of untagged scratch image" $                 assertAst                     "FROM scratch\nMAINTAINER hudu@mail.com"-                    [From (UntaggedImage "scratch"), Maintainer "hudu@mail.com"]+                    [From (UntaggedImage "scratch" Nothing), Maintainer "hudu@mail.com"]             it "maintainer with mail" $                 assertAst "MAINTAINER hudu@mail.com" [Maintainer "hudu@mail.com"]             it "maintainer only mail after from" $                 let maintainerFromProg = "FROM busybox\nMAINTAINER hudu@mail.com"-                    maintainerFromAst = [From (UntaggedImage "busybox"), Maintainer "hudu@mail.com"]+                    maintainerFromAst = [From (UntaggedImage "busybox" Nothing), Maintainer "hudu@mail.com"]                 in assertAst maintainerFromProg maintainerFromAst         describe "parse # comment " $ do             it "multiple comments before run" $                 let dockerfile = unlines ["# line 1", "# line 2", "RUN apt-get update"]-                in assertAst dockerfile [Comment " line 1", Comment " line 2", Run ["apt-get", "update"], EOL]+                in assertAst dockerfile [Comment " line 1", Comment " line 2", Run ["apt-get", "update"]]             it "multiple comments after run" $                 let dockerfile = unlines ["RUN apt-get update", "# line 1", "# line 2"]                 in assertAst                        dockerfile-                       [Run ["apt-get", "update"], Comment " line 1", Comment " line 2", EOL]+                       [Run ["apt-get", "update"], Comment " line 1", Comment " line 2"]++            it "empty comment" $+                let dockerfile = unlines ["#", "# Hello"]+                in assertAst dockerfile [Comment "", Comment " Hello"]         describe "normalize lines" $ do             it "join multiple ENV" $                 let dockerfile = unlines [ "FROM busybox"@@ -128,7 +234,7 @@                             ]                     longEscapedCmdExpected =                         concat-                            [ "RUN wget https://download.com/${version}.tar.gz -O /tmp/logstash.tar.gz &&  "+                            ([ "RUN wget https://download.com/${version}.tar.gz -O /tmp/logstash.tar.gz &&  "                             , "(cd /tmp && tar zxf logstash.tar.gz && mv logstash-${version} /opt/logstash &&  "                             , "rm logstash.tar.gz) &&  "                             , "(cd /opt/logstash &&  "@@ -137,17 +243,88 @@                             , "\n"                             , "\n"                             , "\n"-                            ]+                            ] :: [String])                 in normalizeEscapedLines longEscapedCmd `shouldBe` longEscapedCmdExpected         describe "expose" $ do             it "should handle number ports" $ do                 let content = "EXPOSE 8080"-                parse expose "" content `shouldBe` Right (Expose (Ports [8080]))+                parse expose "" content `shouldBe` Right (Expose (Ports [Port 8080 TCP]))+            it "should handle many number ports" $ do+                let content = "EXPOSE 8080 8081"+                parse expose "" content `shouldBe` Right (Expose (Ports [Port 8080 TCP, Port 8081 TCP]))+            it "should handle ports with protocol" $ do+                let content = "EXPOSE 8080/TCP 8081/UDP"+                parse expose "" content `shouldBe` Right (Expose (Ports [Port 8080 TCP, Port 8081 UDP]))+            it "should handle ports with protocol and variables" $ do+                let content = "EXPOSE $PORT 8080 8081/UDP"+                parse expose "" content `shouldBe` Right (Expose (Ports [PortStr "$PORT", Port 8080 TCP, Port 8081 UDP]))+            it "should handle port ranges" $ do+                let content = "EXPOSE 80 81 8080-8085"+                parse expose "" content `shouldBe` Right (Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085]))+         describe "syntax" $ do             it "should handle lowercase instructions (#7 - https://github.com/beijaflor-io/haskell-language-dockerfile/issues/7)" $ do                 let content = "from ubuntu"-                parse dockerfile "" content `shouldBe` Right [InstructionPos (From (UntaggedImage "ubuntu")) "" 1]+                parse dockerfile "" content `shouldBe` Right [InstructionPos (From (UntaggedImage "ubuntu" Nothing)) "" 1] +        describe "ADD" $ do+            it "simple ADD" $+                let file = unlines ["ADD . /app", "ADD http://foo.bar/baz ."]+                in assertAst file [ Add $ AddArgs [SourcePath "."] (TargetPath "/app") NoChown+                                  , Add $ AddArgs [SourcePath "http://foo.bar/baz"] (TargetPath ".") NoChown+                                  ]+            it "multifiles ADD" $+                let file = unlines ["ADD foo bar baz /app"]+                in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown+                                  ]++            it "list of quoted files" $+                let file = unlines ["ADD [\"foo\", \"bar\", \"baz\", \"/app\"]"]+                in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown+                                  ]++            it "with chown flag" $+                let file = unlines ["ADD --chown=root:root foo bar"]+                in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "root:root")+                                  ]++            it "list of quoted files and chown" $+                let file = unlines ["ADD --chown=user:group [\"foo\", \"bar\", \"baz\", \"/app\"]"]+                in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") (Chown "user:group")+                                  ]+        describe "COPY" $ do+            it "simple COPY" $+                let file = unlines ["COPY . /app", "COPY baz /some/long/path"]+                in assertAst file [ Copy $ CopyArgs [SourcePath "."] (TargetPath "/app") NoChown NoSource+                                  , Copy $ CopyArgs [SourcePath "baz"] (TargetPath "/some/long/path") NoChown NoSource+                                  ]+            it "multifiles COPY" $+                let file = unlines ["COPY foo bar baz /app"]+                in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown NoSource+                                  ]++            it "list of quoted files" $+                let file = unlines ["COPY [\"foo\", \"bar\", \"baz\", \"/app\"]"]+                in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown NoSource+                                  ]++            it "with chown flag" $+                let file = unlines ["COPY --chown=user:group foo bar"]+                in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") NoSource+                                  ]++            it "with from flag" $+                let file = unlines ["COPY --from=node foo bar"]+                in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") NoChown (CopySource "node")+                                  ]+            it "with both flags" $+                let file = unlines ["COPY --from=node --chown=user:group foo bar"]+                in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node")+                                  ]+            it "with both flags in different order" $+                let file = unlines ["COPY --chown=user:group --from=node foo bar"]+                in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node")+                                  ] assertAst s ast =     case parseString (s ++ "\n") of         Left err -> assertFailure $ show err