diff --git a/.travis.yml b/.travis.yml index de7b650..7114c1d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,13 +20,6 @@ matrix: # Nightly builds are allowed to fail - env: ARGS="--resolver nightly" - # Build on OS X in addition to Linux - - env: ARGS="--resolver lts" - os: osx - - - env: ARGS="--resolver nightly" - os: osx - - env: - PURPOSE="Integration tests" - ARGS="" diff --git a/Dockerfile b/Dockerfile deleted file mode 100644 index e8d8491..0000000 --- a/Dockerfile +++ /dev/null @@ -1,3 +0,0 @@ -FROM haskell:8 -RUN cabal update -RUN cabal install language-docker diff --git a/README.md b/README.md index 48b2ca6..db6449a 100644 --- a/README.md +++ b/README.md @@ -12,10 +12,6 @@ writting Dockerfiles in Haskell. - [Parsing files](#parsing-files) - [Parsing strings](#parsing-strings) - [Pretty-printing files](#pretty-printing-files) -- [Writing Dockerfiles in Haskell](#writing-dockerfiles-in-haskell) -- [Using the QuasiQuoter](#using-the-quasiquoter) -- [Templating Dockerfiles in Haskell](#templating-dockerfiles-in-haskell) -- [Using IO in the DSL](#using-io-in-the-dsl) ## Parsing files @@ -35,98 +31,9 @@ main = do print (parseString c) ``` -## Pretty-printing files +## Create Dockerfiles -```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 - -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 diff --git a/examples/complex.hs b/examples/complex.hs deleted file mode 100644 index fceec50..0000000 --- a/examples/complex.hs +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/env stack --silent runghc --package language-docker --package ShellCheck-0.4.4 ./dockerfile.hs --- https://github.com/mhart/alpine-node -{-# LANGUAGE QuasiQuotes #-} - -import Language.Docker - -main = - putDockerfileStr $ - [edockerfile| - # https://github.com/mhart/alpine-node - FROM mhart/alpine-node:5.5.0 - - ENV DIR=/opt/este PORT=8000 \ - # This is a docker comment - - NODE_ENV=production - - RUN apk add --update python python-dev build-base git libpng automake gettext libpng-dev autoconf make zlib-dev nasm - - COPY package.json ${DIR}/ - - RUN cd ${DIR} && npm install - - RUN cd ${DIR} && npm install stylus && npm install eslint-plugin-jsx-a11y - - COPY . $DIR - - WORKDIR $DIR - - RUN NODE_ENV=production SERVER_URL="https://beijaflor.io" npm run build -- -p - - EXPOSE $PORT - - ENTRYPOINT ["npm"] - - CMD ["start"] -|] diff --git a/examples/edsl-quasi.hs b/examples/edsl-quasi.hs deleted file mode 100644 index f6d6970..0000000 --- a/examples/edsl-quasi.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# 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 - |] - -- ... diff --git a/examples/edsl.hs b/examples/edsl.hs deleted file mode 100644 index 0610369..0000000 --- a/examples/edsl.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} - -import Language.Docker - -main = - putDockerfileStr $ do - from "node" - run "apt-get update" - cmd ["node", "app.js"] - -- ... diff --git a/examples/parse-string.hs b/examples/parse-string.hs deleted file mode 100644 index d5ef3ca..0000000 --- a/examples/parse-string.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Language.Docker - -main = do - c <- parseFile "./Dockerfile" - print c diff --git a/examples/parse.hs b/examples/parse.hs deleted file mode 100644 index 1f85578..0000000 --- a/examples/parse.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Language.Docker -main = do - ef <- parseFile "./Dockerfile" - print ef diff --git a/examples/pretty-print.hs b/examples/pretty-print.hs deleted file mode 100644 index b63f234..0000000 --- a/examples/pretty-print.hs +++ /dev/null @@ -1,6 +0,0 @@ -import qualified Data.Text.Lazy.IO as L -import Language.Docker - -main = do - Right d <- parseFile "./Dockerfile" - L.putStr (prettyPrint d) diff --git a/examples/templating-7.10.dockerfile b/examples/templating-7.10.dockerfile deleted file mode 100644 index 9c2e908..0000000 --- a/examples/templating-7.10.dockerfile +++ /dev/null @@ -1,7 +0,0 @@ -FROM haskell:7.10 -RUN cabal sandbox init -RUN cabal update -ADD mypackage.cabal /app/mypackage.cabal -RUN cabal install --only-dep -j -ADD . /app/ -RUN cabal build diff --git a/examples/templating-7.8.dockerfile b/examples/templating-7.8.dockerfile deleted file mode 100644 index ab648bd..0000000 --- a/examples/templating-7.8.dockerfile +++ /dev/null @@ -1,7 +0,0 @@ -FROM haskell:7.8 -RUN cabal sandbox init -RUN cabal update -ADD mypackage.cabal /app/mypackage.cabal -RUN cabal install --only-dep -j -ADD . /app/ -RUN cabal build diff --git a/examples/templating-8.dockerfile b/examples/templating-8.dockerfile deleted file mode 100644 index a23c2a9..0000000 --- a/examples/templating-8.dockerfile +++ /dev/null @@ -1,7 +0,0 @@ -FROM haskell:8 -RUN cabal sandbox init -RUN cabal update -ADD mypackage.cabal /app/mypackage.cabal -RUN cabal install --only-dep -j -ADD . /app/ -RUN cabal build diff --git a/examples/templating.hs b/examples/templating.hs deleted file mode 100644 index 95600cb..0000000 --- a/examples/templating.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} - -import Control.Monad -import Data.Semigroup ((<>)) -import Language.Docker -import Language.Docker.Syntax - -tags :: [Tag] -tags = ["7.8", "7.10", "8"] - -cabalSandboxBuild packageName = do - let cabalFile = packageName <> ".cabal" - run "cabal sandbox init" - run "cabal update" - add [SourcePath cabalFile] (TargetPath $ "/app/" <> cabalFile) - run "cabal install --only-dep -j" - add ["."] "/app/" - run "cabal build" - -main = - forM_ tags $ \tag -> do - let df = - toDockerfile $ do - from ("haskell" `tagged` tag) - cabalSandboxBuild "mypackage" - name = "./examples/templating-" <> unTag tag <> ".dockerfile" - writeDockerFile name df diff --git a/examples/test-dockerfile.dockerfile b/examples/test-dockerfile.dockerfile deleted file mode 100644 index c40acf8..0000000 --- a/examples/test-dockerfile.dockerfile +++ /dev/null @@ -1,5 +0,0 @@ -FROM fpco/stack-build:lts-6.9 -ADD . /app/language-docker -WORKDIR /app/language-docker -RUN stack build --test --only-dependencies -CMD stack test diff --git a/examples/test-dockerfile.hs b/examples/test-dockerfile.hs deleted file mode 100644 index 4fb7eec..0000000 --- a/examples/test-dockerfile.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} - -import Language.Docker - -main :: IO () -main = - writeDockerFile "./examples/test-dockerfile.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" diff --git a/integration-tests/parse_files.sh b/integration-tests/parse_files.sh index acb1a1e..05ae21a 100755 --- a/integration-tests/parse_files.sh +++ b/integration-tests/parse_files.sh @@ -5,9 +5,7 @@ set -o nounset readonly CWD="$PWD" readonly TESTS_DIR="integration-tests/Dockerfiles" -BLACKLIST="./Dockerfiles/dockerfiles/nylas/sync-engine/Dockerfile" -BLACKLIST=$BLACKLIST" ./Dockerfiles/docker-images/OracleWebLogic/samples/12212-domain/Dockerfile" -BLACKLIST=$BLACKLIST" ./Dockerfiles/docker-images/OracleWebLogic/samples/12213-domain/Dockerfile" +BLACKLIST="" function git_clone() { local git_url="$1" diff --git a/language-docker.cabal b/language-docker.cabal new file mode 100644 index 0000000..fa33a05 --- /dev/null +++ b/language-docker.cabal @@ -0,0 +1,90 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 4064f903443322af4bc07da09abc22ee61ae143bfcffb403add7b327cd7b13dd + +name: language-docker +version: 9.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 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 +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/hadolint/language-docker + +library + exposed-modules: + Language.Docker + Language.Docker.Parser + Language.Docker.PrettyPrint + Language.Docker.Syntax + other-modules: + Language.Docker.Parser.Arguments + Language.Docker.Parser.Cmd + Language.Docker.Parser.Copy + Language.Docker.Parser.Expose + Language.Docker.Parser.From + Language.Docker.Parser.Healthcheck + Language.Docker.Parser.Instruction + Language.Docker.Parser.Pairs + Language.Docker.Parser.Prelude + Language.Docker.Parser.Run + Paths_language_docker + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-unused-do-bind -fno-warn-orphans + build-depends: + base >=4.13 && <5 + , bytestring >=0.10 + , containers + , data-default-class + , megaparsec >=8.0 + , prettyprinter + , split >=0.2 + , text + , time + default-language: Haskell2010 + +test-suite hspec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Language.Docker.IntegrationSpec + Language.Docker.ParserSpec + Paths_language_docker + hs-source-dirs: + test + build-depends: + HUnit >=1.2 + , QuickCheck + , base >=4.13 && <5 + , bytestring >=0.10 + , containers + , data-default-class + , hspec + , language-docker + , megaparsec >=8.0 + , prettyprinter + , split >=0.2 + , text + , time + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index aa11ed3..cc10d02 100644 --- a/package.yaml +++ b/package.yaml @@ -1,7 +1,7 @@ name: language-docker -version: '8.1.1' +version: '9.0.0' synopsis: Dockerfile parser, pretty-printer and embedded DSL -description: 'All functions for parsing, printing and writting Dockerfiles are +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. @@ -26,17 +26,13 @@ extra-source-files: dependencies: - base >=4.13 && <5 - bytestring >=0.10 - - megaparsec >=7.0 + - megaparsec >=8.0 - prettyprinter - split >=0.2 - - free - - mtl - - template-haskell - - th-lift - - th-lift-instances - text - time - containers + - data-default-class library: source-dirs: src @@ -52,12 +48,7 @@ library: - 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 tests: hspec: @@ -67,9 +58,5 @@ tests: - hspec - QuickCheck - language-docker - - Glob - - directory - - filepath - - process - HUnit >=1.2 - - megaparsec >=7.0 + - megaparsec >=8.0 diff --git a/src/Language/Docker.hs b/src/Language/Docker.hs index 4f7a83f..382118d 100644 --- a/src/Language/Docker.hs +++ b/src/Language/Docker.hs @@ -1,109 +1,46 @@ module Language.Docker - ( Language.Docker.Syntax.Dockerfile -- * Parsing Dockerfiles (@Language.Docker.Syntax@ and @Language.Docker.Parser@) - , parseText - , parseFile - , parseStdin + ( Language.Docker.Syntax.Dockerfile, + + -- * Parsing Dockerfiles (@Language.Docker.Syntax@ and @Language.Docker.Parser@) + parseText, + parseFile, + parseStdin, + -- * Re-exports from @megaparsec@ - , Text.Megaparsec.parseErrorPretty - , Text.Megaparsec.errorBundlePretty - -- * Pretty-printing Dockerfiles (@Language.Docker.PrettyPrint@) - , prettyPrint - , prettyPrintDockerfile - -- * Writting Dockerfiles (@Language.Docker.EDSL@) - , Language.Docker.EDSL.toDockerfileText - , Language.Docker.EDSL.toDockerfile - , Language.Docker.EDSL.putDockerfileStr - , Language.Docker.EDSL.writeDockerFile - , Language.Docker.EDSL.toDockerfileTextIO - , Language.Docker.EDSL.toDockerfileIO - , Language.Docker.EDSL.runDockerfileIO - , Language.Docker.EDSL.runDockerfileTextIO - , Control.Monad.IO.Class.liftIO - , Language.Docker.EDSL.from - -- ** Constructing base images - , Language.Docker.EDSL.tagged - , Language.Docker.EDSL.untagged - , Language.Docker.EDSL.digested - , Language.Docker.EDSL.aliased - -- ** Syntax - , Language.Docker.EDSL.add - , Language.Docker.EDSL.user - , Language.Docker.EDSL.label - , Language.Docker.EDSL.stopSignal - , Language.Docker.EDSL.copy - , Language.Docker.EDSL.copyFromStage - , Language.Docker.EDSL.to - , Language.Docker.EDSL.fromStage - , Language.Docker.EDSL.ownedBy - , Language.Docker.EDSL.toSources - , Language.Docker.EDSL.toTarget - , Language.Docker.EDSL.run - , Language.Docker.EDSL.runArgs - , Language.Docker.EDSL.cmd - , Language.Docker.EDSL.cmdArgs - , Language.Docker.EDSL.healthcheck - , Language.Docker.EDSL.check - , Language.Docker.EDSL.interval - , Language.Docker.EDSL.timeout - , Language.Docker.EDSL.startPeriod - , Language.Docker.EDSL.retries - , Language.Docker.EDSL.workdir - , Language.Docker.EDSL.expose - , Language.Docker.EDSL.ports - , Language.Docker.EDSL.tcpPort - , Language.Docker.EDSL.udpPort - , Language.Docker.EDSL.variablePort - , Language.Docker.EDSL.portRange - , Language.Docker.EDSL.udpPortRange - , Language.Docker.EDSL.volume - , Language.Docker.EDSL.entrypoint - , Language.Docker.EDSL.entrypointArgs - , Language.Docker.EDSL.maintainer - , Language.Docker.EDSL.env - , Language.Docker.EDSL.arg - , Language.Docker.EDSL.comment - , Language.Docker.EDSL.onBuild - , Language.Docker.EDSL.onBuildRaw - , Language.Docker.EDSL.embed - , Language.Docker.EDSL.Quasi.edockerfile - -- ** Support types for the EDSL - , Language.Docker.EDSL.EDockerfileM - , Language.Docker.EDSL.EDockerfileTM - , Language.Docker.EDSL.Types.EBaseImage(..) - -- * QuasiQuoter (@Language.Docker.EDSL.Quasi@) - , Language.Docker.EDSL.Quasi.dockerfile - -- * Types (@Language.Docker.Syntax@) - , Language.Docker.Syntax.Instruction(..) - , Language.Docker.Syntax.InstructionPos(..) - , Language.Docker.Syntax.BaseImage(..) - , Language.Docker.Syntax.SourcePath(..) - , Language.Docker.Syntax.TargetPath(..) - , Language.Docker.Syntax.Chown(..) - , Language.Docker.Syntax.CopySource(..) - , Language.Docker.Syntax.CopyArgs(..) - , Language.Docker.Syntax.AddArgs(..) - , Language.Docker.Syntax.Check(..) - , Language.Docker.Syntax.CheckArgs(..) - , Language.Docker.Syntax.Image(..) - , Language.Docker.Syntax.Registry(..) - , Language.Docker.Syntax.ImageAlias(..) - , Language.Docker.Syntax.Tag(..) - , Language.Docker.Syntax.Digest(..) - , Language.Docker.Syntax.Ports - , Language.Docker.Syntax.Directory - , Language.Docker.Syntax.Arguments - , Language.Docker.Syntax.Pairs - , Language.Docker.Syntax.Filename - , Language.Docker.Syntax.Platform - , Language.Docker.Syntax.Linenumber - -- * Instruction and InstructionPos helpers - , Language.Docker.EDSL.instructionPos - ) where + Text.Megaparsec.parseErrorPretty, + Text.Megaparsec.errorBundlePretty, + + -- * 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 qualified Control.Monad.IO.Class -import qualified Language.Docker.EDSL -import qualified Language.Docker.EDSL.Quasi -import qualified Language.Docker.EDSL.Types import Language.Docker.Parser import Language.Docker.PrettyPrint import qualified Language.Docker.Syntax diff --git a/src/Language/Docker/EDSL.hs b/src/Language/Docker/EDSL.hs deleted file mode 100644 index 6d6a182..0000000 --- a/src/Language/Docker/EDSL.hs +++ /dev/null @@ -1,383 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Docker.EDSL where - -import Control.Monad.Free -import Control.Monad.Free.TH -import Control.Monad.Trans.Free (FreeT, iterTM) -import Control.Monad.Writer -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as B8 -import Data.List.NonEmpty (NonEmpty) -import Data.String (fromString) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Encoding as E - -import qualified Language.Docker.PrettyPrint as PrettyPrint -import qualified Language.Docker.Syntax as Syntax - -import Language.Docker.EDSL.Types - --- | The type of 'Identity' based EDSL blocks -type EDockerfileM = Free EInstruction - --- | The type of free monad EDSL blocks -type EDockerfileTM = FreeT EInstruction - -type EInstructionM = Free EInstruction - -type EInstructionTM = FreeT EInstruction - -makeFree ''EInstruction - -runDockerWriter :: (MonadWriter [Syntax.Instruction Text] m) => EDockerfileM a -> m a -runDockerWriter = iterM runD - -runDockerWriterIO :: - (Monad m, MonadTrans t, MonadWriter [Syntax.Instruction Text] (t m)) - => EDockerfileTM m a - -> t m a -runDockerWriterIO = iterTM runD - -runDef :: MonadWriter [t] m => (t1 -> t) -> t1 -> m b -> m b -runDef f a n = tell [f a] >> n - -runDef2 :: MonadWriter [t] m => (t1 -> t2 -> t) -> t1 -> t2 -> m b -> m b -runDef2 f a b n = tell [f a b] >> n - -runD :: MonadWriter [Syntax.Instruction Text] m => EInstruction (m b) -> m b -runD (From (EBaseImage name t d a p) n) = runDef Syntax.From (Syntax.BaseImage name t d a p) n -runD (CmdArgs as n) = runDef Syntax.Cmd as n -runD (Shell as n) = runDef Syntax.Shell as n -runD (AddArgs s d c n) = runDef Syntax.Add (Syntax.AddArgs s d c) n -runD (User u n) = runDef Syntax.User u n -runD (Label ps n) = runDef Syntax.Label ps n -runD (StopSignal s n) = runDef Syntax.Stopsignal s n -runD (CopyArgs s d c f n) = runDef Syntax.Copy (Syntax.CopyArgs s d c f) n -runD (RunArgs as n) = runDef Syntax.Run as n -runD (Workdir d n) = runDef Syntax.Workdir d n -runD (Expose ps n) = runDef Syntax.Expose ps n -runD (Volume v n) = runDef Syntax.Volume v n -runD (EntrypointArgs e n) = runDef Syntax.Entrypoint e n -runD (Maintainer m n) = runDef Syntax.Maintainer m n -runD (Env ps n) = runDef Syntax.Env ps n -runD (Arg k v n) = runDef2 Syntax.Arg k v n -runD (Comment c n) = runDef Syntax.Comment c n -runD (Healthcheck c n) = runDef Syntax.Healthcheck c n -runD (OnBuildRaw i n) = runDef Syntax.OnBuild i n -runD (Embed is n) = do - tell (map Syntax.instruction is) - n - -instructionPos :: Syntax.Instruction args -> Syntax.InstructionPos args -instructionPos i = Syntax.InstructionPos i "" 0 - --- | Runs the Dockerfile EDSL and returns a 'Dockerfile' you can pretty print --- or manipulate -toDockerfile :: EDockerfileM a -> Syntax.Dockerfile -toDockerfile e = - let (_, w) = runWriter (runDockerWriter e) - in map instructionPos w - --- | runs the Dockerfile EDSL and returns a 'Data.Text.Lazy' using --- 'Language.Docker.PrettyPrint' --- --- @ --- import Language.Docker --- --- main :: IO () --- main = print $ toDockerfileText $ do --- from (tagged "fpco/stack-build" "lts-6.9") --- add ["."] "/app/language-docker" --- workdir "/app/language-docker" --- run "stack build --test --only-dependencies" --- cmd "stack test" --- @ -toDockerfileText :: EDockerfileM a -> L.Text -toDockerfileText = PrettyPrint.prettyPrint . toDockerfile - --- | Writes the dockerfile to the given file path after pretty-printing it --- --- @ --- import Language.Docker --- --- main :: IO () --- main = writeDockerFile "build.Dockerfile" $ toDockerfile $ do --- from (tagged "fpco/stack-build" "lts-6.9") --- add ["."] "/app/language-docker" --- workdir "/app/language-docker" --- run "stack build --test --only-dependencies" --- cmd "stack test" --- @ -writeDockerFile :: Text -> Syntax.Dockerfile -> IO () -writeDockerFile filename = - BL.writeFile (Text.unpack filename) . E.encodeUtf8 . PrettyPrint.prettyPrint - --- | Prints the dockerfile to stdout. Mainly used for debugging purposes --- --- @ --- import Language.Docker --- --- main :: IO () --- main = putDockerfileStr $ do --- from (tagged "fpco/stack-build" "lts-6.9") --- add ["."] "/app/language-docker" --- workdir "/app/language-docker" --- run "stack build --test --only-dependencies" --- cmd "stack test" --- @ -putDockerfileStr :: EDockerfileM a -> IO () -putDockerfileStr = B8.putStrLn . E.encodeUtf8 . PrettyPrint.prettyPrint . toDockerfile - --- | Use a docker image in a FROM instruction without a tag --- --- The following two examples are equivalent --- --- @ --- from $ untagged "fpco/stack-build" --- @ --- --- Is equivalent to, when having OverloadedStrings: --- --- @ --- from "fpco/stack-build" --- @ -untagged :: Text -> EBaseImage -untagged s = EBaseImage (fromString . Text.unpack $ s) Nothing Nothing Nothing Nothing - --- | Use a specific tag for a docker image. This function is meant --- to be used as an infix operator. --- --- @ --- from $ "fpco/stack-build" `tagged` "lts-10.3" --- @ -tagged :: Syntax.Image -> Syntax.Tag -> EBaseImage -tagged imageName tag = EBaseImage imageName (Just tag) Nothing Nothing Nothing - --- | Adds a digest checksum so a FROM instruction --- This function is meant to be used as an infix operator. --- --- @ --- from $ "fpco/stack-build" `digested` "sha256:abcdef123" --- @ -digested :: EBaseImage -> Syntax.Digest -> EBaseImage -digested (EBaseImage n t _ a p) d = EBaseImage n t (Just d) a p - --- | Alias a FROM instruction to be used as a build stage. --- This function is meant to be used as an infix operator. --- --- @ --- from $ "fpco/stack-build" `aliased` "builder" --- @ -aliased :: EBaseImage -> Syntax.ImageAlias -> EBaseImage -aliased (EBaseImage n t d _ p) a = EBaseImage n t d (Just a) p - --- | Create a RUN instruction with the given arguments. --- --- @ --- run "apt-get install wget" --- @ -run :: MonadFree EInstruction m => Syntax.Arguments Text -> m () -run = runArgs - --- | Create an ENTRYPOINT instruction with the given arguments. --- --- @ --- entrypoint "/usr/local/bin/program --some-flag" --- @ -entrypoint :: MonadFree EInstruction m => Syntax.Arguments Text -> m () -entrypoint = entrypointArgs - --- | Create a CMD instruction with the given arguments. --- --- @ --- cmd "my-program --some-flag" --- @ -cmd :: MonadFree EInstruction m => Syntax.Arguments Text -> m () -cmd = cmdArgs - --- | Create a COPY instruction. This function is meant to be --- used with the compinators 'to', 'fromStage' and 'ownedBy' --- --- @ --- copy $ ["foo.js", "bar.js"] `to` "." --- copy $ ["some_file"] `to` "/some/path" `fromStage` "builder" --- @ -copy :: MonadFree EInstruction m => Syntax.CopyArgs -> m () -copy (Syntax.CopyArgs sources dest ch src) = copyArgs sources dest ch src - --- | Create a COPY instruction from a given build stage. --- This is a shorthand version of using 'copy' with combinators. --- --- @ --- copyFromStage "builder" ["foo.js", "bar.js"] "." --- @ -copyFromStage :: - MonadFree EInstruction m - => Syntax.CopySource - -> NonEmpty Syntax.SourcePath - -> Syntax.TargetPath - -> m () -copyFromStage stage source dest = copy $ Syntax.CopyArgs source dest Syntax.NoChown stage - --- | Create an ADD instruction. This is often used as a shorthand version --- of copy when no extra options are needed. Currently there is no way to --- pass extra options to ADD, so you are encouraged to use 'copy' instead. --- --- @ --- add ["foo.js", "bar.js"] "." --- @ -add :: MonadFree EInstruction m => NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> m () -add sources dest = addArgs sources dest Syntax.NoChown - --- | Converts a NonEmpty list of strings to a NonEmpty list of 'Syntax.SourcePath' --- --- This is a convenience function when you need to pass a non-static list of --- strings that you build somewhere as an argument for 'copy' or 'add' --- --- @ --- someFiles <- glob "*.js" --- copy $ (toSources someFiles) `to` "." --- @ -toSources :: NonEmpty Text -> NonEmpty Syntax.SourcePath -toSources = fmap Syntax.SourcePath - --- | Converts a Text into a 'Syntax.TargetPath' --- --- This is a convenience function when you need to pass a string variable --- as an argument for 'copy' or 'add' --- --- @ --- let destination = buildSomePath pwd --- add ["foo.js"] (toTarget destination) --- @ -toTarget :: Text -> Syntax.TargetPath -toTarget = Syntax.TargetPath - --- | Adds the --from= option to a COPY instruction. --- --- This function is meant to be used as an infix operator: --- --- @ --- copy $ ["foo.js"] `to` "." `fromStage` "builder" --- @ -fromStage :: Syntax.CopyArgs -> Syntax.CopySource -> Syntax.CopyArgs -fromStage args src = args {Syntax.sourceFlag = src} - --- | Adds the --chown= option to a COPY instruction. --- --- This function is meant to be used as an infix operator: --- --- @ --- copy $ ["foo.js"] `to` "." `ownedBy` "www-data:www-data" --- @ -ownedBy :: Syntax.CopyArgs -> Syntax.Chown -> Syntax.CopyArgs -ownedBy args owner = args {Syntax.chownFlag = owner} - --- | Usedto join source paths with atarget path as an arguments for 'copy' --- --- This function is meant to be used as an infix operator: --- --- @ --- copy $ ["foo.js"] `to` "." `ownedBy` --- @ -to :: NonEmpty Syntax.SourcePath -> Syntax.TargetPath -> Syntax.CopyArgs -to sources dest = Syntax.CopyArgs sources dest Syntax.NoChown Syntax.NoSource - -ports :: [Syntax.Port] -> Syntax.Ports -ports = Syntax.Ports - -tcpPort :: Int -> Syntax.Port -tcpPort = flip Syntax.Port Syntax.TCP - -udpPort :: Int -> Syntax.Port -udpPort = flip Syntax.Port Syntax.UDP - -variablePort :: Text -> Syntax.Port -variablePort varName = Syntax.PortStr ("$" <> varName) - -portRange :: Int -> Int -> Syntax.Port -portRange a b = Syntax.PortRange a b Syntax.TCP - -udpPortRange :: Int -> Int -> Syntax.Port -udpPortRange a b = Syntax.PortRange a b Syntax.UDP - -check :: Syntax.Arguments args -> Syntax.Check args -check command = - Syntax.Check - Syntax.CheckArgs - { Syntax.checkCommand = command - , Syntax.interval = Nothing - , Syntax.timeout = Nothing - , Syntax.startPeriod = Nothing - , Syntax.retries = Nothing - } - -interval :: Syntax.Check args -> Integer -> Syntax.Check args -interval ch secs = - case ch of - Syntax.NoCheck -> Syntax.NoCheck - Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.interval = Just $ fromInteger secs} - -timeout :: Syntax.Check args -> Integer -> Syntax.Check args -timeout ch secs = - case ch of - Syntax.NoCheck -> Syntax.NoCheck - Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.timeout = Just $ fromInteger secs} - -startPeriod :: Syntax.Check args -> Integer -> Syntax.Check args -startPeriod ch secs = - case ch of - Syntax.NoCheck -> Syntax.NoCheck - Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.startPeriod = Just $ fromInteger secs} - -retries :: Syntax.Check args -> Integer -> Syntax.Check args -retries ch tries = - case ch of - Syntax.NoCheck -> Syntax.NoCheck - Syntax.Check chArgs -> Syntax.Check chArgs {Syntax.retries = Just $ fromInteger tries} - -noCheck :: Syntax.Check args -noCheck = Syntax.NoCheck - --- | ONBUILD Dockerfile instruction --- --- Each nested instruction gets emitted as a separate @ONBUILD@ block --- --- @ --- 'toDockerfile' $ do --- from "node" --- run "apt-get update" --- onBuild $ do --- run "echo more-stuff" --- run "echo here" --- @ -onBuild :: MonadFree EInstruction m => EDockerfileM a -> m () -onBuild b = mapM_ (onBuildRaw . Syntax.instruction) (toDockerfile b) - --- | A version of 'toDockerfile' which allows IO actions -toDockerfileIO :: MonadIO m => EDockerfileTM m t -> m Syntax.Dockerfile -toDockerfileIO e = fmap snd (runDockerfileIO e) - --- | A version of 'toDockerfileText' which allows IO actions -toDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m L.Text -toDockerfileTextIO e = fmap snd (runDockerfileTextIO e) - --- | Just runs the EDSL's writer monad -runDockerfileIO :: MonadIO m => EDockerfileTM m t -> m (t, Syntax.Dockerfile) -runDockerfileIO e = do - (r, w) <- runWriterT (runDockerWriterIO e) - return (r, map instructionPos w) - --- | Runs the EDSL's writer monad and pretty-prints the result -runDockerfileTextIO :: MonadIO m => EDockerfileTM m t -> m (t, L.Text) -runDockerfileTextIO e = do - (r, w) <- runDockerfileIO e - return (r, PrettyPrint.prettyPrint w) diff --git a/src/Language/Docker/EDSL/Quasi.hs b/src/Language/Docker/EDSL/Quasi.hs deleted file mode 100644 index 81514a3..0000000 --- a/src/Language/Docker/EDSL/Quasi.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Docker.EDSL.Quasi where - -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax - -import qualified Data.Text as Text -import Language.Docker.EDSL -import qualified Language.Docker.Parser as Parser -import Language.Docker.Syntax.Lift () -import Text.Megaparsec (errorBundlePretty) - --- | Quasiquoter for embedding dockerfiles on the EDSL --- --- @ --- putStr $ 'toDockerfile' $ do --- from "node" --- run "apt-get update" --- [edockerfile| --- RUN apt-get update --- CMD node something.js --- |] --- @ -edockerfile :: QuasiQuoter -edockerfile = dockerfile {quoteExp = edockerfileE} - -edockerfileE :: String -> ExpQ -edockerfileE e = - case Parser.parseText (Text.pack e) of - Left err -> fail (errorBundlePretty err) - Right d -> [|embed d|] - -dockerfile :: QuasiQuoter -dockerfile = - QuasiQuoter - { quoteExp = dockerfileE - , quoteDec = error "Can't use Dockerfile as a declaration" - , quotePat = error "Can't use Dockerfile as a pattern" - , quoteType = error "Can't use Dockerfile as a type" - } - -dockerfileE :: String -> ExpQ -dockerfileE e = - case Parser.parseText (Text.pack e) of - Left err -> fail (errorBundlePretty err) - Right d -> lift d diff --git a/src/Language/Docker/EDSL/Types.hs b/src/Language/Docker/EDSL/Types.hs deleted file mode 100644 index c929591..0000000 --- a/src/Language/Docker/EDSL/Types.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} - -module Language.Docker.EDSL.Types where - -import Data.List.NonEmpty (NonEmpty) -import Data.String -import Data.Text (Text) -import qualified Language.Docker.Syntax as Syntax - -data EBaseImage = EBaseImage Syntax.Image - (Maybe Syntax.Tag) - (Maybe Syntax.Digest) - (Maybe Syntax.ImageAlias) - (Maybe Syntax.Platform) - deriving (Show, Eq, Ord) - -instance IsString EBaseImage where - fromString s = EBaseImage (fromString s) Nothing Nothing Nothing Nothing - -data EInstruction next - = From EBaseImage - next - | AddArgs (NonEmpty Syntax.SourcePath) - Syntax.TargetPath - Syntax.Chown - next - | User Text - next - | Label Syntax.Pairs - next - | StopSignal Text - next - | CopyArgs (NonEmpty Syntax.SourcePath) - Syntax.TargetPath - Syntax.Chown - Syntax.CopySource - next - | RunArgs (Syntax.Arguments Text) - next - | CmdArgs (Syntax.Arguments Text) - next - | Shell (Syntax.Arguments Text) - next - | Workdir Syntax.Directory - next - | Expose Syntax.Ports - next - | Volume Text - next - | EntrypointArgs (Syntax.Arguments Text) - next - | Maintainer Text - next - | Env Syntax.Pairs - next - | Arg Text - (Maybe Text) - next - | Comment Text - next - | Healthcheck (Syntax.Check Text) - next - | OnBuildRaw (Syntax.Instruction Text) - next - | Embed [Syntax.InstructionPos Text] - next - deriving (Functor) diff --git a/src/Language/Docker/Normalize.hs b/src/Language/Docker/Normalize.hs deleted file mode 100644 index fac76f0..0000000 --- a/src/Language/Docker/Normalize.hs +++ /dev/null @@ -1,94 +0,0 @@ -module Language.Docker.Normalize - ( normalizeEscapedLines - ) where - -import Data.List (mapAccumL) -import Data.Maybe (catMaybes) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Lazy (toStrict) -import qualified Data.Text.Lazy.Builder as Builder - -data NormalizedLine - = Continue - | Joined !Builder.Builder - !Int - --- Finds all lines ending with \ and joins them with the next line using --- a single space. If the next line is a comment, then the comment line is --- deleted. It finally adds the same amount of new lines for each of the --- lines it joined, in order to preserve the line count in the document. -normalize :: Text -> Text -normalize allLines = - let (lastState, res) -- mapAccumL is the idea of a for loop with a variable holding - -- some state and another variable where we append the final result - -- of the looping operation. For each line in lines, apply the transform - -- function. This function always returns a new state, and another element - -- to append to the final result. The ending result of mapAccumL is the final - -- state variale and the resulting list of values. We initialize the loop with - -- the 'Continue' state, which means "no special action to do next" - = mapAccumL transform Continue (Text.lines allLines) - in case lastState of - Continue -- The last line of the document is a normal line, cleanup and return - -> Text.unlines . catMaybes $ res - Joined l times -- The last line contains a \, so we need to add the buffered - -- line back to the result, pad with newlines and cleanup - -> Text.unlines (catMaybes res <> [toText (l <> padNewlines times)]) - where - toText = toStrict . Builder.toLazyText - -- | Checks the result of the previous operation in the loop (first argument) - -- - -- If the previous result is a 'Joined' operation, then we merge the previous - -- and the current line in a single line and return it. - -- - -- If the current line ends with a \, then we produce a 'Joined' state as result - -- of this looping operation. - -- - -- If the previous 2 conditions are true at the same time, then we produce a new - -- 'Joined' state holding the concatenation of the Joined buffer and the previous line - -- and we return 'Nothing' as an indication that this line does not form part of the - -- final result. - transform :: NormalizedLine -> Text -> (NormalizedLine, Maybe Text) - transform (Joined prev times) rawLine - -- If we are buffering lines and the next one is empty or it starts with a comment - -- we simply ignore the comment and remember to add a newline - | Text.null line || isComment line = (Joined prev (times + 1), Nothing) - -- If we are buffering lines, then we check whether the current line end with \, - -- if it does, then we merged it into the buffered state - | endsWithEscape line = (Joined (prev <> normalizeLast line) (times + 1), Nothing) - -- otherwise we just yield - -- the concatanation of the buffer and the current line as result, after padding with - -- newlines - | otherwise = (Continue, Just (toText (prev <> Builder.fromText line <> padNewlines times))) - where - line = Text.stripEnd rawLine - -- When not buffering lines, then we just check if we need to start doing it by checking - -- whether or not the current line ends with \. If it does not, then we just yield the - -- current line as part of the result - transform Continue rawLine - | isComment line = (Continue, Just line) - | endsWithEscape line = (Joined (normalizeLast line) 1, Nothing) - | otherwise = (Continue, Just line) - where - line = Text.stripEnd rawLine - -- - endsWithEscape t - | Text.null t = False - | otherwise = Text.last t == '\\' - -- - padNewlines times = Builder.fromText (Text.replicate times (Text.singleton '\n')) - -- - normalizeLast = Builder.fromText . Text.dropWhileEnd (== '\\') - -- - isComment line = - case (Text.uncons . Text.stripStart) line of - Just ('#', _) -> True - _ -> False - --- | Remove new line escapes and join escaped lines together on one line --- to simplify parsing later on. Escapes are replaced with line breaks --- to not alter the line numbers. -normalizeEscapedLines :: Text -> Text -normalizeEscapedLines = normalize - -{-# INLINE normalizeEscapedLines #-} diff --git a/src/Language/Docker/Parser.hs b/src/Language/Docker/Parser.hs index 523be59..3af5871 100644 --- a/src/Language/Docker/Parser.hs +++ b/src/Language/Docker/Parser.hs @@ -1,613 +1,48 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} module Language.Docker.Parser - ( parseText - , parseFile - , parseStdin - , Parser - , Error - , DockerfileError(..) - ) where + ( parseText, + parseFile, + parseStdin, + Parser, + Error, + DockerfileError (..), + ) +where -import Control.Monad (void) import qualified Data.ByteString as B -import Data.Data -import Data.List.NonEmpty (NonEmpty, fromList) -import Data.Maybe (listToMaybe) -import qualified Data.Set as S -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E -import Data.Time.Clock (secondsToDiffTime) -import Text.Megaparsec hiding (Label, label) -import Text.Megaparsec.Char hiding (eol) -import qualified Text.Megaparsec.Char.Lexer as L - -import Language.Docker.Normalize +import Language.Docker.Parser.Instruction (parseInstruction) +import Language.Docker.Parser.Prelude import Language.Docker.Syntax -data DockerfileError - = DuplicateFlagError String - | NoValueFlagError String - | InvalidFlagError String - | FileListError String - | QuoteError String - String - deriving (Eq, Data, Typeable, Ord, Read, Show) - -type Parser = Parsec DockerfileError Text - -type Error = ParseErrorBundle Text DockerfileError - -type Instr = Instruction Text - -data CopyFlag - = FlagChown Chown - | FlagSource CopySource - | FlagInvalid (Text, Text) - -data CheckFlag - = FlagInterval Duration - | FlagTimeout Duration - | FlagStartPeriod Duration - | FlagRetries Retries - | CFlagInvalid (Text, Text) - -instance ShowErrorComponent DockerfileError where - showErrorComponent (DuplicateFlagError f) = "duplicate flag: " ++ f - showErrorComponent (FileListError f) = - "unexpected end of line. At least two arguments are required for " ++ f - showErrorComponent (NoValueFlagError f) = "unexpected flag " ++ f ++ " with no value" - showErrorComponent (InvalidFlagError f) = "invalid flag: " ++ f - showErrorComponent (QuoteError t str) = - "unexpected end of " ++ t ++ " quoted string " ++ str ++ " (unmatched quote)" - ------------------------------------- --- Utilities ------------------------------------- --- | End parsing signaling a “conversion error”. -customError :: DockerfileError -> Parser a -customError = fancyFailure . S.singleton . ErrorCustom - -eol :: Parser () -eol = void $ takeWhile1P (Just "whitespace") isSpaceNl - -reserved :: Text -> Parser () -reserved name = void (lexeme (string' name) T.unpack name) - -natural :: Parser Integer -natural = L.decimal "positive number" - -commaSep :: Parser a -> Parser [a] -commaSep p = sepBy (p <* spaces) (symbol ",") - -stringLiteral :: Parser Text -stringLiteral = do - void (char '"') - lit <- manyTill L.charLiteral (char '"') - return (T.pack lit) - -brackets :: Parser a -> Parser a -brackets = between (symbol "[" *> spaces) (spaces *> symbol "]") - -spaces1 :: Parser () -spaces1 = void (takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t')) - -spaces :: Parser () -spaces = void (takeWhileP (Just "at least one space") (\c -> c == ' ' || c == '\t')) - -symbol :: Text -> Parser Text -symbol name = do - x <- string name - spaces - return x - -caseInsensitiveString :: Text -> Parser Text -caseInsensitiveString = string' - -charsWithEscapedSpaces :: String -> Parser Text -charsWithEscapedSpaces stopChars = do - buf <- takeWhile1P Nothing (`notElem` ("\n\t\\ " ++ stopChars)) - try (jumpEscapeSequence buf) <|> try (backslashFollowedByChars buf) <|> return buf - where - backslashFollowedByChars buf = do - backslashes <- takeWhile1P Nothing (== '\\') - notFollowedBy (char ' ') - rest <- charsWithEscapedSpaces stopChars - return $ T.concat [buf, backslashes, rest] - jumpEscapeSequence buf = do - void $ string "\\ " - rest <- charsWithEscapedSpaces stopChars - return $ T.concat [buf, " ", rest] - -lexeme :: Parser a -> Parser a -lexeme p = do - x <- p - spaces1 - return x - -isNl :: Char -> Bool -isNl c = c == '\n' - -isSpaceNl :: Char -> Bool -isSpaceNl c = c == ' ' || c == '\t' || c == '\n' - -anyUnless :: (Char -> Bool) -> Parser Text -anyUnless predicate = takeWhileP Nothing (\c -> not (isSpaceNl c || predicate c)) - -someUnless :: String -> (Char -> Bool) -> Parser Text -someUnless name predicate = takeWhile1P (Just name) (\c -> not (isSpaceNl c || predicate c)) - ------------------------------------- --- DOCKER INSTRUCTIONS PARSER ------------------------------------- -comment :: Parser Instr -comment = do - void $ char '#' - text <- takeWhileP Nothing (not . isNl) - return $ Comment text - -parseRegistry :: Parser Registry -parseRegistry = do - domain <- someUnless "a domain name" (== '.') - void $ char '.' - tld <- someUnless "a TLD" (== '/') - void $ char '/' - return $ Registry (domain <> "." <> tld) - -parsePlatform :: Parser Platform -parsePlatform = do - void $ string "--platform=" - p <- someUnless "the platform for the FROM image" (== ' ') - spaces1 - return p - -parseBaseImage :: (Text -> Parser (Maybe Tag)) -> Parser BaseImage -parseBaseImage tagParser = do - maybePlatform <- (Just <$> try parsePlatform) <|> return Nothing - notFollowedBy (string "--") - registryName <- (Just <$> try parseRegistry) <|> return Nothing - name <- someUnless "the image name with a tag" (\c -> c == '@' || c == ':') - maybeTag <- tagParser name - maybeDigest <- (Just <$> try parseDigest) <|> return Nothing - maybeAlias <- maybeImageAlias - return $ BaseImage (Image registryName name) maybeTag maybeDigest maybeAlias maybePlatform - -taggedImage :: Parser BaseImage -taggedImage = parseBaseImage tagParser - where - tagParser _ = do - void $ char ':' - tag <- someUnless "the image tag" (\c -> c == '@' || c == ':') - return (Just . Tag $ tag) - -parseDigest :: Parser Digest -parseDigest = do - void $ char '@' - d <- someUnless "the image digest" (== '@') - return $ Digest d - -untaggedImage :: Parser BaseImage -untaggedImage = parseBaseImage notInvalidTag - where - notInvalidTag :: Text -> Parser (Maybe Tag) - notInvalidTag name = do - try (notFollowedBy $ string ":") "no ':' or a valid image tag string (example: " ++ T.unpack name ++ ":valid-tag)" - return Nothing - -maybeImageAlias :: Parser (Maybe ImageAlias) -maybeImageAlias = Just <$> (spaces1 >> imageAlias) <|> return Nothing - -imageAlias :: Parser ImageAlias -imageAlias = do - void (try (reserved "AS") "AS followed by the image alias") - alias <- someUnless "the image alias" (== '\n') - return $ ImageAlias alias - -baseImage :: Parser BaseImage -baseImage = try taggedImage <|> untaggedImage - -from :: Parser Instr -from = do - reserved "FROM" - image <- baseImage - return $ From image - -cmd :: Parser Instr -cmd = do - reserved "CMD" - args <- arguments - return $ Cmd args - -copy :: Parser Instr -copy = do - reserved "COPY" - flags <- copyFlag `sepEndBy` spaces1 - let chownFlags = [c | FlagChown c <- flags] - let sourceFlags = [f | FlagSource f <- flags] - let invalid = [i | FlagInvalid i <- flags] - -- Let's do some validation on the flags - case (invalid, chownFlags, sourceFlags) of - ((k, v):_, _, _) -> unexpectedFlag k v - (_, _:_:_, _) -> customError $ DuplicateFlagError "--chown" - (_, _, _:_:_) -> customError $ DuplicateFlagError "--from" - _ -> do - let ch = - case chownFlags of - [] -> NoChown - c:_ -> c - let fr = - case sourceFlags of - [] -> NoSource - f:_ -> f - fileList "COPY" (\src dest -> Copy (CopyArgs src dest ch fr)) - -copyFlag :: Parser CopyFlag -copyFlag = - (FlagChown <$> try chown "only one --chown") <|> - (FlagSource <$> try copySource "only one --from") <|> - (FlagInvalid <$> try anyFlag "no other flags") - -chown :: Parser Chown -chown = do - void $ string "--chown=" - ch <- someUnless "the user and group for chown" (== ' ') - return $ Chown ch - -copySource :: Parser CopySource -copySource = do - void $ string "--from=" - src <- someUnless "the copy source path" isNl - return $ CopySource src - -anyFlag :: Parser (Text, Text) -anyFlag = do - void $ string "--" - name <- someUnless "the flag value" (== '=') - void $ char '=' - val <- anyUnless (== ' ') - return (T.append "--" name, val) - -fileList :: Text -> (NonEmpty SourcePath -> TargetPath -> Instr) -> Parser Instr -fileList name constr = do - paths <- - (try stringList "an array of strings [\"src_file\", \"dest_file\"]") <|> - (try spaceSeparated "a space separated list of file paths") - case paths of - [_] -> customError $ FileListError (T.unpack name) - _ -> return $ constr (SourcePath <$> fromList (init paths)) (TargetPath $ last paths) - where - spaceSeparated = anyUnless (== ' ') `sepBy1` (try spaces1 "at least another file path") - stringList = brackets $ commaSep stringLiteral - -unexpectedFlag :: Text -> Text -> Parser a -unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name) -unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name) - -shell :: Parser Instr -shell = do - reserved "SHELL" - args <- arguments - return $ Shell args - -stopsignal :: Parser Instr -stopsignal = do - reserved "STOPSIGNAL" - args <- untilEol "the stop signal" - return $ Stopsignal args - --- We cannot use string literal because it swallows space --- and therefore have to implement quoted values by ourselves -doubleQuotedValue :: Parser Text -doubleQuotedValue = - between (string "\"") (string "\"") (takeWhileP Nothing (\c -> c /= '"' && c /= '\n')) - -singleQuotedValue :: Parser Text -singleQuotedValue = - between (string "'") (string "'") (takeWhileP Nothing (\c -> c /= '\'' && c /= '\n')) - -unquotedString :: String -> Parser Text -unquotedString stopChars = do - str <- charsWithEscapedSpaces stopChars - checkFaults str - where - checkFaults str - | T.null str = return str - | T.head str == '\'' = customError $ QuoteError "single" (T.unpack str) - | T.head str == '\"' = customError $ QuoteError "double" (T.unpack str) - | otherwise = return str - -singleValue :: String -> Parser Text -singleValue stopChars = - try doubleQuotedValue <|> -- Quotes or no quotes are fine - try singleQuotedValue <|> - (try (unquotedString stopChars) "a string with no quotes") - -pair :: Parser (Text, Text) -pair = do - key <- singleValue "=" - void $ char '=' - value <- singleValue "" - return (key, value) - -pairsList :: Parser Pairs -pairsList = pair `sepBy1` spaces1 - -label :: Parser Instr -label = do - reserved "LABEL" - p <- pairs - return $ Label p - -arg :: Parser Instr -arg = do - reserved "ARG" - (try nameWithDefault "the arg name") <|> - Arg <$> untilEol "the argument name" <*> pure Nothing - where - nameWithDefault = do - name <- someUnless "the argument name" (== '=') - void $ char '=' - def <- untilEol "the argument value" - return $ Arg name (Just def) - -env :: Parser Instr -env = do - reserved "ENV" - p <- pairs - return $ Env p - -pairs :: Parser Pairs -pairs = try pairsList <|> try singlePair - -singlePair :: Parser Pairs -singlePair = do - key <- anyUnless (== '=') - spaces1 "a space followed by the value for the variable '" ++ T.unpack key ++ "'" - val <- untilEol "the variable value" - return [(key, val)] - -user :: Parser Instr -user = do - reserved "USER" - username <- untilEol "the user" - return $ User username - -add :: Parser Instr -add = do - reserved "ADD" - flag <- lexeme copyFlag <|> return (FlagChown NoChown) - notFollowedBy (string "--") "only the --chown flag or the src and dest paths" - case flag of - FlagChown ch -> fileList "ADD" (\src dest -> Add (AddArgs src dest ch)) - FlagSource _ -> customError $ InvalidFlagError "--from" - FlagInvalid (k, v) -> unexpectedFlag k v - -expose :: Parser Instr -expose = do - reserved "EXPOSE" - ps <- ports - return $ Expose ps - -port :: Parser Port -port = - (try portVariable "a variable") <|> -- There a many valid representations of ports - (try portRange "a port range optionally followed by the protocol (udp/tcp)") <|> - (try portWithProtocol "a port with its protocol (udp/tcp)") <|> - (try portInt "a valid port number") - -ports :: Parser Ports -ports = Ports <$> port `sepEndBy` spaces1 - -portRange :: Parser Port -portRange = do - start <- natural - void $ char '-' - finish <- try natural - proto <- try protocol <|> return TCP - return $ PortRange (fromIntegral start) (fromIntegral finish) proto - -protocol :: Parser Protocol -protocol = do - void (char '/') - tcp <|> udp - where - tcp = caseInsensitiveString "tcp" >> return TCP - udp = caseInsensitiveString "udp" >> return UDP - -portInt :: Parser Port -portInt = do - portNumber <- natural - notFollowedBy (string "/" <|> string "-") - return $ Port (fromIntegral portNumber) TCP - -portWithProtocol :: Parser Port -portWithProtocol = do - portNumber <- natural - proto <- protocol - return $ Port (fromIntegral portNumber) proto - -portVariable :: Parser Port -portVariable = do - void (char '$') - variable <- someUnless "the variable name" (== '$') - return $ PortStr (T.append "$" variable) - -run :: Parser Instr -run = do - reserved "RUN" - c <- arguments - return $ Run c - --- Parse value until end of line is reached -untilEol :: String -> Parser Text -untilEol name = takeWhile1P (Just name) (not . isNl) - -workdir :: Parser Instr -workdir = do - reserved "WORKDIR" - directory <- untilEol "the workdir path" - return $ Workdir directory - -volume :: Parser Instr -volume = do - reserved "VOLUME" - directory <- untilEol "the volume path" - return $ Volume directory - -maintainer :: Parser Instr -maintainer = do - reserved "MAINTAINER" - name <- untilEol "the maintainer name" - return $ Maintainer name - --- Parse arguments of a command in the exec form -argumentsExec :: Parser (Arguments Text) -argumentsExec = do - args <- brackets $ commaSep stringLiteral - return $ ArgumentsList (T.unwords args) - --- Parse arguments of a command in the shell form -argumentsShell :: Parser (Arguments Text) -argumentsShell = ArgumentsText <$> toEnd - where - toEnd = untilEol "the shell arguments" - -arguments :: Parser (Arguments Text) -arguments = try argumentsExec <|> try argumentsShell - -entrypoint :: Parser Instr -entrypoint = do - reserved "ENTRYPOINT" - args <- arguments - return $ Entrypoint args - -onbuild :: Parser Instr -onbuild = do - reserved "ONBUILD" - i <- parseInstruction - return $ OnBuild i - -healthcheck :: Parser Instr -healthcheck = do - reserved "HEALTHCHECK" - Healthcheck <$> (fullCheck <|> noCheck) - where - noCheck = string "NONE" >> return NoCheck - allFlags = do - flags <- someFlags - spaces1 "another flag" - return flags - someFlags = do - x <- checkFlag - cont <- try (spaces1 >> lookAhead (string "--") >> return True) <|> return False - if cont - then do - xs <- someFlags - return (x : xs) - else return [x] - fullCheck = do - flags <- allFlags <|> return [] - let intervals = [x | FlagInterval x <- flags] - let timeouts = [x | FlagTimeout x <- flags] - let startPeriods = [x | FlagStartPeriod x <- flags] - let retriesD = [x | FlagRetries x <- flags] - let invalid = [x | CFlagInvalid x <- flags] - -- Let's do some validation on the flags - case (invalid, intervals, timeouts, startPeriods, retriesD) of - ((k, v):_, _, _, _, _) -> unexpectedFlag k v - (_, _:_:_, _, _, _) -> customError $ DuplicateFlagError "--interval" - (_, _, _:_:_, _, _) -> customError $ DuplicateFlagError "--timeout" - (_, _, _, _:_:_, _) -> customError $ DuplicateFlagError "--start-period" - (_, _, _, _, _:_:_) -> customError $ DuplicateFlagError "--retries" - _ -> do - Cmd checkCommand <- cmd - let interval = listToMaybe intervals - let timeout = listToMaybe timeouts - let startPeriod = listToMaybe startPeriods - let retries = listToMaybe retriesD - return $ Check CheckArgs {..} - -checkFlag :: Parser CheckFlag -checkFlag = - (FlagInterval <$> durationFlag "--interval=" "--interval") <|> - (FlagTimeout <$> durationFlag "--timeout=" "--timeout") <|> - (FlagStartPeriod <$> durationFlag "--start-period=" "--start-period") <|> - (FlagRetries <$> retriesFlag "--retries") <|> - (CFlagInvalid <$> anyFlag "no flags") - -durationFlag :: Text -> Parser Duration -durationFlag flagName = do - void $ try (string flagName) - scale <- natural - unit <- char 's' <|> char 'm' <|> char 'h' "either 's', 'm' or 'h' as the unit" - case unit of - 's' -> return $ Duration (secondsToDiffTime scale) - 'm' -> return $ Duration (secondsToDiffTime (scale * 60)) - 'h' -> return $ Duration (secondsToDiffTime (scale * 60 * 60)) - _ -> fail "only 's', 'm' or 'h' are allowed as the duration" - -retriesFlag :: Parser Retries -retriesFlag = do - void $ try (string "--retries=") - n <- try natural "the number of retries" - return $ Retries (fromIntegral n) - ------------------------------------- --- Main Parser ------------------------------------- -parseInstruction :: Parser Instr -parseInstruction = - onbuild <|> -- parse all main instructions - from <|> - copy <|> - run <|> - workdir <|> - entrypoint <|> - volume <|> - expose <|> - env <|> - arg <|> - user <|> - label <|> - stopsignal <|> - cmd <|> - shell <|> - maintainer <|> - add <|> - comment <|> - healthcheck - contents :: Parser a -> Parser a contents p = do - void $ takeWhileP Nothing isSpaceNl - r <- p - eof - return r + void $ takeWhileP Nothing isSpaceNl + r <- p + eof + return r dockerfile :: Parser Dockerfile dockerfile = - many $ do - pos <- getSourcePos - i <- parseInstruction - eol <|> eof "a new line followed by the next instruction" - return $ InstructionPos i (T.pack . sourceName $ pos) (unPos . sourceLine $ pos) + many $ do + pos <- getSourcePos + i <- parseInstruction + eol <|> eof "a new line followed by the next instruction" + return $ InstructionPos i (T.pack . sourceName $ pos) (unPos . sourceLine $ pos) parseText :: Text -> Either Error Dockerfile -parseText s = parse (contents dockerfile) "" $ normalizeEscapedLines s +parseText = parse (contents dockerfile) "" parseFile :: FilePath -> IO (Either Error Dockerfile) parseFile file = doParse <$> B.readFile file where - doParse = - parse (contents dockerfile) file . normalizeEscapedLines . E.decodeUtf8With E.lenientDecode + doParse = parse (contents dockerfile) file . E.decodeUtf8With E.lenientDecode -- | Reads the standard input until the end and parses the contents as a Dockerfile parseStdin :: IO (Either Error Dockerfile) parseStdin = doParse <$> B.getContents where - doParse = - parse (contents dockerfile) "/dev/stdin" . normalizeEscapedLines . E.decodeUtf8With E.lenientDecode + doParse = parse (contents dockerfile) "/dev/stdin" . E.decodeUtf8With E.lenientDecode diff --git a/src/Language/Docker/Parser/Arguments.hs b/src/Language/Docker/Parser/Arguments.hs new file mode 100644 index 0000000..7069430 --- /dev/null +++ b/src/Language/Docker/Parser/Arguments.hs @@ -0,0 +1,23 @@ +module Language.Docker.Parser.Arguments + ( arguments, + ) +where + +import qualified Data.Text as T +import Language.Docker.Parser.Prelude +import Language.Docker.Syntax + +-- Parse arguments of a command in the exec form +argumentsExec :: Parser (Arguments Text) +argumentsExec = do + args <- brackets $ commaSep stringLiteral + return $ ArgumentsList (T.unwords args) + +-- Parse arguments of a command in the shell form +argumentsShell :: Parser (Arguments Text) +argumentsShell = ArgumentsText <$> toEnd + where + toEnd = untilEol "the shell arguments" + +arguments :: Parser (Arguments Text) +arguments = try argumentsExec <|> try argumentsShell diff --git a/src/Language/Docker/Parser/Cmd.hs b/src/Language/Docker/Parser/Cmd.hs new file mode 100644 index 0000000..e9e84cf --- /dev/null +++ b/src/Language/Docker/Parser/Cmd.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Docker.Parser.Cmd + ( parseCmd, + ) +where + +import Language.Docker.Parser.Arguments +import Language.Docker.Parser.Prelude +import Language.Docker.Syntax + +parseCmd :: Parser (Instruction Text) +parseCmd = do + reserved "CMD" + Cmd <$> arguments diff --git a/src/Language/Docker/Parser/Copy.hs b/src/Language/Docker/Parser/Copy.hs new file mode 100644 index 0000000..eedf66e --- /dev/null +++ b/src/Language/Docker/Parser/Copy.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Docker.Parser.Copy + ( parseCopy, + parseAdd, + ) +where + +import Data.List.NonEmpty (NonEmpty, fromList) +import qualified Data.Text as T +import Language.Docker.Parser.Prelude +import Language.Docker.Syntax + +data CopyFlag + = FlagChown Chown + | FlagSource CopySource + | FlagInvalid (Text, Text) + +parseCopy :: Parser (Instruction Text) +parseCopy = do + reserved "COPY" + flags <- copyFlag `sepEndBy` requiredWhitespace + let chownFlags = [c | FlagChown c <- flags] + let sourceFlags = [f | FlagSource f <- flags] + let invalid = [i | FlagInvalid i <- flags] + -- Let's do some validation on the flags + case (invalid, chownFlags, sourceFlags) of + ((k, v) : _, _, _) -> unexpectedFlag k v + (_, _ : _ : _, _) -> customError $ DuplicateFlagError "--chown" + (_, _, _ : _ : _) -> customError $ DuplicateFlagError "--from" + _ -> do + let ch = + case chownFlags of + [] -> NoChown + c : _ -> c + let fr = + case sourceFlags of + [] -> NoSource + f : _ -> f + fileList "COPY" (\src dest -> Copy (CopyArgs src dest ch fr)) + +parseAdd :: Parser (Instruction Text) +parseAdd = do + reserved "ADD" + flag <- lexeme copyFlag <|> return (FlagChown NoChown) + notFollowedBy (string "--") "only the --chown flag or the src and dest paths" + case flag of + FlagChown ch -> fileList "ADD" (\src dest -> Add (AddArgs src dest ch)) + FlagSource _ -> customError $ InvalidFlagError "--from" + FlagInvalid (k, v) -> unexpectedFlag k v + +fileList :: Text -> (NonEmpty SourcePath -> TargetPath -> Instruction Text) -> Parser (Instruction Text) +fileList name constr = do + paths <- + (try stringList "an array of strings [\"src_file\", \"dest_file\"]") + <|> (try spaceSeparated "a space separated list of file paths") + case paths of + [_] -> customError $ FileListError (T.unpack name) + _ -> return $ constr (SourcePath <$> fromList (init paths)) (TargetPath $ last paths) + where + spaceSeparated = + anyUnless (== ' ') `sepEndBy1` (try requiredWhitespace "at least another file path") + stringList = brackets $ commaSep stringLiteral + +unexpectedFlag :: Text -> Text -> Parser a +unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name) +unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name) + +copyFlag :: Parser CopyFlag +copyFlag = + (FlagChown <$> try chown "only one --chown") + <|> (FlagSource <$> try copySource "only one --from") + <|> (FlagInvalid <$> try anyFlag "no other flags") + +chown :: Parser Chown +chown = do + void $ string "--chown=" + ch <- someUnless "the user and group for chown" (== ' ') + return $ Chown ch + +copySource :: Parser CopySource +copySource = do + void $ string "--from=" + src <- someUnless "the copy source path" isNl + return $ CopySource src + +anyFlag :: Parser (Text, Text) +anyFlag = do + void $ string "--" + name <- someUnless "the flag value" (== '=') + void $ char '=' + val <- anyUnless (== ' ') + return (T.append "--" name, val) diff --git a/src/Language/Docker/Parser/Expose.hs b/src/Language/Docker/Parser/Expose.hs new file mode 100644 index 0000000..4db976c --- /dev/null +++ b/src/Language/Docker/Parser/Expose.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Docker.Parser.Expose + ( parseExpose, + ) +where + +import qualified Data.Text as T +import Language.Docker.Parser.Prelude +import Language.Docker.Syntax + +parseExpose :: Parser (Instruction Text) +parseExpose = do + reserved "EXPOSE" + Expose <$> ports + +port :: Parser Port +port = + (try portVariable "a variable") + <|> (try portRange "a port range optionally followed by the protocol (udp/tcp)") -- There a many valid representations of ports + <|> (try portWithProtocol "a port with its protocol (udp/tcp)") + <|> (try portInt "a valid port number") + +ports :: Parser Ports +ports = Ports <$> port `sepEndBy` requiredWhitespace + +portRange :: Parser Port +portRange = do + start <- natural + void $ char '-' + finish <- try natural + proto <- try protocol <|> return TCP + return $ PortRange (fromIntegral start) (fromIntegral finish) proto + +protocol :: Parser Protocol +protocol = do + void (char '/') + tcp <|> udp + where + tcp = caseInsensitiveString "tcp" >> return TCP + udp = caseInsensitiveString "udp" >> return UDP + +portInt :: Parser Port +portInt = do + portNumber <- natural + notFollowedBy (string "/" <|> string "-") + return $ Port (fromIntegral portNumber) TCP + +portWithProtocol :: Parser Port +portWithProtocol = do + portNumber <- natural + Port (fromIntegral portNumber) <$> protocol + +portVariable :: Parser Port +portVariable = do + void (char '$') + variable <- someUnless "the variable name" (== '$') + return $ PortStr (T.append "$" variable) diff --git a/src/Language/Docker/Parser/From.hs b/src/Language/Docker/Parser/From.hs new file mode 100644 index 0000000..79745fe --- /dev/null +++ b/src/Language/Docker/Parser/From.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Docker.Parser.From + ( parseFrom, + ) +where + +import qualified Data.Text as T +import Language.Docker.Parser.Prelude +import Language.Docker.Syntax + +parseRegistry :: Parser Registry +parseRegistry = do + domain <- someUnless "a domain name" (== '.') + void $ char '.' + tld <- someUnless "a TLD" (== '/') + void $ char '/' + return $ Registry (domain <> "." <> tld) + +parsePlatform :: Parser Platform +parsePlatform = do + void $ string "--platform=" + p <- someUnless "the platform for the FROM image" (== ' ') + requiredWhitespace + return p + +parseBaseImage :: (Text -> Parser (Maybe Tag)) -> Parser BaseImage +parseBaseImage tagParser = do + maybePlatform <- (Just <$> try parsePlatform) <|> return Nothing + notFollowedBy (string "--") + regName <- (Just <$> try parseRegistry) <|> return Nothing + name <- someUnless "the image name with a tag" (\c -> c == '@' || c == ':') + maybeTag <- tagParser name <|> return Nothing + maybeDigest <- (Just <$> try parseDigest) <|> return Nothing + maybeAlias <- (Just <$> try (requiredWhitespace *> imageAlias)) <|> return Nothing + return $ BaseImage (Image regName name) maybeTag maybeDigest maybeAlias maybePlatform + +taggedImage :: Parser BaseImage +taggedImage = parseBaseImage tagParser + where + tagParser _ = do + void $ char ':' + t <- someUnless "the image tag" (\c -> c == '@' || c == ':') + return (Just . Tag $ t) + +parseDigest :: Parser Digest +parseDigest = do + void $ char '@' + d <- someUnless "the image digest" (== '@') + return $ Digest d + +untaggedImage :: Parser BaseImage +untaggedImage = parseBaseImage notInvalidTag + where + notInvalidTag :: Text -> Parser (Maybe Tag) + notInvalidTag name = do + try (notFollowedBy $ string ":") "no ':' or a valid image tag string (example: " + ++ T.unpack name + ++ ":valid-tag)" + return Nothing + +imageAlias :: Parser ImageAlias +imageAlias = do + void (try (reserved "AS") "'AS' followed by the image alias") + aka <- someUnless "the image alias" (== '\n') + return $ ImageAlias aka + +baseImage :: Parser BaseImage +baseImage = try taggedImage <|> untaggedImage + +parseFrom :: Parser (Instruction Text) +parseFrom = do + reserved "FROM" + From <$> baseImage diff --git a/src/Language/Docker/Parser/Healthcheck.hs b/src/Language/Docker/Parser/Healthcheck.hs new file mode 100644 index 0000000..76fb27d --- /dev/null +++ b/src/Language/Docker/Parser/Healthcheck.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Language.Docker.Parser.Healthcheck + ( parseHealthcheck, + ) +where + +import Data.Maybe (listToMaybe) +import qualified Data.Text as T +import Data.Time.Clock (secondsToDiffTime) +import Language.Docker.Parser.Cmd (parseCmd) +import Language.Docker.Parser.Prelude +import Language.Docker.Syntax + +data CheckFlag + = FlagInterval Duration + | FlagTimeout Duration + | FlagStartPeriod Duration + | FlagRetries Retries + | CFlagInvalid (Text, Text) + +parseHealthcheck :: Parser (Instruction Text) +parseHealthcheck = do + reserved "HEALTHCHECK" + Healthcheck <$> (fullCheck <|> noCheck) + where + noCheck = string "NONE" >> return NoCheck + allFlags = do + flags <- someFlags + requiredWhitespace "another flag" + return flags + someFlags = do + x <- checkFlag + cont <- try (requiredWhitespace >> lookAhead (string "--") >> return True) <|> return False + if cont + then do + xs <- someFlags + return (x : xs) + else return [x] + fullCheck = do + flags <- allFlags <|> return [] + let intervals = [x | FlagInterval x <- flags] + let timeouts = [x | FlagTimeout x <- flags] + let startPeriods = [x | FlagStartPeriod x <- flags] + let retriesD = [x | FlagRetries x <- flags] + let invalid = [x | CFlagInvalid x <- flags] + -- Let's do some validation on the flags + case (invalid, intervals, timeouts, startPeriods, retriesD) of + ((k, v) : _, _, _, _, _) -> unexpectedFlag k v + (_, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--interval" + (_, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--timeout" + (_, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--start-period" + (_, _, _, _, _ : _ : _) -> customError $ DuplicateFlagError "--retries" + _ -> do + Cmd checkCommand <- parseCmd + let interval = listToMaybe intervals + let timeout = listToMaybe timeouts + let startPeriod = listToMaybe startPeriods + let retries = listToMaybe retriesD + return $ Check CheckArgs {..} + +checkFlag :: Parser CheckFlag +checkFlag = + (FlagInterval <$> durationFlag "--interval=" "--interval") + <|> (FlagTimeout <$> durationFlag "--timeout=" "--timeout") + <|> (FlagStartPeriod <$> durationFlag "--start-period=" "--start-period") + <|> (FlagRetries <$> retriesFlag "--retries") + <|> (CFlagInvalid <$> anyFlag "no flags") + +durationFlag :: Text -> Parser Duration +durationFlag flagName = do + void $ try (string flagName) + scale <- natural + unit <- char 's' <|> char 'm' <|> char 'h' "either 's', 'm' or 'h' as the unit" + case unit of + 's' -> return $ Duration (secondsToDiffTime scale) + 'm' -> return $ Duration (secondsToDiffTime (scale * 60)) + 'h' -> return $ Duration (secondsToDiffTime (scale * 60 * 60)) + _ -> fail "only 's', 'm' or 'h' are allowed as the duration" + +retriesFlag :: Parser Retries +retriesFlag = do + void $ try (string "--retries=") + n <- try natural "the number of retries" + return $ Retries (fromIntegral n) + +anyFlag :: Parser (Text, Text) +anyFlag = do + void $ string "--" + name <- someUnless "the flag value" (== '=') + void $ char '=' + val <- anyUnless (== ' ') + return (T.append "--" name, val) + +unexpectedFlag :: Text -> Text -> Parser a +unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name) +unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name) diff --git a/src/Language/Docker/Parser/Instruction.hs b/src/Language/Docker/Parser/Instruction.hs new file mode 100644 index 0000000..eb1c16a --- /dev/null +++ b/src/Language/Docker/Parser/Instruction.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Docker.Parser.Instruction + ( parseInstruction, + parseShell, + parseStopSignal, + parseArg, + parseUser, + parseWorkdir, + parseVolume, + parseEntryPoint, + parseMaintainer, + parseOnbuild, + parseComment, + ) +where + +import Language.Docker.Parser.Arguments (arguments) +import Language.Docker.Parser.Cmd (parseCmd) +import Language.Docker.Parser.Copy (parseAdd, parseCopy) +import Language.Docker.Parser.Expose (parseExpose) +import Language.Docker.Parser.From (parseFrom) +import Language.Docker.Parser.Healthcheck (parseHealthcheck) +import Language.Docker.Parser.Pairs (parseEnv, parseLabel) +import Language.Docker.Parser.Prelude +import Language.Docker.Parser.Run (parseRun) +import Language.Docker.Syntax + +parseShell :: Parser (Instruction Text) +parseShell = do + reserved "SHELL" + Shell <$> arguments + +parseStopSignal :: Parser (Instruction Text) +parseStopSignal = do + reserved "STOPSIGNAL" + args <- untilEol "the stop signal" + return $ Stopsignal args + +parseArg :: Parser (Instruction Text) +parseArg = do + reserved "ARG" + (try nameWithDefault "the arg name") + <|> Arg <$> untilEol "the argument name" <*> pure Nothing + where + nameWithDefault = do + name <- someUnless "the argument name" (== '=') + void $ char '=' + df <- untilEol "the argument value" + return $ Arg name (Just df) + +parseUser :: Parser (Instruction Text) +parseUser = do + reserved "USER" + username <- untilEol "the user" + return $ User username + +parseWorkdir :: Parser (Instruction Text) +parseWorkdir = do + reserved "WORKDIR" + directory <- untilEol "the workdir path" + return $ Workdir directory + +parseVolume :: Parser (Instruction Text) +parseVolume = do + reserved "VOLUME" + directory <- untilEol "the volume path" + return $ Volume directory + +parseMaintainer :: Parser (Instruction Text) +parseMaintainer = do + reserved "MAINTAINER" + name <- untilEol "the maintainer name" + return $ Maintainer name + +parseEntryPoint :: Parser (Instruction Text) +parseEntryPoint = do + reserved "ENTRYPOINT" + Entrypoint <$> arguments + +parseOnbuild :: Parser (Instruction Text) +parseOnbuild = do + reserved "ONBUILD" + OnBuild <$> parseInstruction + +parseComment :: Parser (Instruction Text) +parseComment = Comment <$> comment + +parseInstruction :: Parser (Instruction Text) +parseInstruction = + choice + [ parseOnbuild, + parseFrom, + parseCopy, + parseRun, + parseWorkdir, + parseEntryPoint, + parseVolume, + parseExpose, + parseEnv, + parseArg, + parseUser, + parseLabel, + parseStopSignal, + parseCmd, + parseShell, + parseMaintainer, + parseAdd, + parseComment, + parseHealthcheck + ] diff --git a/src/Language/Docker/Parser/Pairs.hs b/src/Language/Docker/Parser/Pairs.hs new file mode 100644 index 0000000..72dee3a --- /dev/null +++ b/src/Language/Docker/Parser/Pairs.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Docker.Parser.Pairs + ( parseEnv, + parseLabel, + ) +where + +import qualified Data.Text as T +import Language.Docker.Parser.Prelude +import Language.Docker.Syntax + +-- We cannot use string literal because it swallows space +-- and therefore have to implement quoted values by ourselves +doubleQuotedValue :: Parser Text +doubleQuotedValue = between (string "\"") (string "\"") (stringWithEscaped ['"'] Nothing) + +singleQuotedValue :: Parser Text +singleQuotedValue = between (string "'") (string "'") (stringWithEscaped ['\''] Nothing) + +unquotedString :: (Char -> Bool) -> Parser Text +unquotedString acceptCondition = do + str <- stringWithEscaped [' ', '\t'] (Just (\c -> acceptCondition c && c /= '"' && c /= '\'')) + checkFaults str + where + checkFaults str + | T.null str = fail "a non empty string" + | T.head str == '\'' = customError $ QuoteError "single" (T.unpack str) + | T.head str == '\"' = customError $ QuoteError "double" (T.unpack str) + | otherwise = return str + +singleValue :: (Char -> Bool) -> Parser Text +singleValue acceptCondition = mconcat <$> variants + where + variants = + many $ + choice + [ doubleQuotedValue "a string inside double quotes", + singleQuotedValue "a string inside single quotes", + unquotedString acceptCondition "a string with no quotes" + ] + +pair :: Parser (Text, Text) +pair = do + key <- singleValue (/= '=') + value <- withEqualSign <|> withoutEqualSign + return (key, value) + where + withEqualSign = do + void $ char '=' + singleValue (\c -> c /= ' ' && c /= '\t') + withoutEqualSign = do + requiredWhitespace + untilEol "value" + +pairs :: Parser Pairs +pairs = (pair "a key value pair (key=value)") `sepEndBy1` requiredWhitespace + +parseLabel :: Parser (Instruction Text) +parseLabel = do + reserved "LABEL" + Label <$> pairs + +parseEnv :: Parser (Instruction Text) +parseEnv = do + reserved "ENV" + Env <$> pairs diff --git a/src/Language/Docker/Parser/Prelude.hs b/src/Language/Docker/Parser/Prelude.hs new file mode 100644 index 0000000..6df6611 --- /dev/null +++ b/src/Language/Docker/Parser/Prelude.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Docker.Parser.Prelude + ( customError, + comment, + eol, + reserved, + natural, + commaSep, + stringLiteral, + brackets, + whitespace, + requiredWhitespace, + untilEol, + symbol, + caseInsensitiveString, + stringWithEscaped, + lexeme, + isNl, + isSpaceNl, + anyUnless, + someUnless, + Parser, + Error, + DockerfileError (..), + module Megaparsec, + char, + string, + void, + when, + Text, + module Data.Default.Class + ) +where + +import Control.Monad (void, when) +import Data.Data +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec as Megaparsec hiding (Label) +import Text.Megaparsec.Char hiding (eol) +import qualified Text.Megaparsec.Char.Lexer as L +import Data.Default.Class (Default(def)) + +data DockerfileError + = DuplicateFlagError String + | NoValueFlagError String + | InvalidFlagError String + | FileListError String + | MissingArgument [Text] + | DuplicateArgument Text + | UnexpectedArgument Text Text + | QuoteError + String + String + deriving (Eq, Data, Typeable, Ord, Read, Show) + +type Parser = Parsec DockerfileError Text + +type Error = ParseErrorBundle Text DockerfileError + +instance ShowErrorComponent DockerfileError where + showErrorComponent (DuplicateFlagError f) = "duplicate flag: " ++ f + showErrorComponent (FileListError f) = + "unexpected end of line. At least two arguments are required for " ++ f + showErrorComponent (NoValueFlagError f) = "unexpected flag " ++ f ++ " with no value" + showErrorComponent (InvalidFlagError f) = "invalid flag: " ++ f + showErrorComponent (MissingArgument f) = "missing required argument(s) for mount flag: " ++ show f + showErrorComponent (DuplicateArgument f) = "duplicate argument for mount flag: " ++ T.unpack f + showErrorComponent (UnexpectedArgument a b) = "unexpected argument '" ++ T.unpack a ++ "' for mount of type '" ++ T.unpack b ++ "'" + showErrorComponent (QuoteError t str) = + "unexpected end of " ++ t ++ " quoted string " ++ str ++ " (unmatched quote)" + +-- Spaces are sometimes significant information in a dockerfile, this type records +-- thee presence of lack of such whitespace in certain lines. +data FoundWhitespace + = FoundWhitespace + | MissingWhitespace + deriving (Eq, Show) + +-- There is no need to remember how many spaces we found in a line, so we can +-- cheaply remmeber that we already whitenessed some significant whitespace while +-- parsing an expression by concatenating smaller results +instance Semigroup FoundWhitespace where + FoundWhitespace <> _ = FoundWhitespace + _ <> a = a + +instance Monoid FoundWhitespace where + mempty = MissingWhitespace + +------------------------------------ +-- Utilities +------------------------------------ + +-- | End parsing signaling a “conversion error”. +customError :: DockerfileError -> Parser a +customError = fancyFailure . S.singleton . ErrorCustom + +castToSpace :: FoundWhitespace -> Text +castToSpace FoundWhitespace = " " +castToSpace MissingWhitespace = "" + +eol :: Parser () +eol = void ws "end of line" + where + ws = + some $ + choice [void onlySpaces1, void $ takeWhile1P Nothing (== '\n'), void escapedLineBreaks] + +reserved :: Text -> Parser () +reserved name = void (lexeme (string' name) T.unpack name) + +natural :: Parser Integer +natural = L.decimal "positive number" + +commaSep :: Parser a -> Parser [a] +commaSep p = sepBy (p <* whitespace) (symbol ",") + +stringLiteral :: Parser Text +stringLiteral = do + void (char '"') + lit <- manyTill L.charLiteral (char '"') + return (T.pack lit) + +brackets :: Parser a -> Parser a +brackets = between (symbol "[" *> whitespace) (whitespace *> symbol "]") + +onlySpaces :: Parser Text +onlySpaces = takeWhileP (Just "spaces") (\c -> c == ' ' || c == '\t') + +onlySpaces1 :: Parser Text +onlySpaces1 = takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t') + +escapedLineBreaks :: Parser FoundWhitespace +escapedLineBreaks = mconcat <$> breaks + where + breaks = + some $ do + try (char '\\' *> onlySpaces *> newlines) + skipMany . try $ onlySpaces *> comment *> newlines + -- Spaces before the next '\' have a special significance + -- so we remembeer the fact that we found some + FoundWhitespace <$ onlySpaces1 <|> pure MissingWhitespace + newlines = takeWhile1P Nothing isNl + +foundWhitespace :: Parser FoundWhitespace +foundWhitespace = mconcat <$> found + where + found = many $ choice [FoundWhitespace <$ onlySpaces1, escapedLineBreaks] + +whitespace :: Parser () +whitespace = void foundWhitespace + +requiredWhitespace :: Parser () +requiredWhitespace = do + ws <- foundWhitespace + case ws of + FoundWhitespace -> pure () + MissingWhitespace -> fail "missing whitespace" + +-- Parse value until end of line is reached +-- after consuming all escaped newlines +untilEol :: String -> Parser Text +untilEol name = do + res <- mconcat <$> predicate + when (res == "") $ fail ("expecting " ++ name) + pure res + where + predicate = + many $ + choice + [ castToSpace <$> escapedLineBreaks, + takeWhile1P (Just name) (\c -> c /= '\n' && c /= '\\'), + takeWhile1P Nothing (== '\\') <* notFollowedBy (char '\n') + ] + +symbol :: Text -> Parser Text +symbol name = do + x <- string name + whitespace + return x + +caseInsensitiveString :: Text -> Parser Text +caseInsensitiveString = string' + +stringWithEscaped :: [Char] -> Maybe (Char -> Bool) -> Parser Text +stringWithEscaped quoteChars maybeAcceptCondition = mconcat <$> sequences + where + sequences = + many $ + choice + [ mconcat <$> inner, + try $ takeWhile1P Nothing (== '\\') <* notFollowedBy quoteParser, + string "\\" *> quoteParser + ] + inner = + some $ + choice + [ castToSpace <$> escapedLineBreaks, + takeWhile1P + Nothing + (\c -> c /= '\\' && c /= '\n' && c `notElem` quoteChars && acceptCondition c) + ] + quoteParser = T.singleton <$> choice (fmap char quoteChars) + acceptCondition = fromMaybe (const True) maybeAcceptCondition + +lexeme :: Parser a -> Parser a +lexeme p = do + x <- p + requiredWhitespace + return x + +isNl :: Char -> Bool +isNl c = c == '\n' + +isSpaceNl :: Char -> Bool +isSpaceNl c = c == ' ' || c == '\t' || c == '\n' || c == '\\' + +anyUnless :: (Char -> Bool) -> Parser Text +anyUnless predicate = someUnless "" predicate <|> pure "" + +someUnless :: String -> (Char -> Bool) -> Parser Text +someUnless name predicate = do + res <- applyPredicate + case res of + [] -> fail ("expecting " ++ name) + _ -> pure (mconcat res) + where + applyPredicate = + many $ + choice + [ castToSpace <$> escapedLineBreaks, + takeWhile1P (Just name) (\c -> not (isSpaceNl c || predicate c)), + takeWhile1P Nothing (\c -> c == '\\' && not (predicate c)) + <* notFollowedBy (char '\n') + ] + +comment :: Parser Text +comment = do + void $ char '#' + takeWhileP Nothing (not . isNl) diff --git a/src/Language/Docker/Parser/Run.hs b/src/Language/Docker/Parser/Run.hs new file mode 100644 index 0000000..80370bb --- /dev/null +++ b/src/Language/Docker/Parser/Run.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Language.Docker.Parser.Run + ( parseRun, + runFlags, + ) +where + +import Data.Functor (($>)) +import qualified Data.Set as Set +import Language.Docker.Parser.Arguments (arguments) +import Language.Docker.Parser.Prelude +import Language.Docker.Syntax + +data RunFlag + = RunFlagMount RunMount + | RunFlagSecurity RunSecurity + | RunFlagNetwork RunNetwork + deriving (Show) + +data RunMountArg + = MountArgFromImage Text + | MountArgGid Integer + | MountArgId Text + | MountArgMode Text + | MountArgReadOnly Bool + | MountArgRequired + | MountArgSharing CacheSharing + | MountArgSource SourcePath + | MountArgTarget TargetPath + | MountArgType Text + | MountArgUid Integer + deriving (Show) + +data MountType + = Bind + | Cache + | Tmpfs + | Secret + | Ssh + +parseRun :: Parser (Instruction Text) +parseRun = do + reserved "RUN" + Run <$> runArguments + +runArguments :: Parser (RunArgs Text) +runArguments = do + presentFlags <- choice [runFlags <* requiredWhitespace, pure (RunFlags Nothing Nothing Nothing)] + args <- arguments + return $ RunArgs args presentFlags + +runFlags :: Parser RunFlags +runFlags = do + flags <- runFlag `sepBy` flagSeparator + return $ foldr toRunFlags emptyFlags flags + where + flagSeparator = try (requiredWhitespace *> lookAhead (string "--")) <|> fail "expected flag" + emptyFlags = RunFlags Nothing Nothing Nothing + toRunFlags (RunFlagMount m) rf = rf {mount = Just m} + toRunFlags (RunFlagNetwork n) rf = rf {network = Just n} + toRunFlags (RunFlagSecurity s) rf = rf {security = Just s} + +runFlag :: Parser RunFlag +runFlag = + choice + [RunFlagMount <$> runFlagMount, RunFlagSecurity <$> runFlagSecurity, RunFlagNetwork <$> runFlagNetwork] + +runFlagSecurity :: Parser RunSecurity +runFlagSecurity = do + void $ string "--security=" + choice [Insecure <$ string "insecure", Sandbox <$ string "sandbox"] + +runFlagNetwork :: Parser RunNetwork +runFlagNetwork = do + void $ string "--network=" + choice [NetworkNone <$ string "none", NetworkHost <$ string "host", NetworkDefault <$ string "default"] + +runFlagMount :: Parser RunMount +runFlagMount = do + void $ string "--mount=" + maybeType <- + choice + [ string "type=" + *> choice + [ Just Bind <$ string "bind", + Just Cache <$ string "cache", + Just Tmpfs <$ string "tmpfs", + Just Secret <$ string "secret", + Just Ssh <$ string "ssh" + ], + pure Nothing + ] + (mountType, args) <- return $ + case maybeType of + Nothing -> (Bind, argsParser Bind) + Just Ssh -> (Ssh, choice [string "," *> argsParser Ssh, pure []]) + Just t -> (t, string "," *> argsParser t) + case mountType of + Bind -> BindMount <$> (bindMount =<< args) + Cache -> CacheMount <$> (cacheMount =<< args) + Tmpfs -> TmpfsMount <$> (tmpfsMount =<< args) + Secret -> SecretMount <$> (secretMount =<< args) + Ssh -> SshMount <$> (secretMount =<< args) + +argsParser :: MountType -> Parser [RunMountArg] +argsParser mountType = mountChoices mountType `sepBy1` string "," + +bindMount :: [RunMountArg] -> Parser BindOpts +bindMount args = + case validArgs "bind" allowed required args of + Left e -> customError e + Right as -> return $ foldr bindOpts def as + where + allowed = Set.fromList ["target", "source", "from", "ro"] + required = Set.singleton "target" + bindOpts :: RunMountArg -> BindOpts -> BindOpts + bindOpts (MountArgTarget path) bo = bo {bTarget = path} + bindOpts (MountArgSource path) bo = bo {bSource = Just path} + bindOpts (MountArgFromImage img) bo = bo {bFromImage = Just img} + bindOpts (MountArgReadOnly ro) bo = bo {bReadOnly = Just ro} + bindOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug" + +cacheMount :: [RunMountArg] -> Parser CacheOpts +cacheMount args = + case validArgs "cache" allowed required args of + Left e -> customError e + Right as -> return $ foldr cacheOpts def as + where + allowed = Set.fromList ["target", "sharing", "id", "ro", "from", "source", "mode", "uid", "gid"] + required = Set.fromList ["target", "sharing"] + cacheOpts :: RunMountArg -> CacheOpts -> CacheOpts + cacheOpts (MountArgTarget path) co = co {cTarget = path} + cacheOpts (MountArgSharing sh) co = co {cSharing = sh} + cacheOpts (MountArgId i) co = co {cCacheId = Just i} + cacheOpts (MountArgReadOnly ro) co = co {cReadOnly = Just ro} + cacheOpts (MountArgFromImage img) co = co {cFromImage = Just img} + cacheOpts (MountArgSource path) co = co {cSource = Just path} + cacheOpts (MountArgMode m) co = co {cMode = Just m} + cacheOpts (MountArgUid u) co = co {cUid = Just u} + cacheOpts (MountArgGid g) co = co {cGid = Just g} + cacheOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug" + +tmpfsMount :: [RunMountArg] -> Parser TmpOpts +tmpfsMount args = + case validArgs "tmpfs" required required args of + Left e -> customError e + Right as -> return $ foldr tmpOpts def as + where + required = Set.singleton "target" + tmpOpts :: RunMountArg -> TmpOpts -> TmpOpts + tmpOpts (MountArgTarget path) t = t {tTarget = path} + tmpOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug" + +secretMount :: [RunMountArg] -> Parser SecretOpts +secretMount args = + case validArgs "secret" allowed required args of + Left e -> customError e + Right as -> return $ foldr secretOpts def as + where + allowed = Set.fromList ["target", "id", "required", "source", "mode", "uid", "gid"] + required = Set.empty + secretOpts :: RunMountArg -> SecretOpts -> SecretOpts + secretOpts (MountArgTarget path) co = co {sTarget = Just path} + secretOpts (MountArgId i) co = co {sCacheId = Just i} + secretOpts MountArgRequired co = co {sIsRequired = Just True} + secretOpts (MountArgSource path) co = co {sSource = Just path} + secretOpts (MountArgMode m) co = co {sMode = Just m} + secretOpts (MountArgUid u) co = co {sUid = Just u} + secretOpts (MountArgGid g) co = co {sGid = Just g} + secretOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug" + +validArgs :: + Foldable t => + Text -> + Set.Set Text -> + Set.Set Text -> + t RunMountArg -> + Either DockerfileError [RunMountArg] +validArgs typeName allowed required args = + let (result, seen) = foldr checkValidArg (Right [], Set.empty) args + in case Set.toList (Set.difference required seen) of + [] -> result + missing -> Left $ MissingArgument missing + where + checkValidArg _ x@(Left _, _) = x + checkValidArg a (Right as, seen) = + let name = toArgName a + in case (Set.member name allowed, Set.member name seen) of + (False, _) -> (Left (UnexpectedArgument name typeName), seen) + (_, True) -> (Left (DuplicateArgument name), seen) + (True, False) -> (Right (a : as), Set.insert name seen) + +mountChoices :: MountType -> Parser RunMountArg +mountChoices mountType = + choice $ + case mountType of + Bind -> + [ mountArgTarget, + mountArgSource, + mountArgFromImage, + mountArgReadOnly, + mountArgReadWrite + ] + Cache -> + [ mountArgTarget, + mountArgSource, + mountArgFromImage, + mountArgReadOnly, + mountArgReadWrite, + mountArgId, + mountArgSharing, + mountArgMode, + mountArgUid, + mountArgGid + ] + Tmpfs -> [mountArgTarget] + _ -> -- Secret and Ssh + [ mountArgTarget, + mountArgId, + mountArgRequired, + mountArgSource, + mountArgMode, + mountArgUid, + mountArgGid + ] + +stringArg :: Parser Text +stringArg = choice [stringLiteral, someUnless "a string" (== ',')] + +key :: Text -> Parser a -> Parser a +key name p = string (name <> "=") *> p + +cacheSharing :: Parser CacheSharing +cacheSharing = + choice [Private <$ string "private", Shared <$ string "shared", Locked <$ string "locked"] + +mountArgFromImage :: Parser RunMountArg +mountArgFromImage = MountArgFromImage <$> key "from" stringArg + +mountArgGid :: Parser RunMountArg +mountArgGid = MountArgGid <$> key "gid" natural + +mountArgId :: Parser RunMountArg +mountArgId = MountArgId <$> key "id" stringArg + +mountArgMode :: Parser RunMountArg +mountArgMode = MountArgMode <$> key "mode" stringArg + +mountArgReadOnly :: Parser RunMountArg +mountArgReadOnly = MountArgReadOnly <$> (choice ["ro", "readonly"] $> True) + +mountArgReadWrite :: Parser RunMountArg +mountArgReadWrite = MountArgReadOnly <$> (choice ["rw", "readwrite"] $> False) + +mountArgRequired :: Parser RunMountArg +mountArgRequired = MountArgRequired <$ string "required" + +mountArgSharing :: Parser RunMountArg +mountArgSharing = MountArgSharing <$> key "sharing" cacheSharing + +mountArgSource :: Parser RunMountArg +mountArgSource = do + label "source=" $ choice [string "source=", string "src="] + MountArgSource . SourcePath <$> stringArg + +mountArgTarget :: Parser RunMountArg +mountArgTarget = do + label "target=" $ choice [string "target=", string "dest=", string "destination="] + MountArgTarget . TargetPath <$> stringArg + +mountArgUid :: Parser RunMountArg +mountArgUid = MountArgUid <$> key "uid" natural + +toArgName :: RunMountArg -> Text +toArgName (MountArgFromImage _) = "from" +toArgName (MountArgGid _) = "gid" +toArgName (MountArgId _) = "id" +toArgName (MountArgMode _) = "mode" +toArgName (MountArgReadOnly _) = "ro" +toArgName MountArgRequired = "required" +toArgName (MountArgSharing _) = "sharing" +toArgName (MountArgSource _) = "source" +toArgName (MountArgTarget _) = "target" +toArgName (MountArgType _) = "type" +toArgName (MountArgUid _) = "uid" diff --git a/src/Language/Docker/PrettyPrint.hs b/src/Language/Docker/PrettyPrint.hs index 071454e..e90f509 100644 --- a/src/Language/Docker/PrettyPrint.hs +++ b/src/Language/Docker/PrettyPrint.hs @@ -1,35 +1,36 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Language.Docker.PrettyPrint where -import Data.List.NonEmpty as NonEmpty (NonEmpty(..), toList) +import Data.List.NonEmpty as NonEmpty (NonEmpty (..), toList) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Internal (Doc(Empty)) +import Data.Text.Prettyprint.Doc.Internal (Doc (Empty)) import Data.Text.Prettyprint.Doc.Render.Text (renderLazy) import Language.Docker.Syntax import Prelude hiding ((<>), (>>)) -data EscapeAccum = EscapeAccum - { buffer :: !B.Builder - , count :: !Int - , escaping :: !Bool - } +data EscapeAccum + = EscapeAccum + { buffer :: !B.Builder, + count :: !Int, + escaping :: !Bool + } instance Pretty (Arguments Text) where - pretty = prettyPrintArguments + pretty = prettyPrintArguments -- | Pretty print a 'Dockerfile' to a 'Text' prettyPrint :: Dockerfile -> L.Text @@ -51,30 +52,30 @@ prettyPrintImage (Image Nothing name) = pretty name prettyPrintImage (Image (Just (Registry reg)) name) = pretty reg <> "/" <> pretty name prettyPrintBaseImage :: BaseImage -> Doc ann -prettyPrintBaseImage BaseImage{..} = do - prettyPlatform platform - prettyPrintImage image - prettyTag tag - prettyDigest digest - prettyAlias alias +prettyPrintBaseImage BaseImage {..} = do + prettyPlatform platform + prettyPrintImage image + prettyTag tag + prettyDigest digest + prettyAlias alias where (>>) = (<>) prettyPlatform maybePlatform = - case maybePlatform of - Nothing -> mempty - Just p -> "--platform=" <> pretty p <> " " + case maybePlatform of + Nothing -> mempty + Just p -> "--platform=" <> pretty p <> " " prettyTag maybeTag = - case maybeTag of - Nothing -> mempty - Just (Tag p) -> ":" <> pretty p + case maybeTag of + Nothing -> mempty + Just (Tag p) -> ":" <> pretty p prettyAlias maybeAlias = - case maybeAlias of - Nothing -> mempty - Just (ImageAlias a) -> " AS " <> pretty a + case maybeAlias of + Nothing -> mempty + Just (ImageAlias a) -> " AS " <> pretty a prettyDigest maybeDigest = - case maybeDigest of - Nothing -> mempty - Just (Digest d) -> "@" <> pretty d + case maybeDigest of + Nothing -> mempty + Just (Digest d) -> "@" <> pretty d prettyPrintPairs :: Pairs -> Doc ann prettyPrintPairs ps = align $ sepLine $ fmap prettyPrintPair ps @@ -99,22 +100,22 @@ doubleQoute w = enclose dquote dquote (pretty (escapeQuotes w)) escapeQuotes :: Text -> L.Text escapeQuotes text = - case Text.foldr accumulate (EscapeAccum mempty 0 False) text of - EscapeAccum buffer _ False -> B.toLazyText buffer - EscapeAccum buffer count True -> - case count `mod` 2 of - 0 -> B.toLazyText (B.singleton '\\' <> buffer) - _ -> B.toLazyText buffer + case Text.foldr accumulate (EscapeAccum mempty 0 False) text of + EscapeAccum buffer _ False -> B.toLazyText buffer + EscapeAccum buffer count True -> + case count `mod` 2 of + 0 -> B.toLazyText (B.singleton '\\' <> buffer) + _ -> B.toLazyText buffer where accumulate '"' EscapeAccum {buffer, escaping = False} = - EscapeAccum (B.singleton '"' <> buffer) 0 True + EscapeAccum (B.singleton '"' <> buffer) 0 True accumulate '\\' EscapeAccum {buffer, escaping = True, count} = - EscapeAccum (B.singleton '\\' <> buffer) (count + 1) True + EscapeAccum (B.singleton '\\' <> buffer) (count + 1) True accumulate c EscapeAccum {buffer, escaping = True, count} - | count `mod` 2 == 0 = EscapeAccum (B.singleton c <> B.singleton '\\' <> buffer) 0 False - | otherwise = EscapeAccum (B.singleton c <> buffer) 0 False -- It was already escaped + | count `mod` 2 == 0 = EscapeAccum (B.singleton c <> B.singleton '\\' <> buffer) 0 False + | otherwise = EscapeAccum (B.singleton c <> buffer) 0 False -- It was already escaped accumulate c EscapeAccum {buffer, escaping = False} = - EscapeAccum (B.singleton c <> buffer) 0 False + EscapeAccum (B.singleton c <> buffer) 0 False prettyPrintPort :: Port -> Doc ann prettyPrintPort (PortStr str) = pretty str @@ -125,24 +126,24 @@ prettyPrintPort (Port num UDP) = pretty num <> "/udp" prettyPrintFileList :: NonEmpty SourcePath -> TargetPath -> Doc ann prettyPrintFileList sources (TargetPath dest) = - let ending = - case (Text.isSuffixOf "/" dest, sources) of - (True, _) -> "" -- If the target ends with / then no extra ending is needed - (_, _fst :| _snd:_) -> "/" -- More than one source means that the target should end in / - _ -> "" - in hsep $ [pretty s | SourcePath s <- toList sources] ++ [pretty dest <> ending] + let ending = + case (Text.isSuffixOf "/" dest, sources) of + (True, _) -> "" -- If the target ends with / then no extra ending is needed + (_, _fst :| _snd : _) -> "/" -- More than one source means that the target should end in / + _ -> "" + in hsep $ [pretty s | SourcePath s <- toList sources] ++ [pretty dest <> ending] prettyPrintChown :: Chown -> Doc ann prettyPrintChown chown = - case chown of - Chown c -> "--chown=" <> pretty c - NoChown -> mempty + case chown of + Chown c -> "--chown=" <> pretty c + NoChown -> mempty prettyPrintCopySource :: CopySource -> Doc ann prettyPrintCopySource source = - case source of - CopySource c -> "--from=" <> pretty c - NoSource -> mempty + case source of + CopySource c -> "--from=" <> pretty c + NoSource -> mempty prettyPrintDuration :: Text -> Maybe Duration -> Doc ann prettyPrintDuration flagName = maybe mempty pp @@ -154,78 +155,153 @@ prettyPrintRetries = maybe mempty pp where pp (Retries r) = "--retries=" <> pretty r +prettyPrintRunMount :: Maybe RunMount -> Doc ann +prettyPrintRunMount Nothing = mempty +prettyPrintRunMount (Just mount) = "--mount=" + <> case mount of + BindMount BindOpts {..} -> + "type=bind" + <> printTarget bTarget + <> maybe mempty printSource bSource + <> maybe mempty printFromImage bFromImage + <> maybe mempty printReadOnly bReadOnly + CacheMount CacheOpts {..} -> + "type=cache" + <> printTarget cTarget + <> printSharing cSharing + <> maybe mempty printId cCacheId + <> maybe mempty printFromImage cFromImage + <> maybe mempty printSource cSource + <> maybe mempty printMode cMode + <> maybe mempty printUid cUid + <> maybe mempty printGid cGid + <> maybe mempty printReadOnly cReadOnly + SshMount SecretOpts {..} -> + "type=ssh" + <> maybe mempty printTarget sTarget + <> maybe mempty printId sCacheId + <> maybe mempty printSource sSource + <> maybe mempty printMode sMode + <> maybe mempty printUid sUid + <> maybe mempty printGid sGid + <> maybe mempty printRequired sIsRequired + SecretMount SecretOpts {..} -> + "type=secret" + <> maybe mempty printTarget sTarget + <> maybe mempty printId sCacheId + <> maybe mempty printSource sSource + <> maybe mempty printMode sMode + <> maybe mempty printUid sUid + <> maybe mempty printGid sGid + <> maybe mempty printRequired sIsRequired + TmpfsMount TmpOpts {..} -> "type=tmpfs" <> printTarget tTarget + where + printQuotable str + | Text.any (== '"') str = doubleQoute str + | otherwise = pretty str + printTarget (TargetPath t) = ",target=" <> printQuotable t + printSource (SourcePath s) = ",source=" <> printQuotable s + printFromImage f = ",from=" <> printQuotable f + printSharing sharing = ",sharing=" + <> case sharing of + Shared -> "shared" + Private -> "private" + Locked -> "locked" + printId i = ",id=" <> printQuotable i + printMode m = ",mode=" <> pretty m + printUid uid = ",uid=" <> pretty uid + printGid gid = ",gid=" <> pretty gid + printReadOnly True = ",ro" + printReadOnly False = ",rw" + printRequired True = ",required" + printRequired False = mempty + +prettyPrintRunNetwork :: Maybe RunNetwork -> Doc ann +prettyPrintRunNetwork Nothing = mempty +prettyPrintRunNetwork (Just NetworkHost) = "--network=host" +prettyPrintRunNetwork (Just NetworkNone) = "--network=none" +prettyPrintRunNetwork (Just NetworkDefault) = "--network=default" + +prettyPrintRunSecurity :: Maybe RunSecurity -> Doc ann +prettyPrintRunSecurity Nothing = mempty +prettyPrintRunSecurity (Just Sandbox) = "--security=sandbox" +prettyPrintRunSecurity (Just Insecure) = "--security=insecure" + prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann prettyPrintInstruction i = - case i of - Maintainer m -> do - "MAINTAINER" - pretty m - Arg a Nothing -> do - "ARG" - pretty a - Arg k (Just v) -> do - "ARG" - pretty k <> "=" <> pretty v - Entrypoint e -> do - "ENTRYPOINT" - pretty e - Stopsignal s -> do - "STOPSIGNAL" - pretty s - Workdir w -> do - "WORKDIR" - pretty w - Expose (Ports ps) -> do - "EXPOSE" - hsep (fmap prettyPrintPort ps) - Volume dir -> do - "VOLUME" - pretty dir - Run c -> do - "RUN" - pretty c - Copy CopyArgs {sourcePaths, targetPath, chownFlag, sourceFlag} -> do - "COPY" - prettyPrintChown chownFlag - prettyPrintCopySource sourceFlag - prettyPrintFileList sourcePaths targetPath - Cmd c -> do - "CMD" - pretty c - Label l -> do - "LABEL" - prettyPrintPairs l - Env ps -> do - "ENV" - prettyPrintPairs ps - User u -> do - "USER" - pretty u - Comment s -> do - pretty '#' - pretty s - OnBuild i' -> do - "ONBUILD" - prettyPrintInstruction i' - From b -> do - "FROM" - prettyPrintBaseImage b - Add AddArgs {sourcePaths, targetPath, chownFlag} -> do - "ADD" - prettyPrintChown chownFlag - prettyPrintFileList sourcePaths targetPath - Shell args -> do - "SHELL" - pretty args - Healthcheck NoCheck -> "HEALTHCHECK NONE" - Healthcheck (Check CheckArgs {..}) -> do - "HEALTHCHECK" - prettyPrintDuration "--interval=" interval - prettyPrintDuration "--timeout=" timeout - prettyPrintDuration "--start-period=" startPeriod - prettyPrintRetries retries - "CMD" - pretty checkCommand + case i of + Maintainer m -> do + "MAINTAINER" + pretty m + Arg a Nothing -> do + "ARG" + pretty a + Arg k (Just v) -> do + "ARG" + pretty k <> "=" <> pretty v + Entrypoint e -> do + "ENTRYPOINT" + pretty e + Stopsignal s -> do + "STOPSIGNAL" + pretty s + Workdir w -> do + "WORKDIR" + pretty w + Expose (Ports ps) -> do + "EXPOSE" + hsep (fmap prettyPrintPort ps) + Volume dir -> do + "VOLUME" + pretty dir + Run (RunArgs c RunFlags {mount, network, security}) -> do + "RUN" + prettyPrintRunMount mount + prettyPrintRunNetwork network + prettyPrintRunSecurity security + pretty c + Copy CopyArgs {sourcePaths, targetPath, chownFlag, sourceFlag} -> do + "COPY" + prettyPrintChown chownFlag + prettyPrintCopySource sourceFlag + prettyPrintFileList sourcePaths targetPath + Cmd c -> do + "CMD" + pretty c + Label l -> do + "LABEL" + prettyPrintPairs l + Env ps -> do + "ENV" + prettyPrintPairs ps + User u -> do + "USER" + pretty u + Comment s -> do + pretty '#' + pretty s + OnBuild i' -> do + "ONBUILD" + prettyPrintInstruction i' + From b -> do + "FROM" + prettyPrintBaseImage b + Add AddArgs {sourcePaths, targetPath, chownFlag} -> do + "ADD" + prettyPrintChown chownFlag + prettyPrintFileList sourcePaths targetPath + Shell args -> do + "SHELL" + pretty args + Healthcheck NoCheck -> "HEALTHCHECK NONE" + Healthcheck (Check CheckArgs {..}) -> do + "HEALTHCHECK" + prettyPrintDuration "--interval=" interval + prettyPrintDuration "--timeout=" timeout + prettyPrintDuration "--start-period=" startPeriod + prettyPrintRetries retries + "CMD" + pretty checkCommand where (>>) = spaceCat diff --git a/src/Language/Docker/Syntax.hs b/src/Language/Docker/Syntax.hs index 66d5631..141e913 100644 --- a/src/Language/Docker/Syntax.hs +++ b/src/Language/Docker/Syntax.hs @@ -1,190 +1,326 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, - DuplicateRecordFields, FlexibleInstances, DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Language.Docker.Syntax where +import Data.Default.Class (Default (..)) import Data.List (intercalate, isInfixOf) import Data.List.NonEmpty (NonEmpty) import Data.List.Split (endBy) -import Data.String (IsString(..)) +import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock (DiffTime) -import GHC.Exts (IsList(..)) +import GHC.Exts (IsList (..)) -data Image = Image - { registryName :: !(Maybe Registry) - , imageName :: !Text - } deriving (Show, Eq, Ord) +data Image + = Image + { registryName :: !(Maybe Registry), + imageName :: !Text + } + deriving (Show, Eq, Ord) instance IsString Image where - fromString img = - if "/" `isInfixOf` img - then let parts = endBy "/" img - in if "." `isInfixOf` head parts - then Image - (Just (Registry (Text.pack (head parts)))) - (Text.pack . intercalate "/" $ tail parts) - else Image Nothing (Text.pack img) - else Image Nothing (Text.pack img) - -newtype Registry = Registry - { unRegistry :: Text - } deriving (Show, Eq, Ord, IsString) - -newtype Tag = Tag - { unTag :: Text - } deriving (Show, Eq, Ord, IsString) - -newtype Digest = Digest - { unDigest :: Text - } deriving (Show, Eq, Ord, IsString) + 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 Tag + = Tag + { unTag :: Text + } + deriving (Show, Eq, Ord, IsString) + +newtype Digest + = Digest + { unDigest :: Text + } + deriving (Show, Eq, Ord, IsString) data Protocol - = TCP - | UDP - deriving (Show, Eq, Ord) + = TCP + | UDP + deriving (Show, Eq, Ord) data Port - = Port !Int - !Protocol - | PortStr !Text - | PortRange !Int - !Int - !Protocol - deriving (Show, Eq, Ord) - -newtype Ports = Ports - { unPorts :: [Port] - } deriving (Show, Eq, Ord) + = Port + !Int + !Protocol + | PortStr !Text + | PortRange + !Int + !Int + !Protocol + deriving (Show, Eq, Ord) + +newtype Ports + = Ports + { unPorts :: [Port] + } + deriving (Show, Eq, Ord) instance IsList Ports where - type Item Ports = Port - fromList = Ports - toList (Ports ps) = ps + type Item Ports = Port + fromList = Ports + toList (Ports ps) = ps type Directory = Text type Platform = Text -newtype ImageAlias = ImageAlias - { unImageAlias :: Text - } deriving (Show, Eq, Ord, IsString) - -data BaseImage = BaseImage - { image :: !Image - , tag :: !(Maybe Tag) - , digest :: !(Maybe Digest) - , alias :: !(Maybe ImageAlias) - , platform :: !(Maybe Platform) - } deriving (Eq, Ord, Show) +newtype ImageAlias + = ImageAlias + { unImageAlias :: Text + } + deriving (Show, Eq, Ord, IsString) + +data BaseImage + = BaseImage + { image :: !Image, + tag :: !(Maybe Tag), + digest :: !(Maybe Digest), + alias :: !(Maybe ImageAlias), + platform :: !(Maybe Platform) + } + deriving (Eq, Ord, Show) -- | Type of the Dockerfile AST type Dockerfile = [InstructionPos Text] -newtype SourcePath = SourcePath - { unSourcePath :: Text - } deriving (Show, Eq, Ord, IsString) +newtype SourcePath + = SourcePath + { unSourcePath :: Text + } + deriving (Show, Eq, Ord, IsString) -newtype TargetPath = TargetPath - { unTargetPath :: Text - } deriving (Show, Eq, Ord, IsString) +newtype TargetPath + = TargetPath + { unTargetPath :: Text + } + deriving (Show, Eq, Ord, IsString) data Chown - = Chown !Text - | NoChown - deriving (Show, Eq, Ord) + = Chown !Text + | NoChown + deriving (Show, Eq, Ord) instance IsString Chown where - fromString ch = - case ch of - "" -> NoChown - _ -> Chown (Text.pack ch) + fromString ch = + case ch of + "" -> NoChown + _ -> Chown (Text.pack ch) data CopySource - = CopySource !Text - | NoSource - deriving (Show, Eq, Ord) + = CopySource !Text + | NoSource + deriving (Show, Eq, Ord) instance IsString CopySource where - fromString src = - case src of - "" -> NoSource - _ -> CopySource (Text.pack src) - -newtype Duration = Duration - { durationTime :: DiffTime - } deriving (Show, Eq, Ord, Num) - -newtype Retries = Retries - { times :: Int - } deriving (Show, Eq, Ord, Num) - -data CopyArgs = CopyArgs - { sourcePaths :: NonEmpty SourcePath - , targetPath :: !TargetPath - , chownFlag :: !Chown - , sourceFlag :: !CopySource - } deriving (Show, Eq, Ord) - -data AddArgs = AddArgs - { sourcePaths :: NonEmpty SourcePath - , targetPath :: !TargetPath - , chownFlag :: !Chown - } deriving (Show, Eq, Ord) + fromString src = + case src of + "" -> NoSource + _ -> CopySource (Text.pack src) + +newtype Duration + = Duration + { durationTime :: DiffTime + } + deriving (Show, Eq, Ord, Num) + +newtype Retries + = Retries + { times :: Int + } + deriving (Show, Eq, Ord, Num) + +data CopyArgs + = CopyArgs + { sourcePaths :: NonEmpty SourcePath, + targetPath :: !TargetPath, + chownFlag :: !Chown, + sourceFlag :: !CopySource + } + deriving (Show, Eq, Ord) + +data AddArgs + = AddArgs + { sourcePaths :: NonEmpty SourcePath, + targetPath :: !TargetPath, + chownFlag :: !Chown + } + deriving (Show, Eq, Ord) data Check 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 - -data CheckArgs args = CheckArgs - { checkCommand :: !(Arguments args) - , interval :: !(Maybe Duration) - , timeout :: !(Maybe Duration) - , startPeriod :: !(Maybe Duration) - , retries :: !(Maybe Retries) - } deriving (Show, Eq, Ord, Functor) + type 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) type Pairs = [(Text, Text)] +data RunMount + = BindMount !BindOpts + | CacheMount !CacheOpts + | TmpfsMount !TmpOpts + | SecretMount !SecretOpts + | SshMount !SecretOpts + deriving (Eq, Show, Ord) + +data BindOpts + = BindOpts + { bTarget :: !TargetPath, + bSource :: !(Maybe SourcePath), + bFromImage :: !(Maybe Text), + bReadOnly :: !(Maybe Bool) + } + deriving (Show, Eq, Ord) + +instance Default BindOpts where + def = BindOpts "" Nothing Nothing Nothing + +data CacheOpts + = CacheOpts + { cTarget :: !TargetPath, + cSharing :: !CacheSharing, + cCacheId :: !(Maybe Text), + cReadOnly :: !(Maybe Bool), + cFromImage :: !(Maybe Text), + cSource :: !(Maybe SourcePath), + cMode :: !(Maybe Text), + cUid :: !(Maybe Integer), + cGid :: !(Maybe Integer) + } + deriving (Show, Eq, Ord) + +instance Default CacheOpts where + def = CacheOpts "" Shared Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +newtype TmpOpts = TmpOpts {tTarget :: TargetPath} deriving (Eq, Show, Ord) + +instance Default TmpOpts where + def = TmpOpts "" + +data SecretOpts + = SecretOpts + { sTarget :: !(Maybe TargetPath), + sCacheId :: !(Maybe Text), + sIsRequired :: !(Maybe Bool), + sSource :: !(Maybe SourcePath), + sMode :: !(Maybe Text), + sUid :: !(Maybe Integer), + sGid :: !(Maybe Integer) + } + deriving (Eq, Show, Ord) + +instance Default SecretOpts where + def = SecretOpts Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data CacheSharing + = Shared + | Private + | Locked + deriving (Show, Eq, Ord) + +data RunSecurity + = Insecure + | Sandbox + deriving (Show, Eq, Ord) + +data RunNetwork + = NetworkNone + | NetworkHost + | NetworkDefault + deriving (Show, Eq, Ord) + +data RunFlags + = RunFlags + { mount :: !(Maybe RunMount), + security :: !(Maybe RunSecurity), + network :: !(Maybe RunNetwork) + } + deriving (Show, Eq, Ord) + +instance Default RunFlags where + def = RunFlags Nothing Nothing Nothing + +data RunArgs args = RunArgs (Arguments args) RunFlags + deriving (Show, Eq, Ord, Functor) + +instance IsString (RunArgs Text) where + fromString s = + RunArgs + (ArgumentsText . Text.pack $ s) + RunFlags + { security = Nothing, + network = Nothing, + mount = Nothing + } + -- | All commands available in Dockerfiles data Instruction args - = From !BaseImage - | Add !AddArgs - | User !Text - | Label !Pairs - | Stopsignal !Text - | Copy !CopyArgs - | Run !(Arguments args) - | Cmd !(Arguments args) - | Shell !(Arguments args) - | Workdir !Directory - | Expose !Ports - | Volume !Text - | Entrypoint !(Arguments args) - | Maintainer !Text - | Env !Pairs - | Arg !Text - !(Maybe Text) - | Healthcheck !(Check args) - | Comment !Text - | OnBuild !(Instruction args) - deriving (Eq, Ord, Show, Functor) + = From !BaseImage + | Add !AddArgs + | User !Text + | Label !Pairs + | Stopsignal !Text + | Copy !CopyArgs + | Run !(RunArgs args) + | Cmd !(Arguments args) + | Shell !(Arguments args) + | Workdir !Directory + | Expose !Ports + | Volume !Text + | Entrypoint !(Arguments args) + | Maintainer !Text + | Env !Pairs + | Arg + !Text + !(Maybe Text) + | Healthcheck !(Check args) + | Comment !Text + | OnBuild !(Instruction args) + deriving (Eq, Ord, Show, Functor) type Filename = Text @@ -192,8 +328,10 @@ type Linenumber = Int -- | '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) diff --git a/src/Language/Docker/Syntax/Lift.hs b/src/Language/Docker/Syntax/Lift.hs deleted file mode 100644 index c953d02..0000000 --- a/src/Language/Docker/Syntax/Lift.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Docker.Syntax.Lift where - -import Data.Fixed (Fixed) -import Data.Time.Clock (DiffTime) -import Instances.TH.Lift () -- Defines Lift instances for ByteString and Text -import Language.Haskell.TH.Lift -import Language.Haskell.TH.Syntax () - -import Language.Docker.Syntax - -deriveLift ''Fixed - -deriveLift ''DiffTime - -deriveLift ''Protocol - -deriveLift ''Port - -deriveLift ''Ports - -deriveLift ''Registry - -deriveLift ''Image - -deriveLift ''ImageAlias - -deriveLift ''Tag - -deriveLift ''Digest - -deriveLift ''BaseImage - -deriveLift ''Arguments - -deriveLift ''Instruction - -deriveLift ''InstructionPos - -deriveLift ''SourcePath - -deriveLift ''TargetPath - -deriveLift ''Chown - -deriveLift ''CopySource - -deriveLift ''CopyArgs - -deriveLift ''AddArgs - -deriveLift ''Duration - -deriveLift ''Retries - -deriveLift ''CheckArgs - -deriveLift ''Check diff --git a/stack.yaml b/stack.yaml index 008b7e0..f191033 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-15.1 +resolver: lts-15.13 packages: - '.' flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index 7e51098..ea454db 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 489011 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml - sha256: d4ecc42b7125d68e4c3c036a08046ad0cd02ae0d9efbe3af2223a00ff8cc16f3 - original: lts-15.1 + size: 496112 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/13.yaml + sha256: 75a1a0f870e1876898b117b0e443f911b3fa2985bfabb53158c81ab5765beda5 + original: lts-15.13 diff --git a/test/Language/Docker/EDSL/QuasiSpec.hs b/test/Language/Docker/EDSL/QuasiSpec.hs deleted file mode 100644 index 311f8a7..0000000 --- a/test/Language/Docker/EDSL/QuasiSpec.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE QuasiQuotes #-} -module Language.Docker.EDSL.QuasiSpec - where - -import Language.Docker.EDSL -import Language.Docker.EDSL.Quasi -import Language.Docker.Syntax -import Test.Hspec - -spec :: Spec -spec = do - describe "dockerfile" $ - it "parses a dockerfile and returns its ast" $ do - let df = map instruction [dockerfile| - FROM node - RUN apt-get update - CMD ["node", "something.js"] - |] - df `shouldBe` [ From (BaseImage "node" Nothing Nothing Nothing Nothing) - , Run "apt-get update" - , Cmd ["node", "something.js"] - ] - - describe "edockerfile" $ - it "lets us use parsed dockerfiles seamlessly in our DSL" $ do - let d = do - from ("node" `aliased` "node-build") - expose (ports [tcpPort 8080, variablePort "PORT"]) - [edockerfile| - RUN apt-get update - CMD node something.js - |] - df = map instruction (toDockerfile d) - df `shouldBe` [ From (BaseImage - { image = "node" - , alias = Just "node-build" - , tag = Nothing - , digest = Nothing - , platform = Nothing} - ) - , Expose (Ports [Port 8080 TCP, PortStr "$PORT"]) - , Run "apt-get update" - , Cmd "node something.js" - ] diff --git a/test/Language/Docker/EDSLSpec.hs b/test/Language/Docker/EDSLSpec.hs deleted file mode 100644 index 7723b29..0000000 --- a/test/Language/Docker/EDSLSpec.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -module Language.Docker.EDSLSpec where - -import Control.Monad.IO.Class -import Data.List (sort) -import Language.Docker.EDSL -import Language.Docker.PrettyPrint -import qualified Language.Docker.Syntax as Syntax -import System.Directory -import System.FilePath -import System.FilePath.Glob -import Test.Hspec -import qualified Data.Text.Lazy as L -import qualified Data.Text as Text -import Data.Semigroup ((<>)) - -printed :: [L.Text] -> L.Text -printed = L.unlines - -spec :: Spec -spec = do - describe "toDockerfile s" $ - it "allows us to write haskell code that represents Dockerfiles" $ do - let r = map Syntax.instruction $ toDockerfile (do - from "node" - cmdArgs ["node", "-e", "'console.log(\'hey\')'"]) - r `shouldBe` [ Syntax.From $ - Syntax.BaseImage "node" - Nothing - Nothing - Nothing - Nothing - , Syntax.Cmd ["node", "-e", "'console.log(\'hey\')'"] - ] - - describe "prettyPrint $ toDockerfile s" $ do - it "allows us to write haskell code that represents Dockerfiles" $ do - let r = prettyPrint $ toDockerfile (do - from "node" - shell ["cmd", "/S"] - entrypoint ["/tini", "--"] - cmdArgs ["node", "-e", "'console.log(\'hey\')'"] - healthcheck $ check "curl -f http://localhost/ || exit 1" `interval` 300) - r `shouldBe` printed [ "FROM node" - , "SHELL [\"cmd\", \"/S\"]" - , "ENTRYPOINT [\"/tini\", \"--\"]" - , "CMD [\"node\", \"-e\", \"'console.log(\'hey\')'\"]" - , "HEALTHCHECK --interval=300s CMD curl -f http://localhost/ || exit 1" - ] - it "print expose instructions correctly" $ do - let r = prettyPrint $ toDockerfile (do - from "scratch" - expose $ ports [variablePort "PORT", tcpPort 80, udpPort 51] - expose $ ports [portRange 90 100] - expose $ ports [udpPortRange 190 200]) - r `shouldBe` printed [ "FROM scratch" - , "EXPOSE $PORT 80/tcp 51/udp" - , "EXPOSE 90-100" - , "EXPOSE 190-200/udp" - ] - - it "onBuild let's us nest statements" $ do - let r = prettyPrint $ toDockerfile $ do - from "node" - cmdArgs ["node", "-e", "'console.log(\'hey\')'"] - onBuild $ do - run "echo \"hello world\"" - run "echo \"hello world2\"" - r `shouldBe` printed [ "FROM node" - , "CMD [\"node\", \"-e\", \"'console.log(\'hey\')'\"]" - , "ONBUILD RUN echo \"hello world\"" - , "ONBUILD RUN echo \"hello world2\"" - ] - - it "parses and prints from aliases correctly" $ do - let r = prettyPrint $ toDockerfile $ do - from $ "node" `tagged` "10.1" `aliased` "node-build" - run "echo foo" - r `shouldBe` printed [ "FROM node:10.1 AS node-build" - , "RUN echo foo" - ] - - it "parses and prints from with a registry" $ do - let r = prettyPrint $ toDockerfile $ do - from "opensuse/tumbleweed" - run "echo foo" - r `shouldBe` printed [ "FROM opensuse/tumbleweed" - , "RUN echo foo" - ] - - it "parses and prints copy instructions" $ do - let r = prettyPrint $ toDockerfile $ do - from "scratch" - copy $ ["foo.js"] `to` "bar.js" - copy $ ["foo.js", "bar.js"] `to` "." - copy $ ["foo.js", "bar.js"] `to` "baz/" - copy $ ["something"] `to` "crazy" `fromStage` "builder" - copy $ ["this"] `to` "that" `fromStage` "builder" `ownedBy` "www-data" - r `shouldBe` printed [ "FROM scratch" - , "COPY foo.js bar.js" - , "COPY foo.js bar.js ./" - , "COPY foo.js bar.js baz/" - , "COPY --from=builder something crazy" - , "COPY --chown=www-data --from=builder this that" - ] - it "quotes label and env correctly" $ do - let r = prettyPrint $ toDockerfile $ do - from "scratch" - label [("email", "Example ")] - label [("escape", "Escape this\" thing")] - env [("foo", "bar baz")] - env [("double_escape", "escape this \\\"")] - r `shouldBe` printed [ "FROM scratch" - , "LABEL email=\"Example \"" - , "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" - ] diff --git a/test/Language/Docker/ExamplesSpec.hs b/test/Language/Docker/ExamplesSpec.hs deleted file mode 100644 index 805e7a4..0000000 --- a/test/Language/Docker/ExamplesSpec.hs +++ /dev/null @@ -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 diff --git a/test/Language/Docker/IntegrationSpec.hs b/test/Language/Docker/IntegrationSpec.hs new file mode 100644 index 0000000..ec3f7b7 --- /dev/null +++ b/test/Language/Docker/IntegrationSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +module Language.Docker.IntegrationSpec where + +import Language.Docker.Parser +import Language.Docker.Syntax +import Language.Docker.PrettyPrint (prettyPrint) +import qualified Data.Text.Lazy.IO as L + + +import Test.HUnit hiding (Label) +import Test.Hspec +import Text.Megaparsec hiding (Label) +import qualified Data.Text as Text + +spec :: Spec +spec = do + describe "1" $ do + it "no erors" $ do + parsed <- parseFile "test/fixtures/1.Dockerfile" + case parsed of + Right a -> L.putStr $ prettyPrint a + Left err -> assertFailure $ errorBundlePretty err + describe "2" $ do + it "no erors" $ do + parsed <- parseFile "test/fixtures/2.Dockerfile" + case parsed of + Right a -> L.putStr $ prettyPrint a + Left err -> assertFailure $ errorBundlePretty err diff --git a/test/Language/Docker/ParserSpec.hs b/test/Language/Docker/ParserSpec.hs index 9605699..0d31cdb 100644 --- a/test/Language/Docker/ParserSpec.hs +++ b/test/Language/Docker/ParserSpec.hs @@ -1,16 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + module Language.Docker.ParserSpec where -import Language.Docker.Normalize +import Data.Default.Class (def) +import qualified Data.Text as Text import Language.Docker.Parser import Language.Docker.Syntax - - import Test.HUnit hiding (Label) import Test.Hspec import Text.Megaparsec hiding (Label) -import qualified Data.Text as Text untaggedImage :: Image -> BaseImage untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing @@ -19,427 +18,618 @@ 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 } +withDigest i d = i {digest = Just d} withAlias :: BaseImage -> ImageAlias -> BaseImage -withAlias i a = i { alias = Just a } +withAlias i a = i {alias = Just a} withPlatform :: BaseImage -> Platform -> BaseImage -withPlatform i p = i { platform = Just p } - +withPlatform i p = i {platform = Just p} spec :: Spec spec = do - describe "parse ARG" $ do - it "no default" $ - assertAst "ARG FOO" [Arg "FOO" Nothing] - it "with default" $ - assertAst "ARG FOO=bar" [Arg "FOO" (Just "bar")] - - describe "parse FROM" $ do - it "parse untagged image" $ - assertAst "FROM busybox" [From (untaggedImage "busybox")] - it "parse tagged image" $ - assertAst - "FROM busybox:5.12-dev" - [From (taggedImage "busybox" "5.12-dev")] - it "parse digested image" $ - assertAst - "FROM ubuntu@sha256:0ef2e08ed3fab" - [From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab")] - it "parse digested image with tag" $ - assertAst - "FROM ubuntu:14.04@sha256:0ef2e08ed3fab" - [From (taggedImage "ubuntu" "14.04" `withDigest` "sha256:0ef2e08ed3fab")] - - describe "parse aliased FROM" $ do - it "parse untagged image" $ - assertAst "FROM busybox as foo" [From (untaggedImage "busybox" `withAlias` "foo")] - it "parse tagged image" $ - assertAst "FROM busybox:5.12-dev AS foo-bar" - [ From (taggedImage "busybox" "5.12-dev" `withAlias` "foo-bar") - ] - it "parse diggested image" $ - assertAst "FROM ubuntu@sha256:0ef2e08ed3fab AS foo" - [ From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab" `withAlias` "foo") - ] - - describe "parse FROM with platform" $ do - it "parse untagged image with platform" $ - assertAst "FROM --platform=linux busybox" [From (untaggedImage "busybox" `withPlatform` "linux")] - - it "parse tagged image with platform" $ - assertAst "FROM --platform=linux busybox:foo" [From (taggedImage "busybox" "foo" `withPlatform` "linux")] - - describe "parse FROM with registry" $ do - it "registry without port" $ - assertAst "FROM foo.com/node" [From (untaggedImage (Image (Just "foo.com") "node"))] - it "parse with port and tag" $ - assertAst - "FROM myregistry.com:5000/imagename:5.12-dev" - [From (taggedImage (Image (Just "myregistry.com:5000") "imagename") "5.12-dev")] - it "Not a registry if no TLD" $ - assertAst - "FROM myfolder/imagename:5.12-dev" - [From (taggedImage (Image Nothing "myfolder/imagename") "5.12-dev")] - - describe "parse LABEL" $ do - it "parse label" $ assertAst "LABEL foo=bar" [Label[("foo", "bar")]] - it "parse space separated label" $ assertAst "LABEL foo bar baz" [Label[("foo", "bar baz")]] - it "parse quoted labels" $ assertAst "LABEL \"foo bar\"=baz" [Label[("foo bar", "baz")]] - it "parses multiline labels" $ - let dockerfile = Text.unlines [ "LABEL foo=bar \\", "hobo=mobo"] - ast = [ Label [("foo", "bar"), ("hobo", "mobo")] ] - in assertAst dockerfile ast - - describe "parse ENV" $ do - it "parses unquoted pair" $ assertAst "ENV foo=bar" [Env [("foo", "bar")]] - it "parse with space between key and value" $ - assertAst "ENV foo bar" [Env [("foo", "bar")]] - it "parse with more then one (white)space between key and value" $ - let dockerfile = "ENV NODE_VERSION \t v5.7.1" - in assertAst dockerfile [Env[("NODE_VERSION", "v5.7.1")]] - it "parse quoted value pair" $ assertAst "ENV foo=\"bar\"" [Env [("foo", "bar")]] - it "parse multiple unquoted pairs" $ - assertAst "ENV foo=bar baz=foo" [Env [("foo", "bar"), ("baz", "foo")]] - it "parse multiple quoted pairs" $ - assertAst "ENV foo=\"bar\" baz=\"foo\"" [Env [("foo", "bar"), ("baz", "foo")]] - it "env works before cmd" $ - let dockerfile = "ENV PATH=\"/root\"\nCMD [\"hadolint\",\"-i\"]" - ast = [Env [("PATH", "/root")], Cmd ["hadolint", "-i"]] - in assertAst dockerfile ast - it "parse with two spaces between" $ - let dockerfile = "ENV NODE_VERSION=v5.7.1 DEBIAN_FRONTEND=noninteractive" - in assertAst dockerfile [Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")]] - it "have envs on multiple lines" $ - let dockerfile = Text.unlines [ "FROM busybox" - , "ENV NODE_VERSION=v5.7.1 \\" - , "DEBIAN_FRONTEND=noninteractive" - ] - ast = [ From (untaggedImage "busybox") - , Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")] - ] - in assertAst dockerfile ast - it "parses long env over multiple lines" $ - let dockerfile = Text.unlines [ "ENV LD_LIBRARY_PATH=\"/usr/lib/\" \\" - , "APACHE_RUN_USER=\"www-data\" APACHE_RUN_GROUP=\"www-data\""] - ast = [Env [("LD_LIBRARY_PATH", "/usr/lib/") - ,("APACHE_RUN_USER", "www-data") - ,("APACHE_RUN_GROUP", "www-data") - ] - ] - in assertAst dockerfile ast - it "parse single var list" $ - assertAst "ENV foo val1 val2 val3 val4" [Env [("foo", "val1 val2 val3 val4")]] - it "parses many env lines with an equal sign in the value" $ - let dockerfile = Text.unlines [ "ENV TOMCAT_VERSION 9.0.2" - , "ENV TOMCAT_URL foo.com?q=1" - ] - ast = [ Env [("TOMCAT_VERSION", "9.0.2")] - , Env [("TOMCAT_URL", "foo.com?q=1")] - ] - in assertAst dockerfile ast - it "parses many env lines in mixed style" $ - let dockerfile = Text.unlines [ "ENV myName=\"John Doe\" myDog=Rex\\ The\\ Dog \\" - , " myCat=fluffy" - ] - ast = [ Env [("myName", "John Doe") - ,("myDog", "Rex The Dog") - ,("myCat", "fluffy") - ] - ] - in assertAst dockerfile ast - it "parses many env with backslashes" $ - let dockerfile = Text.unlines [ "ENV JAVA_HOME=C:\\\\jdk1.8.0_112" - ] - ast = [ Env [("JAVA_HOME", "C:\\\\jdk1.8.0_112")] - ] - in assertAst dockerfile ast - it "parses env with % in them" $ - let dockerfile = Text.unlines [ "ENV PHP_FPM_ACCESS_FORMAT=\"prefix \\\"quoted\\\" suffix\"" - ] - ast = [ Env [("PHP_FPM_ACCESS_FORMAT", "%R - %u %t \"%m %r\" %s")] - ] - in assertAst dockerfile ast - - it "parses env with % in them" $ - let dockerfile = Text.unlines [ "ENV PHP_FPM_ACCESS_FORMAT=\"%R - %u %t \\\"%m %r\\\" %s\"" - ] - ast = [ Env [("PHP_FPM_ACCESS_FORMAT", "%R - %u %t \"%m %r\" %s")] - ] - in assertAst dockerfile ast - - describe "parse RUN" $ do - it "escaped with space before" $ - let dockerfile = Text.unlines ["RUN yum install -y \\", "imagemagick \\", "mysql"] - in assertAst dockerfile [Run "yum install -y imagemagick mysql"] - - it "does not choke on unmatched brackets" $ - let dockerfile = Text.unlines ["RUN [foo"] - in assertAst dockerfile [Run "[foo"] - - it "Distinguishes between text and a list" $ - let dockerfile = Text.unlines [ "RUN echo foo" - , "RUN [\"echo\", \"foo\"]" - ] - in assertAst dockerfile [Run $ ArgumentsText "echo foo", Run $ ArgumentsList "echo foo"] - - it "Accepts spaces inside the brackets" $ - let dockerfile = Text.unlines [ "RUN [ \"echo\", \"foo\" ]" - ] - in assertAst dockerfile [Run $ ArgumentsList "echo foo"] - - describe "parse CMD" $ do - it "one line cmd" $ assertAst "CMD true" [Cmd "true"] - - it "cmd over several lines" $ - assertAst "CMD true \\\n && true" [Cmd "true && true"] - - it "quoted command params" $ assertAst "CMD [\"echo\", \"1\"]" [Cmd ["echo", "1"]] - - it "Parses commas correctly" $ assertAst "CMD [ \"echo\" ,\"-e\" , \"1\"]" [Cmd ["echo", "-e", "1"]] - - describe "parse SHELL" $ - it "quoted shell params" $ - assertAst "SHELL [\"/bin/bash\", \"-c\"]" [Shell ["/bin/bash", "-c"]] - - describe "parse HEALTHCHECK" $ do - it "parse healthcheck with interval" $ - assertAst - "HEALTHCHECK --interval=5m \\\nCMD curl -f http://localhost/" - [Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" (Just 300) Nothing Nothing Nothing - ] - - it "parse healthcheck with retries" $ - assertAst - "HEALTHCHECK --retries=10 CMD curl -f http://localhost/" - [Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing (Just $ Retries 10) - ] - - it "parse healthcheck with timeout" $ - assertAst - "HEALTHCHECK --timeout=10s CMD curl -f http://localhost/" - [Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" Nothing (Just 10) Nothing Nothing - ] - - it "parse healthcheck with start-period" $ - assertAst - "HEALTHCHECK --start-period=2m CMD curl -f http://localhost/" - [Healthcheck $ - Check $ - CheckArgs "curl -f http://localhost/" Nothing Nothing (Just 120) Nothing - ] - - it "parse healthcheck with all flags" $ - assertAst - "HEALTHCHECK --start-period=2s --timeout=1m --retries=3 --interval=5s CMD curl -f http://localhost/" - [Healthcheck $ - Check $ - CheckArgs - "curl -f http://localhost/" - (Just 5) - (Just 60) - (Just 2) - (Just $ Retries 3) + describe "parse ARG" $ do + it "no default" $ + assertAst "ARG FOO" [Arg "FOO" Nothing] + it "with default" $ + assertAst "ARG FOO=bar" [Arg "FOO" (Just "bar")] + describe "parse FROM" $ do + it "parse untagged image" $ + assertAst "FROM busybox" [From (untaggedImage "busybox")] + it "parse tagged image" $ + assertAst + "FROM busybox:5.12-dev" + [From (taggedImage "busybox" "5.12-dev")] + it "parse digested image" $ + assertAst + "FROM ubuntu@sha256:0ef2e08ed3fab" + [From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab")] + it "parse digested image with tag" $ + assertAst + "FROM ubuntu:14.04@sha256:0ef2e08ed3fab" + [From (taggedImage "ubuntu" "14.04" `withDigest` "sha256:0ef2e08ed3fab")] + it "parse image with spaces at the end" $ + assertAst + "FROM dockerfile/mariadb " + [From (untaggedImage "dockerfile/mariadb")] + describe "parse aliased FROM" $ do + it "parse untagged image" $ + assertAst "FROM busybox as foo" [From (untaggedImage "busybox" `withAlias` "foo")] + it "parse tagged image" $ + assertAst + "FROM busybox:5.12-dev AS foo-bar" + [ From (taggedImage "busybox" "5.12-dev" `withAlias` "foo-bar") + ] + it "parse diggested image" $ + assertAst + "FROM ubuntu@sha256:0ef2e08ed3fab AS foo" + [ From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab" `withAlias` "foo") + ] + describe "parse FROM with platform" $ do + it "parse untagged image with platform" $ + assertAst "FROM --platform=linux busybox" [From (untaggedImage "busybox" `withPlatform` "linux")] + it "parse tagged image with platform" $ + assertAst "FROM --platform=linux busybox:foo" [From (taggedImage "busybox" "foo" `withPlatform` "linux")] + describe "parse FROM with registry" $ do + it "registry without port" $ + assertAst "FROM foo.com/node" [From (untaggedImage (Image (Just "foo.com") "node"))] + it "parse with port and tag" $ + assertAst + "FROM myregistry.com:5000/imagename:5.12-dev" + [From (taggedImage (Image (Just "myregistry.com:5000") "imagename") "5.12-dev")] + it "Not a registry if no TLD" $ + assertAst + "FROM myfolder/imagename:5.12-dev" + [From (taggedImage (Image Nothing "myfolder/imagename") "5.12-dev")] + describe "parse LABEL" $ do + it "parse label" $ assertAst "LABEL foo=bar" [Label [("foo", "bar")]] + it "parse space separated label" $ assertAst "LABEL foo bar baz" [Label [("foo", "bar baz")]] + it "parse quoted labels" $ assertAst "LABEL \"foo bar\"=baz" [Label [("foo bar", "baz")]] + it "parses multiline labels" $ + let dockerfile = Text.unlines ["LABEL foo=bar \\", "hobo=mobo"] + ast = [Label [("foo", "bar"), ("hobo", "mobo")]] + in assertAst dockerfile ast + describe "parse ENV" $ do + it "parses unquoted pair" $ assertAst "ENV foo=bar" [Env [("foo", "bar")]] + it "parse with space between key and value" $ + assertAst "ENV foo bar" [Env [("foo", "bar")]] + it "parse with more then one (white)space between key and value" $ + let dockerfile = "ENV NODE_VERSION \t v5.7.1" + in assertAst dockerfile [Env [("NODE_VERSION", "v5.7.1")]] + it "parse quoted value pair" $ assertAst "ENV foo=\"bar\"" [Env [("foo", "bar")]] + it "parse multiple unquoted pairs" $ + assertAst "ENV foo=bar baz=foo" [Env [("foo", "bar"), ("baz", "foo")]] + it "parse multiple quoted pairs" $ + assertAst "ENV foo=\"bar\" baz=\"foo\"" [Env [("foo", "bar"), ("baz", "foo")]] + it "env works before cmd" $ + let dockerfile = "ENV PATH=\"/root\"\nCMD [\"hadolint\",\"-i\"]" + ast = [Env [("PATH", "/root")], Cmd ["hadolint", "-i"]] + in assertAst dockerfile ast + it "parse with two spaces between" $ + let dockerfile = "ENV NODE_VERSION=v5.7.1 DEBIAN_FRONTEND=noninteractive" + in assertAst dockerfile [Env [("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")]] + it "have envs on multiple lines" $ + let dockerfile = + Text.unlines + [ "FROM busybox", + "ENV NODE_VERSION=v5.7.1 \\", + "DEBIAN_FRONTEND=noninteractive" + ] + ast = + [ From (untaggedImage "busybox"), + Env [("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")] + ] + in assertAst dockerfile ast + it "parses long env over multiple lines" $ + let dockerfile = + Text.unlines + [ "ENV LD_LIBRARY_PATH=\"/usr/lib/\" \\", + "APACHE_RUN_USER=\"www-data\" APACHE_RUN_GROUP=\"www-data\"" + ] + ast = + [ Env + [ ("LD_LIBRARY_PATH", "/usr/lib/"), + ("APACHE_RUN_USER", "www-data"), + ("APACHE_RUN_GROUP", "www-data") ] - - 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"), Maintainer "hudu@mail.com"] - it "maintainer with mail" $ - assertAst "MAINTAINER hudu@mail.com" [Maintainer "hudu@mail.com"] - it "maintainer only mail after from" $ - let maintainerFromProg = "FROM busybox\nMAINTAINER hudu@mail.com" - maintainerFromAst = [From (untaggedImage "busybox"), Maintainer "hudu@mail.com"] - in assertAst maintainerFromProg maintainerFromAst - describe "parse # comment " $ do - it "multiple comments before run" $ - let dockerfile = Text.unlines ["# line 1", "# line 2", "RUN apt-get update"] - in assertAst dockerfile [Comment " line 1", Comment " line 2", Run "apt-get update"] - it "multiple comments after run" $ - let dockerfile = Text.unlines ["RUN apt-get update", "# line 1", "# line 2"] - in assertAst - dockerfile - [Run "apt-get update", Comment " line 1", Comment " line 2"] - - it "empty comment" $ - let dockerfile = Text.unlines ["#", "# Hello"] - in assertAst dockerfile [Comment "", Comment " Hello"] - describe "normalize lines" $ do - it "join multiple ENV" $ - let dockerfile = Text.unlines [ "FROM busybox" - , "ENV NODE_VERSION=v5.7.1 \\" - , "DEBIAN_FRONTEND=noninteractive" - ] - normalizedDockerfile = Text.unlines [ "FROM busybox" - , "ENV NODE_VERSION=v5.7.1 DEBIAN_FRONTEND=noninteractive\n" - ] - in normalizeEscapedLines dockerfile `shouldBe` normalizedDockerfile - - it "join escaped lines" $ - let dockerfile = Text.unlines ["ENV foo=bar \\", "baz=foz"] - normalizedDockerfile = Text.unlines ["ENV foo=bar baz=foz", ""] - in normalizeEscapedLines dockerfile `shouldBe` normalizedDockerfile - - it "join long CMD" $ - let longEscapedCmd = - Text.unlines - [ "RUN wget https://download.com/${version}.tar.gz -O /tmp/logstash.tar.gz && \\" - , "(cd /tmp && tar zxf logstash.tar.gz && mv logstash-${version} /opt/logstash && \\" - , "rm logstash.tar.gz) && \\" - , "(cd /opt/logstash && \\" - , "/opt/logstash/bin/plugin install contrib)" - ] - longEscapedCmdExpected = - Text.concat - [ "RUN wget https://download.com/${version}.tar.gz -O /tmp/logstash.tar.gz && " - , "(cd /tmp && tar zxf logstash.tar.gz && mv logstash-${version} /opt/logstash && " - , "rm logstash.tar.gz) && " - , "(cd /opt/logstash && " - , "/opt/logstash/bin/plugin install contrib)\n" - , "\n" - , "\n" - , "\n" - , "\n" - ] - in normalizeEscapedLines longEscapedCmd `shouldBe` longEscapedCmdExpected - - it "tolerates spaces after a newline escape" $ - let dockerfile = Text.unlines [ "FROM busy\\ " - , "box" - , "RUN echo\\ " - , " hello" - ] - in assertAst dockerfile [ From (untaggedImage "busybox") - , Run "echo hello" - ] - - it "Correctly joins blank lines starting with comments" $ - let dockerfile = Text.unlines [ "FROM busybox" - , "# I forgot to remove the backslash \\" - , "# This is a comment" - , "RUN echo hello" - ] - in assertAst dockerfile [ From (untaggedImage "busybox") - , Comment " I forgot to remove the backslash \\" - , Comment " This is a comment" - , Run "echo hello" - ] - describe "expose" $ do - it "should handle number ports" $ - let content = "EXPOSE 8080" - in assertAst content [Expose (Ports [Port 8080 TCP])] - it "should handle many number ports" $ - let content = "EXPOSE 8080 8081" - in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 TCP])] - it "should handle ports with protocol" $ - let content = "EXPOSE 8080/TCP 8081/UDP" - in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 UDP])] - it "should handle ports with protocol and variables" $ - let content = "EXPOSE $PORT 8080 8081/UDP" - in assertAst content [Expose (Ports [PortStr "$PORT", Port 8080 TCP, Port 8081 UDP])] - it "should handle port ranges" $ - let content = "EXPOSE 80 81 8080-8085" - in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 TCP])] - it "should handle udp port ranges" $ - let content = "EXPOSE 80 81 8080-8085/udp" - in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 UDP])] - it "should handle multiline variables" $ - let content = "EXPOSE ${PORT} ${PORT_SSL} \\\n\ - \ ${PORT_HTTP} ${PORT_HTTPS} \\\n\ - \ ${PORT_REP} \\\n\ - \ ${PORT_ADMIN} ${PORT_ADMIN_HTTP}" - in assertAst content [ Expose (Ports [ PortStr "${PORT}" - , PortStr "${PORT_SSL}" - , PortStr "${PORT_HTTP}" - , PortStr "${PORT_HTTPS}" - , PortStr "${PORT_REP}" - , PortStr "${PORT_ADMIN}" - , PortStr "${PORT_ADMIN_HTTP}"]) - ] - - describe "syntax" $ do - it "should handle lowercase instructions (#7 - https://github.com/beijaflor-io/haskell-language-dockerfile/issues/7)" $ - let content = "from ubuntu" - in assertAst content [From (untaggedImage "ubuntu")] - - describe "ADD" $ do - it "simple ADD" $ - let file = Text.unlines ["ADD . /app", "ADD http://foo.bar/baz ."] - in assertAst file [ Add $ AddArgs [SourcePath "."] (TargetPath "/app") NoChown - , Add $ AddArgs [SourcePath "http://foo.bar/baz"] (TargetPath ".") NoChown - ] - it "multifiles ADD" $ - let file = Text.unlines ["ADD foo bar baz /app"] - in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown - ] - - it "list of quoted files" $ - let file = Text.unlines ["ADD [\"foo\", \"bar\", \"baz\", \"/app\"]"] - in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown - ] - - it "with chown flag" $ - let file = Text.unlines ["ADD --chown=root:root foo bar"] - in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "root:root") - ] - - it "list of quoted files and chown" $ - let file = Text.unlines ["ADD --chown=user:group [\"foo\", \"bar\", \"baz\", \"/app\"]"] - in assertAst file [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") (Chown "user:group") - ] - describe "COPY" $ do - it "simple COPY" $ - let file = Text.unlines ["COPY . /app", "COPY baz /some/long/path"] - in assertAst file [ Copy $ CopyArgs [SourcePath "."] (TargetPath "/app") NoChown NoSource - , Copy $ CopyArgs [SourcePath "baz"] (TargetPath "/some/long/path") NoChown NoSource - ] - it "multifiles COPY" $ - let file = Text.unlines ["COPY foo bar baz /app"] - in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown NoSource - ] - - it "list of quoted files" $ - let file = Text.unlines ["COPY [\"foo\", \"bar\", \"baz\", \"/app\"]"] - in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown NoSource - ] - - it "with chown flag" $ - let file = Text.unlines ["COPY --chown=user:group foo bar"] - in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") NoSource - ] - - it "with from flag" $ - let file = Text.unlines ["COPY --from=node foo bar"] - in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") NoChown (CopySource "node") - ] - it "with both flags" $ - let file = Text.unlines ["COPY --from=node --chown=user:group foo bar"] - in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node") - ] - it "with both flags in different order" $ - let file = Text.unlines ["COPY --chown=user:group --from=node foo bar"] - in assertAst file [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node") - ] + ] + in assertAst dockerfile ast + it "parses many env with backslashes" $ + let dockerfile = + Text.unlines + [ "ENV JAVA_HOME=C:\\\\jdk1.8.0_112" + ] + ast = + [ Env [("JAVA_HOME", "C:\\\\jdk1.8.0_112")] + ] + in assertAst dockerfile ast + it "parses env with % in them" $ + let dockerfile = + Text.unlines + [ "ENV PHP_FPM_ACCESS_FORMAT=\"prefix \\\"quoted\\\" suffix\"" + ] + ast = + [ Env [("PHP_FPM_ACCESS_FORMAT", "prefix \"quoted\" suffix")] + ] + in assertAst dockerfile ast + it "parses env with % in them" $ + let dockerfile = + Text.unlines + [ "ENV PHP_FPM_ACCESS_FORMAT=\"%R - %u %t \\\"%m %r\\\" %s\"" + ] + ast = + [ Env [("PHP_FPM_ACCESS_FORMAT", "%R - %u %t \"%m %r\" %s")] + ] + in assertAst dockerfile ast + describe "parse RUN" $ do + it "escaped with space before" $ + let dockerfile = Text.unlines ["RUN yum install -y \\", "imagemagick \\", "mysql"] + in assertAst dockerfile [Run "yum install -y imagemagick mysql"] + it "does not choke on unmatched brackets" $ + let dockerfile = Text.unlines ["RUN [foo"] + in assertAst dockerfile [Run "[foo"] + it "Distinguishes between text and a list" $ + let dockerfile = + Text.unlines + [ "RUN echo foo", + "RUN [\"echo\", \"foo\"]" + ] + in assertAst dockerfile [Run $ RunArgs (ArgumentsText "echo foo") def, Run $ RunArgs (ArgumentsList "echo foo") def] + it "Accepts spaces inside the brackets" $ + let dockerfile = + Text.unlines + [ "RUN [ \"echo\", \"foo\" ]" + ] + in assertAst dockerfile [Run $ RunArgs (ArgumentsList "echo foo") def] + describe "parse CMD" $ do + it "one line cmd" $ assertAst "CMD true" [Cmd "true"] + it "cmd over several lines" $ + assertAst "CMD true \\\n && true" [Cmd "true && true"] + it "quoted command params" $ assertAst "CMD [\"echo\", \"1\"]" [Cmd ["echo", "1"]] + it "Parses commas correctly" $ assertAst "CMD [ \"echo\" ,\"-e\" , \"1\"]" [Cmd ["echo", "-e", "1"]] + describe "parse SHELL" + $ it "quoted shell params" + $ assertAst "SHELL [\"/bin/bash\", \"-c\"]" [Shell ["/bin/bash", "-c"]] + describe "parse HEALTHCHECK" $ do + it "parse healthcheck with interval" $ + assertAst + "HEALTHCHECK --interval=5m \\\nCMD curl -f http://localhost/" + [ Healthcheck + $ Check + $ CheckArgs "curl -f http://localhost/" (Just 300) Nothing Nothing Nothing + ] + it "parse healthcheck with retries" $ + assertAst + "HEALTHCHECK --retries=10 CMD curl -f http://localhost/" + [ Healthcheck + $ Check + $ CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing (Just $ Retries 10) + ] + it "parse healthcheck with timeout" $ + assertAst + "HEALTHCHECK --timeout=10s CMD curl -f http://localhost/" + [ Healthcheck + $ Check + $ CheckArgs "curl -f http://localhost/" Nothing (Just 10) Nothing Nothing + ] + it "parse healthcheck with start-period" $ + assertAst + "HEALTHCHECK --start-period=2m CMD curl -f http://localhost/" + [ Healthcheck + $ Check + $ CheckArgs "curl -f http://localhost/" Nothing Nothing (Just 120) Nothing + ] + it "parse healthcheck with all flags" $ + assertAst + "HEALTHCHECK --start-period=2s --timeout=1m --retries=3 --interval=5s CMD curl -f http://localhost/" + [ Healthcheck + $ Check + $ CheckArgs + "curl -f http://localhost/" + (Just 5) + (Just 60) + (Just 2) + (Just $ Retries 3) + ] + it "parse healthcheck with no flags" $ + assertAst + "HEALTHCHECK CMD curl -f http://localhost/" + [ Healthcheck + $ Check + $ CheckArgs "curl -f http://localhost/" Nothing Nothing Nothing Nothing + ] + describe "parse MAINTAINER" $ do + it "maintainer of untagged scratch image" $ + assertAst + "FROM scratch\nMAINTAINER hudu@mail.com" + [From (untaggedImage "scratch"), Maintainer "hudu@mail.com"] + it "maintainer with mail" $ + assertAst "MAINTAINER hudu@mail.com" [Maintainer "hudu@mail.com"] + it "maintainer only mail after from" $ + let maintainerFromProg = "FROM busybox\nMAINTAINER hudu@mail.com" + maintainerFromAst = [From (untaggedImage "busybox"), Maintainer "hudu@mail.com"] + in assertAst maintainerFromProg maintainerFromAst + describe "parse # comment " $ do + it "multiple comments before run" $ + let dockerfile = Text.unlines ["# line 1", "# line 2", "RUN apt-get update"] + in assertAst dockerfile [Comment " line 1", Comment " line 2", Run "apt-get update"] + it "multiple comments after run" $ + let dockerfile = Text.unlines ["RUN apt-get update", "# line 1", "# line 2"] + in assertAst + dockerfile + [Run "apt-get update", Comment " line 1", Comment " line 2"] + it "empty comment" $ + let dockerfile = Text.unlines ["#", "# Hello"] + in assertAst dockerfile [Comment "", Comment " Hello"] + it "many escaped lines" $ + let dockerfile = + Text.unlines + [ "ENV A=\"a.sh\" \\", + " # comment a", + " B=\"b.sh\" \\", + " c=\"true\"", + "" + ] + in assertAst + dockerfile + [ Env [("A", "a.sh"), ("B", "b.sh"), ("c", "true")] + ] + it "accepts backslash inside string" $ + let dockerfile = "RUN grep 'foo \\.'" + in assertAst dockerfile [Run $ RunArgs (ArgumentsText "grep 'foo \\.'") def] + it "tolerates spaces after a newline escape" $ + let dockerfile = + Text.unlines + [ "FROM busy\\ ", + "box", + "RUN echo\\ ", + " hello" + ] + in assertAst + dockerfile + [ From (untaggedImage "busybox"), + Run "echo hello" + ] + it "Correctly joins blank lines starting with comments" $ + let dockerfile = + Text.unlines + [ "FROM busybox", + "# I forgot to remove the backslash \\", + "# This is a comment", + "RUN echo hello" + ] + in assertAst + dockerfile + [ From (untaggedImage "busybox"), + Comment " I forgot to remove the backslash \\", + Comment " This is a comment", + Run "echo hello" + ] + describe "expose" $ do + it "should handle number ports" $ + let content = "EXPOSE 8080" + in assertAst content [Expose (Ports [Port 8080 TCP])] + it "should handle many number ports" $ + let content = "EXPOSE 8080 8081" + in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 TCP])] + it "should handle ports with protocol" $ + let content = "EXPOSE 8080/TCP 8081/UDP" + in assertAst content [Expose (Ports [Port 8080 TCP, Port 8081 UDP])] + it "should handle ports with protocol and variables" $ + let content = "EXPOSE $PORT 8080 8081/UDP" + in assertAst content [Expose (Ports [PortStr "$PORT", Port 8080 TCP, Port 8081 UDP])] + it "should handle port ranges" $ + let content = "EXPOSE 80 81 8080-8085" + in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 TCP])] + it "should handle udp port ranges" $ + let content = "EXPOSE 80 81 8080-8085/udp" + in assertAst content [Expose (Ports [Port 80 TCP, Port 81 TCP, PortRange 8080 8085 UDP])] + it "should handle multiline variables" $ + let content = + "EXPOSE ${PORT} ${PORT_SSL} \\\n\ + \ ${PORT_HTTP} ${PORT_HTTPS} \\\n\ + \ ${PORT_REP} \\\n\ + \ ${PORT_ADMIN} ${PORT_ADMIN_HTTP}" + in assertAst + content + [ Expose + ( Ports + [ PortStr "${PORT}", + PortStr "${PORT_SSL}", + PortStr "${PORT_HTTP}", + PortStr "${PORT_HTTPS}", + PortStr "${PORT_REP}", + PortStr "${PORT_ADMIN}", + PortStr "${PORT_ADMIN_HTTP}" + ] + ) + ] + describe "syntax" $ do + it "should handle lowercase instructions (#7 - https://github.com/beijaflor-io/haskell-language-dockerfile/issues/7)" $ + let content = "from ubuntu" + in assertAst content [From (untaggedImage "ubuntu")] + describe "ADD" $ do + it "simple ADD" $ + let file = Text.unlines ["ADD . /app", "ADD http://foo.bar/baz ."] + in assertAst + file + [ Add $ AddArgs [SourcePath "."] (TargetPath "/app") NoChown, + Add $ AddArgs [SourcePath "http://foo.bar/baz"] (TargetPath ".") NoChown + ] + it "multifiles ADD" $ + let file = Text.unlines ["ADD foo bar baz /app"] + in assertAst + file + [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown + ] + it "list of quoted files" $ + let file = Text.unlines ["ADD [\"foo\", \"bar\", \"baz\", \"/app\"]"] + in assertAst + file + [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown + ] + it "with chown flag" $ + let file = Text.unlines ["ADD --chown=root:root foo bar"] + in assertAst + file + [ Add $ AddArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "root:root") + ] + it "list of quoted files and chown" $ + let file = Text.unlines ["ADD --chown=user:group [\"foo\", \"bar\", \"baz\", \"/app\"]"] + in assertAst + file + [ Add $ AddArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") (Chown "user:group") + ] + describe "COPY" $ do + it "simple COPY" $ + let file = Text.unlines ["COPY . /app", "COPY baz /some/long/path"] + in assertAst + file + [ Copy $ CopyArgs [SourcePath "."] (TargetPath "/app") NoChown NoSource, + Copy $ CopyArgs [SourcePath "baz"] (TargetPath "/some/long/path") NoChown NoSource + ] + it "multifiles COPY" $ + let file = Text.unlines ["COPY foo bar baz /app"] + in assertAst + file + [ Copy $ CopyArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown NoSource + ] + it "list of quoted files" $ + let file = Text.unlines ["COPY [\"foo\", \"bar\", \"baz\", \"/app\"]"] + in assertAst + file + [ Copy $ CopyArgs (fmap SourcePath ["foo", "bar", "baz"]) (TargetPath "/app") NoChown NoSource + ] + it "with chown flag" $ + let file = Text.unlines ["COPY --chown=user:group foo bar"] + in assertAst + file + [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") NoSource + ] + it "with from flag" $ + let file = Text.unlines ["COPY --from=node foo bar"] + in assertAst + file + [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") NoChown (CopySource "node") + ] + it "with both flags" $ + let file = Text.unlines ["COPY --from=node --chown=user:group foo bar"] + in assertAst + file + [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node") + ] + it "with both flags in different order" $ + let file = Text.unlines ["COPY --chown=user:group --from=node foo bar"] + in assertAst + file + [ Copy $ CopyArgs (fmap SourcePath ["foo"]) (TargetPath "bar") (Chown "user:group") (CopySource "node") + ] + it "supports windows paths" $ + let file = Text.unlines ["COPY C:\\\\go C:\\\\go"] + in assertAst + file + [ Copy $ CopyArgs (fmap SourcePath ["C:\\\\go"]) (TargetPath "C:\\\\go") NoChown NoSource + ] + describe "RUN with experimental flags" $ do + it "--mount=type=bind and target" $ + let file = Text.unlines ["RUN --mount=type=bind,target=/foo echo foo"] + flags = def {mount = Just $ BindMount (def {bTarget = "/foo"})} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--mount default to bind" $ + let file = Text.unlines ["RUN --mount=target=/foo echo foo"] + flags = def {mount = Just $ BindMount (def {bTarget = "/foo"})} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--mount=type=bind all modifiers" $ + let file = Text.unlines ["RUN --mount=type=bind,target=/foo,source=/bar,from=ubuntu,ro echo foo"] + flags = def {mount = Just $ BindMount (BindOpts {bTarget = "/foo", bSource = Just "/bar", bFromImage = Just "ubuntu", bReadOnly = Just True})} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--mount=type=cache with target and sharing" $ + let file = + Text.unlines + [ "RUN --mount=type=cache,target=/foo,sharing=private echo foo", + "RUN --mount=type=cache,target=/bar,sharing=shared echo foo", + "RUN --mount=type=cache,target=/baz,sharing=locked echo foo" + ] + flags1 = def {mount = Just $ CacheMount (def {cTarget = "/foo", cSharing = Private})} + flags2 = def {mount = Just $ CacheMount (def {cTarget = "/bar", cSharing = Shared})} + flags3 = def {mount = Just $ CacheMount (def {cTarget = "/baz", cSharing = Locked})} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags1, + Run $ RunArgs (ArgumentsText "echo foo") flags2, + Run $ RunArgs (ArgumentsText "echo foo") flags3 + ] + it "--mount=type=cache with all modifiers" $ + let file = + Text.unlines + [ "RUN --mount=type=cache,target=/foo,sharing=private,id=a,ro,from=ubuntu,source=/bar,mode=0700,uid=0,gid=0 echo foo" + ] + flags = + def + { mount = + Just $ + CacheMount + ( def + { cTarget = "/foo", + cSharing = Private, + cCacheId = Just "a", + cReadOnly = Just True, + cFromImage = Just "ubuntu", + cSource = Just "/bar", + cMode = Just "0700", + cUid = Just 0, + cGid = Just 0 + } + ) + } + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--mount=type=tmpfs" $ + let file = Text.unlines ["RUN --mount=type=tmpfs,target=/foo echo foo"] + flags = def {mount = Just $ TmpfsMount (def {tTarget = "/foo"})} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--mount=type=ssh" $ + let file = Text.unlines ["RUN --mount=type=ssh echo foo"] + flags = def {mount = Just $ SshMount def} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--mount=type=ssh all modifiers" $ + let file = Text.unlines ["RUN --mount=type=ssh,target=/foo,id=a,required,source=/bar,mode=0700,uid=0,gid=0 echo foo"] + flags = + def + { mount = + Just $ + SshMount + ( def + { sTarget = Just "/foo", + sCacheId = Just "a", + sIsRequired = Just True, + sSource = Just "/bar", + sMode = Just "0700", + sUid = Just 0, + sGid = Just 0 + } + ) + } + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--mount=type=secret all modifiers" $ + let file = Text.unlines ["RUN --mount=type=secret,target=/foo,id=a,required,source=/bar,mode=0700,uid=0,gid=0 echo foo"] + flags = + def + { mount = + Just $ + SecretMount + ( def + { sTarget = Just "/foo", + sCacheId = Just "a", + sIsRequired = Just True, + sSource = Just "/bar", + sMode = Just "0700", + sUid = Just 0, + sGid = Just 0 + } + ) + } + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--network=none" $ + let file = Text.unlines ["RUN --network=none echo foo"] + flags = def {network = Just NetworkNone} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--network=host" $ + let file = Text.unlines ["RUN --network=host echo foo"] + flags = def {network = Just NetworkHost} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--network=default" $ + let file = Text.unlines ["RUN --network=default echo foo"] + flags = def {network = Just NetworkDefault} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--security=insecure" $ + let file = Text.unlines ["RUN --security=insecure echo foo"] + flags = def {security = Just Insecure} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "--security=sandbox" $ + let file = Text.unlines ["RUN --security=sandbox echo foo"] + flags = def {security = Just Sandbox} + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] + it "allows all flags" $ + let file = Text.unlines ["RUN --mount=target=/foo --network=none --security=sandbox echo foo"] + flags = + def + { security = Just Sandbox, + network = Just NetworkNone, + mount = Just $ BindMount $ def {bTarget = "/foo"} + } + in assertAst + file + [ Run $ RunArgs (ArgumentsText "echo foo") flags + ] assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion assertAst s ast = - case parseText s of - Left err -> assertFailure $ errorBundlePretty err - Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile + case parseText s of + Left err -> assertFailure $ errorBundlePretty err + Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile diff --git a/test/fixtures/1.Dockerfile b/test/fixtures/1.Dockerfile new file mode 100644 index 0000000..b8e07ed --- /dev/null +++ b/test/fixtures/1.Dockerfile @@ -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 diff --git a/test/fixtures/2.Dockerfile b/test/fixtures/2.Dockerfile new file mode 100644 index 0000000..fd41cf8 --- /dev/null +++ b/test/fixtures/2.Dockerfile @@ -0,0 +1,13 @@ +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/*