language-docker 8.1.1 → 9.0.0

raw patch · 26 files changed

+2291/−2359 lines, 26 filesdep +data-default-classdep −Globdep −directorydep −filepathdep ~megaparsec

Dependencies added: data-default-class

Dependencies removed: Glob, directory, filepath, free, mtl, process, template-haskell, th-lift, th-lift-instances

Dependency ranges changed: megaparsec

Files

• README.md +2/−95
• language-docker.cabal +19/−28
• src/Language/Docker.hs +40/−103
• src/Language/Docker/EDSL.hs +0/−383
• src/Language/Docker/EDSL/Quasi.hs +0/−49
• src/Language/Docker/EDSL/Types.hs +0/−67
• src/Language/Docker/Normalize.hs +0/−94
• src/Language/Docker/Parser.hs +22/−587
• src/Language/Docker/Parser/Arguments.hs +23/−0
• src/Language/Docker/Parser/Cmd.hs +15/−0
• src/Language/Docker/Parser/Copy.hs +93/−0
• src/Language/Docker/Parser/Expose.hs +58/−0
• src/Language/Docker/Parser/From.hs +74/−0
• src/Language/Docker/Parser/Healthcheck.hs +98/−0
• src/Language/Docker/Parser/Instruction.hs +111/−0
• src/Language/Docker/Parser/Pairs.hs +67/−0
• src/Language/Docker/Parser/Prelude.hs +244/−0
• src/Language/Docker/Parser/Run.hs +288/−0
• src/Language/Docker/PrettyPrint.hs +202/−126
• src/Language/Docker/Syntax.hs +271/−133
• src/Language/Docker/Syntax/Lift.hs +0/−60
• test/Language/Docker/EDSL/QuasiSpec.hs +0/−46
• test/Language/Docker/EDSLSpec.hs +0/−136
• test/Language/Docker/ExamplesSpec.hs +0/−20
• test/Language/Docker/IntegrationSpec.hs +29/−0
• test/Language/Docker/ParserSpec.hs +635/−432

@@ -12,10 +12,6 @@ - [Parsing files](#parsing-files) - [Parsing strings](#parsing-strings) - [Pretty-printing files](#pretty-printing-files)-- [Writing Dockerfiles in Haskell](#writing-dockerfiles-in-haskell)-- [Using the QuasiQuoter](#using-the-quasiquoter)-- [Templating Dockerfiles in Haskell](#templating-dockerfiles-in-haskell)-- [Using IO in the DSL](#using-io-in-the-dsl)  ## Parsing files @@ -35,98 +31,9 @@     print (parseString c) ``` -## Pretty-printing files--```haskell-import Language.Docker-main = do-    Right d <- parseFile "./Dockerfile"-    putStr (prettyPrint d)-```--## Writing Dockerfiles in Haskell--```haskell-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-}-import Language.Docker--main = putDockerfileStr $ do-    from "node"-    run "apt-get update"-    run ["apt-get", "install", "something"]-    -- ...-```--## Using the QuasiQuoter--```haskell-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-import Language.Docker-main = putDockerfileStr $ do-    from "node"-    run "apt-get update"-    [edockerfile|-    RUN apt-get update-    CMD node something.js-    |]-    -- ...-```--## Templating Dockerfiles in Haskell--```haskell-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-}-import Control.Monad-import Language.Docker-import Data.String (fromString)-import qualified Data.Text.Lazy.IO as L--tags = ["7.8", "7.10", "8"]-cabalSandboxBuild packageName = do-    let cabalFile = packageName ++ ".cabal"-    run "cabal sandbox init"-    run "cabal update"-    add [fromString cabalFile] (fromString $ "/app/" ++ cabalFile)-    run "cabal install --only-dep -j"-    add "." "/app/"-    run "cabal build"-main =-    forM_ tags $ \tag -> do-        let df = toDockerfileText $ do-            from ("haskell" `tagged` tag)-            cabalSandboxBuild "mypackage"-        L.writeFile ("./examples/templating-" ++ tag ++ ".dockerfile") df-```--## Using IO in the DSL-By default the DSL runs in the `Identity` monad. By running in IO we can-support more features like file globbing:--```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.List.NonEmpty (fromList)-import qualified Data.Text.Lazy.IO    as L+## Create Dockerfiles -main = do-    str <- toDockerfileTextIO $ do-        fs <- liftIO $ do-            cwd <- Directory.getCurrentDirectory-            fs <- Glob.glob "./test/*.hs"-	    let relativeFiles = map (FilePath.makeRelative cwd) fs-            return (fromList relativeFiles)-        from "ubuntu"-	copy $ (toSources fs) `to` "/app/"-    L.putStr str-```+Use the [dockerfile-creator package](https://github.com/hadolint/dockerfile-creator)  [hackage-img]: https://img.shields.io/hackage/v/language-docker.svg [hackage]: https://hackage.haskell.org/package/language-docker

@@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1a3b30b946ca4b0a823997146b93946d7e99ed812bbfdd500d69425534f01c41+-- hash: 4064f903443322af4bc07da09abc22ee61ae143bfcffb403add7b327cd7b13dd  name:           language-docker-version:        8.1.1+version:        9.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.+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. category:       Development homepage:       https://github.com/hadolint/language-docker#readme@@ -36,13 +36,18 @@       Language.Docker       Language.Docker.Parser       Language.Docker.PrettyPrint-      Language.Docker.Normalize       Language.Docker.Syntax-      Language.Docker.Syntax.Lift-      Language.Docker.EDSL-      Language.Docker.EDSL.Quasi-      Language.Docker.EDSL.Types   other-modules:+      Language.Docker.Parser.Arguments+      Language.Docker.Parser.Cmd+      Language.Docker.Parser.Copy+      Language.Docker.Parser.Expose+      Language.Docker.Parser.From+      Language.Docker.Parser.Healthcheck+      Language.Docker.Parser.Instruction+      Language.Docker.Parser.Pairs+      Language.Docker.Parser.Prelude+      Language.Docker.Parser.Run       Paths_language_docker   hs-source-dirs:       src@@ -51,15 +56,11 @@       base >=4.13 && <5     , bytestring >=0.10     , containers-    , free-    , megaparsec >=7.0-    , mtl+    , data-default-class+    , megaparsec >=8.0     , prettyprinter     , split >=0.2-    , template-haskell     , text-    , th-lift-    , th-lift-instances     , time   default-language: Haskell2010 @@ -67,33 +68,23 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:-      Language.Docker.EDSL.QuasiSpec-      Language.Docker.EDSLSpec-      Language.Docker.ExamplesSpec+      Language.Docker.IntegrationSpec       Language.Docker.ParserSpec       Paths_language_docker   hs-source-dirs:       test   build-depends:-      Glob-    , HUnit >=1.2+      HUnit >=1.2     , QuickCheck     , base >=4.13 && <5     , bytestring >=0.10     , containers-    , directory-    , filepath-    , free+    , data-default-class     , hspec     , language-docker-    , megaparsec >=7.0-    , mtl+    , megaparsec >=8.0     , prettyprinter-    , process     , split >=0.2-    , template-haskell     , text-    , th-lift-    , th-lift-instances     , time   default-language: Haskell2010

@@ -1,109 +1,46 @@ module Language.Docker-    ( Language.Docker.Syntax.Dockerfile -- * Parsing Dockerfiles (@Language.Docker.Syntax@ and @Language.Docker.Parser@)-    , parseText-    , parseFile-    , parseStdin+  ( Language.Docker.Syntax.Dockerfile,++    -- * Parsing Dockerfiles (@Language.Docker.Syntax@ and @Language.Docker.Parser@)+    parseText,+    parseFile,+    parseStdin,+     -- * Re-exports from @megaparsec@-    , Text.Megaparsec.parseErrorPretty-    , Text.Megaparsec.errorBundlePretty-      -- * Pretty-printing Dockerfiles (@Language.Docker.PrettyPrint@)-    , prettyPrint-    , prettyPrintDockerfile-      -- * Writting Dockerfiles (@Language.Docker.EDSL@)-    , Language.Docker.EDSL.toDockerfileText-    , Language.Docker.EDSL.toDockerfile-    , Language.Docker.EDSL.putDockerfileStr-    , Language.Docker.EDSL.writeDockerFile-    , Language.Docker.EDSL.toDockerfileTextIO-    , Language.Docker.EDSL.toDockerfileIO-    , Language.Docker.EDSL.runDockerfileIO-    , Language.Docker.EDSL.runDockerfileTextIO-    , Control.Monad.IO.Class.liftIO-    , Language.Docker.EDSL.from-      -- ** Constructing base images-    , 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-    , Language.Docker.EDSL.label-    , Language.Docker.EDSL.stopSignal-    , Language.Docker.EDSL.copy-    , Language.Docker.EDSL.copyFromStage-    , Language.Docker.EDSL.to-    , Language.Docker.EDSL.fromStage-    , Language.Docker.EDSL.ownedBy-    , Language.Docker.EDSL.toSources-    , Language.Docker.EDSL.toTarget-    , Language.Docker.EDSL.run-    , 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.tcpPort-    , Language.Docker.EDSL.udpPort-    , Language.Docker.EDSL.variablePort-    , Language.Docker.EDSL.portRange-    , Language.Docker.EDSL.udpPortRange-    , Language.Docker.EDSL.volume-    , Language.Docker.EDSL.entrypoint-    , Language.Docker.EDSL.entrypointArgs-    , Language.Docker.EDSL.maintainer-    , Language.Docker.EDSL.env-    , Language.Docker.EDSL.arg-    , Language.Docker.EDSL.comment-    , Language.Docker.EDSL.onBuild-    , Language.Docker.EDSL.onBuildRaw-    , Language.Docker.EDSL.embed-    , Language.Docker.EDSL.Quasi.edockerfile-      -- ** Support types for the EDSL-    , Language.Docker.EDSL.EDockerfileM-    , Language.Docker.EDSL.EDockerfileTM-    , Language.Docker.EDSL.Types.EBaseImage(..)-      -- * QuasiQuoter (@Language.Docker.EDSL.Quasi@)-    , Language.Docker.EDSL.Quasi.dockerfile-      -- * Types (@Language.Docker.Syntax@)-    , 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.Registry(..)-    , Language.Docker.Syntax.ImageAlias(..)-    , Language.Docker.Syntax.Tag(..)-    , Language.Docker.Syntax.Digest(..)-    , Language.Docker.Syntax.Ports-    , Language.Docker.Syntax.Directory-    , Language.Docker.Syntax.Arguments-    , Language.Docker.Syntax.Pairs-    , Language.Docker.Syntax.Filename-    , Language.Docker.Syntax.Platform-    , Language.Docker.Syntax.Linenumber-    -- * Instruction and InstructionPos helpers-    , Language.Docker.EDSL.instructionPos-    ) where+    Text.Megaparsec.parseErrorPretty,+    Text.Megaparsec.errorBundlePretty, -import qualified Control.Monad.IO.Class-import qualified Language.Docker.EDSL-import qualified Language.Docker.EDSL.Quasi-import qualified Language.Docker.EDSL.Types+    -- * Pretty-printing Dockerfiles (@Language.Docker.PrettyPrint@)+    prettyPrint,+    prettyPrintDockerfile,++    -- * Types (@Language.Docker.Syntax@)+    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.Registry (..),+    Language.Docker.Syntax.ImageAlias (..),+    Language.Docker.Syntax.Tag (..),+    Language.Docker.Syntax.Digest (..),+    Language.Docker.Syntax.Ports,+    Language.Docker.Syntax.Directory,+    Language.Docker.Syntax.Arguments,+    Language.Docker.Syntax.Pairs,+    Language.Docker.Syntax.Filename,+    Language.Docker.Syntax.Platform,+    Language.Docker.Syntax.Linenumber,+  )+where+ import Language.Docker.Parser import Language.Docker.PrettyPrint import qualified Language.Docker.Syntax

@@ -1,383 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE TemplateHaskell #-}--module Language.Docker.EDSL where--import Control.Monad.Free-import Control.Monad.Free.TH-import Control.Monad.Trans.Free (FreeT, iterTM)-import Control.Monad.Writer-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as B8-import Data.List.NonEmpty (NonEmpty)-import Data.String (fromString)-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Encoding as E--import qualified Language.Docker.PrettyPrint as PrettyPrint-import qualified Language.Docker.Syntax as Syntax--import Language.Docker.EDSL.Types---- | The type of 'Identity' based EDSL blocks-type EDockerfileM = Free EInstruction---- | The type of free monad EDSL blocks-type EDockerfileTM = FreeT EInstruction--type EInstructionM = Free EInstruction--type EInstructionTM = FreeT EInstruction--makeFree ''EInstruction--runDockerWriter :: (MonadWriter [Syntax.Instruction Text] m) => EDockerfileM a -> m a-runDockerWriter = iterM runD--runDockerWriterIO ::-       (Monad m, MonadTrans t, MonadWriter [Syntax.Instruction Text] (t m))-    => EDockerfileTM m a-    -> t m a-runDockerWriterIO = iterTM runD--runDef :: MonadWriter [t] m => (t1 -> t) -> t1 -> m b -> m b-runDef f a n = tell [f a] >> n--runDef2 :: MonadWriter [t] m => (t1 -> t2 -> t) -> t1 -> t2 -> m b -> m b-runDef2 f a b n = tell [f a b] >> n--runD :: MonadWriter [Syntax.Instruction Text] m => EInstruction (m b) -> m b-runD (From (EBaseImage name t d a p) n) = runDef Syntax.From (Syntax.BaseImage name t d a p) n-runD (CmdArgs as n) = runDef Syntax.Cmd as n-runD (Shell as n) = runDef Syntax.Shell as 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 (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-runD (Volume v n) = runDef Syntax.Volume v n-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 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-runD (Embed is n) = do-    tell (map Syntax.instruction is)-    n--instructionPos :: Syntax.Instruction args -> Syntax.InstructionPos args-instructionPos i = Syntax.InstructionPos i "" 0---- | Runs the Dockerfile EDSL and returns a 'Dockerfile' you can pretty print--- or manipulate-toDockerfile :: EDockerfileM a -> Syntax.Dockerfile-toDockerfile e =-    let (_, w) = runWriter (runDockerWriter e)-    in map instructionPos w---- | runs the Dockerfile EDSL and returns a 'Data.Text.Lazy' using--- 'Language.Docker.PrettyPrint'------ @--- import Language.Docker------ main :: IO ()--- main = print $ toDockerfileText $ do---     from (tagged "fpco/stack-build" "lts-6.9")---     add ["."] "/app/language-docker"---     workdir "/app/language-docker"---     run "stack build --test --only-dependencies"---     cmd "stack test"--- @-toDockerfileText :: EDockerfileM a -> L.Text-toDockerfileText = PrettyPrint.prettyPrint . toDockerfile---- | Writes the dockerfile to the given file path after pretty-printing it------ @--- import Language.Docker------ main :: IO ()--- main = writeDockerFile "build.Dockerfile" $ toDockerfile $ do---     from (tagged "fpco/stack-build" "lts-6.9")---     add ["."] "/app/language-docker"---     workdir "/app/language-docker"---     run "stack build --test --only-dependencies"---     cmd "stack test"--- @-writeDockerFile :: Text -> Syntax.Dockerfile -> IO ()-writeDockerFile filename =-    BL.writeFile (Text.unpack filename) . E.encodeUtf8 . PrettyPrint.prettyPrint---- | Prints the dockerfile to stdout. Mainly used for debugging purposes------ @--- import Language.Docker------ main :: IO ()--- main = putDockerfileStr $ do---     from (tagged "fpco/stack-build" "lts-6.9")---     add ["."] "/app/language-docker"---     workdir "/app/language-docker"---     run "stack build --test --only-dependencies"---     cmd "stack test"--- @-putDockerfileStr :: EDockerfileM a -> IO ()-putDockerfileStr = B8.putStrLn . E.encodeUtf8 . PrettyPrint.prettyPrint . toDockerfile---- | Use a docker image in a FROM instruction without a tag------ The following two examples are equivalent------ @--- from $ untagged "fpco/stack-build"--- @------ Is equivalent to, when having OverloadedStrings:------ @--- from "fpco/stack-build"--- @-untagged :: Text -> EBaseImage-untagged s = EBaseImage (fromString . Text.unpack $ s) Nothing Nothing Nothing Nothing---- | Use a specific tag for a docker image. This function is meant--- to be used as an infix operator.------ @--- from $ "fpco/stack-build" `tagged` "lts-10.3"--- @-tagged :: Syntax.Image -> Syntax.Tag -> EBaseImage-tagged imageName tag = EBaseImage imageName (Just tag) Nothing Nothing Nothing---- | Adds a digest checksum so a FROM instruction--- This function is meant to be used as an infix operator.------ @--- from $ "fpco/stack-build" `digested` "sha256:abcdef123"--- @-digested :: EBaseImage -> Syntax.Digest -> EBaseImage-digested (EBaseImage n t _ a p) d = EBaseImage n t (Just d) a p---- | Alias a FROM instruction to be used as a build stage.--- This function is meant to be used as an infix operator.------ @--- from $ "fpco/stack-build" `aliased` "builder"--- @-aliased :: EBaseImage -> Syntax.ImageAlias -> EBaseImage-aliased (EBaseImage n t d _ p) a = EBaseImage n t d (Just a) p---- | Create a RUN instruction with the given arguments.------ @--- run "apt-get install wget"--- @-run :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()-run = runArgs---- | Create an ENTRYPOINT instruction with the given arguments.------ @--- entrypoint "/usr/local/bin/program --some-flag"--- @-entrypoint :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()-entrypoint = entrypointArgs---- | Create a CMD instruction with the given arguments.------ @--- cmd "my-program --some-flag"--- @-cmd :: MonadFree EInstruction m => Syntax.Arguments Text -> m ()-cmd = cmdArgs---- | Create a COPY instruction. This function is meant to be--- used with the compinators 'to', 'fromStage' and 'ownedBy'------ @--- copy $ ["foo.js", "bar.js"] `to` "."--- copy $ ["some_file"] `to` "/some/path" `fromStage` "builder"--- @-copy :: MonadFree EInstruction m => Syntax.CopyArgs -> m ()-copy (Syntax.CopyArgs sources dest ch src) = copyArgs sources dest ch src---- | Create a COPY instruction from a given build stage.--- This is a shorthand version of using 'copy' with combinators.------ @--- copyFromStage "builder" ["foo.js", "bar.js"] "."--- @-copyFromStage ::-       MonadFree EInstruction m-    => Syntax.CopySource-    -> NonEmpty Syntax.SourcePath-    -> Syntax.TargetPath-    -> m ()-copyFromStage stage source dest = copy $ Syntax.CopyArgs source dest Syntax.NoChown stage---- | Create an ADD instruction. This is often used as a shorthand version--- of copy when no extra options are needed. Currently there is no way to--- pass extra options to ADD, so you are encouraged to use 'copy' instead.------ @--- add ["foo.js", "bar.js"] "."--- @-add :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m ()-add sources dest = addArgs sources dest Syntax.NoChown---- | Converts a NonEmpty list of strings to a NonEmpty list of 'Syntax.SourcePath'------ This is a convenience function when you need to pass a non-static list of--- strings that you build somewhere as an argument for 'copy' or 'add'------ @--- someFiles <- glob "*.js"--- copy $ (toSources someFiles) `to` "."--- @-toSources :: NonEmpty Text -> NonEmpty Syntax.SourcePath-toSources = fmap Syntax.SourcePath---- | Converts a Text into a 'Syntax.TargetPath'------ This is a convenience function when you need to pass a string variable--- as an argument for 'copy' or 'add'------ @--- let destination = buildSomePath pwd--- add ["foo.js"] (toTarget destination)--- @-toTarget :: Text -> Syntax.TargetPath-toTarget = Syntax.TargetPath---- | Adds the --from= option to a COPY instruction.------ This function is meant to be used as an infix operator:------ @--- copy $ ["foo.js"] `to` "." `fromStage` "builder"--- @-fromStage :: Syntax.CopyArgs -> Syntax.CopySource -> Syntax.CopyArgs-fromStage args src = args {Syntax.sourceFlag = src}---- | Adds the --chown= option to a COPY instruction.------ This function is meant to be used as an infix operator:------ @--- copy $ ["foo.js"] `to` "." `ownedBy` "www-data:www-data"--- @-ownedBy :: Syntax.CopyArgs -> Syntax.Chown -> Syntax.CopyArgs-ownedBy args owner = args {Syntax.chownFlag = owner}---- | Usedto join source paths with atarget path as an arguments for 'copy'------ This function is meant to be used as an infix operator:------ @--- copy $ ["foo.js"] `to` "." `ownedBy`--- @-to :: NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> Syntax.CopyArgs-to sources dest = Syntax.CopyArgs sources dest Syntax.NoChown Syntax.NoSource--ports :: [Syntax.Port] -> Syntax.Ports-ports = Syntax.Ports--tcpPort :: Int -> Syntax.Port-tcpPort = flip Syntax.Port Syntax.TCP--udpPort :: Int -> Syntax.Port-udpPort = flip Syntax.Port Syntax.UDP--variablePort :: Text -> Syntax.Port-variablePort varName = Syntax.PortStr ("$" <> varName)--portRange :: Int -> Int -> Syntax.Port-portRange a b = Syntax.PortRange a b Syntax.TCP--udpPortRange :: Int -> Int -> Syntax.Port-udpPortRange a b = Syntax.PortRange a b Syntax.UDP--check :: Syntax.Arguments args -> Syntax.Check args-check command =-    Syntax.Check-        Syntax.CheckArgs-        { Syntax.checkCommand = command-        , Syntax.interval = Nothing-        , Syntax.timeout = Nothing-        , Syntax.startPeriod = Nothing-        , Syntax.retries = Nothing-        }--interval :: Syntax.Check args -> Integer -> Syntax.Check args-interval ch secs =-    case ch of-        Syntax.NoCheck -> Syntax.NoCheck-        Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.interval = Just $ fromInteger secs}--timeout :: Syntax.Check args -> Integer -> Syntax.Check args-timeout ch secs =-    case ch of-        Syntax.NoCheck -> Syntax.NoCheck-        Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.timeout = Just $ fromInteger secs}--startPeriod :: Syntax.Check args -> Integer -> Syntax.Check args-startPeriod ch secs =-    case ch of-        Syntax.NoCheck -> Syntax.NoCheck-        Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.startPeriod = Just $ fromInteger secs}--retries :: Syntax.Check args -> Integer -> Syntax.Check args-retries ch tries =-    case ch of-        Syntax.NoCheck -> Syntax.NoCheck-        Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.retries = Just $ fromInteger tries}--noCheck :: Syntax.Check args-noCheck = Syntax.NoCheck---- | ONBUILD Dockerfile instruction------ Each nested instruction gets emitted as a separate @ONBUILD@ block------ @--- 'toDockerfile' $ do---     from "node"---     run "apt-get update"---     onBuild $ do---         run "echo more-stuff"---         run "echo here"--- @-onBuild :: MonadFree EInstruction m => EDockerfileM a -> m ()-onBuild b = mapM_ (onBuildRaw . Syntax.instruction) (toDockerfile b)---- | A version of 'toDockerfile' which allows IO actions-toDockerfileIO :: MonadIO m => EDockerfileTM m t -> m Syntax.Dockerfile-toDockerfileIO e = fmap snd (runDockerfileIO e)---- | A version of 'toDockerfileText' which allows IO actions-toDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m L.Text-toDockerfileTextIO e = fmap snd (runDockerfileTextIO e)---- | Just runs the EDSL's writer monad-runDockerfileIO :: MonadIO m => EDockerfileTM m t -> m (t, Syntax.Dockerfile)-runDockerfileIO e = do-    (r, w) <- runWriterT (runDockerWriterIO e)-    return (r, map instructionPos w)---- | Runs the EDSL's writer monad and pretty-prints the result-runDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m (t, L.Text)-runDockerfileTextIO e = do-    (r, w) <- runDockerfileIO e-    return (r, PrettyPrint.prettyPrint w)

@@ -1,49 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module Language.Docker.EDSL.Quasi where--import Language.Haskell.TH-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax--import qualified Data.Text as Text-import Language.Docker.EDSL-import qualified Language.Docker.Parser as Parser-import Language.Docker.Syntax.Lift ()-import Text.Megaparsec (errorBundlePretty)---- | Quasiquoter for embedding dockerfiles on the EDSL------ @--- putStr $ 'toDockerfile' $ do---     from "node"---     run "apt-get update"---     [edockerfile|---     RUN apt-get update---     CMD node something.js---     |]--- @-edockerfile :: QuasiQuoter-edockerfile = dockerfile {quoteExp = edockerfileE}--edockerfileE :: String -> ExpQ-edockerfileE e =-    case Parser.parseText (Text.pack e) of-        Left err -> fail (errorBundlePretty err)-        Right d -> [|embed d|]--dockerfile :: QuasiQuoter-dockerfile =-    QuasiQuoter-    { quoteExp = dockerfileE-    , quoteDec = error "Can't use Dockerfile as a declaration"-    , quotePat = error "Can't use Dockerfile as a pattern"-    , quoteType = error "Can't use Dockerfile as a type"-    }--dockerfileE :: String -> ExpQ-dockerfileE e =-    case Parser.parseText (Text.pack e) of-        Left err -> fail (errorBundlePretty err)-        Right d -> lift d

@@ -1,67 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}--module Language.Docker.EDSL.Types where--import Data.List.NonEmpty (NonEmpty)-import Data.String-import Data.Text (Text)-import qualified Language.Docker.Syntax as Syntax--data EBaseImage = EBaseImage Syntax.Image-                             (Maybe Syntax.Tag)-                             (Maybe Syntax.Digest)-                             (Maybe Syntax.ImageAlias)-                             (Maybe Syntax.Platform)-    deriving (Show, Eq, Ord)--instance IsString EBaseImage where-    fromString s = EBaseImage (fromString s) Nothing Nothing Nothing Nothing--data EInstruction next-    = From EBaseImage-           next-    | AddArgs (NonEmpty Syntax.SourcePath)-              Syntax.TargetPath-              Syntax.Chown-              next-    | User Text-           next-    | Label Syntax.Pairs-            next-    | StopSignal Text-                 next-    | CopyArgs (NonEmpty Syntax.SourcePath)-               Syntax.TargetPath-               Syntax.Chown-               Syntax.CopySource-               next-    | RunArgs (Syntax.Arguments Text)-              next-    | CmdArgs (Syntax.Arguments Text)-              next-    | Shell (Syntax.Arguments Text)-            next-    | Workdir Syntax.Directory-              next-    | Expose Syntax.Ports-             next-    | Volume Text-             next-    | EntrypointArgs (Syntax.Arguments Text)-                     next-    | Maintainer Text-                 next-    | Env Syntax.Pairs-          next-    | Arg Text-          (Maybe Text)-          next-    | Comment Text-              next-    | Healthcheck (Syntax.Check Text)-                  next-    | OnBuildRaw (Syntax.Instruction Text)-                 next-    | Embed [Syntax.InstructionPos Text]-            next-    deriving (Functor)

@@ -1,94 +0,0 @@-module Language.Docker.Normalize-    ( normalizeEscapedLines-    ) where--import Data.List (mapAccumL)-import Data.Maybe (catMaybes)-import Data.Text (Text)-import qualified Data.Text as Text-import Data.Text.Lazy (toStrict)-import qualified Data.Text.Lazy.Builder as Builder--data NormalizedLine-    = Continue-    | Joined !Builder.Builder-             !Int---- 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 :: Text -> Text-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 (Text.lines allLines)-    in case lastState of-           Continue -- The last line of the document is a normal line, cleanup and return-            -> Text.unlines . 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-            -> Text.unlines (catMaybes res <> [toText (l <> padNewlines times)])-  where-    toText = toStrict . Builder.toLazyText-    -- | 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 -> Text -> (NormalizedLine, Maybe Text)-    transform (Joined prev times) rawLine-        -- If we are buffering lines and the next one is empty or it starts with a comment-        -- we simply ignore the comment and remember to add a newline-        | Text.null line || isComment line = (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-        | endsWithEscape line = (Joined (prev <> normalizeLast line) (times + 1), Nothing)-        -- otherwise we just yield-        -- the concatanation of the buffer and the current line as result, after padding with-        -- newlines-        | otherwise = (Continue, Just (toText (prev <> Builder.fromText line <> padNewlines times)))-      where-        line = Text.stripEnd rawLine-    -- 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 rawLine-        | isComment line = (Continue, Just line)-        | endsWithEscape line = (Joined (normalizeLast line) 1, Nothing)-        | otherwise = (Continue, Just line)-      where-        line = Text.stripEnd rawLine-    ---    endsWithEscape t-        | Text.null t = False-        | otherwise = Text.last t == '\\'-    ---    padNewlines times = Builder.fromText (Text.replicate times (Text.singleton '\n'))-    ---    normalizeLast = Builder.fromText . Text.dropWhileEnd (== '\\')-    ---    isComment line =-        case (Text.uncons . Text.stripStart) line of-            Just ('#', _) -> True-            _ -> False---- | 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 :: Text -> Text-normalizeEscapedLines = normalize--{-# INLINE normalizeEscapedLines #-}

@@ -1,613 +1,48 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}  module Language.Docker.Parser-    ( parseText-    , parseFile-    , parseStdin-    , Parser-    , Error-    , DockerfileError(..)-    ) where+  ( parseText,+    parseFile,+    parseStdin,+    Parser,+    Error,+    DockerfileError (..),+  )+where -import Control.Monad (void) import qualified Data.ByteString as B-import Data.Data-import Data.List.NonEmpty (NonEmpty, fromList)-import Data.Maybe (listToMaybe)-import qualified Data.Set as S-import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E-import Data.Time.Clock (secondsToDiffTime)-import Text.Megaparsec hiding (Label, label)-import Text.Megaparsec.Char hiding (eol)-import qualified Text.Megaparsec.Char.Lexer as L--import Language.Docker.Normalize+import Language.Docker.Parser.Instruction (parseInstruction)+import Language.Docker.Parser.Prelude import Language.Docker.Syntax -data DockerfileError-    = DuplicateFlagError String-    | NoValueFlagError String-    | InvalidFlagError String-    | FileListError String-    | QuoteError String-                 String-    deriving (Eq, Data, Typeable, Ord, Read, Show)--type Parser = Parsec DockerfileError Text--type Error = ParseErrorBundle Text DockerfileError--type Instr = Instruction Text--data CopyFlag-    = FlagChown Chown-    | FlagSource CopySource-    | FlagInvalid (Text, Text)--data CheckFlag-    = FlagInterval Duration-    | FlagTimeout Duration-    | FlagStartPeriod Duration-    | FlagRetries Retries-    | CFlagInvalid (Text, Text)--instance ShowErrorComponent DockerfileError where-    showErrorComponent (DuplicateFlagError f) = "duplicate flag: " ++ f-    showErrorComponent (FileListError f) =-        "unexpected end of line. At least two arguments are required for " ++ f-    showErrorComponent (NoValueFlagError f) = "unexpected flag " ++ f ++ " with no value"-    showErrorComponent (InvalidFlagError f) = "invalid flag: " ++ f-    showErrorComponent (QuoteError t str) =-        "unexpected end of " ++ t ++ " quoted string " ++ str ++ " (unmatched quote)"----------------------------------------- Utilities---------------------------------------- | End parsing signaling a “conversion error”.-customError :: DockerfileError -> Parser a-customError = fancyFailure . S.singleton . ErrorCustom--eol :: Parser ()-eol = void $ takeWhile1P (Just "whitespace") isSpaceNl--reserved :: Text -> Parser ()-reserved name = void (lexeme (string' name) <?> T.unpack name)--natural :: Parser Integer-natural = L.decimal <?> "positive number"--commaSep :: Parser a -> Parser [a]-commaSep p = sepBy (p <* spaces) (symbol ",")--stringLiteral :: Parser Text-stringLiteral = do-    void (char '"')-    lit <- manyTill L.charLiteral (char '"')-    return (T.pack lit)--brackets :: Parser a -> Parser a-brackets = between (symbol "[" *> spaces) (spaces *> symbol "]")--spaces1 :: Parser ()-spaces1 = void (takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t'))--spaces :: Parser ()-spaces = void (takeWhileP (Just "at least one space") (\c -> c == ' ' || c == '\t'))--symbol :: Text -> Parser Text-symbol name = do-    x <- string name-    spaces-    return x--caseInsensitiveString :: Text -> Parser Text-caseInsensitiveString = string'--charsWithEscapedSpaces :: String -> Parser Text-charsWithEscapedSpaces stopChars = do-    buf <- takeWhile1P Nothing (`notElem` ("\n\t\\ " ++ stopChars))-    try (jumpEscapeSequence buf) <|> try (backslashFollowedByChars buf) <|> return buf-  where-    backslashFollowedByChars buf = do-        backslashes <- takeWhile1P Nothing (== '\\')-        notFollowedBy (char ' ')-        rest <- charsWithEscapedSpaces stopChars-        return $ T.concat [buf, backslashes, rest]-    jumpEscapeSequence buf = do-        void $ string "\\ "-        rest <- charsWithEscapedSpaces stopChars-        return $ T.concat [buf, " ", rest]--lexeme :: Parser a -> Parser a-lexeme p = do-    x <- p-    spaces1-    return x--isNl :: Char -> Bool-isNl c = c == '\n'--isSpaceNl :: Char -> Bool-isSpaceNl c = c == ' ' || c == '\t' || c == '\n'--anyUnless :: (Char -> Bool) -> Parser Text-anyUnless predicate = takeWhileP Nothing (\c -> not (isSpaceNl c || predicate c))--someUnless :: String -> (Char -> Bool) -> Parser Text-someUnless name predicate = takeWhile1P (Just name) (\c -> not (isSpaceNl c || predicate c))----------------------------------------- DOCKER INSTRUCTIONS PARSER--------------------------------------comment :: Parser Instr-comment = do-    void $ char '#'-    text <- takeWhileP Nothing (not . isNl)-    return $ Comment text--parseRegistry :: 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 = do-    void $ string "--platform="-    p <- someUnless "the platform for the FROM image" (== ' ')-    spaces1-    return p--parseBaseImage :: (Text -> Parser (Maybe Tag)) -> Parser BaseImage-parseBaseImage tagParser = do-    maybePlatform <- (Just <$> try parsePlatform) <|> return Nothing-    notFollowedBy (string "--")-    registryName <- (Just <$> try parseRegistry) <|> return Nothing-    name <- someUnless "the image name with a tag" (\c -> c == '@' || c == ':')-    maybeTag <- tagParser name-    maybeDigest <- (Just <$> try parseDigest) <|> return Nothing-    maybeAlias <- maybeImageAlias-    return $ BaseImage (Image registryName name) maybeTag maybeDigest maybeAlias maybePlatform--taggedImage :: Parser BaseImage-taggedImage = parseBaseImage tagParser-  where-    tagParser _ = do-      void $ char ':'-      tag <- someUnless "the image tag" (\c -> c == '@' || c == ':')-      return (Just . Tag $ tag)--parseDigest :: Parser Digest-parseDigest = do-    void $ char '@'-    d <- someUnless "the image digest" (== '@')-    return $ Digest d--untaggedImage :: Parser BaseImage-untaggedImage = parseBaseImage notInvalidTag-  where-    notInvalidTag :: Text -> Parser (Maybe Tag)-    notInvalidTag name = do-        try (notFollowedBy $ string ":") <?> "no ':' or a valid image tag string (example: " ++ T.unpack name ++ ":valid-tag)"-        return Nothing--maybeImageAlias :: Parser (Maybe ImageAlias)-maybeImageAlias = Just <$> (spaces1 >> imageAlias) <|> return Nothing--imageAlias :: Parser ImageAlias-imageAlias = do-    void (try (reserved "AS") <?> "AS followed by the image alias")-    alias <- someUnless "the image alias" (== '\n')-    return $ ImageAlias alias--baseImage :: Parser BaseImage-baseImage = try taggedImage <|> untaggedImage--from :: Parser Instr-from = do-    reserved "FROM"-    image <- baseImage-    return $ From image--cmd :: Parser Instr-cmd = do-    reserved "CMD"-    args <- arguments-    return $ Cmd args--copy :: Parser Instr-copy = do-    reserved "COPY"-    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-        (_, _:_:_, _) -> customError $ DuplicateFlagError "--chown"-        (_, _, _:_:_) -> customError $ DuplicateFlagError "--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 <- someUnless "the user and group for chown" (== ' ')-    return $ Chown ch--copySource :: Parser CopySource-copySource = do-    void $ string "--from="-    src <- someUnless "the copy source path" isNl-    return $ CopySource src--anyFlag :: Parser (Text, Text)-anyFlag = do-    void $ string "--"-    name <- someUnless "the flag value" (== '=')-    void $ char '='-    val <- anyUnless (== ' ')-    return (T.append "--" name, val)--fileList :: Text -> (NonEmpty SourcePath -> TargetPath -> Instr) -> Parser Instr-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-        [_] -> customError $ FileListError (T.unpack name)-        _ -> return $ constr (SourcePath <$> fromList (init paths)) (TargetPath $ last paths)-  where-    spaceSeparated = anyUnless (== ' ') `sepBy1` (try spaces1 <?> "at least another file path")-    stringList = brackets $ commaSep stringLiteral--unexpectedFlag :: Text -> Text -> Parser a-unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name)-unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name)--shell :: Parser Instr-shell = do-    reserved "SHELL"-    args <- arguments-    return $ Shell args--stopsignal :: Parser Instr-stopsignal = do-    reserved "STOPSIGNAL"-    args <- untilEol "the stop signal"-    return $ Stopsignal args---- We cannot use string literal because it swallows space--- and therefore have to implement quoted values by ourselves-doubleQuotedValue :: Parser Text-doubleQuotedValue =-    between (string "\"") (string "\"") (takeWhileP Nothing (\c -> c /= '"' && c /= '\n'))--singleQuotedValue :: Parser Text-singleQuotedValue =-    between (string "'") (string "'") (takeWhileP Nothing (\c -> c /= '\'' && c /= '\n'))--unquotedString :: String -> Parser Text-unquotedString stopChars = do-    str <- charsWithEscapedSpaces stopChars-    checkFaults str-  where-    checkFaults str-        | T.null str = return str-        | T.head str == '\'' = customError $ QuoteError "single" (T.unpack str)-        | T.head str == '\"' = customError $ QuoteError "double" (T.unpack str)-        | otherwise = return str--singleValue :: String -> Parser Text-singleValue stopChars =-    try doubleQuotedValue <|> -- Quotes or no quotes are fine-    try singleQuotedValue <|>-    (try (unquotedString stopChars) <?> "a string with no quotes")--pair :: Parser (Text, Text)-pair = do-    key <- singleValue "="-    void $ char '='-    value <- singleValue ""-    return (key, value)--pairsList :: Parser Pairs-pairsList = pair `sepBy1` spaces1--label :: Parser Instr-label = do-    reserved "LABEL"-    p <- pairs-    return $ Label p--arg :: Parser Instr-arg = do-    reserved "ARG"-    (try nameWithDefault <?> "the arg name") <|>-        Arg <$> untilEol "the argument name" <*> pure Nothing-  where-    nameWithDefault = do-        name <- someUnless "the argument name" (== '=')-        void $ char '='-        def <- untilEol "the argument value"-        return $ Arg name (Just def)--env :: Parser Instr-env = do-    reserved "ENV"-    p <- pairs-    return $ Env p--pairs :: Parser Pairs-pairs = try pairsList <|> try singlePair--singlePair :: Parser Pairs-singlePair = do-    key <- anyUnless (== '=')-    spaces1 <?> "a space followed by the value for the variable '" ++ T.unpack key ++ "'"-    val <- untilEol "the variable value"-    return [(key, val)]--user :: Parser Instr-user = do-    reserved "USER"-    username <- untilEol "the user"-    return $ User username--add :: Parser Instr-add = do-    reserved "ADD"-    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 _ -> customError $ InvalidFlagError "--from"-        FlagInvalid (k, v) -> unexpectedFlag k v--expose :: Parser Instr-expose = do-    reserved "EXPOSE"-    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 optionally followed by the protocol (udp/tcp)") <|>-    (try portWithProtocol <?> "a port with its protocol (udp/tcp)") <|>-    (try portInt <?> "a valid port number")--ports :: Parser Ports-ports = Ports <$> port `sepEndBy` spaces1--portRange :: Parser Port-portRange = do-    start <- natural-    void $ char '-'-    finish <- try natural-    proto <- try protocol <|> return TCP-    return $ PortRange (fromIntegral start) (fromIntegral finish) proto--protocol :: Parser Protocol-protocol = do-    void (char '/')-    tcp <|> udp-  where-    tcp = caseInsensitiveString "tcp" >> return TCP-    udp = caseInsensitiveString "udp" >> return UDP--portInt :: Parser Port-portInt = do-    portNumber <- natural-    notFollowedBy (string "/" <|> string "-")-    return $ Port (fromIntegral portNumber) TCP--portWithProtocol :: Parser Port-portWithProtocol = do-    portNumber <- natural-    proto <- protocol-    return $ Port (fromIntegral portNumber) proto--portVariable :: Parser Port-portVariable = do-    void (char '$')-    variable <- someUnless "the variable name" (== '$')-    return $ PortStr (T.append "$" variable)--run :: Parser Instr-run = do-    reserved "RUN"-    c <- arguments-    return $ Run c---- Parse value until end of line is reached-untilEol :: String -> Parser Text-untilEol name = takeWhile1P (Just name) (not . isNl)--workdir :: Parser Instr-workdir = do-    reserved "WORKDIR"-    directory <- untilEol "the workdir path"-    return $ Workdir directory--volume :: Parser Instr-volume = do-    reserved "VOLUME"-    directory <- untilEol "the volume path"-    return $ Volume directory--maintainer :: Parser Instr-maintainer = do-    reserved "MAINTAINER"-    name <- untilEol "the maintainer name"-    return $ Maintainer name---- Parse arguments of a command in the exec form-argumentsExec :: 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 = ArgumentsText <$> toEnd-  where-    toEnd = untilEol "the shell arguments"--arguments :: Parser (Arguments Text)-arguments = try argumentsExec <|> try argumentsShell--entrypoint :: Parser Instr-entrypoint = do-    reserved "ENTRYPOINT"-    args <- arguments-    return $ Entrypoint args--onbuild :: Parser Instr-onbuild = do-    reserved "ONBUILD"-    i <- parseInstruction-    return $ OnBuild i--healthcheck :: Parser Instr-healthcheck = do-    reserved "HEALTHCHECK"-    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-            (_, _:_:_, _, _, _) -> customError $ DuplicateFlagError "--interval"-            (_, _, _:_:_, _, _) -> customError $ DuplicateFlagError "--timeout"-            (_, _, _, _:_:_, _) -> customError $ DuplicateFlagError "--start-period"-            (_, _, _, _, _:_:_) -> customError $ DuplicateFlagError "--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 :: Text -> 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))-        'h' -> return $ Duration (secondsToDiffTime (scale * 60 * 60))-        _ -> fail "only 's', 'm' or 'h' are allowed as the duration"--retriesFlag :: Parser Retries-retriesFlag = do-    void $ try (string "--retries=")-    n <- try natural <?> "the number of retries"-    return $ Retries (fromIntegral n)----------------------------------------- Main Parser--------------------------------------parseInstruction :: Parser Instr-parseInstruction =-    onbuild <|> -- parse all main instructions-    from <|>-    copy <|>-    run <|>-    workdir <|>-    entrypoint <|>-    volume <|>-    expose <|>-    env <|>-    arg <|>-    user <|>-    label <|>-    stopsignal <|>-    cmd <|>-    shell <|>-    maintainer <|>-    add <|>-    comment <|>-    healthcheck- contents :: Parser a -> Parser a contents p = do-    void $ takeWhileP Nothing isSpaceNl-    r <- p-    eof-    return r+  void $ takeWhileP Nothing isSpaceNl+  r <- p+  eof+  return r  dockerfile :: Parser Dockerfile dockerfile =-    many $ do-        pos <- getSourcePos-        i <- parseInstruction-        eol <|> eof <?> "a new line followed by the next instruction"-        return $ InstructionPos i (T.pack . sourceName $ pos) (unPos . sourceLine $ pos)+  many $ do+    pos <- getSourcePos+    i <- parseInstruction+    eol <|> eof <?> "a new line followed by the next instruction"+    return $ InstructionPos i (T.pack . sourceName $ pos) (unPos . sourceLine $ pos)  parseText :: Text -> Either Error Dockerfile-parseText s = parse (contents dockerfile) "<string>" $ normalizeEscapedLines s+parseText = parse (contents dockerfile) "<string>"  parseFile :: FilePath -> IO (Either Error Dockerfile) parseFile file = doParse <$> B.readFile file   where-    doParse =-        parse (contents dockerfile) file . normalizeEscapedLines . E.decodeUtf8With E.lenientDecode+    doParse = parse (contents dockerfile) file . E.decodeUtf8With E.lenientDecode  -- | Reads the standard input until the end and parses the contents as a Dockerfile parseStdin :: IO (Either Error Dockerfile) parseStdin = doParse <$> B.getContents   where-    doParse =-        parse (contents dockerfile) "/dev/stdin" . normalizeEscapedLines . E.decodeUtf8With E.lenientDecode+    doParse = parse (contents dockerfile) "/dev/stdin" . E.decodeUtf8With E.lenientDecode

@@ -0,0 +1,23 @@+module Language.Docker.Parser.Arguments+  ( arguments,+  )+where++import qualified Data.Text as T+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++-- Parse arguments of a command in the exec form+argumentsExec :: 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 = ArgumentsText <$> toEnd+  where+    toEnd = untilEol "the shell arguments"++arguments :: Parser (Arguments Text)+arguments = try argumentsExec <|> try argumentsShell

@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Docker.Parser.Cmd+  ( parseCmd,+  )+where++import Language.Docker.Parser.Arguments+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++parseCmd :: Parser (Instruction Text)+parseCmd = do+  reserved "CMD"+  Cmd <$> arguments

@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Docker.Parser.Copy+  ( parseCopy,+    parseAdd,+  )+where++import Data.List.NonEmpty (NonEmpty, fromList)+import qualified Data.Text as T+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++data CopyFlag+  = FlagChown Chown+  | FlagSource CopySource+  | FlagInvalid (Text, Text)++parseCopy :: Parser (Instruction Text)+parseCopy = do+  reserved "COPY"+  flags <- copyFlag `sepEndBy` requiredWhitespace+  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+    (_, _ : _ : _, _) -> customError $ DuplicateFlagError "--chown"+    (_, _, _ : _ : _) -> customError $ DuplicateFlagError "--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))++parseAdd :: Parser (Instruction Text)+parseAdd = do+  reserved "ADD"+  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 _ -> customError $ InvalidFlagError "--from"+    FlagInvalid (k, v) -> unexpectedFlag k v++fileList :: Text -> (NonEmpty SourcePath -> TargetPath -> Instruction Text) -> Parser (Instruction Text)+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+    [_] -> customError $ FileListError (T.unpack name)+    _ -> return $ constr (SourcePath <$> fromList (init paths)) (TargetPath $ last paths)+  where+    spaceSeparated =+      anyUnless (== ' ') `sepEndBy1` (try requiredWhitespace <?> "at least another file path")+    stringList = brackets $ commaSep stringLiteral++unexpectedFlag :: Text -> Text -> Parser a+unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name)+unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name)++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 <- someUnless "the user and group for chown" (== ' ')+  return $ Chown ch++copySource :: Parser CopySource+copySource = do+  void $ string "--from="+  src <- someUnless "the copy source path" isNl+  return $ CopySource src++anyFlag :: Parser (Text, Text)+anyFlag = do+  void $ string "--"+  name <- someUnless "the flag value" (== '=')+  void $ char '='+  val <- anyUnless (== ' ')+  return (T.append "--" name, val)

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Docker.Parser.Expose+  ( parseExpose,+  )+where++import qualified Data.Text as T+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++parseExpose :: Parser (Instruction Text)+parseExpose = do+  reserved "EXPOSE"+  Expose <$> ports++port :: 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 = Ports <$> port `sepEndBy` requiredWhitespace++portRange :: Parser Port+portRange = do+  start <- natural+  void $ char '-'+  finish <- try natural+  proto <- try protocol <|> return TCP+  return $ PortRange (fromIntegral start) (fromIntegral finish) proto++protocol :: Parser Protocol+protocol = do+  void (char '/')+  tcp <|> udp+  where+    tcp = caseInsensitiveString "tcp" >> return TCP+    udp = caseInsensitiveString "udp" >> return UDP++portInt :: Parser Port+portInt = do+  portNumber <- natural+  notFollowedBy (string "/" <|> string "-")+  return $ Port (fromIntegral portNumber) TCP++portWithProtocol :: Parser Port+portWithProtocol = do+  portNumber <- natural+  Port (fromIntegral portNumber) <$> protocol++portVariable :: Parser Port+portVariable = do+  void (char '$')+  variable <- someUnless "the variable name" (== '$')+  return $ PortStr (T.append "$" variable)

@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Docker.Parser.From+  ( parseFrom,+  )+where++import qualified Data.Text as T+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++parseRegistry :: 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 = do+  void $ string "--platform="+  p <- someUnless "the platform for the FROM image" (== ' ')+  requiredWhitespace+  return p++parseBaseImage :: (Text -> Parser (Maybe Tag)) -> Parser BaseImage+parseBaseImage tagParser = do+  maybePlatform <- (Just <$> try parsePlatform) <|> return Nothing+  notFollowedBy (string "--")+  regName <- (Just <$> try parseRegistry) <|> return Nothing+  name <- someUnless "the image name with a tag" (\c -> c == '@' || c == ':')+  maybeTag <- tagParser name <|> return Nothing+  maybeDigest <- (Just <$> try parseDigest) <|> return Nothing+  maybeAlias <- (Just <$> try (requiredWhitespace *> imageAlias)) <|> return Nothing+  return $ BaseImage (Image regName name) maybeTag maybeDigest maybeAlias maybePlatform++taggedImage :: 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 = do+  void $ char '@'+  d <- someUnless "the image digest" (== '@')+  return $ Digest d++untaggedImage :: Parser BaseImage+untaggedImage = parseBaseImage notInvalidTag+  where+    notInvalidTag :: Text -> Parser (Maybe Tag)+    notInvalidTag name = do+      try (notFollowedBy $ string ":") <?> "no ':' or a valid image tag string (example: "+        ++ T.unpack name+        ++ ":valid-tag)"+      return Nothing++imageAlias :: 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 = try taggedImage <|> untaggedImage++parseFrom :: Parser (Instruction Text)+parseFrom = do+  reserved "FROM"+  From <$> baseImage

@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Language.Docker.Parser.Healthcheck+  ( parseHealthcheck,+  )+where++import Data.Maybe (listToMaybe)+import qualified Data.Text as T+import Data.Time.Clock (secondsToDiffTime)+import Language.Docker.Parser.Cmd (parseCmd)+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++data CheckFlag+  = FlagInterval Duration+  | FlagTimeout Duration+  | FlagStartPeriod Duration+  | FlagRetries Retries+  | CFlagInvalid (Text, Text)++parseHealthcheck :: Parser (Instruction Text)+parseHealthcheck = do+  reserved "HEALTHCHECK"+  Healthcheck <$> (fullCheck <|> noCheck)+  where+    noCheck = string "NONE" >> return NoCheck+    allFlags = do+      flags <- someFlags+      requiredWhitespace <?> "another flag"+      return flags+    someFlags = do+      x <- checkFlag+      cont <- try (requiredWhitespace >> 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+        (_, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--interval"+        (_, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--timeout"+        (_, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--start-period"+        (_, _, _, _, _ : _ : _) -> customError $ DuplicateFlagError "--retries"+        _ -> do+          Cmd checkCommand <- parseCmd+          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 :: Text -> 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))+    'h' -> return $ Duration (secondsToDiffTime (scale * 60 * 60))+    _ -> fail "only 's', 'm' or 'h' are allowed as the duration"++retriesFlag :: Parser Retries+retriesFlag = do+  void $ try (string "--retries=")+  n <- try natural <?> "the number of retries"+  return $ Retries (fromIntegral n)++anyFlag :: Parser (Text, Text)+anyFlag = do+  void $ string "--"+  name <- someUnless "the flag value" (== '=')+  void $ char '='+  val <- anyUnless (== ' ')+  return (T.append "--" name, val)++unexpectedFlag :: Text -> Text -> Parser a+unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name)+unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name)

@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Docker.Parser.Instruction+  ( parseInstruction,+    parseShell,+    parseStopSignal,+    parseArg,+    parseUser,+    parseWorkdir,+    parseVolume,+    parseEntryPoint,+    parseMaintainer,+    parseOnbuild,+    parseComment,+  )+where++import Language.Docker.Parser.Arguments (arguments)+import Language.Docker.Parser.Cmd (parseCmd)+import Language.Docker.Parser.Copy (parseAdd, parseCopy)+import Language.Docker.Parser.Expose (parseExpose)+import Language.Docker.Parser.From (parseFrom)+import Language.Docker.Parser.Healthcheck (parseHealthcheck)+import Language.Docker.Parser.Pairs (parseEnv, parseLabel)+import Language.Docker.Parser.Prelude+import Language.Docker.Parser.Run (parseRun)+import Language.Docker.Syntax++parseShell :: Parser (Instruction Text)+parseShell = do+  reserved "SHELL"+  Shell <$> arguments++parseStopSignal :: Parser (Instruction Text)+parseStopSignal = do+  reserved "STOPSIGNAL"+  args <- untilEol "the stop signal"+  return $ Stopsignal args++parseArg :: Parser (Instruction Text)+parseArg = do+  reserved "ARG"+  (try nameWithDefault <?> "the arg name")+    <|> Arg <$> untilEol "the argument name" <*> pure Nothing+  where+    nameWithDefault = do+      name <- someUnless "the argument name" (== '=')+      void $ char '='+      df <- untilEol "the argument value"+      return $ Arg name (Just df)++parseUser :: Parser (Instruction Text)+parseUser = do+  reserved "USER"+  username <- untilEol "the user"+  return $ User username++parseWorkdir :: Parser (Instruction Text)+parseWorkdir = do+  reserved "WORKDIR"+  directory <- untilEol "the workdir path"+  return $ Workdir directory++parseVolume :: Parser (Instruction Text)+parseVolume = do+  reserved "VOLUME"+  directory <- untilEol "the volume path"+  return $ Volume directory++parseMaintainer :: Parser (Instruction Text)+parseMaintainer = do+  reserved "MAINTAINER"+  name <- untilEol "the maintainer name"+  return $ Maintainer name++parseEntryPoint :: Parser (Instruction Text)+parseEntryPoint = do+  reserved "ENTRYPOINT"+  Entrypoint <$> arguments++parseOnbuild :: Parser (Instruction Text)+parseOnbuild = do+  reserved "ONBUILD"+  OnBuild <$> parseInstruction++parseComment :: Parser (Instruction Text)+parseComment = Comment <$> comment++parseInstruction :: Parser (Instruction Text)+parseInstruction =+  choice+    [ parseOnbuild,+      parseFrom,+      parseCopy,+      parseRun,+      parseWorkdir,+      parseEntryPoint,+      parseVolume,+      parseExpose,+      parseEnv,+      parseArg,+      parseUser,+      parseLabel,+      parseStopSignal,+      parseCmd,+      parseShell,+      parseMaintainer,+      parseAdd,+      parseComment,+      parseHealthcheck+    ]

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Docker.Parser.Pairs+  ( parseEnv,+    parseLabel,+  )+where++import qualified Data.Text as T+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++-- We cannot use string literal because it swallows space+-- and therefore have to implement quoted values by ourselves+doubleQuotedValue :: Parser Text+doubleQuotedValue = between (string "\"") (string "\"") (stringWithEscaped ['"'] Nothing)++singleQuotedValue :: Parser Text+singleQuotedValue = between (string "'") (string "'") (stringWithEscaped ['\''] Nothing)++unquotedString :: (Char -> Bool) -> Parser Text+unquotedString acceptCondition = do+  str <- stringWithEscaped [' ', '\t'] (Just (\c -> acceptCondition c && c /= '"' && c /= '\''))+  checkFaults str+  where+    checkFaults str+      | T.null str = fail "a non empty string"+      | T.head str == '\'' = customError $ QuoteError "single" (T.unpack str)+      | T.head str == '\"' = customError $ QuoteError "double" (T.unpack str)+      | otherwise = return str++singleValue :: (Char -> Bool) -> Parser Text+singleValue acceptCondition = mconcat <$> variants+  where+    variants =+      many $+        choice+          [ doubleQuotedValue <?> "a string inside double quotes",+            singleQuotedValue <?> "a string inside single quotes",+            unquotedString acceptCondition <?> "a string with no quotes"+          ]++pair :: Parser (Text, Text)+pair = do+  key <- singleValue (/= '=')+  value <- withEqualSign <|> withoutEqualSign+  return (key, value)+  where+    withEqualSign = do+      void $ char '='+      singleValue (\c -> c /= ' ' && c /= '\t')+    withoutEqualSign = do+      requiredWhitespace+      untilEol "value"++pairs :: Parser Pairs+pairs = (pair <?> "a key value pair (key=value)") `sepEndBy1` requiredWhitespace++parseLabel :: Parser (Instruction Text)+parseLabel = do+  reserved "LABEL"+  Label <$> pairs++parseEnv :: Parser (Instruction Text)+parseEnv = do+  reserved "ENV"+  Env <$> pairs

@@ -0,0 +1,244 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Docker.Parser.Prelude+  ( customError,+    comment,+    eol,+    reserved,+    natural,+    commaSep,+    stringLiteral,+    brackets,+    whitespace,+    requiredWhitespace,+    untilEol,+    symbol,+    caseInsensitiveString,+    stringWithEscaped,+    lexeme,+    isNl,+    isSpaceNl,+    anyUnless,+    someUnless,+    Parser,+    Error,+    DockerfileError (..),+    module Megaparsec,+    char,+    string,+    void,+    when,+    Text,+    module Data.Default.Class+  )+where++import Control.Monad (void, when)+import Data.Data+import Data.Maybe (fromMaybe)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import Text.Megaparsec as Megaparsec hiding (Label)+import Text.Megaparsec.Char hiding (eol)+import qualified Text.Megaparsec.Char.Lexer as L+import Data.Default.Class (Default(def))++data DockerfileError+  = DuplicateFlagError String+  | NoValueFlagError String+  | InvalidFlagError String+  | FileListError String+  | MissingArgument [Text]+  | DuplicateArgument Text+  | UnexpectedArgument Text Text+  | QuoteError+      String+      String+  deriving (Eq, Data, Typeable, Ord, Read, Show)++type Parser = Parsec DockerfileError Text++type Error = ParseErrorBundle Text DockerfileError++instance ShowErrorComponent DockerfileError where+  showErrorComponent (DuplicateFlagError f) = "duplicate flag: " ++ f+  showErrorComponent (FileListError f) =+    "unexpected end of line. At least two arguments are required for " ++ f+  showErrorComponent (NoValueFlagError f) = "unexpected flag " ++ f ++ " with no value"+  showErrorComponent (InvalidFlagError f) = "invalid flag: " ++ f+  showErrorComponent (MissingArgument f) = "missing required argument(s) for mount flag: " ++ show f+  showErrorComponent (DuplicateArgument f) = "duplicate argument for mount flag: " ++ T.unpack f+  showErrorComponent (UnexpectedArgument a b) = "unexpected argument '" ++ T.unpack a ++ "' for mount of type '" ++ T.unpack b ++ "'"+  showErrorComponent (QuoteError t str) =+    "unexpected end of " ++ t ++ " quoted string " ++ str ++ " (unmatched quote)"++-- Spaces are sometimes significant information in a dockerfile, this type records+-- thee presence of lack of such whitespace in certain lines.+data FoundWhitespace+  = FoundWhitespace+  | MissingWhitespace+  deriving (Eq, Show)++-- There is no need to remember how many spaces we found in a line, so we can+-- cheaply remmeber that we already whitenessed some significant whitespace while+-- parsing an expression by concatenating smaller results+instance Semigroup FoundWhitespace where+  FoundWhitespace <> _ = FoundWhitespace+  _ <> a = a++instance Monoid FoundWhitespace where+  mempty = MissingWhitespace++------------------------------------+-- Utilities+------------------------------------++-- | End parsing signaling a “conversion error”.+customError :: DockerfileError -> Parser a+customError = fancyFailure . S.singleton . ErrorCustom++castToSpace :: FoundWhitespace -> Text+castToSpace FoundWhitespace = " "+castToSpace MissingWhitespace = ""++eol :: Parser ()+eol = void ws <?> "end of line"+  where+    ws =+      some $+        choice [void onlySpaces1, void $ takeWhile1P Nothing (== '\n'), void escapedLineBreaks]++reserved :: Text -> Parser ()+reserved name = void (lexeme (string' name) <?> T.unpack name)++natural :: Parser Integer+natural = L.decimal <?> "positive number"++commaSep :: Parser a -> Parser [a]+commaSep p = sepBy (p <* whitespace) (symbol ",")++stringLiteral :: Parser Text+stringLiteral = do+  void (char '"')+  lit <- manyTill L.charLiteral (char '"')+  return (T.pack lit)++brackets :: Parser a -> Parser a+brackets = between (symbol "[" *> whitespace) (whitespace *> symbol "]")++onlySpaces :: Parser Text+onlySpaces = takeWhileP (Just "spaces") (\c -> c == ' ' || c == '\t')++onlySpaces1 :: Parser Text+onlySpaces1 = takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t')++escapedLineBreaks :: Parser FoundWhitespace+escapedLineBreaks = mconcat <$> breaks+  where+    breaks =+      some $ do+        try (char '\\' *> onlySpaces *> newlines)+        skipMany . try $ onlySpaces *> comment *> newlines+        -- Spaces before the next '\' have a special significance+        -- so we remembeer the fact that we found some+        FoundWhitespace <$ onlySpaces1 <|> pure MissingWhitespace+    newlines = takeWhile1P Nothing isNl++foundWhitespace :: Parser FoundWhitespace+foundWhitespace = mconcat <$> found+  where+    found = many $ choice [FoundWhitespace <$ onlySpaces1, escapedLineBreaks]++whitespace :: Parser ()+whitespace = void foundWhitespace++requiredWhitespace :: Parser ()+requiredWhitespace = do+  ws <- foundWhitespace+  case ws of+    FoundWhitespace -> pure ()+    MissingWhitespace -> fail "missing whitespace"++-- Parse value until end of line is reached+-- after consuming all escaped newlines+untilEol :: String -> Parser Text+untilEol name = do+  res <- mconcat <$> predicate+  when (res == "") $ fail ("expecting " ++ name)+  pure res+  where+    predicate =+      many $+        choice+          [ castToSpace <$> escapedLineBreaks,+            takeWhile1P (Just name) (\c -> c /= '\n' && c /= '\\'),+            takeWhile1P Nothing (== '\\') <* notFollowedBy (char '\n')+          ]++symbol :: Text -> Parser Text+symbol name = do+  x <- string name+  whitespace+  return x++caseInsensitiveString :: Text -> Parser Text+caseInsensitiveString = string'++stringWithEscaped :: [Char] -> Maybe (Char -> Bool) -> Parser Text+stringWithEscaped quoteChars maybeAcceptCondition = mconcat <$> sequences+  where+    sequences =+      many $+        choice+          [ mconcat <$> inner,+            try $ takeWhile1P Nothing (== '\\') <* notFollowedBy quoteParser,+            string "\\" *> quoteParser+          ]+    inner =+      some $+        choice+          [ castToSpace <$> escapedLineBreaks,+            takeWhile1P+              Nothing+              (\c -> c /= '\\' && c /= '\n' && c `notElem` quoteChars && acceptCondition c)+          ]+    quoteParser = T.singleton <$> choice (fmap char quoteChars)+    acceptCondition = fromMaybe (const True) maybeAcceptCondition++lexeme :: Parser a -> Parser a+lexeme p = do+  x <- p+  requiredWhitespace+  return x++isNl :: Char -> Bool+isNl c = c == '\n'++isSpaceNl :: Char -> Bool+isSpaceNl c = c == ' ' || c == '\t' || c == '\n' || c == '\\'++anyUnless :: (Char -> Bool) -> Parser Text+anyUnless predicate = someUnless "" predicate <|> pure ""++someUnless :: String -> (Char -> Bool) -> Parser Text+someUnless name predicate = do+  res <- applyPredicate+  case res of+    [] -> fail ("expecting " ++ name)+    _ -> pure (mconcat res)+  where+    applyPredicate =+      many $+        choice+          [ castToSpace <$> escapedLineBreaks,+            takeWhile1P (Just name) (\c -> not (isSpaceNl c || predicate c)),+            takeWhile1P Nothing (\c -> c == '\\' && not (predicate c))+              <* notFollowedBy (char '\n')+          ]++comment :: Parser Text+comment = do+  void $ char '#'+  takeWhileP Nothing (not . isNl)

@@ -0,0 +1,288 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Language.Docker.Parser.Run+  ( parseRun,+    runFlags,+  )+where++import Data.Functor (($>))+import qualified Data.Set as Set+import Language.Docker.Parser.Arguments (arguments)+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++data RunFlag+  = RunFlagMount RunMount+  | RunFlagSecurity RunSecurity+  | RunFlagNetwork RunNetwork+  deriving (Show)++data RunMountArg+  = MountArgFromImage Text+  | MountArgGid Integer+  | MountArgId Text+  | MountArgMode Text+  | MountArgReadOnly Bool+  | MountArgRequired+  | MountArgSharing CacheSharing+  | MountArgSource SourcePath+  | MountArgTarget TargetPath+  | MountArgType Text+  | MountArgUid Integer+  deriving (Show)++data MountType+  = Bind+  | Cache+  | Tmpfs+  | Secret+  | Ssh++parseRun :: Parser (Instruction Text)+parseRun = do+  reserved "RUN"+  Run <$> runArguments++runArguments :: Parser (RunArgs Text)+runArguments = do+  presentFlags <- choice [runFlags <* requiredWhitespace, pure (RunFlags Nothing Nothing Nothing)]+  args <- arguments+  return $ RunArgs args presentFlags++runFlags :: Parser RunFlags+runFlags = do+  flags <- runFlag `sepBy` flagSeparator+  return $ foldr toRunFlags emptyFlags flags+  where+    flagSeparator = try (requiredWhitespace *> lookAhead (string "--")) <|> fail "expected flag"+    emptyFlags = RunFlags Nothing Nothing Nothing+    toRunFlags (RunFlagMount m) rf = rf {mount = Just m}+    toRunFlags (RunFlagNetwork n) rf = rf {network = Just n}+    toRunFlags (RunFlagSecurity s) rf = rf {security = Just s}++runFlag :: Parser RunFlag+runFlag =+  choice+    [RunFlagMount <$> runFlagMount, RunFlagSecurity <$> runFlagSecurity, RunFlagNetwork <$> runFlagNetwork]++runFlagSecurity :: Parser RunSecurity+runFlagSecurity = do+  void $ string "--security="+  choice [Insecure <$ string "insecure", Sandbox <$ string "sandbox"]++runFlagNetwork :: Parser RunNetwork+runFlagNetwork = do+  void $ string "--network="+  choice [NetworkNone <$ string "none", NetworkHost <$ string "host", NetworkDefault <$ string "default"]++runFlagMount :: Parser RunMount+runFlagMount = do+  void $ string "--mount="+  maybeType <-+    choice+      [ string "type="+          *> choice+            [ Just Bind <$ string "bind",+              Just Cache <$ string "cache",+              Just Tmpfs <$ string "tmpfs",+              Just Secret <$ string "secret",+              Just Ssh <$ string "ssh"+            ],+        pure Nothing+      ]+  (mountType, args) <- return $+    case maybeType of+      Nothing -> (Bind, argsParser Bind)+      Just Ssh -> (Ssh, choice [string "," *> argsParser Ssh, pure []])+      Just t -> (t, string "," *> argsParser t)+  case mountType of+    Bind -> BindMount <$> (bindMount =<< args)+    Cache -> CacheMount <$> (cacheMount =<< args)+    Tmpfs -> TmpfsMount <$> (tmpfsMount =<< args)+    Secret -> SecretMount <$> (secretMount =<< args)+    Ssh -> SshMount <$> (secretMount =<< args)++argsParser :: MountType -> Parser [RunMountArg]+argsParser mountType = mountChoices mountType `sepBy1` string ","++bindMount :: [RunMountArg] -> Parser BindOpts+bindMount args =+  case validArgs "bind" allowed required args of+    Left e -> customError e+    Right as -> return $ foldr bindOpts def as+  where+    allowed = Set.fromList ["target", "source", "from", "ro"]+    required = Set.singleton "target"+    bindOpts :: RunMountArg -> BindOpts -> BindOpts+    bindOpts (MountArgTarget path) bo = bo {bTarget = path}+    bindOpts (MountArgSource path) bo = bo {bSource = Just path}+    bindOpts (MountArgFromImage img) bo = bo {bFromImage = Just img}+    bindOpts (MountArgReadOnly ro) bo = bo {bReadOnly = Just ro}+    bindOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug"++cacheMount :: [RunMountArg] -> Parser CacheOpts+cacheMount args =+  case validArgs "cache" allowed required args of+    Left e -> customError e+    Right as -> return $ foldr cacheOpts def as+  where+    allowed = Set.fromList ["target", "sharing", "id", "ro", "from", "source", "mode", "uid", "gid"]+    required = Set.fromList ["target", "sharing"]+    cacheOpts :: RunMountArg -> CacheOpts -> CacheOpts+    cacheOpts (MountArgTarget path) co = co {cTarget = path}+    cacheOpts (MountArgSharing sh) co = co {cSharing = sh}+    cacheOpts (MountArgId i) co = co {cCacheId = Just i}+    cacheOpts (MountArgReadOnly ro) co = co {cReadOnly = Just ro}+    cacheOpts (MountArgFromImage img) co = co {cFromImage = Just img}+    cacheOpts (MountArgSource path) co = co {cSource = Just path}+    cacheOpts (MountArgMode m) co = co {cMode = Just m}+    cacheOpts (MountArgUid u) co = co {cUid = Just u}+    cacheOpts (MountArgGid g) co = co {cGid = Just g}+    cacheOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug"++tmpfsMount :: [RunMountArg] -> Parser TmpOpts+tmpfsMount args =+  case validArgs "tmpfs" required required args of+    Left e -> customError e+    Right as -> return $ foldr tmpOpts def as+  where+    required = Set.singleton "target"+    tmpOpts :: RunMountArg -> TmpOpts -> TmpOpts+    tmpOpts (MountArgTarget path) t = t {tTarget = path}+    tmpOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug"++secretMount :: [RunMountArg] -> Parser SecretOpts+secretMount args =+  case validArgs "secret" allowed required args of+    Left e -> customError e+    Right as -> return $ foldr secretOpts def as+  where+    allowed = Set.fromList ["target", "id", "required", "source", "mode", "uid", "gid"]+    required = Set.empty+    secretOpts :: RunMountArg -> SecretOpts -> SecretOpts+    secretOpts (MountArgTarget path) co = co {sTarget = Just path}+    secretOpts (MountArgId i) co = co {sCacheId = Just i}+    secretOpts MountArgRequired co = co {sIsRequired = Just True}+    secretOpts (MountArgSource path) co = co {sSource = Just path}+    secretOpts (MountArgMode m) co = co {sMode = Just m}+    secretOpts (MountArgUid u) co = co {sUid = Just u}+    secretOpts (MountArgGid g) co = co {sGid = Just g}+    secretOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug"++validArgs ::+  Foldable t =>+  Text ->+  Set.Set Text ->+  Set.Set Text ->+  t RunMountArg ->+  Either DockerfileError [RunMountArg]+validArgs typeName allowed required args =+  let (result, seen) = foldr checkValidArg (Right [], Set.empty) args+   in case Set.toList (Set.difference required seen) of+        [] -> result+        missing -> Left $ MissingArgument missing+  where+    checkValidArg _ x@(Left _, _) = x+    checkValidArg a (Right as, seen) =+      let name = toArgName a+       in case (Set.member name allowed, Set.member name seen) of+            (False, _) -> (Left (UnexpectedArgument name typeName), seen)+            (_, True) -> (Left (DuplicateArgument name), seen)+            (True, False) -> (Right (a : as), Set.insert name seen)++mountChoices :: MountType -> Parser RunMountArg+mountChoices mountType =+  choice $+    case mountType of+      Bind ->+        [ mountArgTarget,+          mountArgSource,+          mountArgFromImage,+          mountArgReadOnly,+          mountArgReadWrite+        ]+      Cache ->+        [ mountArgTarget,+          mountArgSource,+          mountArgFromImage,+          mountArgReadOnly,+          mountArgReadWrite,+          mountArgId,+          mountArgSharing,+          mountArgMode,+          mountArgUid,+          mountArgGid+        ]+      Tmpfs -> [mountArgTarget]+      _ -> -- Secret and Ssh+        [ mountArgTarget,+          mountArgId,+          mountArgRequired,+          mountArgSource,+          mountArgMode,+          mountArgUid,+          mountArgGid+        ]++stringArg :: Parser Text+stringArg = choice [stringLiteral, someUnless "a string" (== ',')]++key :: Text -> Parser a -> Parser a+key name p = string (name <> "=") *> p++cacheSharing :: Parser CacheSharing+cacheSharing =+  choice [Private <$ string "private", Shared <$ string "shared", Locked <$ string "locked"]++mountArgFromImage :: Parser RunMountArg+mountArgFromImage = MountArgFromImage <$> key "from" stringArg++mountArgGid :: Parser RunMountArg+mountArgGid = MountArgGid <$> key "gid" natural++mountArgId :: Parser RunMountArg+mountArgId = MountArgId <$> key "id" stringArg++mountArgMode :: Parser RunMountArg+mountArgMode = MountArgMode <$> key "mode" stringArg++mountArgReadOnly :: Parser RunMountArg+mountArgReadOnly = MountArgReadOnly <$> (choice ["ro", "readonly"] $> True)++mountArgReadWrite :: Parser RunMountArg+mountArgReadWrite = MountArgReadOnly <$> (choice ["rw", "readwrite"] $> False)++mountArgRequired :: Parser RunMountArg+mountArgRequired = MountArgRequired <$ string "required"++mountArgSharing :: Parser RunMountArg+mountArgSharing = MountArgSharing <$> key "sharing" cacheSharing++mountArgSource :: Parser RunMountArg+mountArgSource = do+  label "source=" $ choice [string "source=", string "src="]+  MountArgSource . SourcePath <$> stringArg++mountArgTarget :: Parser RunMountArg+mountArgTarget = do+  label "target=" $ choice [string "target=", string "dest=", string "destination="]+  MountArgTarget . TargetPath <$> stringArg++mountArgUid :: Parser RunMountArg+mountArgUid = MountArgUid <$> key "uid" natural++toArgName :: RunMountArg -> Text+toArgName (MountArgFromImage _) = "from"+toArgName (MountArgGid _) = "gid"+toArgName (MountArgId _) = "id"+toArgName (MountArgMode _) = "mode"+toArgName (MountArgReadOnly _) = "ro"+toArgName MountArgRequired = "required"+toArgName (MountArgSharing _) = "sharing"+toArgName (MountArgSource _) = "source"+toArgName (MountArgTarget _) = "target"+toArgName (MountArgType _) = "type"+toArgName (MountArgUid _) = "uid"

@@ -1,35 +1,36 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoMonomorphismRestriction #-}  module Language.Docker.PrettyPrint where -import Data.List.NonEmpty as NonEmpty (NonEmpty(..), toList)+import Data.List.NonEmpty as NonEmpty (NonEmpty (..), toList) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Internal (Doc(Empty))+import Data.Text.Prettyprint.Doc.Internal (Doc (Empty)) import Data.Text.Prettyprint.Doc.Render.Text (renderLazy) import Language.Docker.Syntax import Prelude hiding ((<>), (>>)) -data EscapeAccum = EscapeAccum-    { buffer :: !B.Builder-    , count :: !Int-    , escaping :: !Bool-    }+data EscapeAccum+  = EscapeAccum+      { buffer :: !B.Builder,+        count :: !Int,+        escaping :: !Bool+      }  instance Pretty (Arguments Text) where-    pretty = prettyPrintArguments+  pretty = prettyPrintArguments  -- | Pretty print a 'Dockerfile' to a 'Text' prettyPrint :: Dockerfile -> L.Text@@ -51,30 +52,30 @@ prettyPrintImage (Image (Just (Registry reg)) name) = pretty reg <> "/" <> pretty name  prettyPrintBaseImage :: BaseImage -> Doc ann-prettyPrintBaseImage BaseImage{..} = do-    prettyPlatform platform-    prettyPrintImage image-    prettyTag tag-    prettyDigest digest-    prettyAlias alias+prettyPrintBaseImage BaseImage {..} = do+  prettyPlatform platform+  prettyPrintImage image+  prettyTag tag+  prettyDigest digest+  prettyAlias alias   where     (>>) = (<>)     prettyPlatform maybePlatform =-        case maybePlatform of-            Nothing -> mempty-            Just p -> "--platform=" <> pretty p <> " "+      case maybePlatform of+        Nothing -> mempty+        Just p -> "--platform=" <> pretty p <> " "     prettyTag maybeTag =-        case maybeTag of-            Nothing -> mempty-            Just (Tag p) -> ":" <> pretty p+      case maybeTag of+        Nothing -> mempty+        Just (Tag p) -> ":" <> pretty p     prettyAlias maybeAlias =-        case maybeAlias of-            Nothing -> mempty-            Just (ImageAlias a) -> " AS " <> pretty a+      case maybeAlias of+        Nothing -> mempty+        Just (ImageAlias a) -> " AS " <> pretty a     prettyDigest maybeDigest =-        case maybeDigest of-            Nothing -> mempty-            Just (Digest d) -> "@" <> pretty d+      case maybeDigest of+        Nothing -> mempty+        Just (Digest d) -> "@" <> pretty d  prettyPrintPairs :: Pairs -> Doc ann prettyPrintPairs ps = align $ sepLine $ fmap prettyPrintPair ps@@ -99,22 +100,22 @@  escapeQuotes :: Text -> L.Text escapeQuotes text =-    case Text.foldr accumulate (EscapeAccum mempty 0 False) text of-        EscapeAccum buffer _ False -> B.toLazyText buffer-        EscapeAccum buffer count True ->-            case count `mod` 2 of-                0 -> B.toLazyText (B.singleton '\\' <> buffer)-                _ -> B.toLazyText buffer+  case Text.foldr accumulate (EscapeAccum mempty 0 False) text of+    EscapeAccum buffer _ False -> B.toLazyText buffer+    EscapeAccum buffer count True ->+      case count `mod` 2 of+        0 -> B.toLazyText (B.singleton '\\' <> buffer)+        _ -> B.toLazyText buffer   where     accumulate '"' EscapeAccum {buffer, escaping = False} =-        EscapeAccum (B.singleton '"' <> buffer) 0 True+      EscapeAccum (B.singleton '"' <> buffer) 0 True     accumulate '\\' EscapeAccum {buffer, escaping = True, count} =-        EscapeAccum (B.singleton '\\' <> buffer) (count + 1) True+      EscapeAccum (B.singleton '\\' <> buffer) (count + 1) True     accumulate c EscapeAccum {buffer, escaping = True, count}-        | count `mod` 2 == 0 = EscapeAccum (B.singleton c <> B.singleton '\\' <> buffer) 0 False-        | otherwise = EscapeAccum (B.singleton c <> buffer) 0 False -- It was already escaped+      | count `mod` 2 == 0 = EscapeAccum (B.singleton c <> B.singleton '\\' <> buffer) 0 False+      | otherwise = EscapeAccum (B.singleton c <> buffer) 0 False -- It was already escaped     accumulate c EscapeAccum {buffer, escaping = False} =-        EscapeAccum (B.singleton c <> buffer) 0 False+      EscapeAccum (B.singleton c <> buffer) 0 False  prettyPrintPort :: Port -> Doc ann prettyPrintPort (PortStr str) = pretty str@@ -125,24 +126,24 @@  prettyPrintFileList :: NonEmpty SourcePath -> TargetPath -> Doc ann prettyPrintFileList sources (TargetPath dest) =-    let ending =-            case (Text.isSuffixOf "/" dest, sources) of-                (True, _) -> "" -- If the target ends with / then no extra ending is needed-                (_, _fst :| _snd:_) -> "/" -- More than one source means that the target should end in /-                _ -> ""-    in hsep $ [pretty s | SourcePath s <- toList sources] ++ [pretty dest <> ending]+  let ending =+        case (Text.isSuffixOf "/" dest, sources) of+          (True, _) -> "" -- If the target ends with / then no extra ending is needed+          (_, _fst :| _snd : _) -> "/" -- More than one source means that the target should end in /+          _ -> ""+   in hsep $ [pretty s | SourcePath s <- toList sources] ++ [pretty dest <> ending]  prettyPrintChown :: Chown -> Doc ann prettyPrintChown chown =-    case chown of-        Chown c -> "--chown=" <> pretty c-        NoChown -> mempty+  case chown of+    Chown c -> "--chown=" <> pretty c+    NoChown -> mempty  prettyPrintCopySource :: CopySource -> Doc ann prettyPrintCopySource source =-    case source of-        CopySource c -> "--from=" <> pretty c-        NoSource -> mempty+  case source of+    CopySource c -> "--from=" <> pretty c+    NoSource -> mempty  prettyPrintDuration :: Text -> Maybe Duration -> Doc ann prettyPrintDuration flagName = maybe mempty pp@@ -154,78 +155,153 @@   where     pp (Retries r) = "--retries=" <> pretty r +prettyPrintRunMount :: Maybe RunMount -> Doc ann+prettyPrintRunMount Nothing = mempty+prettyPrintRunMount (Just mount) = "--mount="+  <> case mount of+    BindMount BindOpts {..} ->+      "type=bind"+        <> printTarget bTarget+        <> maybe mempty printSource bSource+        <> maybe mempty printFromImage bFromImage+        <> maybe mempty printReadOnly bReadOnly+    CacheMount CacheOpts {..} ->+      "type=cache"+        <> printTarget cTarget+        <> printSharing cSharing+        <> maybe mempty printId cCacheId+        <> maybe mempty printFromImage cFromImage+        <> maybe mempty printSource cSource+        <> maybe mempty printMode cMode+        <> maybe mempty printUid cUid+        <> maybe mempty printGid cGid+        <> maybe mempty printReadOnly cReadOnly+    SshMount SecretOpts {..} ->+      "type=ssh"+        <> maybe mempty printTarget sTarget+        <> maybe mempty printId sCacheId+        <> maybe mempty printSource sSource+        <> maybe mempty printMode sMode+        <> maybe mempty printUid sUid+        <> maybe mempty printGid sGid+        <> maybe mempty printRequired sIsRequired+    SecretMount SecretOpts {..} ->+      "type=secret"+        <> maybe mempty printTarget sTarget+        <> maybe mempty printId sCacheId+        <> maybe mempty printSource sSource+        <> maybe mempty printMode sMode+        <> maybe mempty printUid sUid+        <> maybe mempty printGid sGid+        <> maybe mempty printRequired sIsRequired+    TmpfsMount TmpOpts {..} -> "type=tmpfs" <> printTarget tTarget+  where+    printQuotable str+      | Text.any (== '"') str = doubleQoute str+      | otherwise = pretty str+    printTarget (TargetPath t) = ",target=" <> printQuotable t+    printSource (SourcePath s) = ",source=" <> printQuotable s+    printFromImage f = ",from=" <> printQuotable f+    printSharing sharing = ",sharing="+      <> case sharing of+        Shared -> "shared"+        Private -> "private"+        Locked -> "locked"+    printId i = ",id=" <> printQuotable i+    printMode m = ",mode=" <> pretty m+    printUid uid = ",uid=" <> pretty uid+    printGid gid = ",gid=" <> pretty gid+    printReadOnly True = ",ro"+    printReadOnly False = ",rw"+    printRequired True = ",required"+    printRequired False = mempty++prettyPrintRunNetwork :: Maybe RunNetwork -> Doc ann+prettyPrintRunNetwork Nothing = mempty+prettyPrintRunNetwork (Just NetworkHost) = "--network=host"+prettyPrintRunNetwork (Just NetworkNone) = "--network=none"+prettyPrintRunNetwork (Just NetworkDefault) = "--network=default"++prettyPrintRunSecurity :: Maybe RunSecurity -> Doc ann+prettyPrintRunSecurity Nothing = mempty+prettyPrintRunSecurity (Just Sandbox) = "--security=sandbox"+prettyPrintRunSecurity (Just Insecure) = "--security=insecure"+ prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann prettyPrintInstruction i =-    case i of-        Maintainer m -> do-            "MAINTAINER"-            pretty m-        Arg a Nothing -> do-            "ARG"-            pretty a-        Arg k (Just v) -> do-            "ARG"-            pretty k <> "=" <> pretty v-        Entrypoint e -> do-            "ENTRYPOINT"-            pretty e-        Stopsignal s -> do-            "STOPSIGNAL"-            pretty s-        Workdir w -> do-            "WORKDIR"-            pretty w-        Expose (Ports ps) -> do-            "EXPOSE"-            hsep (fmap prettyPrintPort ps)-        Volume dir -> do-            "VOLUME"-            pretty dir-        Run c -> do-            "RUN"-            pretty c-        Copy CopyArgs {sourcePaths, targetPath, chownFlag, sourceFlag} -> do-            "COPY"-            prettyPrintChown chownFlag-            prettyPrintCopySource sourceFlag-            prettyPrintFileList sourcePaths targetPath-        Cmd c -> do-            "CMD"-            pretty c-        Label l -> do-            "LABEL"-            prettyPrintPairs l-        Env ps -> do-            "ENV"-            prettyPrintPairs ps-        User u -> do-            "USER"-            pretty u-        Comment s -> do-            pretty '#'-            pretty s-        OnBuild i' -> do-            "ONBUILD"-            prettyPrintInstruction i'-        From b -> do-            "FROM"-            prettyPrintBaseImage b-        Add AddArgs {sourcePaths, targetPath, chownFlag} -> do-            "ADD"-            prettyPrintChown chownFlag-            prettyPrintFileList sourcePaths targetPath-        Shell args -> do-            "SHELL"-            pretty args-        Healthcheck NoCheck -> "HEALTHCHECK NONE"-        Healthcheck (Check CheckArgs {..}) -> do-            "HEALTHCHECK"-            prettyPrintDuration "--interval=" interval-            prettyPrintDuration "--timeout=" timeout-            prettyPrintDuration "--start-period=" startPeriod-            prettyPrintRetries retries-            "CMD"-            pretty checkCommand+  case i of+    Maintainer m -> do+      "MAINTAINER"+      pretty m+    Arg a Nothing -> do+      "ARG"+      pretty a+    Arg k (Just v) -> do+      "ARG"+      pretty k <> "=" <> pretty v+    Entrypoint e -> do+      "ENTRYPOINT"+      pretty e+    Stopsignal s -> do+      "STOPSIGNAL"+      pretty s+    Workdir w -> do+      "WORKDIR"+      pretty w+    Expose (Ports ps) -> do+      "EXPOSE"+      hsep (fmap prettyPrintPort ps)+    Volume dir -> do+      "VOLUME"+      pretty dir+    Run (RunArgs c RunFlags {mount, network, security}) -> do+      "RUN"+      prettyPrintRunMount mount+      prettyPrintRunNetwork network+      prettyPrintRunSecurity security+      pretty c+    Copy CopyArgs {sourcePaths, targetPath, chownFlag, sourceFlag} -> do+      "COPY"+      prettyPrintChown chownFlag+      prettyPrintCopySource sourceFlag+      prettyPrintFileList sourcePaths targetPath+    Cmd c -> do+      "CMD"+      pretty c+    Label l -> do+      "LABEL"+      prettyPrintPairs l+    Env ps -> do+      "ENV"+      prettyPrintPairs ps+    User u -> do+      "USER"+      pretty u+    Comment s -> do+      pretty '#'+      pretty s+    OnBuild i' -> do+      "ONBUILD"+      prettyPrintInstruction i'+    From b -> do+      "FROM"+      prettyPrintBaseImage b+    Add AddArgs {sourcePaths, targetPath, chownFlag} -> do+      "ADD"+      prettyPrintChown chownFlag+      prettyPrintFileList sourcePaths targetPath+    Shell args -> do+      "SHELL"+      pretty args+    Healthcheck NoCheck -> "HEALTHCHECK NONE"+    Healthcheck (Check CheckArgs {..}) -> do+      "HEALTHCHECK"+      prettyPrintDuration "--interval=" interval+      prettyPrintDuration "--timeout=" timeout+      prettyPrintDuration "--start-period=" startPeriod+      prettyPrintRetries retries+      "CMD"+      pretty checkCommand   where     (>>) = spaceCat 

@@ -1,190 +1,326 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies,-  DuplicateRecordFields, FlexibleInstances, DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}  module Language.Docker.Syntax where +import Data.Default.Class (Default (..)) import Data.List (intercalate, isInfixOf) import Data.List.NonEmpty (NonEmpty) import Data.List.Split (endBy)-import Data.String (IsString(..))+import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock (DiffTime)-import GHC.Exts (IsList(..))+import GHC.Exts (IsList (..)) -data Image = Image-    { registryName :: !(Maybe Registry)-    , imageName :: !Text-    } deriving (Show, Eq, Ord)+data Image+  = Image+      { registryName :: !(Maybe Registry),+        imageName :: !Text+      }+  deriving (Show, Eq, Ord)  instance IsString Image where-    fromString img =-        if "/" `isInfixOf` img-            then let parts = endBy "/" img-                 in if "." `isInfixOf` head parts-                        then Image-                                 (Just (Registry (Text.pack (head parts))))-                                 (Text.pack . intercalate "/" $ tail parts)-                        else Image Nothing (Text.pack img)-            else Image Nothing (Text.pack img)+  fromString img =+    if "/" `isInfixOf` img+      then+        let parts = endBy "/" img+         in if "." `isInfixOf` head parts+              then+                Image+                  (Just (Registry (Text.pack (head parts))))+                  (Text.pack . intercalate "/" $ tail parts)+              else Image Nothing (Text.pack img)+      else Image Nothing (Text.pack img) -newtype Registry = Registry-    { unRegistry :: Text-    } deriving (Show, Eq, Ord, IsString)+newtype Registry+  = Registry+      { unRegistry :: Text+      }+  deriving (Show, Eq, Ord, IsString) -newtype Tag = Tag-    { unTag :: Text-    } deriving (Show, Eq, Ord, IsString)+newtype Tag+  = Tag+      { unTag :: Text+      }+  deriving (Show, Eq, Ord, IsString) -newtype Digest = Digest-    { unDigest :: Text-    } deriving (Show, Eq, Ord, IsString)+newtype Digest+  = Digest+      { unDigest :: Text+      }+  deriving (Show, Eq, Ord, IsString)  data Protocol-    = TCP-    | UDP-    deriving (Show, Eq, Ord)+  = TCP+  | UDP+  deriving (Show, Eq, Ord)  data Port-    = Port !Int-           !Protocol-    | PortStr !Text-    | PortRange !Int-                !Int-                !Protocol-    deriving (Show, Eq, Ord)+  = Port+      !Int+      !Protocol+  | PortStr !Text+  | PortRange+      !Int+      !Int+      !Protocol+  deriving (Show, Eq, Ord) -newtype Ports = Ports-    { unPorts :: [Port]-    } deriving (Show, Eq, Ord)+newtype Ports+  = Ports+      { unPorts :: [Port]+      }+  deriving (Show, Eq, Ord)  instance IsList Ports where-    type Item Ports = Port-    fromList = Ports-    toList (Ports ps) = ps+  type Item Ports = Port+  fromList = Ports+  toList (Ports ps) = ps  type Directory = Text  type Platform = Text -newtype ImageAlias = ImageAlias-    { unImageAlias :: Text-    } deriving (Show, Eq, Ord, IsString)+newtype ImageAlias+  = ImageAlias+      { unImageAlias :: Text+      }+  deriving (Show, Eq, Ord, IsString) -data BaseImage = BaseImage-    { image :: !Image-    , tag :: !(Maybe Tag)-    , digest :: !(Maybe Digest)-    , alias :: !(Maybe ImageAlias)-    , platform :: !(Maybe Platform)-    } deriving (Eq, Ord, Show)+data BaseImage+  = BaseImage+      { image :: !Image,+        tag :: !(Maybe Tag),+        digest :: !(Maybe Digest),+        alias :: !(Maybe ImageAlias),+        platform :: !(Maybe Platform)+      }+  deriving (Eq, Ord, Show)  -- | Type of the Dockerfile AST type Dockerfile = [InstructionPos Text] -newtype SourcePath = SourcePath-    { unSourcePath :: Text-    } deriving (Show, Eq, Ord, IsString)+newtype SourcePath+  = SourcePath+      { unSourcePath :: Text+      }+  deriving (Show, Eq, Ord, IsString) -newtype TargetPath = TargetPath-    { unTargetPath :: Text-    } deriving (Show, Eq, Ord, IsString)+newtype TargetPath+  = TargetPath+      { unTargetPath :: Text+      }+  deriving (Show, Eq, Ord, IsString)  data Chown-    = Chown !Text-    | NoChown-    deriving (Show, Eq, Ord)+  = Chown !Text+  | NoChown+  deriving (Show, Eq, Ord)  instance IsString Chown where-    fromString ch =-        case ch of-            "" -> NoChown-            _ -> Chown (Text.pack ch)+  fromString ch =+    case ch of+      "" -> NoChown+      _ -> Chown (Text.pack ch)  data CopySource-    = CopySource !Text-    | NoSource-    deriving (Show, Eq, Ord)+  = CopySource !Text+  | NoSource+  deriving (Show, Eq, Ord)  instance IsString CopySource where-    fromString src =-        case src of-            "" -> NoSource-            _ -> CopySource (Text.pack src)+  fromString src =+    case src of+      "" -> NoSource+      _ -> CopySource (Text.pack src) -newtype Duration = Duration-    { durationTime :: DiffTime-    } deriving (Show, Eq, Ord, Num)+newtype Duration+  = Duration+      { durationTime :: DiffTime+      }+  deriving (Show, Eq, Ord, Num) -newtype Retries = Retries-    { times :: Int-    } 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 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 AddArgs+  = AddArgs+      { sourcePaths :: NonEmpty SourcePath,+        targetPath :: !TargetPath,+        chownFlag :: !Chown+      }+  deriving (Show, Eq, Ord)  data Check args-    = Check !(CheckArgs args)-    | NoCheck-    deriving (Show, Eq, Ord, Functor)+  = Check !(CheckArgs args)+  | NoCheck+  deriving (Show, Eq, Ord, Functor)  data Arguments args-    = ArgumentsText args-    | ArgumentsList args-    deriving (Show, Eq, Ord, Functor)+  = ArgumentsText args+  | ArgumentsList args+  deriving (Show, Eq, Ord, Functor)  instance IsString (Arguments Text) where-    fromString = ArgumentsText . Text.pack+  fromString = ArgumentsText . Text.pack  instance IsList (Arguments Text) where-    type Item (Arguments Text) = Text-    fromList = ArgumentsList . Text.unwords-    toList (ArgumentsText ps) = Text.words ps-    toList (ArgumentsList ps) = Text.words ps+  type Item (Arguments Text) = Text+  fromList = ArgumentsList . Text.unwords+  toList (ArgumentsText ps) = Text.words ps+  toList (ArgumentsList ps) = Text.words ps -data CheckArgs args = CheckArgs-    { checkCommand :: !(Arguments args)-    , interval :: !(Maybe Duration)-    , timeout :: !(Maybe Duration)-    , startPeriod :: !(Maybe Duration)-    , retries :: !(Maybe Retries)-    } deriving (Show, Eq, Ord, Functor)+data CheckArgs args+  = CheckArgs+      { checkCommand :: !(Arguments args),+        interval :: !(Maybe Duration),+        timeout :: !(Maybe Duration),+        startPeriod :: !(Maybe Duration),+        retries :: !(Maybe Retries)+      }+  deriving (Show, Eq, Ord, Functor)  type Pairs = [(Text, Text)] +data RunMount+  = BindMount !BindOpts+  | CacheMount !CacheOpts+  | TmpfsMount !TmpOpts+  | SecretMount !SecretOpts+  | SshMount !SecretOpts+  deriving (Eq, Show, Ord)++data BindOpts+  = BindOpts+      { bTarget :: !TargetPath,+        bSource :: !(Maybe SourcePath),+        bFromImage :: !(Maybe Text),+        bReadOnly :: !(Maybe Bool)+      }+  deriving (Show, Eq, Ord)++instance Default BindOpts where+  def = BindOpts "" Nothing Nothing Nothing++data CacheOpts+  = CacheOpts+      { cTarget :: !TargetPath,+        cSharing :: !CacheSharing,+        cCacheId :: !(Maybe Text),+        cReadOnly :: !(Maybe Bool),+        cFromImage :: !(Maybe Text),+        cSource :: !(Maybe SourcePath),+        cMode :: !(Maybe Text),+        cUid :: !(Maybe Integer),+        cGid :: !(Maybe Integer)+      }+  deriving (Show, Eq, Ord)++instance Default CacheOpts where+  def = CacheOpts "" Shared Nothing Nothing Nothing Nothing Nothing Nothing Nothing++newtype TmpOpts = TmpOpts {tTarget :: TargetPath} deriving (Eq, Show, Ord)++instance Default TmpOpts where+  def = TmpOpts ""++data SecretOpts+  = SecretOpts+      { sTarget :: !(Maybe TargetPath),+        sCacheId :: !(Maybe Text),+        sIsRequired :: !(Maybe Bool),+        sSource :: !(Maybe SourcePath),+        sMode :: !(Maybe Text),+        sUid :: !(Maybe Integer),+        sGid :: !(Maybe Integer)+      }+  deriving (Eq, Show, Ord)++instance Default SecretOpts where+  def = SecretOpts Nothing Nothing Nothing Nothing Nothing Nothing Nothing++data CacheSharing+  = Shared+  | Private+  | Locked+  deriving (Show, Eq, Ord)++data RunSecurity+  = Insecure+  | Sandbox+  deriving (Show, Eq, Ord)++data RunNetwork+  = NetworkNone+  | NetworkHost+  | NetworkDefault+  deriving (Show, Eq, Ord)++data RunFlags+  = RunFlags+      { mount :: !(Maybe RunMount),+        security :: !(Maybe RunSecurity),+        network :: !(Maybe RunNetwork)+      }+  deriving (Show, Eq, Ord)++instance Default RunFlags where+  def = RunFlags Nothing Nothing Nothing++data RunArgs args = RunArgs (Arguments args) RunFlags+  deriving (Show, Eq, Ord, Functor)++instance IsString (RunArgs Text) where+  fromString s =+    RunArgs+      (ArgumentsText . Text.pack $ s)+      RunFlags+        { security = Nothing,+          network = Nothing,+          mount = Nothing+        }+ -- | All commands available in Dockerfiles data Instruction args-    = From !BaseImage-    | Add !AddArgs-    | User !Text-    | Label !Pairs-    | Stopsignal !Text-    | Copy !CopyArgs-    | Run !(Arguments args)-    | Cmd !(Arguments args)-    | Shell !(Arguments args)-    | Workdir !Directory-    | Expose !Ports-    | Volume !Text-    | Entrypoint !(Arguments args)-    | Maintainer !Text-    | Env !Pairs-    | Arg !Text-          !(Maybe Text)-    | Healthcheck !(Check args)-    | Comment !Text-    | OnBuild !(Instruction args)-    deriving (Eq, Ord, Show, Functor)+  = From !BaseImage+  | Add !AddArgs+  | User !Text+  | Label !Pairs+  | Stopsignal !Text+  | Copy !CopyArgs+  | Run !(RunArgs args)+  | Cmd !(Arguments args)+  | Shell !(Arguments args)+  | Workdir !Directory+  | Expose !Ports+  | Volume !Text+  | Entrypoint !(Arguments args)+  | Maintainer !Text+  | Env !Pairs+  | Arg+      !Text+      !(Maybe Text)+  | Healthcheck !(Check args)+  | Comment !Text+  | OnBuild !(Instruction args)+  deriving (Eq, Ord, Show, Functor)  type Filename = Text @@ -192,8 +328,10 @@  -- | 'Instruction' with additional location information required for creating -- good check messages-data InstructionPos args = InstructionPos-    { instruction :: !(Instruction args)-    , sourcename :: !Filename-    , lineNumber :: !Linenumber-    } deriving (Eq, Ord, Show, Functor)+data InstructionPos args+  = InstructionPos+      { instruction :: !(Instruction args),+        sourcename :: !Filename,+        lineNumber :: !Linenumber+      }+  deriving (Eq, Ord, Show, Functor)

@@ -1,60 +0,0 @@-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TemplateHaskell #-}--module Language.Docker.Syntax.Lift where--import Data.Fixed (Fixed)-import Data.Time.Clock (DiffTime)-import Instances.TH.Lift () -- Defines Lift instances for ByteString and Text-import Language.Haskell.TH.Lift-import Language.Haskell.TH.Syntax ()--import Language.Docker.Syntax--deriveLift ''Fixed--deriveLift ''DiffTime--deriveLift ''Protocol--deriveLift ''Port--deriveLift ''Ports--deriveLift ''Registry--deriveLift ''Image--deriveLift ''ImageAlias--deriveLift ''Tag--deriveLift ''Digest--deriveLift ''BaseImage--deriveLift ''Arguments--deriveLift ''Instruction--deriveLift ''InstructionPos--deriveLift ''SourcePath--deriveLift ''TargetPath--deriveLift ''Chown--deriveLift ''CopySource--deriveLift ''CopyArgs--deriveLift ''AddArgs--deriveLift ''Duration--deriveLift ''Retries--deriveLift ''CheckArgs--deriveLift ''Check

@@ -1,46 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE QuasiQuotes #-}-module Language.Docker.EDSL.QuasiSpec-  where--import           Language.Docker.EDSL-import           Language.Docker.EDSL.Quasi-import           Language.Docker.Syntax-import           Test.Hspec--spec :: Spec-spec = do-    describe "dockerfile" $-        it "parses a dockerfile and returns its ast" $ do-            let df = map instruction [dockerfile|-                                                FROM node-                                                RUN apt-get update-                                                CMD ["node", "something.js"]-                                                |]-            df `shouldBe` [ From (BaseImage "node" Nothing Nothing Nothing Nothing)-                          , Run "apt-get update"-                          , Cmd ["node", "something.js"]-                          ]--    describe "edockerfile" $-        it "lets us use parsed dockerfiles seamlessly in our DSL" $ do-            let d = do-                    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 (BaseImage-                                            { image = "node"-                                            , alias = Just "node-build"-                                            , tag = Nothing-                                            , digest = Nothing-                                            , platform = Nothing}-                                 )-                          , Expose (Ports [Port 8080 TCP, PortStr "$PORT"])-                          , Run "apt-get update"-                          , Cmd "node something.js"-                          ]

@@ -1,136 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-}-module Language.Docker.EDSLSpec where--import           Control.Monad.IO.Class-import           Data.List                       (sort)-import           Language.Docker.EDSL-import           Language.Docker.PrettyPrint-import qualified Language.Docker.Syntax      as Syntax-import           System.Directory-import           System.FilePath-import           System.FilePath.Glob-import           Test.Hspec-import qualified Data.Text.Lazy as L-import qualified Data.Text as Text-import           Data.Semigroup ((<>))--printed :: [L.Text] -> L.Text-printed = L.unlines--spec :: Spec-spec = do-    describe "toDockerfile s" $-        it "allows us to write haskell code that represents Dockerfiles" $ do-            let r = map Syntax.instruction $ toDockerfile (do-                        from "node"-                        cmdArgs ["node", "-e", "'console.log(\'hey\')'"])-            r `shouldBe` [ Syntax.From $-                             Syntax.BaseImage "node"-                             Nothing-                             Nothing-                             Nothing-                             Nothing-                         , Syntax.Cmd ["node", "-e", "'console.log(\'hey\')'"]-                         ]--    describe "prettyPrint $ toDockerfile s" $ do-        it "allows us to write haskell code that represents Dockerfiles" $ do-            let r = prettyPrint $ toDockerfile (do-                        from "node"-                        shell ["cmd", "/S"]-                        entrypoint ["/tini", "--"]-                        cmdArgs ["node", "-e", "'console.log(\'hey\')'"]-                        healthcheck $ check "curl -f http://localhost/ || exit 1" `interval` 300)-            r `shouldBe` printed [ "FROM node"-                                 , "SHELL [\"cmd\", \"/S\"]"-                                 , "ENTRYPOINT [\"/tini\", \"--\"]"-                                 , "CMD [\"node\", \"-e\", \"'console.log(\'hey\')'\"]"-                                 , "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]-                        expose $ ports [udpPortRange 190 200])-            r `shouldBe` printed [ "FROM scratch"-                                 , "EXPOSE $PORT 80/tcp 51/udp"-                                 , "EXPOSE 90-100"-                                 , "EXPOSE 190-200/udp"-                                 ]--        it "onBuild let's us nest statements" $ do-            let r = prettyPrint $ toDockerfile $ do-                        from "node"-                        cmdArgs ["node", "-e", "'console.log(\'hey\')'"]-                        onBuild $ do-                            run "echo \"hello world\""-                            run "echo \"hello world2\""-            r `shouldBe` printed [ "FROM node"-                                 , "CMD [\"node\", \"-e\", \"'console.log(\'hey\')'\"]"-                                 , "ONBUILD RUN echo \"hello world\""-                                 , "ONBUILD RUN echo \"hello world2\""-                                 ]--        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` printed [ "FROM node:10.1 AS node-build"-                                 , "RUN echo foo"-                                 ]--        it "parses and prints from with a registry" $ do-            let r = prettyPrint $ toDockerfile $ do-                        from "opensuse/tumbleweed"-                        run "echo foo"-            r `shouldBe` printed [ "FROM opensuse/tumbleweed"-                                 , "RUN echo foo"-                                 ]--        it "parses and prints copy instructions" $ do-            let r = prettyPrint $ toDockerfile $ do-                        from "scratch"-                        copy $ ["foo.js"] `to` "bar.js"-                        copy $ ["foo.js", "bar.js"] `to` "."-                        copy $ ["foo.js", "bar.js"] `to` "baz/"-                        copy $ ["something"] `to` "crazy" `fromStage` "builder"-                        copy $ ["this"] `to` "that" `fromStage` "builder" `ownedBy` "www-data"-            r `shouldBe` printed [ "FROM scratch"-                                 , "COPY foo.js bar.js"-                                 , "COPY foo.js bar.js ./"-                                 , "COPY foo.js bar.js baz/"-                                 , "COPY --from=builder something crazy"-                                 , "COPY --chown=www-data --from=builder this that"-                                 ]-        it "quotes label and env correctly" $ do-            let r = prettyPrint $ toDockerfile $ do-                        from "scratch"-                        label [("email", "Example <example@example.com>")]-                        label [("escape", "Escape this\" thing")]-                        env [("foo", "bar baz")]-                        env [("double_escape", "escape this \\\"")]-            r `shouldBe` printed [ "FROM scratch"-                                 , "LABEL email=\"Example <example@example.com>\""-                                 , "LABEL escape=\"Escape this\\\" thing\""-                                 , "ENV foo=\"bar baz\""-                                 , "ENV double_escape=\"escape this \\\"\""-                                 ]--    describe "toDockerfileTextIO" $-        it "let's us run in the IO monad" $ do-            -- TODO - "glob" is a really useful combinator-            str <- toDockerfileTextIO $ do-                fs <- liftIO $ do-                    cwd <- getCurrentDirectory-                    fs <- glob "./test/Language/Docker/*.hs"-                    return (map (makeRelative cwd) (sort fs))-                from "ubuntu"-                let file = Text.pack . takeFileName-                mapM_ (\f -> add [Syntax.SourcePath (Text.pack f)] (Syntax.TargetPath $ "/app/" <> file f)) fs-            str `shouldBe` printed [ "FROM ubuntu"-                                   , "ADD ./test/Language/Docker/EDSLSpec.hs /app/EDSLSpec.hs"-                                   , "ADD ./test/Language/Docker/ExamplesSpec.hs /app/ExamplesSpec.hs"-                                   , "ADD ./test/Language/Docker/ParserSpec.hs /app/ParserSpec.hs"-                                   ]

@@ -1,20 +0,0 @@-module Language.Docker.ExamplesSpec where--import           Control.Monad-import           Data.Monoid-import           System.Directory-import           System.FilePath-import           System.FilePath.Glob-import           System.Process-import           Test.Hspec--stackRunGhc e = callProcess "stack" ["runghc", "--package", "language-docker", e]--spec :: Spec-spec = do-    cwd <- runIO getCurrentDirectory-    exampleSources <- runIO $ glob "./examples/*.hs"-    forM_ exampleSources $ \exampleSource -> do-        let exampleSource' = makeRelative cwd exampleSource-        describe exampleSource $ it ("stack runghc " <> exampleSource') $-            stackRunGhc exampleSource

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+module Language.Docker.IntegrationSpec where++import Language.Docker.Parser+import Language.Docker.Syntax+import Language.Docker.PrettyPrint (prettyPrint)+import qualified Data.Text.Lazy.IO as L+++import Test.HUnit hiding (Label)+import Test.Hspec+import Text.Megaparsec hiding (Label)+import qualified Data.Text as Text++spec :: Spec+spec = do+        describe "1" $ do+            it "no erors" $ do+               parsed <- parseFile "test/fixtures/1.Dockerfile"+               case parsed of+                    Right a -> L.putStr $ prettyPrint a+                    Left err -> assertFailure $ errorBundlePretty err+        describe "2" $ do+            it "no erors" $ do+               parsed <- parseFile "test/fixtures/2.Dockerfile"+               case parsed of+                    Right a -> L.putStr $ prettyPrint a+                    Left err -> assertFailure $ errorBundlePretty err

@@ -1,432 +1,635 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-}-module Language.Docker.ParserSpec where--import Language.Docker.Normalize-import Language.Docker.Parser-import Language.Docker.Syntax---import Test.HUnit hiding (Label)-import Test.Hspec-import Text.Megaparsec hiding (Label)-import qualified Data.Text as Text--untaggedImage :: Image -> BaseImage-untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing--taggedImage :: Image -> Tag -> BaseImage-taggedImage n t = BaseImage n (Just t) Nothing Nothing Nothing--withDigest :: BaseImage -> Digest -> BaseImage-withDigest i d = i { digest = Just d }--withAlias :: BaseImage -> ImageAlias -> BaseImage-withAlias i a = i { alias = Just a }--withPlatform :: BaseImage -> Platform -> BaseImage-withPlatform i p = i { platform = Just p }---spec :: Spec-spec = do-        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")]-            it "parse tagged image" $-                assertAst-                    "FROM busybox:5.12-dev"-                    [From (taggedImage "busybox" "5.12-dev")]-            it "parse digested image" $-                assertAst-                    "FROM ubuntu@sha256:0ef2e08ed3fab"-                    [From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab")]-            it "parse digested image with tag" $-                assertAst-                    "FROM ubuntu:14.04@sha256:0ef2e08ed3fab"-                    [From (taggedImage "ubuntu" "14.04" `withDigest` "sha256:0ef2e08ed3fab")]--        describe "parse aliased FROM" $ do-            it "parse untagged image" $-                assertAst "FROM busybox as foo" [From (untaggedImage "busybox" `withAlias` "foo")]-            it "parse tagged image" $-                assertAst "FROM busybox:5.12-dev AS foo-bar"-                          [ From (taggedImage "busybox" "5.12-dev" `withAlias` "foo-bar")-                          ]-            it "parse diggested image" $-                assertAst "FROM ubuntu@sha256:0ef2e08ed3fab AS foo"-                          [ From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab" `withAlias` "foo")-                          ]--        describe "parse FROM with platform" $ do-            it "parse untagged image with platform" $-                assertAst "FROM --platform=linux busybox" [From (untaggedImage "busybox" `withPlatform` "linux")]--            it "parse tagged image with platform" $-                assertAst "FROM --platform=linux busybox:foo" [From (taggedImage "busybox" "foo" `withPlatform` "linux")]--        describe "parse FROM with registry" $ do-            it "registry without port" $-                assertAst "FROM foo.com/node" [From (untaggedImage (Image (Just "foo.com") "node"))]-            it "parse with port and tag" $-                assertAst-                "FROM myregistry.com:5000/imagename:5.12-dev"-                [From (taggedImage (Image (Just "myregistry.com:5000") "imagename") "5.12-dev")]-            it "Not a registry if no TLD" $-                assertAst-                "FROM myfolder/imagename:5.12-dev"-                [From (taggedImage (Image Nothing "myfolder/imagename") "5.12-dev")]--        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 = Text.unlines [ "LABEL foo=bar \\", "hobo=mobo"]-                    ast = [ Label [("foo", "bar"), ("hobo", "mobo")] ]-                in assertAst dockerfile ast--        describe "parse ENV" $ do-            it "parses unquoted pair" $ assertAst "ENV foo=bar" [Env [("foo", "bar")]]-            it "parse with space between key and value" $-                assertAst "ENV foo bar" [Env [("foo", "bar")]]-            it "parse with more then one (white)space between key and value" $-                let dockerfile = "ENV          NODE_VERSION  \t   v5.7.1"-                in assertAst dockerfile [Env[("NODE_VERSION",    "v5.7.1")]]-            it "parse quoted value pair" $ assertAst "ENV foo=\"bar\"" [Env [("foo", "bar")]]-            it "parse multiple unquoted pairs" $-                assertAst "ENV foo=bar baz=foo" [Env [("foo", "bar"), ("baz", "foo")]]-            it "parse multiple quoted pairs" $-                assertAst "ENV foo=\"bar\" baz=\"foo\"" [Env [("foo", "bar"), ("baz", "foo")]]-            it "env works before cmd" $-                let dockerfile = "ENV PATH=\"/root\"\nCMD [\"hadolint\",\"-i\"]"-                    ast = [Env [("PATH", "/root")], Cmd ["hadolint", "-i"]]-                in assertAst dockerfile ast-            it "parse with two spaces between" $-                let dockerfile = "ENV NODE_VERSION=v5.7.1  DEBIAN_FRONTEND=noninteractive"-                in assertAst dockerfile [Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")]]-            it "have envs on multiple lines" $-                let dockerfile = Text.unlines [ "FROM busybox"-                                              , "ENV NODE_VERSION=v5.7.1 \\"-                                              , "DEBIAN_FRONTEND=noninteractive"-                                              ]-                    ast = [ From (untaggedImage "busybox")-                          , Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")]-                          ]-                in assertAst dockerfile ast-            it "parses long env over multiple lines" $-                let dockerfile = Text.unlines [ "ENV LD_LIBRARY_PATH=\"/usr/lib/\" \\"-                                         , "APACHE_RUN_USER=\"www-data\" APACHE_RUN_GROUP=\"www-data\""]-                    ast = [Env [("LD_LIBRARY_PATH", "/usr/lib/")-                               ,("APACHE_RUN_USER", "www-data")-                               ,("APACHE_RUN_GROUP", "www-data")-                               ]-                          ]-                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 = Text.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 = Text.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 = Text.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" $ do-            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 "does not choke on unmatched brackets" $-                let dockerfile = Text.unlines ["RUN [foo"]-                in assertAst dockerfile [Run "[foo"]--            it "Distinguishes between text and a list" $-                let dockerfile = Text.unlines [ "RUN echo foo"-                                              , "RUN [\"echo\", \"foo\"]"-                                              ]-                in assertAst dockerfile [Run $ ArgumentsText "echo foo", Run $ ArgumentsList "echo foo"]--            it "Accepts spaces inside the brackets" $-                let dockerfile = Text.unlines [ "RUN [  \"echo\", \"foo\"  ]"-                                              ]-                in assertAst dockerfile [Run $ ArgumentsList "echo 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"]--            it "quoted command params" $ assertAst "CMD [\"echo\",  \"1\"]" [Cmd ["echo", "1"]]--            it "Parses commas correctly" $ assertAst "CMD [ \"echo\" ,\"-e\" , \"1\"]" [Cmd ["echo", "-e", "1"]]--        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-                    "FROM scratch\nMAINTAINER hudu@mail.com"-                    [From (untaggedImage "scratch"), 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"]-                in assertAst maintainerFromProg maintainerFromAst-        describe "parse # comment " $ do-            it "multiple comments before run" $-                let dockerfile = Text.unlines ["# line 1", "# line 2", "RUN apt-get update"]-                in assertAst dockerfile [Comment " line 1", Comment " line 2", Run "apt-get update"]-            it "multiple comments after run" $-                let dockerfile = Text.unlines ["RUN apt-get update", "# line 1", "# line 2"]-                in assertAst-                       dockerfile-                       [Run "apt-get update", Comment " line 1", Comment " line 2"]--            it "empty comment" $-                let dockerfile = Text.unlines ["#", "# Hello"]-                in assertAst dockerfile [Comment "", Comment " Hello"]-        describe "normalize lines" $ do-            it "join multiple ENV" $-                let dockerfile = Text.unlines [ "FROM busybox"-                                              , "ENV NODE_VERSION=v5.7.1 \\"-                                              , "DEBIAN_FRONTEND=noninteractive"-                                              ]-                    normalizedDockerfile = Text.unlines [ "FROM busybox"-                                                   , "ENV NODE_VERSION=v5.7.1 DEBIAN_FRONTEND=noninteractive\n"-                                                   ]-                in normalizeEscapedLines dockerfile `shouldBe` normalizedDockerfile--            it "join escaped lines" $-                let dockerfile = Text.unlines ["ENV foo=bar \\", "baz=foz"]-                    normalizedDockerfile = Text.unlines ["ENV foo=bar baz=foz", ""]-                in normalizeEscapedLines dockerfile `shouldBe` normalizedDockerfile--            it "join long CMD" $-                let longEscapedCmd =-                        Text.unlines-                            [ "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 && \\"-                            , "/opt/logstash/bin/plugin install contrib)"-                            ]-                    longEscapedCmdExpected =-                        Text.concat-                            [ "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 && "-                            , "/opt/logstash/bin/plugin install contrib)\n"-                            , "\n"-                            , "\n"-                            , "\n"-                            , "\n"-                            ]-                in normalizeEscapedLines longEscapedCmd `shouldBe` longEscapedCmdExpected--            it "tolerates spaces after a newline escape" $-                let dockerfile = Text.unlines [ "FROM busy\\     "-                                              , "box"-                                              , "RUN echo\\    "-                                              , " hello"-                                              ]-                in assertAst dockerfile [ From (untaggedImage "busybox")-                                        , Run "echo hello"-                                        ]--            it "Correctly joins blank lines starting with comments" $-                let dockerfile = Text.unlines [ "FROM busybox"-                                              , "# I forgot to remove the backslash \\"-                                              , "# This is a comment"-                                              , "RUN echo hello"-                                              ]-                in assertAst dockerfile [ From (untaggedImage "busybox")-                                        , Comment " I forgot to remove the backslash \\"-                                        , Comment " This is a comment"-                                        , Run "echo hello"-                                        ]-        describe "expose" $ do-            it "should handle number ports" $-                let content = "EXPOSE 8080"-                in assertAst content [Expose (Ports [Port 8080 TCP])]-            it "should handle many number ports" $-                let content = "EXPOSE 8080 8081"-                in  assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 TCP])]-            it "should handle ports with protocol" $-                let content = "EXPOSE 8080/TCP 8081/UDP"-                in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 UDP])]-            it "should handle ports with protocol and variables" $-                let content = "EXPOSE $PORT 8080 8081/UDP"-                in assertAst content [Expose (Ports [PortStr "$PORT", Port 8080 TCP, Port 8081 UDP])]-            it "should handle port ranges" $-                let content = "EXPOSE 80 81 8080-8085"-                in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 TCP])]-            it "should handle udp port ranges" $-                let content = "EXPOSE 80 81 8080-8085/udp"-                in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 UDP])]-            it "should handle multiline variables" $-                let content = "EXPOSE  ${PORT} ${PORT_SSL} \\\n\-                              \        ${PORT_HTTP} ${PORT_HTTPS} \\\n\-                              \        ${PORT_REP} \\\n\-                              \        ${PORT_ADMIN} ${PORT_ADMIN_HTTP}"-                in assertAst content [ Expose (Ports [ PortStr "${PORT}"-                                                     , PortStr "${PORT_SSL}"-                                                     , PortStr "${PORT_HTTP}"-                                                     , PortStr "${PORT_HTTPS}"-                                                     , PortStr "${PORT_REP}"-                                                     , PortStr "${PORT_ADMIN}"-                                                     , PortStr "${PORT_ADMIN_HTTP}"])-                                     ]--        describe "syntax" $ do-            it "should handle lowercase instructions (#7 - https://github.com/beijaflor-io/haskell-language-dockerfile/issues/7)" $-                let content = "from ubuntu"-                in assertAst content [From (untaggedImage "ubuntu")]--        describe "ADD" $ do-            it "simple ADD" $-                let file = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion-assertAst s ast =-    case parseText s of-        Left err -> assertFailure $ errorBundlePretty err-        Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Docker.ParserSpec where++import Data.Default.Class (def)+import qualified Data.Text as Text+import Language.Docker.Parser+import Language.Docker.Syntax+import Test.HUnit hiding (Label)+import Test.Hspec+import Text.Megaparsec hiding (Label)++untaggedImage :: Image -> BaseImage+untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing++taggedImage :: Image -> Tag -> BaseImage+taggedImage n t = BaseImage n (Just t) Nothing Nothing Nothing++withDigest :: BaseImage -> Digest -> BaseImage+withDigest i d = i {digest = Just d}++withAlias :: BaseImage -> ImageAlias -> BaseImage+withAlias i a = i {alias = Just a}++withPlatform :: BaseImage -> Platform -> BaseImage+withPlatform i p = i {platform = Just p}++spec :: Spec+spec = do+  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")]+    it "parse tagged image" $+      assertAst+        "FROM busybox:5.12-dev"+        [From (taggedImage "busybox" "5.12-dev")]+    it "parse digested image" $+      assertAst+        "FROM ubuntu@sha256:0ef2e08ed3fab"+        [From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab")]+    it "parse digested image with tag" $+      assertAst+        "FROM ubuntu:14.04@sha256:0ef2e08ed3fab"+        [From (taggedImage "ubuntu" "14.04" `withDigest` "sha256:0ef2e08ed3fab")]+    it "parse image with spaces at the end" $+      assertAst+        "FROM dockerfile/mariadb "+        [From (untaggedImage "dockerfile/mariadb")]+  describe "parse aliased FROM" $ do+    it "parse untagged image" $+      assertAst "FROM busybox as foo" [From (untaggedImage "busybox" `withAlias` "foo")]+    it "parse tagged image" $+      assertAst+        "FROM busybox:5.12-dev AS foo-bar"+        [ From (taggedImage "busybox" "5.12-dev" `withAlias` "foo-bar")+        ]+    it "parse diggested image" $+      assertAst+        "FROM ubuntu@sha256:0ef2e08ed3fab AS foo"+        [ From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab" `withAlias` "foo")+        ]+  describe "parse FROM with platform" $ do+    it "parse untagged image with platform" $+      assertAst "FROM --platform=linux busybox" [From (untaggedImage "busybox" `withPlatform` "linux")]+    it "parse tagged image with platform" $+      assertAst "FROM --platform=linux busybox:foo" [From (taggedImage "busybox" "foo" `withPlatform` "linux")]+  describe "parse FROM with registry" $ do+    it "registry without port" $+      assertAst "FROM foo.com/node" [From (untaggedImage (Image (Just "foo.com") "node"))]+    it "parse with port and tag" $+      assertAst+        "FROM myregistry.com:5000/imagename:5.12-dev"+        [From (taggedImage (Image (Just "myregistry.com:5000") "imagename") "5.12-dev")]+    it "Not a registry if no TLD" $+      assertAst+        "FROM myfolder/imagename:5.12-dev"+        [From (taggedImage (Image Nothing "myfolder/imagename") "5.12-dev")]+  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 = Text.unlines ["LABEL foo=bar \\", "hobo=mobo"]+          ast = [Label [("foo", "bar"), ("hobo", "mobo")]]+       in assertAst dockerfile ast+  describe "parse ENV" $ do+    it "parses unquoted pair" $ assertAst "ENV foo=bar" [Env [("foo", "bar")]]+    it "parse with space between key and value" $+      assertAst "ENV foo bar" [Env [("foo", "bar")]]+    it "parse with more then one (white)space between key and value" $+      let dockerfile = "ENV          NODE_VERSION  \t   v5.7.1"+       in assertAst dockerfile [Env [("NODE_VERSION", "v5.7.1")]]+    it "parse quoted value pair" $ assertAst "ENV foo=\"bar\"" [Env [("foo", "bar")]]+    it "parse multiple unquoted pairs" $+      assertAst "ENV foo=bar baz=foo" [Env [("foo", "bar"), ("baz", "foo")]]+    it "parse multiple quoted pairs" $+      assertAst "ENV foo=\"bar\" baz=\"foo\"" [Env [("foo", "bar"), ("baz", "foo")]]+    it "env works before cmd" $+      let dockerfile = "ENV PATH=\"/root\"\nCMD [\"hadolint\",\"-i\"]"+          ast = [Env [("PATH", "/root")], Cmd ["hadolint", "-i"]]+       in assertAst dockerfile ast+    it "parse with two spaces between" $+      let dockerfile = "ENV NODE_VERSION=v5.7.1  DEBIAN_FRONTEND=noninteractive"+       in assertAst dockerfile [Env [("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")]]+    it "have envs on multiple lines" $+      let dockerfile =+            Text.unlines+              [ "FROM busybox",+                "ENV NODE_VERSION=v5.7.1 \\",+                "DEBIAN_FRONTEND=noninteractive"+              ]+          ast =+            [ From (untaggedImage "busybox"),+              Env [("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")]+            ]+       in assertAst dockerfile ast+    it "parses long env over multiple lines" $+      let dockerfile =+            Text.unlines+              [ "ENV LD_LIBRARY_PATH=\"/usr/lib/\" \\",+                "APACHE_RUN_USER=\"www-data\" APACHE_RUN_GROUP=\"www-data\""+              ]+          ast =+            [ Env+                [ ("LD_LIBRARY_PATH", "/usr/lib/"),+                  ("APACHE_RUN_USER", "www-data"),+                  ("APACHE_RUN_GROUP", "www-data")+                ]+            ]+       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 =+            Text.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 =+            Text.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 =+            Text.unlines+              [ "ENV JAVA_HOME=C:\\\\jdk1.8.0_112"+              ]+          ast =+            [ Env [("JAVA_HOME", "C:\\\\jdk1.8.0_112")]+            ]+       in assertAst dockerfile ast+    it "parses env with % in them" $+      let dockerfile =+            Text.unlines+              [ "ENV PHP_FPM_ACCESS_FORMAT=\"prefix \\\"quoted\\\" suffix\""+              ]+          ast =+            [ Env [("PHP_FPM_ACCESS_FORMAT", "prefix \"quoted\" suffix")]+            ]+       in assertAst dockerfile ast+    it "parses env with % in them" $+      let dockerfile =+            Text.unlines+              [ "ENV PHP_FPM_ACCESS_FORMAT=\"%R - %u %t \\\"%m %r\\\" %s\""+              ]+          ast =+            [ Env [("PHP_FPM_ACCESS_FORMAT", "%R - %u %t \"%m %r\" %s")]+            ]+       in assertAst dockerfile ast+  describe "parse RUN" $ do+    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 "does not choke on unmatched brackets" $+      let dockerfile = Text.unlines ["RUN [foo"]+       in assertAst dockerfile [Run "[foo"]+    it "Distinguishes between text and a list" $+      let dockerfile =+            Text.unlines+              [ "RUN echo foo",+                "RUN [\"echo\", \"foo\"]"+              ]+       in assertAst dockerfile [Run $ RunArgs (ArgumentsText "echo foo") def, Run $ RunArgs (ArgumentsList "echo foo") def]+    it "Accepts spaces inside the brackets" $+      let dockerfile =+            Text.unlines+              [ "RUN [  \"echo\", \"foo\"  ]"+              ]+       in assertAst dockerfile [Run $ RunArgs (ArgumentsList "echo foo") def]+  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"]+    it "quoted command params" $ assertAst "CMD [\"echo\",  \"1\"]" [Cmd ["echo", "1"]]+    it "Parses commas correctly" $ assertAst "CMD [ \"echo\" ,\"-e\" , \"1\"]" [Cmd ["echo", "-e", "1"]]+  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+        "FROM scratch\nMAINTAINER hudu@mail.com"+        [From (untaggedImage "scratch"), 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"]+       in assertAst maintainerFromProg maintainerFromAst+  describe "parse # comment " $ do+    it "multiple comments before run" $+      let dockerfile = Text.unlines ["# line 1", "# line 2", "RUN apt-get update"]+       in assertAst dockerfile [Comment " line 1", Comment " line 2", Run "apt-get update"]+    it "multiple comments after run" $+      let dockerfile = Text.unlines ["RUN apt-get update", "# line 1", "# line 2"]+       in assertAst+            dockerfile+            [Run "apt-get update", Comment " line 1", Comment " line 2"]+    it "empty comment" $+      let dockerfile = Text.unlines ["#", "# Hello"]+       in assertAst dockerfile [Comment "", Comment " Hello"]+    it "many escaped lines" $+      let dockerfile =+            Text.unlines+              [ "ENV A=\"a.sh\" \\",+                "    # comment a",+                "    B=\"b.sh\" \\",+                "    c=\"true\"",+                ""+              ]+       in assertAst+            dockerfile+            [ Env [("A", "a.sh"), ("B", "b.sh"), ("c", "true")]+            ]+    it "accepts backslash inside string" $+      let dockerfile = "RUN grep 'foo \\.'"+       in assertAst dockerfile [Run $ RunArgs (ArgumentsText "grep 'foo \\.'") def]+    it "tolerates spaces after a newline escape" $+      let dockerfile =+            Text.unlines+              [ "FROM busy\\     ",+                "box",+                "RUN echo\\    ",+                " hello"+              ]+       in assertAst+            dockerfile+            [ From (untaggedImage "busybox"),+              Run "echo hello"+            ]+    it "Correctly joins blank lines starting with comments" $+      let dockerfile =+            Text.unlines+              [ "FROM busybox",+                "# I forgot to remove the backslash \\",+                "# This is a comment",+                "RUN echo hello"+              ]+       in assertAst+            dockerfile+            [ From (untaggedImage "busybox"),+              Comment " I forgot to remove the backslash \\",+              Comment " This is a comment",+              Run "echo hello"+            ]+  describe "expose" $ do+    it "should handle number ports" $+      let content = "EXPOSE 8080"+       in assertAst content [Expose (Ports [Port 8080 TCP])]+    it "should handle many number ports" $+      let content = "EXPOSE 8080 8081"+       in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 TCP])]+    it "should handle ports with protocol" $+      let content = "EXPOSE 8080/TCP 8081/UDP"+       in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 UDP])]+    it "should handle ports with protocol and variables" $+      let content = "EXPOSE $PORT 8080 8081/UDP"+       in assertAst content [Expose (Ports [PortStr "$PORT", Port 8080 TCP, Port 8081 UDP])]+    it "should handle port ranges" $+      let content = "EXPOSE 80 81 8080-8085"+       in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 TCP])]+    it "should handle udp port ranges" $+      let content = "EXPOSE 80 81 8080-8085/udp"+       in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 UDP])]+    it "should handle multiline variables" $+      let content =+            "EXPOSE  ${PORT} ${PORT_SSL} \\\n\+            \        ${PORT_HTTP} ${PORT_HTTPS} \\\n\+            \        ${PORT_REP} \\\n\+            \        ${PORT_ADMIN} ${PORT_ADMIN_HTTP}"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortStr "${PORT}",+                      PortStr "${PORT_SSL}",+                      PortStr "${PORT_HTTP}",+                      PortStr "${PORT_HTTPS}",+                      PortStr "${PORT_REP}",+                      PortStr "${PORT_ADMIN}",+                      PortStr "${PORT_ADMIN_HTTP}"+                    ]+                )+            ]+  describe "syntax" $ do+    it "should handle lowercase instructions (#7 - https://github.com/beijaflor-io/haskell-language-dockerfile/issues/7)" $+      let content = "from ubuntu"+       in assertAst content [From (untaggedImage "ubuntu")]+  describe "ADD" $ do+    it "simple ADD" $+      let file = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.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 = Text.unlines ["COPY --chown=user:group --from=node foo bar"]+       in assertAst+            file+            [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node")+            ]+    it "supports windows paths" $+      let file = Text.unlines ["COPY C:\\\\go C:\\\\go"]+       in assertAst+            file+            [ Copy $ CopyArgs (fmap SourcePath ["C:\\\\go"]) (TargetPath "C:\\\\go") NoChown NoSource+            ]+  describe "RUN with experimental flags" $ do+    it "--mount=type=bind and target" $+      let file = Text.unlines ["RUN --mount=type=bind,target=/foo echo foo"]+          flags = def {mount = Just $ BindMount (def {bTarget = "/foo"})}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount default to bind" $+      let file = Text.unlines ["RUN --mount=target=/foo echo foo"]+          flags = def {mount = Just $ BindMount (def {bTarget = "/foo"})}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=bind all modifiers" $+      let file = Text.unlines ["RUN --mount=type=bind,target=/foo,source=/bar,from=ubuntu,ro echo foo"]+          flags = def {mount = Just $ BindMount (BindOpts {bTarget = "/foo", bSource = Just "/bar", bFromImage = Just "ubuntu", bReadOnly = Just True})}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=cache with target and sharing" $+      let file =+            Text.unlines+              [ "RUN --mount=type=cache,target=/foo,sharing=private echo foo",+                "RUN --mount=type=cache,target=/bar,sharing=shared echo foo",+                "RUN --mount=type=cache,target=/baz,sharing=locked echo foo"+              ]+          flags1 = def {mount = Just $ CacheMount (def {cTarget = "/foo", cSharing = Private})}+          flags2 = def {mount = Just $ CacheMount (def {cTarget = "/bar", cSharing = Shared})}+          flags3 = def {mount = Just $ CacheMount (def {cTarget = "/baz", cSharing = Locked})}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags1,+              Run $ RunArgs (ArgumentsText "echo foo") flags2,+              Run $ RunArgs (ArgumentsText "echo foo") flags3+            ]+    it "--mount=type=cache with all modifiers" $+      let file =+            Text.unlines+              [ "RUN --mount=type=cache,target=/foo,sharing=private,id=a,ro,from=ubuntu,source=/bar,mode=0700,uid=0,gid=0 echo foo"+              ]+          flags =+            def+              { mount =+                  Just $+                    CacheMount+                      ( def+                          { cTarget = "/foo",+                            cSharing = Private,+                            cCacheId = Just "a",+                            cReadOnly = Just True,+                            cFromImage = Just "ubuntu",+                            cSource = Just "/bar",+                            cMode = Just "0700",+                            cUid = Just 0,+                            cGid = Just 0+                          }+                      )+              }+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=tmpfs" $+      let file = Text.unlines ["RUN --mount=type=tmpfs,target=/foo echo foo"]+          flags = def {mount = Just $ TmpfsMount (def {tTarget = "/foo"})}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=ssh" $+      let file = Text.unlines ["RUN --mount=type=ssh echo foo"]+          flags = def {mount = Just $ SshMount def}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=ssh all modifiers" $+      let file = Text.unlines ["RUN --mount=type=ssh,target=/foo,id=a,required,source=/bar,mode=0700,uid=0,gid=0 echo foo"]+          flags =+            def+              { mount =+                  Just $+                    SshMount+                      ( def+                          { sTarget = Just "/foo",+                            sCacheId = Just "a",+                            sIsRequired = Just True,+                            sSource = Just "/bar",+                            sMode = Just "0700",+                            sUid = Just 0,+                            sGid = Just 0+                          }+                      )+              }+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=secret all modifiers" $+      let file = Text.unlines ["RUN --mount=type=secret,target=/foo,id=a,required,source=/bar,mode=0700,uid=0,gid=0 echo foo"]+          flags =+            def+              { mount =+                  Just $+                    SecretMount+                      ( def+                          { sTarget = Just "/foo",+                            sCacheId = Just "a",+                            sIsRequired = Just True,+                            sSource = Just "/bar",+                            sMode = Just "0700",+                            sUid = Just 0,+                            sGid = Just 0+                          }+                      )+              }+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--network=none" $+      let file = Text.unlines ["RUN --network=none echo foo"]+          flags = def {network = Just NetworkNone}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--network=host" $+      let file = Text.unlines ["RUN --network=host echo foo"]+          flags = def {network = Just NetworkHost}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--network=default" $+      let file = Text.unlines ["RUN --network=default echo foo"]+          flags = def {network = Just NetworkDefault}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--security=insecure" $+      let file = Text.unlines ["RUN --security=insecure echo foo"]+          flags = def {security = Just Insecure}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--security=sandbox" $+      let file = Text.unlines ["RUN --security=sandbox echo foo"]+          flags = def {security = Just Sandbox}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "allows all flags" $+      let file = Text.unlines ["RUN --mount=target=/foo --network=none --security=sandbox echo foo"]+          flags =+            def+              { security = Just Sandbox,+                network = Just NetworkNone,+                mount = Just $ BindMount $ def {bTarget = "/foo"}+              }+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]++assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion+assertAst s ast =+  case parseText s of+    Left err -> assertFailure $ errorBundlePretty err+    Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile