diff --git a/language-docker.cabal b/language-docker.cabal --- a/language-docker.cabal +++ b/language-docker.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ec17b57a0353ccb2f2acde00b3f39a8983c7b388e00b574ee76db0cc11c206f7 +-- hash: e70e395205673f99130496542ebb35f3353a9d6568091de10c1457576d58a1ac name: language-docker -version: 7.0.0 +version: 8.0.0 synopsis: Dockerfile parser, pretty-printer and embedded DSL description: All functions for parsing, printing and writting Dockerfiles are exported through @Language.Docker@. For more fine-grained operations look for specific modules that implement a certain functionality. See the for the source-code and examples. @@ -52,7 +52,7 @@ , bytestring >=0.10 , containers , free - , megaparsec >=6.4 + , megaparsec >=7.0 , mtl , prettyprinter , split >=0.2 @@ -85,7 +85,7 @@ , free , hspec , language-docker - , megaparsec >=6.4 + , megaparsec >=7.0 , mtl , prettyprinter , process diff --git a/src/Language/Docker.hs b/src/Language/Docker.hs --- a/src/Language/Docker.hs +++ b/src/Language/Docker.hs @@ -5,6 +5,7 @@ , parseStdin -- * Re-exports from @megaparsec@ , Text.Megaparsec.parseErrorPretty + , Text.Megaparsec.errorBundlePretty -- * Pretty-printing Dockerfiles (@Language.Docker.PrettyPrint@) , prettyPrint , prettyPrintDockerfile @@ -93,6 +94,7 @@ , 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 diff --git a/src/Language/Docker/EDSL.hs b/src/Language/Docker/EDSL.hs --- a/src/Language/Docker/EDSL.hs +++ b/src/Language/Docker/EDSL.hs @@ -53,10 +53,7 @@ runDef2 f a b n = tell [f a b] >> n runD :: MonadWriter [Syntax.Instruction Text] m => EInstruction (m b) -> m b -runD (From bi n) = - case bi of - EUntaggedImage bi' md alias -> runDef Syntax.From (Syntax.UntaggedImage bi' md alias) n - ETaggedImage bi' tg md alias -> runDef Syntax.From (Syntax.TaggedImage bi' tg md alias) n +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 @@ -153,7 +150,7 @@ -- from "fpco/stack-build" -- @ untagged :: Text -> EBaseImage -untagged s = EUntaggedImage (fromString . Text.unpack $ s) Nothing Nothing +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. @@ -162,7 +159,7 @@ -- from $ "fpco/stack-build" `tagged` "lts-10.3" -- @ tagged :: Syntax.Image -> Syntax.Tag -> EBaseImage -tagged imageName tag = ETaggedImage imageName tag Nothing Nothing +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. @@ -171,10 +168,7 @@ -- from $ "fpco/stack-build" `digested` "sha256:abcdef123" -- @ digested :: EBaseImage -> Syntax.Digest -> EBaseImage -digested image d = - case image of - EUntaggedImage n _ alias -> EUntaggedImage n (Just d) alias - ETaggedImage n t _ alias -> ETaggedImage n t (Just d) alias +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. @@ -183,10 +177,7 @@ -- from $ "fpco/stack-build" `aliased` "builder" -- @ aliased :: EBaseImage -> Syntax.ImageAlias -> EBaseImage -aliased image alias = - case image of - EUntaggedImage n d _ -> EUntaggedImage n d (Just alias) - ETaggedImage n t d _ -> ETaggedImage n t d (Just alias) +aliased (EBaseImage n t d _ p) a = EBaseImage n t d (Just a) p -- | Create a RUN instruction with the given arguments. -- diff --git a/src/Language/Docker/EDSL/Quasi.hs b/src/Language/Docker/EDSL/Quasi.hs --- a/src/Language/Docker/EDSL/Quasi.hs +++ b/src/Language/Docker/EDSL/Quasi.hs @@ -11,7 +11,7 @@ import Language.Docker.EDSL import qualified Language.Docker.Parser as Parser import Language.Docker.Syntax.Lift () -import Text.Megaparsec (parseErrorPretty) +import Text.Megaparsec (errorBundlePretty) -- | Quasiquoter for embedding dockerfiles on the EDSL -- @@ -30,7 +30,7 @@ edockerfileE :: String -> ExpQ edockerfileE e = case Parser.parseText (Text.pack e) of - Left err -> fail (parseErrorPretty err) + Left err -> fail (errorBundlePretty err) Right d -> [|embed d|] dockerfile :: QuasiQuoter @@ -45,5 +45,5 @@ dockerfileE :: String -> ExpQ dockerfileE e = case Parser.parseText (Text.pack e) of - Left err -> fail (parseErrorPretty err) + 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 --- a/src/Language/Docker/EDSL/Types.hs +++ b/src/Language/Docker/EDSL/Types.hs @@ -7,18 +7,15 @@ import Data.Text (Text) import qualified Language.Docker.Syntax as Syntax -data EBaseImage - = EUntaggedImage Syntax.Image - (Maybe Syntax.Digest) - (Maybe Syntax.ImageAlias) - | ETaggedImage Syntax.Image - Syntax.Tag - (Maybe Syntax.Digest) - (Maybe Syntax.ImageAlias) +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 = EUntaggedImage (fromString s) Nothing Nothing + fromString s = EBaseImage (fromString s) Nothing Nothing Nothing Nothing data EInstruction next = From EBaseImage diff --git a/src/Language/Docker/Parser.hs b/src/Language/Docker/Parser.hs --- a/src/Language/Docker/Parser.hs +++ b/src/Language/Docker/Parser.hs @@ -41,7 +41,7 @@ type Parser = Parsec DockerfileError Text -type Error = ParseError Char DockerfileError +type Error = ParseErrorBundle Text DockerfileError type Instr = Instruction Text @@ -159,35 +159,45 @@ void $ char '/' return $ Registry (domain <> "." <> tld) -taggedImage :: Parser BaseImage -taggedImage = do +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 == ':') - void $ char ':' - tag <- someUnless "the image tag" (\c -> c == '@' || c == ':') - maybeDigest <- (Just <$> try digest) <|> return Nothing + maybeTag <- tagParser name + maybeDigest <- (Just <$> try parseDigest) <|> return Nothing maybeAlias <- maybeImageAlias - return $ TaggedImage (Image registryName name) (Tag tag) maybeDigest maybeAlias + return $ BaseImage (Image registryName name) maybeTag maybeDigest maybeAlias maybePlatform -digest :: Parser Digest -digest = do +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 = do - registryName <- (Just <$> try parseRegistry) <|> return Nothing - name <- someUnless "just the image name" (\c -> c == '@' || c == ':') - notInvalidTag name - maybeDigest <- (Just <$> try digest) <|> return Nothing - maybeAlias <- maybeImageAlias - return $ UntaggedImage (Image registryName name) maybeDigest maybeAlias +untaggedImage = parseBaseImage notInvalidTag where - notInvalidTag :: Text -> Parser () - notInvalidTag name = - try (notFollowedBy $ string ":") "no ':' or a valid image tag string (example: " ++ - T.unpack name ++ ":valid-tag)" + 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 @@ -582,7 +592,7 @@ dockerfile :: Parser Dockerfile dockerfile = many $ do - pos <- getPosition + pos <- getSourcePos i <- parseInstruction eol <|> eof "a new line followed by the next instruction" return $ InstructionPos i (T.pack . sourceName $ pos) (unPos . sourceLine $ pos) diff --git a/src/Language/Docker/PrettyPrint.hs b/src/Language/Docker/PrettyPrint.hs --- a/src/Language/Docker/PrettyPrint.hs +++ b/src/Language/Docker/PrettyPrint.hs @@ -53,25 +53,27 @@ prettyPrintImage (Image (Just (Registry reg)) name) = pretty reg <> "/" <> pretty name prettyPrintBaseImage :: BaseImage -> Doc ann -prettyPrintBaseImage b = - case b of - UntaggedImage img digest alias -> do - prettyPrintImage img - prettyDigest digest - prettyAlias alias - TaggedImage img (Tag tag) digest alias -> do - prettyPrintImage img - pretty ':' - pretty tag - prettyDigest digest - prettyAlias alias +prettyPrintBaseImage BaseImage{..} = do + prettyPlatform platform + prettyPrintImage image + prettyTag tag + prettyDigest digest + prettyAlias alias where (>>) = (<>) return = (mempty <>) + prettyPlatform maybePlatform = + case maybePlatform of + Nothing -> mempty + Just p -> "--platform=" <> pretty p <> " " + prettyTag maybeTag = + case maybeTag of + Nothing -> mempty + Just (Tag p) -> ":" <> pretty p prettyAlias maybeAlias = case maybeAlias of Nothing -> mempty - Just (ImageAlias alias) -> " AS " <> pretty alias + Just (ImageAlias a) -> " AS " <> pretty a prettyDigest maybeDigest = case maybeDigest of Nothing -> mempty diff --git a/src/Language/Docker/Syntax.hs b/src/Language/Docker/Syntax.hs --- a/src/Language/Docker/Syntax.hs +++ b/src/Language/Docker/Syntax.hs @@ -65,19 +65,19 @@ type Directory = Text +type Platform = Text + newtype ImageAlias = ImageAlias { unImageAlias :: Text } deriving (Show, Eq, Ord, IsString) -data BaseImage - = UntaggedImage !Image - !(Maybe Digest) - !(Maybe ImageAlias) - | TaggedImage !Image - !Tag - !(Maybe Digest) - !(Maybe ImageAlias) - deriving (Eq, Ord, Show) +data BaseImage = BaseImage + { image :: !Image + , tag :: !(Maybe Tag) + , digest :: !(Maybe Digest) + , alias :: !(Maybe ImageAlias) + , platform :: !(Maybe Platform) + } deriving (Eq, Ord, Show) -- | Type of the Dockerfile AST type Dockerfile = [InstructionPos Text] diff --git a/test/Language/Docker/EDSL/QuasiSpec.hs b/test/Language/Docker/EDSL/QuasiSpec.hs --- a/test/Language/Docker/EDSL/QuasiSpec.hs +++ b/test/Language/Docker/EDSL/QuasiSpec.hs @@ -18,7 +18,7 @@ RUN apt-get update CMD ["node", "something.js"] |] - df `shouldBe` [ From (UntaggedImage "node" Nothing Nothing) + df `shouldBe` [ From (BaseImage "node" Nothing Nothing Nothing Nothing) , Run "apt-get update" , Cmd ["node", "something.js"] ] @@ -33,7 +33,13 @@ CMD node something.js |] df = map instruction (toDockerfile d) - df `shouldBe` [ From (UntaggedImage "node" Nothing (Just "node-build")) + 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 --- a/test/Language/Docker/EDSLSpec.hs +++ b/test/Language/Docker/EDSLSpec.hs @@ -26,7 +26,9 @@ from "node" cmdArgs ["node", "-e", "'console.log(\'hey\')'"]) r `shouldBe` [ Syntax.From $ - Syntax.UntaggedImage "node" + Syntax.BaseImage "node" + Nothing + Nothing Nothing Nothing , Syntax.Cmd ["node", "-e", "'console.log(\'hey\')'"] diff --git a/test/Language/Docker/ParserSpec.hs b/test/Language/Docker/ParserSpec.hs --- a/test/Language/Docker/ParserSpec.hs +++ b/test/Language/Docker/ParserSpec.hs @@ -12,6 +12,22 @@ import Text.Megaparsec hiding (Label) import qualified Data.Text as Text +untaggedImage :: Image -> BaseImage +untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing + +taggedImage :: Image -> Tag -> BaseImage +taggedImage n t = BaseImage n (Just t) Nothing Nothing Nothing + +withDigest :: BaseImage -> Digest -> BaseImage +withDigest i d = i { digest = Just d } + +withAlias :: BaseImage -> ImageAlias -> BaseImage +withAlias i a = i { alias = Just a } + +withPlatform :: BaseImage -> Platform -> BaseImage +withPlatform i p = i { platform = Just p } + + spec :: Spec spec = do describe "parse ARG" $ do @@ -22,43 +38,50 @@ describe "parse FROM" $ do it "parse untagged image" $ - assertAst "FROM busybox" [From (UntaggedImage "busybox" Nothing Nothing)] + assertAst "FROM busybox" [From (untaggedImage "busybox")] it "parse tagged image" $ assertAst "FROM busybox:5.12-dev" - [From (TaggedImage "busybox" "5.12-dev" Nothing Nothing)] + [From (taggedImage "busybox" "5.12-dev")] it "parse digested image" $ assertAst "FROM ubuntu@sha256:0ef2e08ed3fab" - [From (UntaggedImage "ubuntu" (Just "sha256:0ef2e08ed3fab") Nothing)] + [From (untaggedImage "ubuntu" `withDigest` "sha256:0ef2e08ed3fab")] it "parse digested image with tag" $ assertAst "FROM ubuntu:14.04@sha256:0ef2e08ed3fab" - [From (TaggedImage "ubuntu" "14.04" (Just "sha256:0ef2e08ed3fab") Nothing)] + [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" Nothing (Just "foo"))] + 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" Nothing (Just "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" (Just "sha256:0ef2e08ed3fab") (Just "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") Nothing Nothing)] + 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" Nothing Nothing)] + [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" Nothing Nothing)] + [From (taggedImage (Image Nothing "myfolder/imagename") "5.12-dev")] describe "parse LABEL" $ do it "parse label" $ assertAst "LABEL foo=bar" [Label[("foo", "bar")]] @@ -93,7 +116,7 @@ , "ENV NODE_VERSION=v5.7.1 \\" , "DEBIAN_FRONTEND=noninteractive" ] - ast = [ From (UntaggedImage "busybox" Nothing Nothing) + ast = [ From (untaggedImage "busybox") , Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")] ] in assertAst dockerfile ast @@ -221,12 +244,12 @@ it "maintainer of untagged scratch image" $ assertAst "FROM scratch\nMAINTAINER hudu@mail.com" - [From (UntaggedImage "scratch" Nothing Nothing), Maintainer "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" Nothing Nothing), Maintainer "hudu@mail.com"] + maintainerFromAst = [From (untaggedImage "busybox"), Maintainer "hudu@mail.com"] in assertAst maintainerFromProg maintainerFromAst describe "parse # comment " $ do it "multiple comments before run" $ @@ -286,7 +309,7 @@ , "RUN echo\\ " , " hello" ] - in assertAst dockerfile [ From (UntaggedImage "busybox" Nothing Nothing) + in assertAst dockerfile [ From (untaggedImage "busybox") , Run "echo hello" ] describe "expose" $ do @@ -325,7 +348,7 @@ describe "syntax" $ do it "should handle lowercase instructions (#7 - https://github.com/beijaflor-io/haskell-language-dockerfile/issues/7)" $ let content = "from ubuntu" - in assertAst content [From (UntaggedImage "ubuntu" Nothing Nothing)] + in assertAst content [From (untaggedImage "ubuntu")] describe "ADD" $ do it "simple ADD" $ @@ -389,5 +412,5 @@ assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion assertAst s ast = case parseText s of - Left err -> assertFailure $ parseErrorPretty err + Left err -> assertFailure $ errorBundlePretty err Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile