packages feed

language-docker 6.0.4 → 15.0.0

raw patch · 51 files changed

Files

README.md view
@@ -1,4 +1,4 @@-[![Build Status][travis-img]][travis]+[![Build Status][actions-img]][actions] [![Hackage][hackage-img]][hackage] [![GPL-3 licensed][license-img]][license] @@ -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,102 +31,13 @@     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-[travis-img]: https://travis-ci.org/hadolint/language-docker.svg?branch=master-[travis]: https://travis-ci.org/hadolint/language-docker+[actions-img]: https://github.com/hadolint/language-docker/actions/workflows/haskell.yml/badge.svg+[actions]: https://github.com/hadolint/language-docker/actions/workflows/haskell.yml [license-img]: https://img.shields.io/badge/license-GPL--3-blue.svg [license]: https://tldrlegal.com/license/gnu-general-public-license-v3-(gpl-3)
language-docker.cabal view
@@ -1,96 +1,132 @@--- This file has been generated from package.yaml by hpack version 0.28.2.------ see: https://github.com/sol/hpack------ hash: 64e893f351e7689307e2cbe6595ac2c624f727f4e02b9ff0aae6ec166f4cf5d4+cabal-version:      3.4+name:               language-docker+version:            15.0.0+synopsis:           Dockerfile parser, pretty-printer and embedded DSL+description:+  All functions for parsing and pretty-printing Dockerfiles are exported through @Language.Docker@. For more fine-grained operations look for specific modules that implement a certain functionality.+  See the <https://github.com/hadolint/language-docker GitHub project> for the source-code and examples. -name:           language-docker-version:        6.0.4-synopsis:       Dockerfile parser, pretty-printer and embedded DSL-description:    All functions for parsing, printing and writting Dockerfiles are exported through @Language.Docker@. For more fine-grained operations look for specific modules that implement a certain functionality.-                See the <https://github.com/hadolint/language-docker GitHub project> for the source-code and examples.-category:       Development-homepage:       https://github.com/hadolint/language-docker#readme-bug-reports:    https://github.com/hadolint/language-docker/issues-author:         Lukas Martinelli,-                Pedro Tacla Yamada,-                José Lorenzo Rodríguez-maintainer:     lorenzo@seatgeek.com-copyright:      Lukas Martinelli, Copyright (c) 2016,-                Pedro Tacla Yamada, Copyright (c) 2016,-                José Lorenzo Rodríguez, Copyright (c) 2017-license:        GPL-3-license-file:   LICENSE-build-type:     Simple-cabal-version:  >= 1.10+category:           Development+homepage:           https://github.com/hadolint/language-docker#readme+bug-reports:        https://github.com/hadolint/language-docker/issues+author:+  Lukas Martinelli,+  Pedro Tacla Yamada,+  José Lorenzo Rodríguez++maintainer:         lorenzo@seatgeek.com+copyright:+  Lukas Martinelli, Copyright (c) 2016,+  Pedro Tacla Yamada, Copyright (c) 2016,+  José Lorenzo Rodríguez, Copyright (c) 2017++license:            GPL-3.0-or-later+license-file:       LICENSE+build-type:         Simple extra-source-files:-    README.md+  README.md+  test/fixtures/1.Dockerfile+  test/fixtures/2.Dockerfile+  test/fixtures/3.Dockerfile+  test/fixtures/4.Dockerfile+  test/fixtures/5.Dockerfile+  test/fixtures/6.Dockerfile+  test/fixtures/7.Dockerfile+  test/fixtures/8.Dockerfile+  test/fixtures/Dockerfile.bom.utf16be+  test/fixtures/Dockerfile.bom.utf16le+  test/fixtures/Dockerfile.bom.utf32be+  test/fixtures/Dockerfile.bom.utf32le+  test/fixtures/Dockerfile.bom.utf8  source-repository head-  type: git+  type:     git   location: https://github.com/hadolint/language-docker +common deps+  build-depends:+    , base                >=4.8    && <5+    , bytestring          >=0.11.5 && <0.13+    , containers          >=0.6.7  && <0.8+    , data-default        >=0.8.0  && <0.10+    , data-default-class  >=0.2.0  && <0.4+    , megaparsec          >=9.7.0  && <9.9+    , prettyprinter       >=1.7.1  && <1.9+    , split               >=0.2.5  && <0.4+    , text                >=2.0.2  && <2.2+    , time                >=1.12.2 && <1.14+ library+  import:             deps   exposed-modules:-      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+    Language.Docker+    Language.Docker.Parser+    Language.Docker.PrettyPrint+    Language.Docker.Syntax+   other-modules:-      Paths_language_docker-  hs-source-dirs:-      src-  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-unused-do-bind -fno-warn-orphans-  build-depends:-      base >=4.8 && <5-    , bytestring >=0.10-    , containers-    , free-    , megaparsec >=6.4-    , mtl-    , prettyprinter-    , split >=0.2-    , template-haskell-    , text-    , th-lift-    , time-  default-language: Haskell2010+    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+    Language.Docker.Syntax.Port+    Language.Docker.Syntax.PortRange+    Language.Docker.Syntax.Protocol +  hs-source-dirs:     src+  default-extensions:+    ImplicitParams+    OverloadedStrings+    Rank2Types++  ghc-options:+    -Wall -Wcompat -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wredundant-constraints+    -fno-warn-unused-do-bind -fno-warn-orphans++  default-language:   GHC2021+ test-suite hspec-  type: exitcode-stdio-1.0-  main-is: Spec.hs+  import:             deps+  type:               exitcode-stdio-1.0+  main-is:            Spec.hs   other-modules:-      Language.Docker.EDSL.QuasiSpec-      Language.Docker.EDSLSpec-      Language.Docker.ExamplesSpec-      Language.Docker.ParserSpec-      Paths_language_docker-  hs-source-dirs:-      test+    Language.Docker.IntegrationSpec+    Language.Docker.ParseAddSpec+    Language.Docker.ParseCmdSpec+    Language.Docker.ParseCopySpec+    Language.Docker.ParseExposeSpec+    Language.Docker.ParseHealthcheckSpec+    Language.Docker.ParsePragmaSpec+    Language.Docker.ParserSpec+    Language.Docker.ParseRunSpec+    Language.Docker.PrettyPrintSpec+    TestHelper++  hs-source-dirs:     test+  default-extensions:+    ImplicitParams+    OverloadedLists+    OverloadedStrings+    Rank2Types++  ghc-options:+    -Wall -Wcompat -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wredundant-constraints+    -fno-warn-unused-do-bind -fno-warn-orphans+   build-depends:-      Glob-    , HUnit >=1.2-    , QuickCheck-    , base >=4.8 && <5-    , bytestring >=0.10-    , containers-    , directory-    , filepath-    , free     , hspec+    , hspec-megaparsec+    , HUnit             >=1.2     , language-docker-    , megaparsec >=6.4-    , mtl-    , prettyprinter-    , process-    , split >=0.2-    , template-haskell-    , text-    , th-lift-    , time-  default-language: Haskell2010+    , QuickCheck++  default-language:   GHC2021+  build-tool-depends: hspec-discover:hspec-discover >=2 && <3
src/Language/Docker.hs view
@@ -1,105 +1,48 @@+{-# LANGUAGE DuplicateRecordFields #-}+ module Language.Docker-    ( Language.Docker.Syntax.Dockerfile -- * Parsing Dockerfiles (@Language.Docker.Syntax@ and @Language.Docker.Parser@)-    , parseText-    , parseFile+  ( Language.Docker.Syntax.Dockerfile,++    -- * Parsing Dockerfiles (@Language.Docker.Syntax@ and @Language.Docker.Parser@)+    parseText,+    parseFile,+    parseStdin,+     -- * Re-exports from @megaparsec@-    , Text.Megaparsec.parseErrorPretty-      -- * 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.Ports-    , Language.Docker.Syntax.Directory-    , Language.Docker.Syntax.Arguments-    , Language.Docker.Syntax.Pairs-    , Language.Docker.Syntax.Filename-    , 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
− src/Language/Docker/EDSL.hs 
@@ -1,385 +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 bi n) =-    case bi of-        EUntaggedImage bi' alias -> runDef Syntax.From (Syntax.UntaggedImage bi' alias) n-        ETaggedImage bi' tg alias -> runDef Syntax.From (Syntax.TaggedImage bi' tg alias) n-        EDigestedImage bi' d alias -> runDef Syntax.From (Syntax.DigestedImage bi' d alias) n-runD (CmdArgs as n) = runDef Syntax.Cmd as n-runD (Shell as n) = runDef Syntax.Shell as n-runD (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 = flip EUntaggedImage Nothing . fromString . Text.unpack---- | 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 = ETaggedImage imageName tag Nothing--digested :: Syntax.Image -> Text -> EBaseImage-digested imageName hash = EDigestedImage imageName hash Nothing---- | 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 -> Text -> EBaseImage-aliased image alias =-    case image of-        EUntaggedImage n _ -> EUntaggedImage n (Just $ Syntax.ImageAlias alias)-        ETaggedImage n t _ -> ETaggedImage n t (Just $ Syntax.ImageAlias alias)-        EDigestedImage n h _ -> EDigestedImage n h (Just $ Syntax.ImageAlias alias)---- | 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)
− src/Language/Docker/EDSL/Quasi.hs 
@@ -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 (parseErrorPretty)---- | 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 (parseErrorPretty 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 (parseErrorPretty err)-        Right d -> lift d
− src/Language/Docker/EDSL/Types.hs 
@@ -1,71 +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-    = EUntaggedImage Syntax.Image-                     (Maybe Syntax.ImageAlias)-    | ETaggedImage Syntax.Image-                   Syntax.Tag-                   (Maybe Syntax.ImageAlias)-    | EDigestedImage Syntax.Image-                     Text-                     (Maybe Syntax.ImageAlias)-    deriving (Show, Eq, Ord)--instance IsString EBaseImage where-    fromString = flip EUntaggedImage Nothing . fromString--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)
− src/Language/Docker/Normalize.hs 
@@ -1,94 +0,0 @@-module Language.Docker.Normalize-    ( normalizeEscapedLines-    ) where--import Data.List (mapAccumL)-import Data.Maybe (catMaybes)-import Data.Semigroup ((<>))-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-        | 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 #-}
src/Language/Docker/Parser.hs view
@@ -1,604 +1,86 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}- module Language.Docker.Parser-    ( parseText-    , parseFile-    , 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 Data.Semigroup ((<>))-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, parseComment)+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 = ParseError Char 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 (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)--taggedImage :: Parser BaseImage-taggedImage = do-    registryName <- (Just <$> try parseRegistry) <|> return Nothing-    name <- someUnless "the image name with a tag" (\c -> c == '@' || c == ':')-    void $ char ':'-    tag <- someUnless "the image tag" (== ':')-    maybeAlias <- maybeImageAlias-    return $ TaggedImage (Image registryName name) (Tag tag) maybeAlias--digestedImage :: Parser BaseImage-digestedImage = do-    name <- someUnless "the image name with a digest" (\c -> c == '@' || c == ':')-    void $ char '@'-    digest <- someUnless "the image digest" (== '@')-    maybeAlias <- maybeImageAlias-    return $ DigestedImage (Image Nothing name) digest maybeAlias--untaggedImage :: Parser BaseImage-untaggedImage = do-    registryName <- (Just <$> try parseRegistry) <|> return Nothing-    name <- someUnless "just the image name" (\c -> c == '@' || c == ':')-    notInvalidTag name-    notInvalidDigest name-    maybeAlias <- maybeImageAlias-    return $ UntaggedImage (Image registryName name) maybeAlias-  where-    notInvalidTag :: Text -> Parser ()-    notInvalidTag name =-        try (notFollowedBy $ string ":") <?> "no ':' or a valid image tag string (example: " ++-        T.unpack name ++ ":valid-tag)"-    notInvalidDigest :: Text -> Parser ()-    notInvalidDigest name =-        try (notFollowedBy $ string "@") <?> "no '@' or a valid digest hash (example: " ++-        T.unpack name ++ "@a3f42f2de)"--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 digestedImage <|> -- Let's try each version-    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 `sepEndBy1` (char ' ' <|> char '\t')--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 onlyWhitespaces+  r <- p+  eof+  return r -dockerfile :: Parser Dockerfile+dockerfile :: (?esc :: Char) => Parser Dockerfile dockerfile =-    many $ do-        pos <- getPosition-        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 txt = do+  let ?esc = findEscapePragma (T.lines (dos2unix txt))+   in parse (contents dockerfile) "<string>" (dos2unix txt)  parseFile :: FilePath -> IO (Either Error Dockerfile)-parseFile file = doParse <$> B.readFile file+parseFile file = doParse file <$> B.readFile file++-- | Reads the standard input until the end and parses the contents as a Dockerfile+parseStdin :: IO (Either Error Dockerfile)+parseStdin = doParse "/dev/stdin" <$> B.getContents++-- | Parses a list of lines from a dockerfile one by one until either the escape+-- | pragma has been found, or pragmas are no longer expected.+-- | Pragmas can occur only until a comment, an empty line or another+-- | instruction occurs (i.e. they have to be the first lines of a Dockerfile).+findEscapePragma :: [Text] -> Char+findEscapePragma [] = defaultEsc+findEscapePragma (l:ls) =+  case parse (contents parseComment) "<line>" l of+    Left _ -> defaultEsc+    Right (Pragma (Escape (EscapeChar c))) -> c+    Right (Pragma _) -> findEscapePragma ls+    Right _ -> defaultEsc   where-    doParse =-        parse (contents dockerfile) file . normalizeEscapedLines . E.decodeUtf8With E.lenientDecode+    ?esc = defaultEsc++doParse :: FilePath -> B.ByteString -> Either Error Dockerfile+doParse path txt = do+  let ?esc = findEscapePragma (T.lines src)+   in parse (contents dockerfile) path src+  where+    src =+      case B.take 4 txt of+        "\255\254\NUL\NUL" ->+          dos2unix (E.decodeUtf32LEWith E.lenientDecode $ B.drop 4 txt)+        "\NUL\NUL\254\255" ->+          dos2unix (E.decodeUtf32BEWith E.lenientDecode $ B.drop 4 txt)+        _ ->+          case B.take 2 txt of+            "\255\254" ->+              dos2unix (E.decodeUtf16LEWith E.lenientDecode $ B.drop 2 txt)+            "\254\255" ->+              dos2unix (E.decodeUtf16BEWith E.lenientDecode $ B.drop 2 txt)+            _ ->+              case B.take 3 txt of+                "\239\187\191" ->+                  dos2unix (E.decodeUtf8With E.lenientDecode $ B.drop 3 txt)+                _ -> dos2unix (E.decodeUtf8With E.lenientDecode txt)++-- | Changes crlf line endings to simple line endings+dos2unix :: T.Text -> T.Text+dos2unix = T.replace "\r\n" "\n"
+ src/Language/Docker/Parser/Arguments.hs view
@@ -0,0 +1,31 @@+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 :: (?esc :: Char) => Parser (Arguments Text)+argumentsExec = do+  args <- brackets $ commaSep doubleQuotedStringEscaped+  return $ ArgumentsList (T.unwords args)++-- Parse arguments of a command in the shell form+argumentsShell :: (?esc :: Char) => Parser (Arguments Text)+argumentsShell =+  try (ArgumentsText <$> untilHeredoc)+    <|> (ArgumentsText <$> toEnd)+  where+    toEnd = untilEol "the shell arguments"++-- Parse arguments of a command in the heredoc format+argumentsHeredoc :: (?esc :: Char) => Parser (Arguments Text)+argumentsHeredoc = ArgumentsText <$> heredoc++arguments :: (?esc :: Char) => Parser (Arguments Text)+arguments = try argumentsHeredoc+  <|> try argumentsExec+  <|> try argumentsShell
+ src/Language/Docker/Parser/Cmd.hs view
@@ -0,0 +1,13 @@+module Language.Docker.Parser.Cmd+  ( parseCmd,+  )+where++import Language.Docker.Parser.Arguments+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++parseCmd :: (?esc :: Char) => Parser (Instruction Text)+parseCmd = do+  reserved "CMD"+  Cmd <$> arguments
+ src/Language/Docker/Parser/Copy.hs view
@@ -0,0 +1,173 @@+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 Flag+  = FlagChecksum Checksum+  | FlagChown Chown+  | FlagChmod Chmod+  | FlagLink Link+  | FlagSource CopySource+  | FlagExclude Exclude+  | FlagInvalid (Text, Text)++parseCopy :: (?esc :: Char) => Parser (Instruction Text)+parseCopy = do+  reserved "COPY"+  flags <- copyFlag `sepEndBy` requiredWhitespace+  let chownFlags = [c | FlagChown c <- flags]+  let chmodFlags = [c | FlagChmod c <- flags]+  let linkFlags = [l | FlagLink l <- flags]+  let sourceFlags = [f | FlagSource f <- flags]+  let excludeFlags = [e | FlagExclude e <- flags]+  let invalid = [i | FlagInvalid i <- flags]+  -- Let's do some validation on the flags+  case (invalid, chownFlags, chmodFlags, linkFlags, sourceFlags, excludeFlags) of+    ((k, v) : _, _, _, _, _, _) -> unexpectedFlag k v+    (_, _ : _ : _, _, _, _, _) -> customError $ DuplicateFlagError "--chown"+    (_, _, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--chmod"+    (_, _, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--link"+    (_, _, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--from"+    _ -> do+      let cho =+            case chownFlags of+              [] -> NoChown+              c : _ -> c+      let chm =+            case chmodFlags of+              [] -> NoChmod+              c : _ -> c+      let lnk =+            case linkFlags of+              [] -> NoLink+              l : _ -> l+      let fr =+            case sourceFlags of+              [] -> NoSource+              f : _ -> f+      try (heredocList (\src dest -> Copy (CopyArgs src dest) (CopyFlags cho chm lnk fr excludeFlags)))+        <|> fileList "COPY" (\src dest -> Copy (CopyArgs src dest) (CopyFlags cho chm lnk fr excludeFlags))++parseAdd :: (?esc :: Char) => Parser (Instruction Text)+parseAdd = do+  reserved "ADD"+  flags <- addFlag `sepEndBy` requiredWhitespace+  let checksumFlags = [c | FlagChecksum c <- flags]+  let chownFlags = [c | FlagChown c <- flags]+  let chmodFlags = [c | FlagChmod c <- flags]+  let linkFlags = [l | FlagLink l <- flags]+  let excludeFlags = [e | FlagExclude e <- flags]+  let invalidFlags = [i | FlagInvalid i <- flags]+  notFollowedBy (string "--") <?>+    "only the --checksum, --chown, --chmod, --link, --exclude flags or the src and dest paths"+  case (invalidFlags, checksumFlags, chownFlags, linkFlags, chmodFlags, excludeFlags) of+    ((k, v) : _, _, _, _, _, _) -> unexpectedFlag k v+    (_, _ : _ : _, _, _, _, _) -> customError $ DuplicateFlagError "--checksum"+    (_, _, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--chown"+    (_, _, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--chmod"+    (_, _, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--link"+    _ -> do+      let chk = case checksumFlags of+                  [] -> NoChecksum+                  c : _ -> c+      let cho = case chownFlags of+                  [] -> NoChown+                  c : _ -> c+      let chm = case chmodFlags of+                  [] -> NoChmod+                  c : _ -> c+      let lnk = case linkFlags of+                  [] -> NoLink+                  l : _ -> l+      fileList "ADD" (\src dest -> Add (AddArgs src dest) (AddFlags chk cho chm lnk excludeFlags))++heredocList :: (?esc :: Char) =>+               (NonEmpty SourcePath -> TargetPath -> Instruction Text) ->+               Parser (Instruction Text)+heredocList constr = do+  markers <- try (spaceSep1 heredocMarker) <?> "a list of heredoc markers"+  target <- untilEol "target path"+  case reverse markers of+    [] -> customError $ FileListError "empty list of heredoc markers"+    m:_ -> void $ heredocContent m+  return $ constr (SourcePath <$> fromList markers) (TargetPath target)++fileList :: (?esc :: Char) => Text ->+            (NonEmpty SourcePath -> TargetPath -> Instruction Text) ->+            Parser (Instruction Text)+fileList name constr = do+  paths <-+    (try stringList <?> "an array of strings [\"src_file\", \"dest_file\"]")+      <|> (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 =+      someUnless "a file" (== ' ') `sepEndBy1` (try requiredWhitespace <?> "at least another file path")+    stringList = brackets $ commaSep doubleQuotedString++unexpectedFlag :: Text -> Text -> Parser a+unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name)+unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name)++copyFlag :: (?esc :: Char) => Parser Flag+copyFlag = (FlagSource <$> try copySource <?> "only one --from") <|> addFlag++addFlag :: (?esc :: Char) => Parser Flag+addFlag = (FlagChecksum <$> try checksum <?> "--checksum")+  <|> (FlagChown <$> try chown <?> "--chown")+  <|> (FlagChmod <$> try chmod <?> "--chmod")+  <|> (FlagLink <$> try link <?> "--link")+  <|> (FlagExclude <$> try exclude <?> "--exclude")+  <|> (FlagInvalid <$> try anyFlag <?> "other flag")++checksum :: (?esc :: Char) => Parser Checksum+checksum = do+  void $ string "--checksum="+  chk <- someUnless "the remote file checksum" (== ' ')+  return $ Checksum chk++chown :: (?esc :: Char) => Parser Chown+chown = do+  void $ string "--chown="+  cho <- someUnless "the user and group for chown" (== ' ')+  return $ Chown cho++chmod :: (?esc :: Char) => Parser Chmod+chmod = do+  void $ string "--chmod="+  chm <- someUnless "the mode for chmod" (== ' ')+  return $ Chmod chm++link :: Parser Link+link = do+  void $ string "--link"+  return Link++copySource :: (?esc :: Char) => Parser CopySource+copySource = do+  void $ string "--from="+  src <- someUnless "the copy source path" isNl+  return $ CopySource src++exclude :: (?esc :: Char) => Parser Exclude+exclude = do+  void $ string "--exclude="+  exc <- someUnless "the exclude pattern" (== ' ')+  return $ Exclude exc++anyFlag :: (?esc :: Char) => Parser (Text, Text)+anyFlag = do+  void $ string "--"+  name <- someUnless "the flag value" (== '=')+  void $ char '='+  val <- anyUnless (== ' ')+  return (T.append "--" name, val)
+ src/Language/Docker/Parser/Expose.hs view
@@ -0,0 +1,81 @@+module Language.Docker.Parser.Expose+  ( parseExpose,+  )+where++import qualified Data.Text as T+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++parseExpose :: (?esc :: Char) => Parser (Instruction Text)+parseExpose = do+  reserved "EXPOSE"+  Expose <$> ports++ports :: (?esc :: Char) => Parser Ports+ports = Ports <$> portspec `sepEndBy` requiredWhitespace++portspec :: (?esc :: Char) => Parser PortSpec+portspec =+  ( try parsePortRangeSpec <?> "A range of ports optionally followed by the protocol" )+    <|> ( parsePortSpec <?> "A port optionally followed by the protocol" )++parsePortRangeSpec :: (?esc :: Char) => Parser PortSpec+parsePortRangeSpec = PortRangeSpec <$> portRange++parsePortSpec :: (?esc :: Char) => Parser PortSpec+parsePortSpec = PortSpec <$> port++port :: (?esc :: Char) => Parser Port+port = (try portVariable <?> "a variable")+    <|> (try portWithProtocol <?> "a port with its protocol (udp/tcp)")+    <|> (portInt <?> "a valid port number")++portRangeLimit :: (?esc :: Char) => Parser Port+portRangeLimit = number <|> variable+  where+    number = do+      num <- natural+      return $ Port (fromIntegral num) TCP++    variable = do+      void (char '$')+      var <- someUnless "the variable name" (\c -> c == '-' || c == '/')+      return $ PortStr (T.append "$" var)++portRange :: (?esc :: Char) => Parser PortRange+portRange = do+  start <- portRangeLimit+  void $ char '-'+  finish <- try portRangeLimit+  proto <- try protocol <|> return TCP+  return $ PortRange (setProto start proto) (setProto finish proto)+  where+    setProto :: Port -> Protocol -> Port+    setProto (Port p _) prot = Port p prot+    setProto (PortStr s) _ = PortStr s++protocol :: Parser Protocol+protocol = do+  void (char '/')+  try (tcp <|> udp) <|> fail "invalid protocol"+  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 :: (?esc :: Char) => Parser Port+portVariable = do+  void (char '$')+  variable <- someUnless "the variable name" (== '$')+  return $ PortStr (T.append "$" variable)
+ src/Language/Docker/Parser/From.hs view
@@ -0,0 +1,72 @@+module Language.Docker.Parser.From+  ( parseFrom,+  )+where++import qualified Data.Text as T+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax++parseRegistry :: (?esc :: Char) => Parser Registry+parseRegistry = do+  domain <- someUnless "a domain name" (== '.')+  void $ char '.'+  tld <- someUnless "a TLD" (== '/')+  void $ char '/'+  return $ Registry (domain <> "." <> tld)++parsePlatform :: (?esc :: Char) => Parser Platform+parsePlatform = do+  void $ string "--platform="+  p <- someUnless "the platform for the FROM image" (== ' ')+  requiredWhitespace+  return p++parseBaseImage :: (?esc :: Char) => (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 :: (?esc :: Char) => Parser BaseImage+taggedImage = parseBaseImage tagParser+  where+    tagParser _ = do+      void $ char ':'+      t <- someUnless "the image tag" (\c -> c == '@' || c == ':')+      return (Just . Tag $ t)++parseDigest :: (?esc :: Char) => Parser Digest+parseDigest = do+  void $ char '@'+  d <- someUnless "the image digest" (== '@')+  return $ Digest d++untaggedImage :: (?esc :: Char) => 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 :: (?esc :: Char) => Parser ImageAlias+imageAlias = do+  void (try (reserved "AS") <?> "'AS' followed by the image alias")+  aka <- someUnless "the image alias" (== '\n')+  return $ ImageAlias aka++baseImage :: (?esc :: Char) => Parser BaseImage+baseImage = try taggedImage <|> untaggedImage++parseFrom :: (?esc :: Char) => Parser (Instruction Text)+parseFrom = do+  reserved "FROM"+  From <$> baseImage
+ src/Language/Docker/Parser/Healthcheck.hs view
@@ -0,0 +1,104 @@+{-# 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+  | FlagStartInterval Duration+  | FlagRetries Retries+  | CFlagInvalid (Text, Text)++parseHealthcheck :: (?esc :: Char) => 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 startIntervals = [x | FlagStartInterval 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, startIntervals, retriesD) of+        ((k, v) : _, _, _, _, _, _) -> unexpectedFlag k v+        (_, _ : _ : _, _, _, _, _) -> customError $ DuplicateFlagError "--interval"+        (_, _, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--timeout"+        (_, _, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--start-period"+        (_, _, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--start-interval"+        (_, _, _, _, _, _ : _ : _) -> customError $ DuplicateFlagError "--retries"+        _ -> do+          Cmd checkCommand <- parseCmd+          let interval = listToMaybe intervals+          let timeout = listToMaybe timeouts+          let startPeriod = listToMaybe startPeriods+          let startInterval = listToMaybe startIntervals+          let retries = listToMaybe retriesD+          return $ Check CheckArgs {..}++checkFlag :: (?esc :: Char) => Parser CheckFlag+checkFlag =+  (FlagInterval <$> durationFlag "--interval=" <?> "--interval")+    <|> (FlagTimeout <$> durationFlag "--timeout=" <?> "--timeout")+    <|> (FlagStartPeriod <$> durationFlag "--start-period=" <?> "--start-period")+    <|> (FlagStartInterval <$> durationFlag "--start-interval=" <?> "--start-interval")+    <|> (FlagRetries <$> retriesFlag <?> "--retries")+    <|> (CFlagInvalid <$> anyFlag <?> "no flags")++durationFlag :: Text -> Parser Duration+durationFlag flagName = do+  void $ try (string flagName)+  value <- try ( fromRational . realToFrac <$> fractional )+              <|> ( secondsToDiffTime . fromInteger <$> natural )+              <?> "a natural or fractional number"+  unit <- char 's' <|> char 'm' <|> char 'h' <?> "either 's', 'm' or 'h' as the unit"+  case unit of+    's' -> return $ Duration value+    'm' -> return $ Duration (value * 60)+    'h' -> return $ Duration (value * 60 * 60)+    _ -> fail "only 's', 'm' or 'h' are allowed as the duration"++retriesFlag :: Parser Retries+retriesFlag = do+  void $ try (string "--retries=")+  n <- try natural <?> "the number of retries"+  return $ Retries (fromIntegral n)++anyFlag :: (?esc :: Char) => 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)
+ src/Language/Docker/Parser/Instruction.hs view
@@ -0,0 +1,147 @@+module Language.Docker.Parser.Instruction+  ( parseArg,+    parseComment,+    parseEntryPoint,+    parseEscapePragma,+    parseInstruction,+    parseMaintainer,+    parseOnbuild,+    parsePragma,+    parseShell,+    parseStopSignal,+    parseSyntaxPragma,+    parseUser,+    parseVolume,+    parseWorkdir,+  )+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 :: (?esc :: Char) => Parser (Instruction Text)+parseShell = do+  reserved "SHELL"+  Shell <$> arguments++parseStopSignal :: (?esc :: Char) => Parser (Instruction Text)+parseStopSignal = do+  reserved "STOPSIGNAL"+  args <- untilEol "the stop signal"+  return $ Stopsignal args++parseArg :: (?esc :: Char) => Parser (Instruction Text)+parseArg = do+  reserved "ARG"+  (try nameWithDefault <?> "the arg name")+    <|> (try nameWithoutDefault <?> "the arg name")+    <|> Arg <$> untilEol "the argument name" <*> pure Nothing+  where+    nameWithoutDefault = do+      name <- someUnless "the argument name" (== '=')+      void $ untilEol "the rest"+      return $ Arg name Nothing+    nameWithDefault = do+      name <- someUnless "the argument name" (== '=')+      void $ char '='+      df <- untilEol "the argument value"+      return $ Arg name (Just df)++parseUser :: (?esc :: Char) => Parser (Instruction Text)+parseUser = do+  reserved "USER"+  username <- untilEol "the user"+  return $ User username++parseWorkdir :: (?esc :: Char) => Parser (Instruction Text)+parseWorkdir = do+  reserved "WORKDIR"+  directory <- untilEol "the workdir path"+  return $ Workdir directory++parseVolume :: (?esc :: Char) => Parser (Instruction Text)+parseVolume = do+  reserved "VOLUME"+  directory <- untilEol "the volume path"+  return $ Volume directory++parseMaintainer :: (?esc :: Char) => Parser (Instruction Text)+parseMaintainer = do+  reserved "MAINTAINER"+  name <- untilEol "the maintainer name"+  return $ Maintainer name++parseEntryPoint :: (?esc :: Char) => Parser (Instruction Text)+parseEntryPoint = do+  reserved "ENTRYPOINT"+  Entrypoint <$> arguments++parseOnbuild :: (?esc :: Char) => Parser (Instruction Text)+parseOnbuild = do+  reserved "ONBUILD"+  OnBuild <$> parseInstruction++parsePragma :: (?esc :: Char) => Parser (Instruction Text)+parsePragma = do+  void $ lexeme' (char '#')+  choice+    [ parseEscapePragma <?> "an escape",+      parseSyntaxPragma <?> "a syntax"+    ]++parseEscapePragma :: Parser (Instruction Text)+parseEscapePragma = do+  void $ lexeme' (string "escape")+  void $ lexeme' (string "=")+  Pragma . Escape . EscapeChar <$> charLiteral++parseSyntaxPragma :: (?esc :: Char) => Parser (Instruction Text)+parseSyntaxPragma = do+  void $ lexeme' (string "syntax")+  void $ lexeme' (string "=")+  img <- untilEol "the syntax"+  return $ Pragma+      ( Syntax+          ( SyntaxImage+              ( Image+                  { registryName = Nothing,+                    imageName = img+                  }+              )+          )+      )++parseComment :: (?esc :: Char) => Parser (Instruction Text)+parseComment = (try parsePragma <?> "a pragma") <|> Comment <$> comment++parseInstruction :: (?esc :: Char) => Parser (Instruction Text)+parseInstruction =+  choice+    [ parseOnbuild,+      parseFrom,+      parseCopy,+      parseRun,+      parseWorkdir,+      parseEntryPoint,+      parseVolume,+      parseExpose,+      parseEnv,+      parseArg,+      parseUser,+      parseLabel,+      parseStopSignal,+      parseCmd,+      parseShell,+      parseMaintainer,+      parseAdd,+      parseComment,+      parseHealthcheck+    ]
+ src/Language/Docker/Parser/Pairs.hs view
@@ -0,0 +1,58 @@+module Language.Docker.Parser.Pairs+  ( parseEnv,+    parseLabel,+  )+where++import qualified Data.Text as T+import Language.Docker.Parser.Prelude+import Language.Docker.Syntax+++unquotedString :: (?esc :: Char) => (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 :: (?esc :: Char) => (Char -> Bool) -> Parser Text+singleValue acceptCondition = mconcat <$> variants+  where+    variants =+      many $+        choice+          [ doubleQuotedStringEscaped <?> "a string inside double quotes",+            singleQuotedStringEscaped <?> "a string inside single quotes",+            unquotedString acceptCondition <?> "a string with no quotes"+          ]++pair :: (?esc :: Char) => 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 :: (?esc :: Char) => Parser Pairs+pairs = (pair <?> "a key value pair (key=value)") `sepEndBy1` requiredWhitespace++parseLabel :: (?esc :: Char) => Parser (Instruction Text)+parseLabel = do+  reserved "LABEL"+  Label <$> pairs++parseEnv :: (?esc :: Char) => Parser (Instruction Text)+parseEnv = do+  reserved "ENV"+  Env <$> pairs
+ src/Language/Docker/Parser/Prelude.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Language.Docker.Parser.Prelude+  (+    DockerfileError (..),+    Error,+    Parser,+    anyUnless,+    brackets,+    caseInsensitiveString,+    commaSep,+    comment,+    customError,+    doubleQuotedString,+    doubleQuotedStringEscaped,+    eol,+    escapedLineBreaks',+    fractional,+    heredoc,+    heredocContent,+    heredocMarker,+    isNl,+    isSpaceNl,+    lexeme',+    lexeme,+    natural,+    onlySpaces,+    onlyWhitespaces,+    requiredWhitespace,+    reserved,+    singleQuotedString,+    singleQuotedStringEscaped,+    someUnless,+    spaceSep1,+    stringWithEscaped,+    symbol,+    untilEol,+    untilHeredoc,+    whitespace,+    module Megaparsec,+    char,+    L.charLiteral,+    string,+    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 :: (?esc :: Char) => Parser ()+eol = void ws <?> "end of line"+  where+    ws =+      some $+        choice+          [ void onlySpaces1,+            void $ takeWhile1P Nothing (== '\n'),+            void escapedLineBreaks+          ]++reserved :: (?esc :: Char) => Text -> Parser ()+reserved name = void (lexeme (string' name) <?> T.unpack name)++natural :: Parser Integer+natural = L.decimal <?> "positive number"++fractional :: Parser Float+fractional = L.float <?> "fractional number"++commaSep :: (?esc :: Char) => Parser a -> Parser [a]+commaSep p = sepBy (p <* whitespace) (symbol ",")++spaceSep1 :: Parser a -> Parser [a]+spaceSep1 p = sepEndBy1 p onlySpaces++singleQuotedString :: Parser Text+singleQuotedString = quotedString '\''++doubleQuotedString :: Parser Text+doubleQuotedString = quotedString '\"'++-- | Special variants of the string parsers dealing with escaped line breaks+-- and escaped quote characters well.+singleQuotedStringEscaped :: (?esc :: Char) => Parser Text+singleQuotedStringEscaped = quotedStringEscaped '\''++doubleQuotedStringEscaped :: (?esc :: Char) => Parser Text+doubleQuotedStringEscaped = quotedStringEscaped '\"'++quotedString :: Char -> Parser Text+quotedString c = do+  lit <- char c >> manyTill L.charLiteral (char c)+  return $ T.pack lit++quotedStringEscaped :: (?esc :: Char) => Char -> Parser Text+quotedStringEscaped q =+  between (char q) (char q) $ stringWithEscaped [q] Nothing++brackets :: (?esc :: Char) => Parser a -> Parser a+brackets = between (symbol "[" *> whitespace) (whitespace *> symbol "]")++untilWS :: Parser Text+untilWS = do+  s <- manyTill anySingle spaceChar+  return $ T.pack s++heredocMarker :: (?esc :: Char) => Parser Text+heredocMarker = do+  void $ string "<<"+  void $ takeWhileP (Just "dash") (== '-')+  m <- try doubleQuotedString <|> try singleQuotedString <|> untilWS+  optional heredocRedirect+  pure m++heredocRedirect :: (?esc :: Char) => Parser Text+heredocRedirect = do+  void $ ( string "|" <|> string ">" <|> string ">>" ) *> onlySpaces+  untilEol "heredoc path"++-- | This tries to parse everything until there is the just the heredoc marker+-- on its own on a line. Making provisions for the case that the marker is+-- followed by the end of the file rather than another newline.+heredocContent :: Text -> Parser Text+heredocContent marker = do+  emptyHeredoc <- observing delimiter+  doc <- case emptyHeredoc of+    Left _ -> manyTill anySingle termination+    Right _ -> pure ""+  return $ T.strip $ T.pack doc+  where+    termination :: Parser Text+    termination = try terEOL <|> terEOF++    terEOL :: Parser Text+    terEOL = string $ "\n" <> marker <> "\n"++    terEOF :: Parser Text+    terEOF = do+      t <- string $ "\n" <> marker+      hidden eof+      pure t++    delimiter :: Parser Text+    delimiter = try delEOL <|> delEOF++    delEOL :: Parser Text+    delEOL = string $ marker <> "\n"++    delEOF :: Parser Text+    delEOF = do+      t <- string marker+      hidden eof+      pure t++heredoc :: (?esc :: Char) => Parser Text+heredoc = do+  m <- heredocMarker+  heredocContent m++-- | Parses text until a heredoc or newline is found. Will also consume the+-- heredoc. It will however respect escaped newlines.+untilHeredoc :: (?esc :: Char) => Parser Text+untilHeredoc = do+  txt <- manyTill chars heredoc+  return $ T.strip $ mconcat txt+  where+    chars =+      choice+        [ castToSpace <$> escapedLineBreaks,+          charToTxt <$> anySingleBut '\n'+        ]+    charToTxt c = T.pack [c]++onlySpaces :: Parser Text+onlySpaces = takeWhileP (Just "spaces") (\c -> c == ' ' || c == '\t')++onlySpaces1 :: Parser Text+onlySpaces1 = takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t')++onlyWhitespaces :: Parser Text+onlyWhitespaces = takeWhileP+    (Just "whitespaces")+    (\c -> c == ' ' || c == '\t' || c == '\n' || c == '\r')++escapedLineBreaks :: (?esc :: Char) => Parser FoundWhitespace+escapedLineBreaks = mconcat <$> breaks+  where+    breaks =+      some $ do+        try (char ?esc *> onlySpaces *> newlines)+        skipMany . try $ onlySpaces *> comment *> newlines+        -- Spaces before the next '\' have a special significance+        -- so we remembeer the fact that we found some+        FoundWhitespace <$ onlySpaces1 <|> pure MissingWhitespace+    newlines = takeWhile1P Nothing isNl++-- | This converts escaped line breaks, but keeps _all_ spaces before and after+escapedLineBreaks' :: (?esc :: Char) => Parser Text+escapedLineBreaks' = mconcat <$> breaks+  where+    breaks =+      some $ do+        try ( char ?esc *> onlySpaces *> newlines )+        skipMany . try $ onlySpaces *> comment *> newlines+        onlySpaces1+    newlines = takeWhile1P Nothing isNl++foundWhitespace :: (?esc :: Char) => Parser FoundWhitespace+foundWhitespace = mconcat <$> found+  where+    found = many $ choice [FoundWhitespace <$ onlySpaces1, escapedLineBreaks]++whitespace :: (?esc :: Char) => Parser ()+whitespace = void foundWhitespace++requiredWhitespace :: (?esc :: Char) => 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 :: (?esc :: Char) => 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 /= ?esc),+            takeWhile1P Nothing (== ?esc) <* notFollowedBy (char '\n')+          ]++symbol :: (?esc :: Char) => Text -> Parser Text+symbol name = do+  x <- string name+  whitespace+  return x++caseInsensitiveString :: Text -> Parser Text+caseInsensitiveString = string'++stringWithEscaped :: (?esc :: Char) => [Char] -> Maybe (Char -> Bool) -> Parser Text+stringWithEscaped quoteChars maybeAcceptCondition = mconcat <$> sequences+  where+    sequences =+      many $+        choice+          [ mconcat <$> inner,+            try $ takeWhile1P Nothing (== ?esc) <* notFollowedBy quoteParser,+            string (T.singleton ?esc) *> quoteParser+          ]+    inner =+      some $+        choice+          [ castToSpace <$> escapedLineBreaks,+            takeWhile1P+              Nothing+              (\c -> c /= ?esc && c /= '\n' && c `notElem` quoteChars && acceptCondition c)+          ]+    quoteParser = T.singleton <$> choice (fmap char quoteChars)+    acceptCondition = fromMaybe (const True) maybeAcceptCondition++lexeme :: (?esc :: Char) => Parser a -> Parser a+lexeme p = do+  x <- p+  requiredWhitespace+  return x++lexeme' :: Parser a -> Parser a+lexeme' p = do+  x <- p+  void onlySpaces+  return x++isNl :: Char -> Bool+isNl c = c == '\n'++isSpaceNl :: (?esc :: Char) => Char -> Bool+isSpaceNl c = c == ' ' || c == '\t' || c == '\n' || c == ?esc++anyUnless :: (?esc :: Char) => (Char -> Bool) -> Parser Text+anyUnless predicate = someUnless "" predicate <|> pure ""++someUnless :: (?esc :: Char) => 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 == ?esc && not (predicate c))+              <* notFollowedBy (char '\n')+          ]++comment :: Parser Text+comment = do+  void $ char '#'+  takeWhileP Nothing (not . isNl)
+ src/Language/Docker/Parser/Run.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE DuplicateRecordFields #-}++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+  = MountArgEnv Text+  | MountArgFromImage Text+  | MountArgId Text+  | MountArgMode Text+  | MountArgReadOnly Bool+  | MountArgRequired Bool+  | MountArgSharing CacheSharing+  | MountArgSource SourcePath+  | MountArgTarget TargetPath+  | MountArgType MountType+  | MountArgUid Text+  | MountArgGid Text+  | MountArgRelabel Relabel+  deriving (Show)++data MountType+  = Bind+  | Cache+  | Tmpfs+  | Secret+  | Ssh+  deriving (Show)++parseRun :: (?esc :: Char) => Parser (Instruction Text)+parseRun = do+  reserved "RUN"+  Run <$> runArguments++runArguments :: (?esc :: Char) => Parser (RunArgs Text)+runArguments = do+  presentFlags <- choice [runFlags <* requiredWhitespace, pure (RunFlags mempty Nothing Nothing)]+  args <- arguments+  return $ RunArgs args presentFlags++runFlags :: (?esc :: Char) => Parser RunFlags+runFlags = do+  flags <- runFlag `sepBy` flagSeparator+  return $ foldr toRunFlags emptyFlags flags+  where+    flagSeparator = try (requiredWhitespace *> lookAhead (string "--")) <|> fail "expected flag"+    emptyFlags = RunFlags mempty Nothing Nothing+    toRunFlags (RunFlagMount m) rf@RunFlags { mount = mnt } = rf {mount = Set.insert m mnt}+    toRunFlags (RunFlagNetwork n) rf = rf {network = Just n}+    toRunFlags (RunFlagSecurity s) rf = rf {security = Just s}++runFlag :: (?esc :: Char) => 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 :: (?esc :: Char) => Parser RunMount+runFlagMount = do+  void $ string "--mount="+  args <- mountArgs `sepBy1` string ","+  mt <- parseTypeFromArgs args+  case mt of+    Bind -> BindMount <$> bindMount (filter (not . isMountArgType) args)+    Cache -> CacheMount <$> cacheMount (filter (not . isMountArgType) args)+    Tmpfs -> TmpfsMount <$> tmpfsMount (filter (not . isMountArgType) args)+    Secret -> SecretMount <$> secretMount (filter (not . isMountArgType) args)+    Ssh -> SshMount <$> secretMount (filter (not . isMountArgType) args)++parseTypeFromArgs :: [RunMountArg] -> Parser MountType+parseTypeFromArgs args =+  -- `notFollowedBy eof` is a trivially succeeding parser that isn't supposed to+  -- consume any input here. It's a hack that converts a simple type into a+  -- parser. This allows this function to emit parse errors after analyzing its+  -- input arguments and not consume any input.+  case filter isMountArgType args of+    [] -> Bind <$ notFollowedBy eof+    [MountArgType t] -> t <$ notFollowedBy eof+    _:_ -> fail "--mount with multiple `type` arguments"++isMountArgType :: RunMountArg -> Bool+isMountArgType (MountArgType _) = True+isMountArgType _ = False++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", "relabel"]+    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 (MountArgRelabel re) bo = bo {bRelabel = Just re}+    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.singleton "target"+    cacheOpts :: RunMountArg -> CacheOpts -> CacheOpts+    cacheOpts (MountArgTarget path) co = co {cTarget = path}+    cacheOpts (MountArgSharing sh) co = co {cSharing = Just 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", "env"]+    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 r) co = co {sIsRequired = Just r}+    secretOpts (MountArgSource path) co = co {sSource = Just path}+    secretOpts (MountArgEnv e) co = co {sEnv = Just e}+    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 :: RunMountArg -> (Either DockerfileError [RunMountArg], Set.Set Text) -> (Either DockerfileError [RunMountArg], Set.Set Text)+    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)++mountArgs :: (?esc :: Char) => Parser RunMountArg+mountArgs =+  choice+    [ mountArgEnv,+      mountArgFromImage,+      mountArgGid,+      mountArgId,+      mountArgMode,+      mountArgReadOnly,+      mountArgRelabel,+      mountArgRequired,+      mountArgSharing,+      mountArgSource,+      mountArgTarget,+      mountArgType,+      mountArgUid+    ]++stringArg :: (?esc :: Char) => Parser Text+stringArg = choice [doubleQuotedString, someUnless "a string" (== ',')]++key :: Text -> Parser a -> Parser a+key name p = string (name <> "=") *> p++tryKeyValue' :: Text -> Text -> Parser Text+tryKeyValue' k v = try $ string' (k <> "=") *> string' v++cacheSharing :: Parser CacheSharing+cacheSharing =+  choice [Private <$ string "private", Shared <$ string "shared", Locked <$ string "locked"]++mountArgEnv :: (?esc :: Char) => Parser RunMountArg+mountArgEnv = MountArgEnv <$> key "env" stringArg++mountArgFromImage :: (?esc :: Char) => Parser RunMountArg+mountArgFromImage = MountArgFromImage <$> key "from" stringArg++mountArgGid :: (?esc :: Char) => Parser RunMountArg+mountArgGid = MountArgGid <$> key "gid" stringArg++mountArgId :: (?esc :: Char) => Parser RunMountArg+mountArgId = MountArgId <$> key "id" stringArg++mountArgMode :: (?esc :: Char) => Parser RunMountArg+mountArgMode = MountArgMode <$> key "mode" stringArg++mountArgReadOnly :: Parser RunMountArg+mountArgReadOnly =+  MountArgReadOnly+    <$> choice+          [ choiceRoExplicit,+            choiceRwExplicit,+            choiceRo,  -- these two must come last and be separate+            choiceRw+          ]+  where+    choiceRoExplicit =+      choice+        [ tryKeyValue' "ro" "true",+          tryKeyValue' "rw" "false",+          tryKeyValue' "readonly" "true",+          tryKeyValue' "readwrite" "false"+        ] $> True++    choiceRwExplicit =+      choice+        [ tryKeyValue' "rw" "true",+          tryKeyValue' "ro" "false",+          tryKeyValue' "readwrite" "true",+          tryKeyValue' "readonly" "false"+        ] $> False++    choiceRo =+      choice+        [ string' "ro",+          string' "readonly"+        ] $> True++    choiceRw =+      choice+        [ string' "rw",+          string' "readwrite"+        ] $> False++mountArgRequired :: Parser RunMountArg+mountArgRequired = MountArgRequired <$> choice+    [ choice ["required=true",+              "required=True"+             ] $> True,+      choice ["required=false",+              "required=False"+             ] $> False,+      string "required" $> True  -- This must come last in the list!+    ]++mountArgSharing :: Parser RunMountArg+mountArgSharing = MountArgSharing <$> key "sharing" cacheSharing++mountArgSource :: (?esc :: Char) => Parser RunMountArg+mountArgSource = do+  label "source=" $ choice [string "source=", string "src="]+  MountArgSource . SourcePath <$> stringArg++mountArgTarget :: (?esc :: Char) => Parser RunMountArg+mountArgTarget = do+  label "target=" $ choice [string "target=", string "dst=", string "destination="]+  MountArgTarget . TargetPath <$> stringArg++mountArgType :: Parser RunMountArg+mountArgType = MountArgType <$> key "type" mountType++mountType :: Parser MountType+mountType =+  choice+    [ Bind <$ string "bind",+      Cache <$ string "cache",+      Tmpfs <$ string "tmpfs",+      Secret <$ string "secret",+      Ssh <$ string "ssh"+    ]++mountArgUid :: (?esc :: Char) => Parser RunMountArg+mountArgUid = MountArgUid <$> key "uid" stringArg++mountArgRelabel :: Parser RunMountArg+mountArgRelabel = MountArgRelabel <$> key "relabel" relabel++relabel :: Parser Relabel+relabel = choice [RelabelShared <$ string "shared", RelabelPrivate <$ string "private"]++toArgName :: RunMountArg -> Text+toArgName (MountArgEnv _) = "env"+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"+toArgName (MountArgRelabel _) = "relabel"
src/Language/Docker/PrettyPrint.hs view
@@ -1,37 +1,33 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoMonomorphismRestriction #-}  module Language.Docker.PrettyPrint where -import Data.List.NonEmpty as NonEmpty (NonEmpty(..), toList)-import Data.Maybe (Maybe(..))-import Data.Semigroup ((<>))+import Data.List.NonEmpty as NonEmpty (NonEmpty (..), toList)+import Data.Set (Set) import Data.String (fromString) import Data.Text (Text)+import Prettyprinter+import Prettyprinter.Internal (Doc (Empty))+import Prettyprinter.Render.Text (renderLazy)+import Language.Docker.Syntax+import Prelude hiding ((<>), (>>))+import qualified Data.Set as Set 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.Render.Text (renderLazy)-import Language.Docker.Syntax-import Prelude hiding ((<>), (>>), return) -data EscapeAccum = EscapeAccum-    { buffer :: !B.Builder-    , count :: !Int-    , escaping :: !Bool-    }--instance Pretty (Arguments Text) where-    pretty = prettyPrintArguments+data EscapeAccum+  = EscapeAccum+      { buffer :: !B.Builder,+        count :: !Int,+        escaping :: !Bool+      }  -- | Pretty print a 'Dockerfile' to a 'Text' prettyPrint :: Dockerfile -> L.Text@@ -39,13 +35,23 @@   where     opts = LayoutOptions Unbounded -prettyPrintDockerfile :: Pretty (Arguments args) => [InstructionPos args] -> Doc ann+prettyPrintDockerfile :: [InstructionPos Text] -> Doc ann prettyPrintDockerfile instr = doPrint instr <> "\n"   where-    doPrint = vsep . fmap prettyPrintInstructionPos+    doPrint ips =+      let ?esc = findEscapeChar ips+       in (vsep . fmap prettyPrintInstructionPos ) ips +findEscapeChar ::  [InstructionPos args] -> Char+findEscapeChar [] = defaultEsc+findEscapeChar (i:is) =+  case i of+    InstructionPos {instruction = (Pragma (Escape (EscapeChar c)))} -> c+    InstructionPos {instruction = (Pragma _)} -> findEscapeChar is+    _ -> defaultEsc+ -- | Pretty print a 'InstructionPos' to a 'Doc'-prettyPrintInstructionPos :: Pretty (Arguments args) => InstructionPos args -> Doc ann+prettyPrintInstructionPos :: (?esc :: Char) => InstructionPos Text -> Doc ann prettyPrintInstructionPos (InstructionPos i _ _) = prettyPrintInstruction i  prettyPrintImage :: Image -> Doc ann@@ -53,94 +59,112 @@ prettyPrintImage (Image (Just (Registry reg)) name) = pretty reg <> "/" <> pretty name  prettyPrintBaseImage :: BaseImage -> Doc ann-prettyPrintBaseImage b =-    case b of-        DigestedImage img digest alias -> do-            prettyPrintImage img-            pretty '@'-            pretty digest-            prettyAlias alias-        UntaggedImage img alias -> do-            prettyPrintImage img-            prettyAlias alias-        TaggedImage img (Tag tag) alias -> do-            prettyPrintImage img-            pretty ':'-            pretty tag-            prettyAlias alias+prettyPrintBaseImage BaseImage {..} = do+  prettyPlatform platform+  prettyPrintImage image+  prettyTag tag+  prettyDigest digest+  prettyAlias alias   where     (>>) = (<>)-    return = (mempty <>)+    prettyPlatform maybePlatform =+      case maybePlatform of+        Nothing -> mempty+        Just p -> "--platform=" <> pretty p <> " "+    prettyTag maybeTag =+      case maybeTag of+        Nothing -> mempty+        Just (Tag p) -> ":" <> pretty p     prettyAlias maybeAlias =-        case maybeAlias of-            Nothing -> mempty-            Just (ImageAlias alias) -> " AS " <> pretty alias+      case maybeAlias of+        Nothing -> mempty+        Just (ImageAlias a) -> " AS " <> pretty a+    prettyDigest maybeDigest =+      case maybeDigest of+        Nothing -> mempty+        Just (Digest d) -> "@" <> pretty d -prettyPrintPairs :: Pairs -> Doc ann-prettyPrintPairs ps = hsep $ fmap prettyPrintPair ps+prettyPrintPairs :: (?esc :: Char) => Pairs -> Doc ann+prettyPrintPairs ps = align $ sepLine $ fmap prettyPrintPair ps+  where+    sepLine = concatWith (\x y -> x <> " " <> pretty ?esc <> line <> y) -prettyPrintPair :: (Text, Text) -> Doc ann+prettyPrintPair :: (?esc :: Char) => (Text, Text) -> Doc ann prettyPrintPair (k, v) = pretty k <> pretty '=' <> doubleQoute v -prettyPrintArguments :: Arguments Text -> Doc ann+prettyPrintArguments :: (?esc :: Char) => Arguments Text -> Doc ann prettyPrintArguments (ArgumentsList as) = prettyPrintJSON (Text.words as) prettyPrintArguments (ArgumentsText as) = hsep (fmap helper (Text.words as))   where-    helper "&&" = "\\\n &&"+    helper "&&" = pretty ?esc <> "\n &&"     helper a = pretty a -prettyPrintJSON :: [Text] -> Doc ann+prettyPrintJSON :: (?esc :: Char) => [Text] -> Doc ann prettyPrintJSON args = list (fmap doubleQoute args) -doubleQoute :: Text -> Doc ann+doubleQoute :: (?esc :: Char) => Text -> Doc ann doubleQoute w = enclose dquote dquote (pretty (escapeQuotes w)) -escapeQuotes :: Text -> L.Text+escapeQuotes :: (?esc :: Char) => Text -> L.Text escapeQuotes text =-    case Text.foldr accumulate (EscapeAccum mempty 0 False) text of-        EscapeAccum buffer _ False -> B.toLazyText buffer-        EscapeAccum buffer count True ->-            case count `mod` 2 of-                0 -> B.toLazyText (B.singleton '\\' <> buffer)-                _ -> 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 ?esc <> buffer)+        _ -> B.toLazyText buffer   where     accumulate '"' EscapeAccum {buffer, escaping = False} =-        EscapeAccum (B.singleton '"' <> buffer) 0 True-    accumulate '\\' EscapeAccum {buffer, escaping = True, count} =-        EscapeAccum (B.singleton '\\' <> buffer) (count + 1) True+      EscapeAccum (B.singleton '"' <> buffer) 0 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+      | c == ?esc = EscapeAccum (B.singleton ?esc <> buffer) (count + 1) True+      | even count = EscapeAccum (B.singleton c <> B.singleton ?esc <> buffer) 0 False+      | otherwise = EscapeAccum (B.singleton c <> buffer) 0 False -- It was already escaped     accumulate c EscapeAccum {buffer, escaping = False} =-        EscapeAccum (B.singleton c <> buffer) 0 False+      EscapeAccum (B.singleton c <> buffer) 0 False -prettyPrintPort :: Port -> Doc ann-prettyPrintPort (PortStr str) = pretty str-prettyPrintPort (PortRange start stop TCP) = pretty start <> "-" <> pretty stop-prettyPrintPort (PortRange start stop UDP) = pretty start <> "-" <> pretty stop <> "/udp"-prettyPrintPort (Port num TCP) = pretty num <> "/tcp"-prettyPrintPort (Port num UDP) = pretty num <> "/udp"+prettyPrintPortSpec :: PortSpec -> Doc ann+prettyPrintPortSpec (PortSpec port) = pretty port+prettyPrintPortSpec (PortRangeSpec portrange) = pretty portrange  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] +prettyPrintChecksum :: Checksum -> Doc ann+prettyPrintChecksum checksum =+  case checksum of+    Checksum c -> "--checksum=" <> pretty c+    NoChecksum -> mempty+ 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 +prettyPrintChmod :: Chmod -> Doc ann+prettyPrintChmod chmod =+  case chmod of+    Chmod c -> "--chmod=" <> pretty c+    NoChmod -> mempty++prettyPrintLink :: Link -> Doc ann+prettyPrintLink link =+  case link of+    Link -> "--link"+    NoLink -> 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@@ -152,81 +176,186 @@   where     pp (Retries r) = "--retries=" <> pretty r -prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann+prettyPrintRunMount :: (?esc :: Char) => Set RunMount -> Doc ann+prettyPrintRunMount set =+  foldl (<>) "" (map printSingleMount (Set.toList set))+  where+    printSingleMount mount = "--mount="+      <> case mount of+        BindMount BindOpts {..} ->+          "type=bind"+            <> printTarget bTarget+            <> maybe mempty printSource bSource+            <> maybe mempty printFromImage bFromImage+            <> maybe mempty printReadOnly bReadOnly+            <> maybe mempty printRelabel bRelabel+        CacheMount CacheOpts {..} ->+          "type=cache"+            <> printTarget cTarget+            <> maybe mempty 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+    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+    printRelabel r = ",relabel="+      <> case r of+        RelabelShared -> printQuotable "shared"+        RelabelPrivate -> printQuotable "private"++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"++prettyPrintPragma :: PragmaDirective -> Doc ann+prettyPrintPragma (Escape (EscapeChar esc)) = "escape = " <> pretty esc+prettyPrintPragma (Syntax (SyntaxImage img)) = "syntax = " <> prettyPrintImage img++prettyPrintInstruction :: (?esc :: Char) => Instruction Text -> 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"+      prettyPrintArguments e+    Stopsignal s -> do+      "STOPSIGNAL"+      pretty s+    Workdir w -> do+      "WORKDIR"+      pretty w+    Expose (Ports ps) -> do+      "EXPOSE"+      hsep (fmap prettyPrintPortSpec ps)+    Volume dir -> do+      "VOLUME"+      pretty dir+    Run (RunArgs c RunFlags {mount, network, security}) -> do+      "RUN"+      prettyPrintRunMount mount+      prettyPrintRunNetwork network+      prettyPrintRunSecurity security+      prettyPrintArguments c+    Copy+      CopyArgs {sourcePaths, targetPath}+      CopyFlags {chmodFlag, chownFlag, linkFlag, sourceFlag, excludeFlags} -> do+        "COPY"+        prettyPrintChown chownFlag+        prettyPrintChmod chmodFlag+        prettyPrintLink linkFlag+        prettyPrintCopySource sourceFlag+        prettyPrintExcludes excludeFlags+        prettyPrintFileList sourcePaths targetPath+    Cmd c -> do+      "CMD"+      prettyPrintArguments c+    Label l -> do+      "LABEL"+      prettyPrintPairs l+    Env ps -> do+      "ENV"+      prettyPrintPairs ps+    User u -> do+      "USER"+      pretty u+    Pragma p -> do+      pretty '#'+      prettyPrintPragma p+    Comment s -> do+      pretty '#'+      pretty s+    OnBuild i' -> do+      "ONBUILD"+      prettyPrintInstruction i'+    From b -> do+      "FROM"+      prettyPrintBaseImage b+    Add+      AddArgs {sourcePaths, targetPath}+      AddFlags {checksumFlag, chownFlag, chmodFlag, linkFlag, excludeFlags} -> do+        "ADD"+        prettyPrintChecksum checksumFlag+        prettyPrintChown chownFlag+        prettyPrintChmod chmodFlag+        prettyPrintLink linkFlag+        prettyPrintExcludes excludeFlags+        prettyPrintFileList sourcePaths targetPath+    Shell args -> do+      "SHELL"+      prettyPrintArguments args+    Healthcheck NoCheck -> "HEALTHCHECK NONE"+    Healthcheck (Check CheckArgs {..}) -> do+      "HEALTHCHECK"+      prettyPrintDuration "--interval=" interval+      prettyPrintDuration "--timeout=" timeout+      prettyPrintDuration "--start-period=" startPeriod+      prettyPrintDuration "--start-interval" startInterval+      prettyPrintRetries retries+      "CMD"+      prettyPrintArguments checkCommand   where     (>>) = spaceCat-    return a = a++prettyPrintExcludes :: [Exclude] -> Doc ann+prettyPrintExcludes excludes = hsep (fmap prettyPrintExclude excludes)++prettyPrintExclude :: Exclude -> Doc ann+prettyPrintExclude (Exclude e) = "--exclude=" <> pretty e  spaceCat :: Doc ann -> Doc ann -> Doc ann spaceCat a Empty = a
src/Language/Docker/Syntax.hs view
@@ -1,187 +1,415 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies,-  DuplicateRecordFields, FlexibleInstances, DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} -module Language.Docker.Syntax where+module Language.Docker.Syntax+  ( module Language.Docker.Syntax,+    module Language.Docker.Syntax.Port,+    module Language.Docker.Syntax.PortRange,+    module Language.Docker.Syntax.Protocol+  )+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 Data.Set (Set) import qualified Data.Text as Text import Data.Time.Clock (DiffTime)-import GHC.Exts (IsList(..))+import GHC.Exts (IsList (..))+import Text.Printf -data Image = Image-    { registryName :: !(Maybe Registry)-    , imageName :: !Text-    } deriving (Show, Eq, Ord) +import Language.Docker.Syntax.Port+import Language.Docker.Syntax.PortRange+import Language.Docker.Syntax.Protocol+++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) -data Protocol-    = TCP-    | UDP-    deriving (Show, Eq, Ord)+newtype Digest+  = Digest+      { unDigest :: Text+      }+  deriving (Show, Eq, Ord, IsString) -data Port-    = Port !Int-           !Protocol-    | PortStr !Text-    | PortRange !Int-                !Int-                !Protocol-    deriving (Show, Eq, Ord)+data PortSpec+  = PortSpec !Port+  | PortRangeSpec !PortRange+  deriving (Show, Eq, Ord) -newtype Ports = Ports-    { unPorts :: [Port]-    } deriving (Show, Eq, Ord)+newtype Ports+  = Ports+      { unPorts :: [PortSpec]+      }+  deriving (Show, Eq, Ord)  instance IsList Ports where-    type Item Ports = Port-    fromList = Ports-    toList (Ports ps) = ps+  type Item Ports = PortSpec+  fromList = Ports+  toList (Ports ps) = ps  type Directory = Text -newtype ImageAlias = ImageAlias-    { unImageAlias :: Text-    } deriving (Show, Eq, Ord, IsString)+type Platform = Text +newtype ImageAlias+  = ImageAlias+      { unImageAlias :: Text+      }+  deriving (Show, Eq, Ord, IsString)+ data BaseImage-    = UntaggedImage !Image-                    !(Maybe ImageAlias)-    | TaggedImage !Image-                  !Tag-                  !(Maybe ImageAlias)-    | DigestedImage !Image-                    !Text-                    !(Maybe ImageAlias)-    deriving (Eq, Ord, Show)+  = 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 Relabel+  = RelabelShared+  | RelabelPrivate+  deriving (Show, Eq, Ord)++data Checksum+  = Checksum !Text+  | NoChecksum+  deriving (Show, Eq, Ord)++instance IsString Checksum where+  fromString ch =+    case ch of+      "" -> NoChecksum+      _ -> Checksum (Text.pack ch)+ 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 Chmod+  = Chmod !Text+  | NoChmod+  deriving (Show, Eq, Ord)++instance IsString Chmod where+  fromString ch =+    case ch of+      "" -> NoChmod+      _ -> Chmod (Text.pack ch)++data Link+  = Link+  | NoLink+  deriving (Show, Eq, Ord)+ 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, Fractional) -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+      }+  deriving (Show, Eq, Ord) -data AddArgs = AddArgs-    { sourcePaths :: NonEmpty SourcePath-    , targetPath :: !TargetPath-    , chownFlag :: !Chown-    } deriving (Show, Eq, Ord)+data CopyFlags+  = CopyFlags+      { chownFlag :: !Chown,+        chmodFlag :: !Chmod,+        linkFlag :: !Link,+        sourceFlag :: !CopySource,+        excludeFlags :: ![Exclude]+      }+  deriving (Show, Eq, Ord) +instance Default CopyFlags where+  def = CopyFlags NoChown NoChmod NoLink NoSource []++data AddArgs+  = AddArgs+      { sourcePaths :: NonEmpty SourcePath,+        targetPath :: !TargetPath+      }+  deriving (Show, Eq, Ord)++data AddFlags+  = AddFlags+      { checksumFlag :: !Checksum,+        chownFlag :: !Chown,+        chmodFlag :: !Chmod,+        linkFlag :: !Link,+        excludeFlags :: ![Exclude]+      }+  deriving (Show, Eq, Ord)++instance Default AddFlags where+  def = AddFlags NoChecksum NoChown NoChmod NoLink []++newtype Exclude+  = Exclude+      { unExclude :: Text+      }+  deriving (Show, Eq, Ord, IsString)+ 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),+        startInterval :: !(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),+        bRelabel :: !(Maybe Relabel)+      }+  deriving (Show, Eq, Ord)++instance Default BindOpts where+  def = BindOpts "" Nothing Nothing Nothing Nothing++data CacheOpts+  = CacheOpts+      { cTarget :: !TargetPath,+        cSharing :: !(Maybe CacheSharing),+        cCacheId :: !(Maybe Text),+        cReadOnly :: !(Maybe Bool),+        cFromImage :: !(Maybe Text),+        cSource :: !(Maybe SourcePath),+        cMode :: !(Maybe Text),+        cUid :: !(Maybe Text),+        cGid :: !(Maybe Text)+      }+  deriving (Show, Eq, Ord)++instance Default CacheOpts where+  def = CacheOpts "" Nothing 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),+        sEnv :: !(Maybe Text),+        sMode :: !(Maybe Text),+        sUid :: !(Maybe Text),+        sGid :: !(Maybe Text)+      }+  deriving (Eq, Show, Ord)++instance Default SecretOpts where+  def = SecretOpts Nothing 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 :: !(Set RunMount),+        security :: !(Maybe RunSecurity),+        network :: !(Maybe RunNetwork)+      }+  deriving (Show, Eq, Ord)++instance Default RunFlags where+  def = RunFlags mempty 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+        { mount = mempty,+          security = Nothing,+          network = Nothing+        }++newtype EscapeChar+  = EscapeChar+      { escape :: Char+      }+  deriving (Show, Eq, Ord)++instance IsChar EscapeChar where+  fromChar c =+    EscapeChar {escape = c}+  toChar e = escape e++newtype SyntaxImage+  = SyntaxImage+      { syntax :: Image+      }+  deriving (Show, Eq, Ord)++data PragmaDirective+  = Escape !EscapeChar+  | Syntax !SyntaxImage+  deriving (Show, Eq, Ord)+ -- | All commands available in Dockerfiles data Instruction args-    = From !BaseImage-    | 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 !AddFlags+  | User !Text+  | Label !Pairs+  | Stopsignal !Text+  | Copy !CopyArgs !CopyFlags+  | 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)+  | Pragma !PragmaDirective+  | Comment !Text+  | OnBuild !(Instruction args)+  deriving (Eq, Ord, Show, Functor)  type Filename = Text @@ -189,8 +417,13 @@  -- | '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)++defaultEsc :: Char+defaultEsc = '\\'
− src/Language/Docker/Syntax/Lift.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Language.Docker.Syntax.Lift where--import qualified Data.ByteString as ByteString-import Data.Fixed (Fixed)-import Data.List.NonEmpty (NonEmpty)-import qualified Data.Text as Text-import Data.Time.Clock (DiffTime)-import Language.Haskell.TH.Lift-import Language.Haskell.TH.Syntax ()--import Language.Docker.Syntax--instance Lift ByteString.ByteString where-    lift b = [|ByteString.pack $(lift $ ByteString.unpack b)|]--instance Lift Text.Text where-    lift b = [|Text.pack $(lift $ Text.unpack b)|]--deriveLift ''NonEmpty--deriveLift ''Fixed--deriveLift ''DiffTime--deriveLift ''Protocol--deriveLift ''Port--deriveLift ''Ports--deriveLift ''Registry--deriveLift ''Image--deriveLift ''ImageAlias--deriveLift ''Tag--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
+ src/Language/Docker/Syntax/Port.hs view
@@ -0,0 +1,19 @@+module Language.Docker.Syntax.Port where+++import Data.Text+import Prettyprinter+import Language.Docker.Syntax.Protocol+++-- | A port can either be a number (plus a protocol, tcp by default) or a+-- variable.+data Port+  = Port !Int !Protocol+  | PortStr !Text+  deriving (Show, Eq, Ord)+++instance Pretty Port where+  pretty (Port num proto) = pretty num <> pretty proto+  pretty (PortStr str) = pretty str
+ src/Language/Docker/Syntax/PortRange.hs view
@@ -0,0 +1,20 @@+module Language.Docker.Syntax.PortRange where+++import Prettyprinter+import Language.Docker.Syntax.Port+import Language.Docker.Syntax.Protocol+++-- | A port range starts and ends with either a number or a variable and can+-- have a protocol associated (tcp by default). The protocol of the start and+-- end port shall be ignored.+data PortRange+  = PortRange !Port !Port+  deriving (Show, Eq, Ord)+++instance Pretty PortRange where+  pretty (PortRange (Port start UDP) (Port end UDP)) = pretty start <> "-" <> pretty end <> "/udp"+  pretty (PortRange (Port start UDP) end) = pretty start <> "-" <> pretty end <> "/udp"+  pretty (PortRange start end) = pretty start <> "-" <> pretty end
+ src/Language/Docker/Syntax/Protocol.hs view
@@ -0,0 +1,15 @@+module Language.Docker.Syntax.Protocol where+++import Prettyprinter+++data Protocol+  = TCP+  | UDP+  deriving (Show, Eq, Ord)+++instance Pretty Protocol where+  pretty TCP = ""+  pretty UDP = "/udp"
− test/Language/Docker/EDSL/QuasiSpec.hs 
@@ -1,40 +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 (UntaggedImage "node" 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 (UntaggedImage "node" (Just $ ImageAlias "node-build"))-                          , Expose (Ports [Port 8080 TCP, PortStr "$PORT"])-                          , Run "apt-get update"-                          , Cmd "node something.js"-                          ]
− test/Language/Docker/EDSLSpec.hs 
@@ -1,133 +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.UntaggedImage "node"-                             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"-                                   ]
− test/Language/Docker/ExamplesSpec.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
+ test/Language/Docker/IntegrationSpec.hs view
@@ -0,0 +1,163 @@+module Language.Docker.IntegrationSpec where++import qualified Data.Text as Text+import qualified Data.Text.IO+import qualified Data.Text.Lazy.IO as L+import Language.Docker.Parser+import Language.Docker.PrettyPrint (prettyPrint, prettyPrintDockerfile)+import Test.HUnit hiding (Label)+import Test.Hspec+import Text.Megaparsec hiding (Label)++spec :: Spec+spec = do+  describe "parse file" $ do+    it "1.Dockerfile" $ do+      parsed <- parseFile "test/fixtures/1.Dockerfile"+      case parsed of+        Right a -> L.putStr $ prettyPrint a+        Left err -> assertFailure $ errorBundlePretty err++    it "2.Dockerfile" $ do+      parsed <- parseFile "test/fixtures/2.Dockerfile"+      case parsed of+        Right a -> L.putStr $ prettyPrint a+        Left err -> assertFailure $ errorBundlePretty err++    it "3.Dockerfile" $ do+      parsed <- parseFile "test/fixtures/3.Dockerfile"+      case parsed of+        Right a -> L.putStr $ prettyPrint a+        Left err -> assertFailure $ errorBundlePretty err++    it "4.Dockerfile" $ do+      parsed <- parseFile "test/fixtures/4.Dockerfile"+      case parsed of+        Right a -> L.putStr $ prettyPrint a+        Left err -> assertFailure $ errorBundlePretty err++    it "5.Dockerfile" $ do+      parsed <- parseFile "test/fixtures/5.Dockerfile"+      case parsed of+        Right a -> L.putStr $ prettyPrint a+        Left err -> assertFailure $ errorBundlePretty err++  describe "escape character detection logic" $ do+    it "ensure the pretty printer respects escape pragmas" $ do+      fromDisk <- Data.Text.IO.readFile "test/fixtures/6.Dockerfile"+      let ast = parseText fromDisk+       in case ast of+          Right a ->+             let fromAst = prettyPrintDockerfile a+              in assertEqual "error" fromDisk (Text.pack . show $ fromAst)+          Left err -> assertFailure $ errorBundlePretty err++    it "ensure escape character '\\' is used as default" $ do+      fromDisk <- Data.Text.IO.readFile "test/fixtures/7.Dockerfile"+      let ast = parseText fromDisk+       in case ast of+          Right a ->+             let fromAst = prettyPrintDockerfile a+              in assertEqual "error" fromDisk (Text.pack . show $ fromAst)+          Left err -> assertFailure $ errorBundlePretty err++    it "ensure the printer ignores escape pragmas in the wrong place" $ do+      fromDisk <- Data.Text.IO.readFile "test/fixtures/8.Dockerfile"+      let ast = parseText fromDisk+       in case ast of+          Right a ->+             let fromAst = prettyPrintDockerfile a+              in assertEqual "error" fromDisk (Text.pack . show $ fromAst)+          Left err -> assertFailure $ errorBundlePretty err++  describe "parse text" $ do+    it "1.Dockerfile" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/1.Dockerfile"+      case parseText (Text.replace "\n" "\r\n" contents) of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "2.Dockerfile" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/2.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "3.Dockerfile" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/3.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "4.Dockerfile" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/4.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "5.Dockerfile" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/5.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "1.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/1.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "2.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/2.Dockerfile"+      case parseText (Text.replace "\n" "\r\n" contents) of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "3.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/3.Dockerfile"+      case parseText (Text.replace "\n" "\r\n" contents) of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "4.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/4.Dockerfile"+      case parseText (Text.replace "\n" "\r\n" contents) of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "5.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/5.Dockerfile"+      case parseText (Text.replace "\n" "\r\n" contents) of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++  describe "parse utf encoded files with byte order mark" $ do+    it "Dockerfile UTF-8 with BOM" $ do+      parsed <- parseFile "test/fixtures/Dockerfile.bom.utf8"+      case parsed of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "Dockerfile UTF-16 Little Endian with BOM" $ do+      parsed <- parseFile "test/fixtures/Dockerfile.bom.utf16le"+      case parsed of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "Dockerfile UTF-16 Big Endian with BOM" $ do+      parsed <- parseFile "test/fixtures/Dockerfile.bom.utf16be"+      case parsed of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "Dockerfile UTF-32 Little Endian with BOM" $ do+      parsed <- parseFile "test/fixtures/Dockerfile.bom.utf32le"+      case parsed of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "Dockerfile UTF-32 Big Endian with BOM" $ do+      parsed <- parseFile "test/fixtures/Dockerfile.bom.utf32be"+      case parsed of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err
+ test/Language/Docker/ParseAddSpec.hs view
@@ -0,0 +1,137 @@+module Language.Docker.ParseAddSpec (spec) where++import Data.Default+import qualified Data.Text as Text+import Language.Docker.Syntax+import TestHelper+import Test.Hspec+++spec :: Spec+spec = do+  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") ) def,+              Add+                ( AddArgs [SourcePath "http://foo.bar/baz"] (TargetPath ".") )+                def+            ]+    it "multifiles ADD" $+      let file = Text.unlines ["ADD foo bar baz /app"]+       in assertAst+            file+            [ Add+                ( AddArgs+                    (fmap SourcePath ["foo", "bar", "baz"])+                    (TargetPath "/app")+                )+                def+            ]+    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")+                )+                def+            ]+    it "with checksum flag" $+       let file = Text.unlines ["ADD --checksum=sha256:24454f830cdd http://www.example.com/foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["http://www.example.com/foo"]) (TargetPath "bar") )+                ( AddFlags (Checksum "sha256:24454f830cdd") NoChown NoChmod NoLink [] )+            ]+    it "with chown flag" $+      let file = Text.unlines ["ADD --chown=root:root foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags NoChecksum (Chown "root:root") NoChmod NoLink [] )+            ]+    it "with chmod flag" $+      let file = Text.unlines ["ADD --chmod=640 foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags NoChecksum NoChown (Chmod "640") NoLink [] )+            ]+    it "with link flag" $+      let file = Text.unlines ["ADD --link foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags NoChecksum NoChown NoChmod Link [])+            ]+    it "with chown and chmod flag" $+      let file = Text.unlines ["ADD --chown=root:root --chmod=640 foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags NoChecksum (Chown "root:root") (Chmod "640") NoLink [] )+            ]+    it "with chown and chmod flag other order" $+      let file = Text.unlines ["ADD --chmod=640 --chown=root:root foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags NoChecksum (Chown "root:root") (Chmod "640") NoLink [] )+            ]+    it "with all flags" $+      let file =+            Text.unlines ["ADD --chmod=640 --chown=root:root --checksum=sha256:24454f830cdd --link foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags (Checksum "sha256:24454f830cdd") (Chown "root:root") (Chmod "640") Link [] )+            ]+    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")+                )+                ( AddFlags NoChecksum (Chown "user:group") NoChmod NoLink [] )+            ]+    it "with exclude flag" $+      let file = Text.unlines ["ADD --exclude=*.tmp foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags NoChecksum NoChown NoChmod NoLink [Exclude "*.tmp"] )+            ]+    it "with multiple exclude flags" $+      let file = Text.unlines ["ADD --exclude=*.tmp --exclude=*.log foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags NoChecksum NoChown NoChmod NoLink [Exclude "*.tmp", Exclude "*.log"] )+            ]+    it "with exclude and other flags" $+      let file = Text.unlines ["ADD --chown=root:root --exclude=*.tmp foo bar"]+       in assertAst+            file+            [ Add+                ( AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") )+                ( AddFlags NoChecksum (Chown "root:root") NoChmod NoLink [Exclude "*.tmp"] )+            ]
+ test/Language/Docker/ParseCmdSpec.hs view
@@ -0,0 +1,64 @@+module Language.Docker.ParseCmdSpec where++import Language.Docker.Syntax+import Test.Hspec+import TestHelper+import qualified Data.Text as Text+++spec :: Spec+spec = do+  describe "parse CMD instructions" $ 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"]]++    ---------------------------------------------------------------------------+    -- This is the Dockefile statement under test (cleaned of Haskell escapes):+    --+    -- CMD [ "/bin/sh", "-c", \+    --       "echo foo && \+    --        echo bar" \+    --     ]+    it "parse exec style CMD with long broken lines" $ do+      let cmd =+            Text.unlines+              [ "CMD [ \"/bin/sh\", \"-c\", \\",+                "      \"echo foo && \\",+                "       echo bar\" \\",+                "    ]"+              ]+       in assertAst cmd [ Cmd [ "/bin/sh", "-c", "echo foo &&  echo bar" ] ]+    it "parse exec style CMD with long broken lines" $ do+      let cmd =+            Text.unlines+              [ "# escape = `",+                "CMD [ \"/bin/sh\", \"-c\", `",+                "      \"echo foo && `",+                "       echo bar\" `",+                "    ]"+              ]+       in assertAst+            cmd+            [ Pragma ( Escape ( EscapeChar '`' ) ),+              Cmd [ "/bin/sh", "-c", "echo foo &&  echo bar" ]+            ]+    ---------------------------------------------------------------------------++    it "parse exec style CMD with escaped characters" $ do+      let cmd =+            Text.unlines+              [ "CMD [ \"sbt\", \"set reStart / mainClass := Some(\\\"Main\\\");~reStart\" ]" ]+       in assertAst cmd [ Cmd [ "sbt", "set reStart / mainClass := Some(\"Main\");~reStart" ] ]+    it "parse exec style CMD with windows style escaped characters" $ do+      let cmd =+            Text.unlines+              [ "# escape = `",+                "CMD [ \"sbt\", \"set reStart / mainClass := Some(`\"Main`\");~reStart\" ]" ]+       in assertAst+            cmd+            [ Pragma ( Escape ( EscapeChar '`' ) ),+              Cmd [ "sbt", "set reStart / mainClass := Some(\"Main\");~reStart" ]+            ]
+ test/Language/Docker/ParseCopySpec.hs view
@@ -0,0 +1,267 @@+module Language.Docker.ParseCopySpec where++import Data.Default+import qualified Data.Text as Text+import Language.Docker.Syntax+import TestHelper+import Test.Hspec+++spec :: Spec+spec = do+  describe "regular Copy" $ do+    it "simple COPY" $+      let file = Text.unlines ["COPY . /app", "COPY baz /some/long/path"]+       in assertAst+            file+            [ Copy ( CopyArgs [ SourcePath "." ] ( TargetPath "/app" ) ) def,+              Copy+                ( CopyArgs+                    [ SourcePath "baz" ]+                    ( TargetPath "/some/long/path" )+                )+                def+            ]+    it "multifiles COPY" $+      let file = Text.unlines ["COPY foo bar baz /app"]+       in assertAst+            file+            [ Copy+                ( CopyArgs+                    (fmap SourcePath ["foo", "bar", "baz"])+                    (TargetPath "/app")+                )+                def+            ]+    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")+                )+                def+            ]+    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")+                )+                def+            ]+    it "does not get confused with trailing whitespace" $+      let file = Text.unlines ["COPY a b  "]+       in assertAst+            file+            [ Copy ( CopyArgs [SourcePath "a"] (TargetPath "b") ) def ]++  describe "Copy with flags" $ do+    it "with chown flag" $+      let file = Text.unlines ["COPY --chown=user:group foo bar"]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "foo" ] (TargetPath "bar") )+                ( CopyFlags ( Chown "user:group" ) NoChmod NoLink NoSource [])+            ]+    it "with chmod flag" $+      let file = Text.unlines ["COPY --chmod=777 foo bar"]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "foo" ] (TargetPath "bar") )+                ( CopyFlags NoChown ( Chmod "777" ) NoLink NoSource [])+            ]+    it "with link flag" $+      let file = Text.unlines [ "COPY --link source /target" ]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "source" ] ( TargetPath "/target" ) )+                ( CopyFlags NoChown NoChmod Link NoSource [])+            ]+    it "with from flag" $+      let file = Text.unlines ["COPY --from=node foo bar"]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "foo" ] (TargetPath "bar") )+                ( CopyFlags NoChown NoChmod NoLink ( CopySource "node" ) [])+            ]+    it "with all flags" $+      let file =+            Text.unlines+              [ "COPY --from=node --chmod=751 --link --chown=user:group foo bar" ]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "foo" ] (TargetPath "bar") )+                ( CopyFlags+                    (Chown "user:group")+                    (Chmod "751")+                    Link+                    (CopySource "node")+                    []+                )+            ]+    it "with all flags in different order" $+      let file =+            Text.unlines+              [ "COPY --link --chown=user:group --from=node --chmod=644 foo bar" ]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "foo" ] (TargetPath "bar") )+                ( CopyFlags+                    (Chown "user:group")+                    (Chmod "644")+                    Link+                    (CopySource "node")+                    []+                )+            ]+    it "with exclude flag" $+      let file = Text.unlines ["COPY --exclude=*.tmp foo bar"]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "foo" ] (TargetPath "bar") )+                ( CopyFlags NoChown NoChmod NoLink NoSource [Exclude "*.tmp"] )+            ]+    it "with multiple exclude flags" $+      let file = Text.unlines ["COPY --exclude=*.tmp --exclude=*.log foo bar"]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "foo" ] (TargetPath "bar") )+                ( CopyFlags NoChown NoChmod NoLink NoSource [Exclude "*.tmp", Exclude "*.log"] )+            ]+    it "with exclude and other flags" $+      let file = Text.unlines ["COPY --chown=root:root --exclude=*.tmp foo bar"]+       in assertAst+            file+            [ Copy+                ( CopyArgs [ SourcePath "foo" ] (TargetPath "bar") )+                ( CopyFlags (Chown "root:root") NoChmod NoLink NoSource [Exclude "*.tmp"] )+            ]++  describe "Copy with Heredocs" $ do+    it "empty heredoc" $+      let file = Text.unlines ["COPY <<EOF /target", "EOF"]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [SourcePath "EOF"] (TargetPath "/target") )+                  def+              ]+    it "foo heredoc" $+      let file = Text.unlines ["COPY <<FOO /target", "foo", "FOO"]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [SourcePath "FOO"] (TargetPath "/target") )+                  def+              ]+    it "foo heredoc lowercase +extensions" $+      let file =+            Text.unlines+              [ "COPY <<foo.txt /target", "foo content", "line 2", "foo.txt" ]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [SourcePath "foo.txt"] (TargetPath "/target") )+                  def+              ]+    it "foo heredoc single quoted marker" $+      let file = Text.unlines ["COPY <<\'FOO\' /target", "foo", "FOO"]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [SourcePath "FOO"] (TargetPath "/target") )+                  def+              ]+    it "foo heredoc double quoted marker" $+      let file = Text.unlines ["COPY <<\"FOO\" /target", "foo", "FOO"]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [SourcePath "FOO"] (TargetPath "/target") )+                  def+              ]+    it "foo heredoc +dash" $+      let file = Text.unlines ["COPY <<-FOO /target", "foo", "FOO"]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [SourcePath "FOO"] (TargetPath "/target") )+                  def+              ]+    it "foo heredoc single quoted marker +dash" $+      let file = Text.unlines ["COPY <<-\'FOO\' /target", "foo", "FOO"]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [ SourcePath "FOO" ] ( TargetPath "/target" ) )+                  def+              ]+    it "foo heredoc double quoted marker +dash" $+      let file = Text.unlines ["COPY <<-\"FOO\" /target", "foo", "FOO"]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [ SourcePath "FOO" ] ( TargetPath "/target" ) )+                  def+              ]+    it "multiple heredocs" $+      let file =+            Text.unlines+              [ "COPY <<FOO <<BAR /target", "foo", "FOO", "bar", "BAR" ]+       in assertAst+            file+              [ Copy+                  ( CopyArgs+                      [ SourcePath "FOO", SourcePath "BAR" ]+                      ( TargetPath "/target" )+                  )+                  def+              ]+    it "multiple heredocs with single/double quotes and dash mixed" $+      let file =+            Text.unlines+              [ "COPY <<FOO <<-\"BAR\" <<\'FIZZ\' <<-BUZZ /target",+                "foo",+                "FOO",+                "bar",+                "BAR",+                "fizz",+                "FIZZ",+                "buss",+                "BUZZ"+              ]+       in assertAst+            file+              [ Copy+                  ( CopyArgs+                      [ SourcePath "FOO",+                        SourcePath "BAR",+                        SourcePath "FIZZ",+                        SourcePath "BUZZ"+                      ]+                      ( TargetPath "/target" )+                  )+                  def+              ]+    it "foo heredoc with line continuations" $+      let file = Text.unlines ["COPY <<FOO /target", "foo \\", "bar", "FOO"]+       in assertAst+            file+              [ Copy+                  ( CopyArgs [ SourcePath "FOO" ] ( TargetPath "/target" ) )+                  def+              ]
+ test/Language/Docker/ParseExposeSpec.hs view
@@ -0,0 +1,146 @@+module Language.Docker.ParseExposeSpec where++import Language.Docker.Syntax+import TestHelper+import Test.Hspec+++spec :: Spec+spec = do+  describe "parse EXPOSE" $ do++    it "should handle number ports" $+      let content = "EXPOSE 8080"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortSpec (Port 8080 TCP)+                    ]+                )+            ]++    it "should handle many number ports" $+      let content = "EXPOSE 8080 8081"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortSpec (Port 8080 TCP),+                      PortSpec (Port 8081 TCP)+                    ]+                )+            ]++    it "should handle ports with protocol" $+      let content = "EXPOSE 8080/TCP 8081/UDP"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortSpec (Port 8080 TCP),+                      PortSpec (Port 8081 UDP)+                    ]+                )+            ]++    it "should handle ports with protocol and variables" $+      let content = "EXPOSE $PORT 8080 8081/UDP"+       in assertAst+            content+            [ Expose+                ( Ports+                  [ PortSpec (PortStr "$PORT"),+                    PortSpec (Port 8080 TCP),+                    PortSpec (Port 8081 UDP)+                  ]+                )+            ]++    it "should handle port ranges" $+      let content = "EXPOSE 80 81 8080-8085"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortSpec (Port 80 TCP),+                      PortSpec (Port 81 TCP),+                      PortRangeSpec+                        ( PortRange (Port 8080 TCP) (Port 8085 TCP) )+                    ]+                )+            ]++    it "should handle udp port ranges" $+      let content = "EXPOSE 80 81 8080-8085/udp"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortSpec (Port 80 TCP),+                      PortSpec (Port 81 TCP),+                      PortRangeSpec+                        ( PortRange (Port 8080 UDP) (Port 8085 UDP) )+                    ]+                )+            ]++    it "should handle one variable port ranges 1" $+      let content = "EXPOSE 8080-${bar}/udp"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortRangeSpec+                        ( PortRange (Port 8080 UDP) (PortStr "${bar}") )+                    ]+                )+            ]++    it "should handle one variable port ranges 2" $+      let content = "EXPOSE ${foo}-8080/udp"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortRangeSpec+                        ( PortRange (PortStr "${foo}") (Port 8080 UDP) )+                    ]+                )+            ]++    it "should handle two variables port ranges" $+      let content = "EXPOSE ${foo}-${bar}/udp"+       in assertAst+            content+            [ Expose+                ( Ports+                    [ PortRangeSpec+                        ( PortRange (PortStr "${foo}") (PortStr "${bar}") )+                    ]+                )+            ]++    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+                    [ PortSpec (PortStr "${PORT}"),+                      PortSpec (PortStr "${PORT_SSL}"),+                      PortSpec (PortStr "${PORT_HTTP}"),+                      PortSpec (PortStr "${PORT_HTTPS}"),+                      PortSpec (PortStr "${PORT_REP}"),+                      PortSpec (PortStr "${PORT_ADMIN}"),+                      PortSpec (PortStr "${PORT_ADMIN_HTTP}")+                    ]+                )+            ]+    it "should fail with wrong protocol" $+      let content = "EXPOSE 80/ip"+       in expectFail content
+ test/Language/Docker/ParseHealthcheckSpec.hs view
@@ -0,0 +1,89 @@+module Language.Docker.ParseHealthcheckSpec where++import Language.Docker.Syntax+import Test.Hspec+import TestHelper+import qualified Data.Text as Text+++spec :: Spec+spec = do+  describe "parse HEALTHCHECK" $ do+    it "parse healthcheck with interval" $+      assertAst+        "HEALTHCHECK --interval=5m \\\nCMD curl -f http://localhost/"+        [ Healthcheck $+            Check $+              CheckArgs "curl -f http://localhost/" (Just 300) Nothing Nothing Nothing 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 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 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 Nothing+        ]+    it "parse healthcheck with start-interval" $+      assertAst+        "HEALTHCHECK --start-interval=4m CMD curl -f http://localhost/"+        [ Healthcheck $+            Check $+              CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing (Just 240) Nothing+        ]+    it "parse healthcheck with all flags" $+      assertAst+        "HEALTHCHECK --start-period=2s --start-interval=10s --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 10)+                (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 Nothing+        ]++    it "fractional arguments to flags" $+      let file =+            Text.unlines+              [ "HEALTHCHECK \\",+                "  --interval=0.5s \\",+                "  --timeout=0.1s \\",+                "  --start-period=0.2s \\",+                "  --start-interval=0.5s \\",+                "  CMD curl -f http://localhost"+              ]+       in assertAst+            file+            [ Healthcheck $+                Check $+                  CheckArgs+                    "curl -f http://localhost"+                    ( Just 0.5 )+                    ( Just 0.10000000149 )+                    ( Just 0.20000000298 )+                    ( Just 0.5 )+                    Nothing+            ]
+ test/Language/Docker/ParsePragmaSpec.hs view
@@ -0,0 +1,71 @@+module Language.Docker.ParsePragmaSpec where++import qualified Data.Text as Text+import Language.Docker.Syntax+import TestHelper+import Test.Hspec+++spec :: Spec+spec = do+  describe "parse # pragma" $ do+    it "# escape = \\" $+      let dockerfile = Text.unlines ["# escape = \\\\"]  -- this need double escaping for some reason.+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '\\'})]+    it "#escape=`" $+      let dockerfile = Text.unlines ["#escape=`"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# escape=`" $+      let dockerfile = Text.unlines ["# escape=`"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "#escape =`" $+      let dockerfile = Text.unlines ["#escape =`"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "#escape= `" $+      let dockerfile = Text.unlines ["#escape= `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# escape =`" $+      let dockerfile = Text.unlines ["# escape =`"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "#escape = `" $+      let dockerfile = Text.unlines ["#escape = `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# escape = `" $+      let dockerfile = Text.unlines ["# escape = `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# Escape = `" $+      let dockerfile = Text.unlines ["# escape = `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# ESCAPE = `" $+      let dockerfile = Text.unlines ["# escape = `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "#syntax=docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["#syntax=docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# syntax=docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax=docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "#syntax =docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["#syntax =docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "#syntax= docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["#syntax= docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# syntax =docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax =docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "#syntax = docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["#syntax = docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# syntax= docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax= docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# syntax = docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# Syntax = docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# SYNTAX = docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]
+ test/Language/Docker/ParseRunSpec.hs view
@@ -0,0 +1,736 @@+module Language.Docker.ParseRunSpec where++import Data.Default.Class (def)+import Language.Docker.Syntax+import Test.Hspec+import TestHelper+import qualified Data.Set as Set+import qualified Data.Text as Text+++spec :: Spec+spec = do+  describe "parse RUN instructions" $ 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 "escaped linebreak, indented" $+      let file = Text.unlines [ "RUN foo ; \\", "    bar" ]+       in assertAst file [ Run "foo ;  bar" ]+    it "does not choke on unmatched brackets" $+      let dockerfile = Text.unlines ["RUN [foo"]+       in assertAst dockerfile [Run "[foo"]+    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 "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 = Set.singleton $ 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 = Set.singleton $ 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,relabel=shared echo foo"]+          flags = def {mount = Set.singleton $ BindMount (BindOpts {bTarget = "/foo", bSource = Just "/bar", bFromImage = Just "ubuntu", bReadOnly = Just True, bRelabel = Just RelabelShared})}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=cache with target" $+      let file =+            Text.unlines+              [ "RUN --mount=type=cache,target=/foo echo foo",+                "RUN --mount=type=cache,target=/bar echo foo",+                "RUN --mount=type=cache,target=/baz echo foo"+              ]+          flags1 = def {mount = Set.singleton $ CacheMount (def {cTarget = "/foo"})}+          flags2 = def {mount = Set.singleton $ CacheMount (def {cTarget = "/bar"})}+          flags3 = def {mount = Set.singleton $ CacheMount (def {cTarget = "/baz"})}+       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 id from variable/arg" $+      let file =+            Text.unlines+              [ "ARG debian_version=12",+                "FROM debian:bookworm-slim",+                "RUN --mount=id=debian:${debian_version},type=cache,target=/foo foo bar"+              ]+          flags = def {mount = Set.singleton $ CacheMount (def {cTarget = "/foo", cCacheId = Just "debian:${debian_version}"})}+       in assertAst+            file+            [ Arg "debian_version" (Just "12"),+              From $ BaseImage+                        { image = Image+                                    { registryName = Nothing,+                                      imageName="debian"+                                    },+                          tag = Just Tag { unTag="bookworm-slim" },+                          digest = Nothing,+                          alias = Nothing,+                          platform = Nothing+                        },+              Run $ RunArgs (ArgumentsText "foo bar") flags+            ]++    it "--mount=type=cache,dst=/foo" $+      let file = Text.unlines [ "RUN --mount=type=cache,dst=/foo echo foo" ]+          flags = def {mount = Set.singleton $ CacheMount (def {cTarget = "/foo"})}+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flags ]++    it "--mount=dst=/foo,type=cache" $+      let file = Text.unlines [ "RUN --mount=dst=/foo,type=cache echo foo" ]+          flags = def {mount = Set.singleton $ CacheMount (def {cTarget = "/foo"})}+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flags ]++    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 =+                  Set.singleton $+                    CacheMount+                      ( def+                          { cTarget = "/foo",+                            cSharing = Just 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=cache with all modifiers, different order" $+      let file =+            Text.unlines+              [ "RUN --mount=readonly,sharing=private,id=a,type=cache,from=ubuntu,source=/bar,destination=/foo,mode=0700,uid=0,gid=0 echo foo"+              ]+          flags =+            def+              { mount =+                  Set.singleton $+                    CacheMount+                      ( def+                          { cTarget = "/foo",+                            cSharing = Just 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 = Set.singleton $ 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 = Set.singleton $ SshMount def}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=ssh,required=false" $+      let file = Text.unlines ["RUN --mount=type=ssh,required=false echo foo"]+          flags = def {mount = Set.singleton $ SshMount def {sIsRequired = Just False}}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=ssh,required=False" $+      let file = Text.unlines ["RUN --mount=type=ssh,required=False echo foo"]+          flags = def {mount = Set.singleton $ SshMount def {sIsRequired = Just False}}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=secret,required=true" $+      let file = Text.unlines ["RUN --mount=type=secret,required=true echo foo"]+          flags = def {mount = Set.singleton $ SecretMount def {sIsRequired = Just True}}+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "--mount=type=secret,required=True" $+      let file = Text.unlines ["RUN --mount=type=secret,required=True echo foo"]+          flags = def {mount = Set.singleton $ SecretMount def {sIsRequired = Just True}}+       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 =+                  Set.singleton $+                    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=ssh all modifiers, required explicit" $+      let file = Text.unlines ["RUN --mount=type=ssh,target=/foo,id=a,required=true,source=/bar,mode=0700,uid=0,gid=0 echo foo"]+          flags =+            def+              { mount =+                  Set.singleton $+                    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,env=baz,id=a,required,source=/bar,mode=0700,uid=0,gid=0 echo foo"]+          flags =+            def+              { mount =+                  Set.singleton $+                    SecretMount+                      ( def+                          { sTarget = Just "/foo",+                            sEnv = Just "baz",+                            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, required explicit" $+      let file = Text.unlines ["RUN --mount=type=secret,target=/foo,env=baz,id=a,required=true,source=/bar,mode=0700,uid=0,gid=0 echo foo"]+          flags =+            def+              { mount =+                  Set.singleton $+                    SecretMount+                      ( def+                          { sTarget = Just "/foo",+                            sEnv = Just "baz",+                            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=cache uid/gid=$var" $+      let file = Text.unlines ["RUN --mount=type=cache,target=/foo,uid=$VAR_UID,gid=$VAR_GID echo foo"]+          flags =+            def+              { mount =+                  Set.singleton $+                    CacheMount+                      ( def+                          { cTarget = TargetPath "/foo",+                            cUid = Just "$VAR_UID",+                            cGid = Just "$VAR_GID"+                          }+                      )+              }+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "multiple --mount=type=cache flags" $+      let file = Text.unlines+                  [ "RUN --mount=type=cache,target=/foo \\",+                    "    --mount=type=cache,target=/bar \\",+                    "    echo foo"+                  ]+          flags =+            def+              { mount =+                  Set.fromList+                    [ CacheMount ( def { cTarget = TargetPath "/foo" } ),+                      CacheMount ( def { cTarget = TargetPath "/bar" } )+                    ]+              }+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]+    it "multiple different --mount flags" $+      let file = Text.unlines+                  [ "RUN --mount=type=cache,target=/foo \\",+                    "    --mount=type=secret,target=/bar \\",+                    "    echo foo"+                  ]+          flags =+            def+              { mount =+                  Set.fromList+                    [ CacheMount ( def { cTarget = TargetPath "/foo" } ),+                      SecretMount ( def { sTarget = Just "/bar" } )+                    ]+              }+       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 = Set.singleton $ BindMount $ def {bTarget = "/foo"}+              }+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]++  describe "RUN with --mount flag and different ways to write ro/rw" $ do+    let flagsRo = def { mount = Set.singleton $+                                BindMount+                                  ( def+                                      { bTarget = "/foo",+                                        bSource = Just "/bar",+                                        bReadOnly = Just True+                                      }+                                  )+                    }+        flagsRw = def { mount = Set.singleton $+                                BindMount+                                  ( def+                                      { bTarget = "/foo",+                                        bSource = Just "/bar",+                                        bReadOnly = Just False+                                      }+                                  )+                    }+     in do+      it "--mount=type=bind,ro" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,ro echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,RO" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,RO echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,readonly" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readonly echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,Readonly" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,Readonly echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,ro=true" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,ro=true echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,RO=TRUE" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,RO=TRUE echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,readonly=true" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readonly=true echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,Readonly=True" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,Readonly=True echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,ro=True" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,ro=True echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,readonly=True" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readonly=True echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,rw=false" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,rw=false echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,readwrite=false" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readwrite=false echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,rw=False" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,rw=False echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]+      it "--mount=type=bind,readwrite=False" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readwrite=False echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRo ]++      it "--mount=type=bind,rw" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,rw echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,readwrite" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readwrite echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,rw=true" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,rw=true echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,readwrite=true" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readwrite=true echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,rw=True" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,rw=True echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,readwrite=True" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readwrite=True echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,ro=false" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,ro=false echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,readonly=false" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readonly=false echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,ro=False" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,ro=False echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]+      it "--mount=type=bind,readonly=False" $+        let file = Text.unlines+              [ "RUN --mount=type=bind,target=/foo,source=/bar,readonly=False echo foo" ]+         in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRw ]++  describe "parse RUN in heredocs format" $ do+    it "foo heredoc" $+      let file = Text.unlines [ "RUN <<EOF", "foo", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "foo heredoc without newline at end" $+      let file = "RUN <<EOF\nfoo\nEOF"+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "foo heredoc marker" $+      let file = Text.unlines [ "RUN <<FOO", "foo", "FOO" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "foo heredoc quoted marker" $+      let file = Text.unlines [ "RUN <<\"FOO\"", "foo", "FOO" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "foo heredoc single quoted marker" $+      let file = Text.unlines [ "RUN <<\'FOO\'", "foo", "FOO" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "foo heredoc +dash" $+      let file = Text.unlines [ "RUN <<-FOO", "foo", "FOO" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "foo heredoc quoted +dash" $+      let file = Text.unlines [ "RUN <<-\"FOO\"", "foo", "FOO" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "foo heredoc single quoted +dash" $+      let file = Text.unlines [ "RUN <<-\'FOO\'", "foo", "FOO" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "multiline foo heredoc" $+      let file = Text.unlines [ "RUN <<EOF", "foo", "bar", "", "dodo", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo\nbar\n\ndodo") flags ]+    it "heredoc with shebang/commend" $+      let file = Text.unlines [ "RUN <<EOF", "#/usr/bin/env python", "", "#print foo", "print(\"foo\")", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "#/usr/bin/env python\n\n#print foo\nprint(\"foo\")") flags ]+    it "empty heredoc" $+      let file = Text.unlines [ "RUN <<EOF", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "") flags ]+    it "empty heredoc not followed by newline" $+      let file = "RUN <<EOF\nEOF"+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "") flags ]+    it "evil heredoc" $+      let file = Text.unlines [ "RUN <<EOF foo", "bar EOF", "EOF"]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo\nbar EOF") flags ]+    it "heredoc with redirection to file" $+      let file = Text.unlines [ "RUN <<EOF > /file", "foo", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "foo") flags ]+    it "heredoc to program stdin" $+      let file = Text.unlines [ "RUN python <<EOF", "print(\"foo\")", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "python") flags ]+    it "heredoc to program stdin with redirect to file with '>'" $+      let file = Text.unlines [ "RUN python <<EOF > /file", "print(\"foo\")", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "python") flags ]+    it "heredoc to program stdin with redirect to file with '>>'" $+      let file = Text.unlines [ "RUN python <<EOF >> /file", "print(\"foo\")", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "python") flags ]+    it "heredoc pipe to program" $+      let file = Text.unlines [ "RUN cat <<EOF | sh", "echo foo", "EOF" ]+          flags = def { security = Nothing }+       in assertAst file [ Run $ RunArgs ( ArgumentsText "cat" ) flags ]+    it "heredoc with line continuation in the heredoc" $+      let file = Text.unlines [ "RUN <<EOF", "apt-get update", "apt-get install foo bar \\", "  buzz bar", "EOF" ]+          flags = def {security = Nothing }+       in assertAst+            file+            [ Run $ RunArgs+                      ( ArgumentsText+                          "apt-get update\napt-get install foo bar \\\n  buzz bar"+                      )+                      flags+            ]+    it "heredoc correct termination" $+      let file = Text.unlines [ "RUN <<EOF", "echo $EOF", "EOF" ]+          flags = def {security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo $EOF") flags ]+    it "heredoc correct termination without newline" $+      let file = "RUN <<EOF\necho $EOF\nEOF"+          flags = def {security = Nothing }+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo $EOF") flags ]++    -- This one is neccessary to make sure that we can both parse+    -- RUN something <<EOF+    -- bla+    -- EOF+    --+    -- and not overshoot while parsing that `something` and accidentally parse+    -- some docker instructions as well.+    it "heredoc no overzealous parsing" $+      let file =+            Text.unlines+              [ "RUN foo bar",+                "FROM something",+                "COPY <<EOF /foobar.sh",+                "#!/bin/bash",+                "echo foobar",+                "EOF"+              ]+          flags = def+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "foo bar") flags,+              From+                ( BaseImage+                    { image =+                        Image+                          { registryName = Nothing,+                            imageName = "something"+                          },+                      tag = Nothing,+                      digest = Nothing,+                      alias = Nothing,+                      platform = Nothing+                    }+                ),+              Copy+                ( CopyArgs+                    [ SourcePath "EOF" ]+                    (TargetPath "/foobar.sh")+                )+                ( def :: CopyFlags )+            ]++    -- See https://github.com/hadolint/hadolint/issues/923 for the following+    -- tests+    it "heredoc in command chain with escaped newlines after redirect" $+      let file =+            Text.unlines+              [ "RUN ls && cat <<EOF >> go.mod && \\",+                "    tac go.mod",+                "replace (",+                "    github.com/user/repo => ../dir",+                ")",+                "EOF"+              ]+          flags = def++       in assertAst+            file+            [ Run $ RunArgs ( ArgumentsText "ls && cat" ) flags+            ]++    it "heredoc in command chain with escaped newlines before heredoc" $+      let file =+            Text.unlines+              [ "RUN ls && \\",+                "    cat <<EOF >> go.mod && tac go.mod",+                "replace (",+                "    github.com/user/repo => ../dir",+                ")",+                "EOF"+              ]+          flags = def++       in assertAst+            file+            [ Run $ RunArgs ( ArgumentsText "ls &&  cat" ) flags+            ]++    it "heredoc in command chain with escaped newlines before and after heredoc" $+      let file =+            Text.unlines+              [ "RUN ls && \\",+                "    cat <<EOF >> go.mod && \\",+                "    tac go.mod",+                "replace (",+                "    github.com/user/repo => ../dir",+                ")",+                "EOF"+              ]+          flags = def++       in assertAst+            file+            [ Run $ RunArgs ( ArgumentsText "ls &&  cat" ) flags+            ]++  describe "Parse RUN instructions - invalid cases" $ do+    it "fail because of multiple types in --mount" $+      let line = "RUN --mount=type=cache,type=tmpfs,target=/foo foo bar"+       in expectFail line++  describe "Parse RUN instructions - SELinux relabeling" $ do+    let flagsRelabelShared =+          def { mount = Set.singleton $+                  BindMount+                    ( def+                        { bTarget = "/bar",+                          bRelabel = Just RelabelShared+                        }+                    )+              }+        flagsRelabelPrivate =+          def { mount = Set.singleton $+                  BindMount+                    ( def+                        { bTarget = "/bar",+                          bRelabel = Just RelabelPrivate+                        }+                    )+              }+    it "RUN with --relabel=shared" $+      let file = Text.unlines+            ["RUN --mount=type=bind,target=/bar,relabel=shared echo foo"]+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRelabelShared ]+    it "RUN with --relabel=private" $+      let file = Text.unlines+            ["RUN --mount=type=bind,target=/bar,relabel=private echo foo"]+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRelabelPrivate ]
test/Language/Docker/ParserSpec.hs view
@@ -1,372 +1,247 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-} module Language.Docker.ParserSpec where -import Language.Docker.Normalize-import Language.Docker.Parser+import Data.Default.Class (def)+import qualified Data.Text as Text import Language.Docker.Syntax---import Test.HUnit hiding (Label)+import TestHelper import Test.Hspec-import Text.Megaparsec hiding (Label)-import qualified Data.Text as Text + 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" Nothing)]-            it "parse tagged image" $-                assertAst-                    "FROM busybox:5.12-dev"-                    [From (TaggedImage "busybox" "5.12-dev" Nothing)]-            it "parse digested image" $-                assertAst-                    "FROM ubuntu@sha256:0ef2e08ed3fab"-                    [From (DigestedImage "ubuntu" "sha256:0ef2e08ed3fab" Nothing)]--        describe "parse aliased FROM" $ do-            it "parse untagged image" $-                assertAst "FROM busybox as foo" [From (UntaggedImage "busybox" (Just $ ImageAlias "foo"))]-            it "parse tagged image" $-                assertAst "FROM busybox:5.12-dev AS foo-bar" [From (TaggedImage "busybox" "5.12-dev" (Just $ ImageAlias "foo-bar"))]-            it "parse diggested image" $-                assertAst "FROM ubuntu@sha256:0ef2e08ed3fab AS foo" [From (DigestedImage "ubuntu" "sha256:0ef2e08ed3fab" (Just $ ImageAlias "foo"))]--        describe "parse FROM with registry" $ do-            it "registry without port" $-                assertAst "FROM foo.com/node" [From (UntaggedImage (Image (Just "foo.com") "node") Nothing)]-            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" Nothing)]-            it "Not a registry if no TLD" $-                assertAst-                "FROM myfolder/imagename:5.12-dev"-                [From (TaggedImage (Image Nothing "myfolder/imagename") "5.12-dev" Nothing)]--        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" Nothing)-                          , 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"]]--        describe "parse SHELL" $ do-            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)+  describe "parse ARG" $ do+    it "no default" $+      assertAst "ARG FOO" [Arg "FOO" Nothing]+    it "no default with =" $+      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")                 ]--            it "parse healthcheck with no flags" $-              assertAst-                "HEALTHCHECK CMD curl -f http://localhost/"-                [Healthcheck $-                    Check $-                      CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing Nothing+            ]+       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")                 ]--        describe "parse MAINTAINER" $ do-            it "maintainer of untagged scratch image" $-                assertAst-                    "FROM scratch\nMAINTAINER hudu@mail.com"-                    [From (UntaggedImage "scratch" Nothing), Maintainer "hudu@mail.com"]-            it "maintainer with mail" $-                assertAst "MAINTAINER hudu@mail.com" [Maintainer "hudu@mail.com"]-            it "maintainer only mail after from" $-                let maintainerFromProg = "FROM busybox\nMAINTAINER hudu@mail.com"-                    maintainerFromAst = [From (UntaggedImage "busybox" Nothing), 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" Nothing)-                                        , 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])]--        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" Nothing)]--        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 $ parseErrorPretty err-        Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile+            ]+       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 SHELL" $+    it "quoted shell params" $+      assertAst "SHELL [\"/bin/bash\",  \"-c\"]" [Shell ["/bin/bash", "-c"]]+  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 "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")]
+ test/Language/Docker/PrettyPrintSpec.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Language.Docker.PrettyPrintSpec where++import Data.Default+import qualified Data.Text as Text+import Prettyprinter+import Prettyprinter.Render.Text+import Language.Docker.Syntax+import Language.Docker.PrettyPrint+import Test.HUnit hiding (Label)+import Test.Hspec+++spec :: Spec+spec = do+  describe "pretty print ADD" $ do+    it "with just copy" $ do+      let add = Add+                  ( AddArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( def :: AddFlags )+       in assertPretty "ADD foo bar" add+    it "with just checksum" $ do+      let add = Add+                  ( AddArgs [SourcePath "http://www.example.com/foo"] (TargetPath "bar") )+                  ( AddFlags ( Checksum "sha256:24454f830cdd" ) NoChown NoChmod NoLink [])+       in assertPretty "ADD --checksum=sha256:24454f830cdd http://www.example.com/foo bar" add+    it "with just chown" $ do+      let add = Add+                  ( AddArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( AddFlags NoChecksum ( Chown "root:root" ) NoChmod NoLink [] )+       in assertPretty "ADD --chown=root:root foo bar" add+    it "with just chmod" $ do+      let add = Add+                  ( AddArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( AddFlags NoChecksum NoChown ( Chmod "751" ) NoLink [] )+       in assertPretty "ADD --chmod=751 foo bar" add+    it "with just link" $ do+      let add = Add+                  ( AddArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( AddFlags NoChecksum NoChown NoChmod Link [] )+       in assertPretty "ADD --link foo bar" add+    it "with chown, chmod and link" $ do+      let add = Add+                  ( AddArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( AddFlags NoChecksum ( Chown "root:root" ) ( Chmod "751" ) Link [] )+       in assertPretty "ADD --chown=root:root --chmod=751 --link foo bar" add+    it "with just exclude" $ do+      let add = Add+                  ( AddArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( AddFlags NoChecksum NoChown NoChmod NoLink [Exclude "*.tmp"] )+       in assertPretty "ADD --exclude=*.tmp foo bar" add+    it "with multiple exclude flags" $ do+      let add = Add+                  ( AddArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( AddFlags NoChecksum NoChown NoChmod NoLink [Exclude "*.tmp", Exclude "*.log"] )+       in assertPretty "ADD --exclude=*.tmp --exclude=*.log foo bar" add+    it "with exclude and other flags" $ do+      let add = Add+                  ( AddArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( AddFlags NoChecksum (Chown "root:root") NoChmod NoLink [Exclude "*.tmp"] )+       in assertPretty "ADD --chown=root:root --exclude=*.tmp foo bar" add++  describe "pretty print COPY" $ do+    it "with just copy" $ do+      let copy = Copy+                  ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( def :: CopyFlags )+       in assertPretty "COPY foo bar" copy+    it "with just chown" $ do+      let copy = Copy+                  ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( CopyFlags ( Chown "root:root" ) NoChmod NoLink NoSource [] )+       in assertPretty "COPY --chown=root:root foo bar" copy+    it "with just chmod" $ do+      let copy = Copy+                  ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( CopyFlags NoChown ( Chmod "751" ) NoLink NoSource [] )+       in assertPretty "COPY --chmod=751 foo bar" copy+    it "with just link" $ do+      let copy = Copy+                  ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( CopyFlags NoChown NoChmod Link NoSource [] )+       in assertPretty "COPY --link foo bar" copy+    it "with source baseimage" $ do+      let copy =+            Copy+              ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+              ( CopyFlags NoChown NoChmod NoLink ( CopySource "baseimage" ) [])+       in assertPretty "COPY --from=baseimage foo bar" copy+    it "with both chown and chmod" $ do+      let copy =+            Copy+              ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+              ( CopyFlags+                  ( Chown "root:root" ) ( Chmod "751" ) NoLink NoSource []+              )+       in assertPretty "COPY --chown=root:root --chmod=751 foo bar" copy+    it "with all flags" $ do+      let copy =+            Copy+              ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+              ( CopyFlags+                  ( Chown "root:root")+                  ( Chmod "751")+                  Link+                  ( CopySource "baseimage" )+                  []+              )+       in assertPretty+            "COPY --chown=root:root --chmod=751 --link --from=baseimage foo bar"+            copy+    it "with just exclude" $ do+      let copy = Copy+                  ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( CopyFlags NoChown NoChmod NoLink NoSource [Exclude "*.tmp"] )+       in assertPretty "COPY --exclude=*.tmp foo bar" copy+    it "with multiple exclude flags" $ do+      let copy = Copy+                  ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( CopyFlags NoChown NoChmod NoLink NoSource [Exclude "*.tmp", Exclude "*.log"] )+       in assertPretty "COPY --exclude=*.tmp --exclude=*.log foo bar" copy+    it "with exclude and other flags" $ do+      let copy = Copy+                  ( CopyArgs [SourcePath "foo"] (TargetPath "bar") )+                  ( CopyFlags (Chown "root:root") NoChmod NoLink NoSource [Exclude "*.tmp"] )+       in assertPretty "COPY --chown=root:root --exclude=*.tmp foo bar" copy++  describe "pretty print # escape" $ do+    it "# escape = \\" $ do+      let esc = Pragma (Escape (EscapeChar '\\'))+       in assertPretty "# escape = \\" esc+    it "# escape = `" $ do+      let esc = Pragma (Escape (EscapeChar '`'))+       in assertPretty "# escape = `" esc++  describe "pretty print # syntax" $ do+    it "# syntax = docker/dockerfile:1.0" $ do+      let img = Pragma+                  ( Syntax+                    ( SyntaxImage+                        ( Image+                            { registryName = Nothing,+                              imageName = "docker/dockerfile:1.0"+                            }+                        )+                    )+                  )+       in assertPretty "# syntax = docker/dockerfile:1.0" img+++assertPretty :: Text.Text -> Instruction Text.Text -> Assertion+assertPretty expected inst = assertEqual+    "prettyfied instruction not pretty enough"+    expected+    (prettyPrintStrict inst)++prettyPrintStrict :: Instruction Text.Text -> Text.Text+prettyPrintStrict =+  let ?esc = defaultEsc+   in renderStrict+      . layoutPretty (LayoutOptions Unbounded)+      . prettyPrintInstruction
+ test/TestHelper.hs view
@@ -0,0 +1,44 @@+module TestHelper+  ( assertAst,+    expectFail,+    taggedImage,+    withAlias,+    withDigest,+    withPlatform,+    untaggedImage+  )+  where++import qualified Data.Text as Text+import Language.Docker.Parser+import Language.Docker.Syntax+import Test.HUnit hiding (Label)+import Test.Hspec+import Test.Hspec.Megaparsec+import Text.Megaparsec hiding (Label)+++untaggedImage :: Image -> BaseImage+untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing++taggedImage :: Image -> Tag -> BaseImage+taggedImage n t = BaseImage n (Just t) Nothing Nothing Nothing++withDigest :: BaseImage -> Digest -> BaseImage+withDigest i d = i {digest = Just d}++withAlias :: BaseImage -> ImageAlias -> BaseImage+withAlias i a = i {alias = Just a}++withPlatform :: BaseImage -> Platform -> BaseImage+withPlatform i p = i {platform = Just p}++assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion+assertAst s ast =+  case parseText s of+    Left errmsg -> assertFailure $ errorBundlePretty errmsg+    Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile++expectFail :: HasCallStack => Text.Text -> Assertion+expectFail input =+  parseText `shouldFailOn` input
+ test/fixtures/1.Dockerfile view
@@ -0,0 +1,17 @@+FROM foo:7-slim++# An extra space after the env value should be no problem+ENV container=false\+    container2=true ++ENV A="a.sh" D="c"\+    B="installDBBinaries.sh" ++ENV X "Y" Z++ENV DOG=Rex\ The\ Dog\ +    CAT=Top\ Cat++ENV DOCKER_TLS_CERTDIR=+ENV foo\ a=afoo' bar 'baz"qu\"z"+ENV BASE_PATH		/var/spool/apt-mirror
+ test/fixtures/2.Dockerfile view
@@ -0,0 +1,16 @@+FROM scratch++RUN set -ex; \+	apt-get update; \+	if ! which gpg; then \+		apt-get install -y --no-install-recommends gnupg; \+	fi; \+	if ! gpg --version | grep -q '^gpg (GnuPG) 1\.'; then \+# Ubuntu includes "gnupg" (not "gnupg2", but still 2.x), but not dirmngr, and gnupg 2.x requires dirmngr+# so, if we're not running gnupg 1.x, explicitly install dirmngr too+		apt-get install -y --no-install-recommends dirmngr; \+	fi; \+	rm -rf /var/lib/apt/lists/*++ONBUILD ENV RUNNER_CMD_EXEC=${RUNNER_CMD_EXEC:-"java \$JAVA_OPTS -jar /runtime/server.jar \$JAR_OPTS"}+ENV BUNDLE_WITHOUT=${bundle_without:-'development test'}
+ test/fixtures/3.Dockerfile view
@@ -0,0 +1,6 @@+# escape = `++FROM debian:10++RUN first cmd `+ && second cmd
+ test/fixtures/4.Dockerfile view
@@ -0,0 +1,8 @@+#syntax=docker/dockerfile:1.0+# escape = `++FROM debian:10++RUN first cmd `+ && second cmd `+ && command C:\some\windows\style\path
+ test/fixtures/5.Dockerfile view
@@ -0,0 +1,8 @@+# this will prevent the pragma from taking effect+#syntax=docker/dockerfile:1.0+# escape = `++FROM debian:10++RUN first cmd \+ && second cmd
+ test/fixtures/6.Dockerfile view
@@ -0,0 +1,3 @@+# escape = `+RUN cmd a `+ && cmd b
+ test/fixtures/7.Dockerfile view
@@ -0,0 +1,3 @@+FROM debian:buster+RUN cmd a \+ && cmd b
+ test/fixtures/8.Dockerfile view
@@ -0,0 +1,4 @@+FROM debian:buster+# escape = `+RUN cmd a \+ && cmd b
+ test/fixtures/Dockerfile.bom.utf16be view

binary file changed (absent → 76 bytes)

+ test/fixtures/Dockerfile.bom.utf16le view

binary file changed (absent → 76 bytes)

+ test/fixtures/Dockerfile.bom.utf32be view

binary file changed (absent → 152 bytes)

+ test/fixtures/Dockerfile.bom.utf32le view

binary file changed (absent → 152 bytes)

+ test/fixtures/Dockerfile.bom.utf8 view
@@ -0,0 +1,3 @@+FROM debian:11+USER root+RUN foo bar