diff --git a/language-docker.cabal b/language-docker.cabal --- a/language-docker.cabal +++ b/language-docker.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.0. -- -- see: https://github.com/sol/hpack -- --- hash: 64e893f351e7689307e2cbe6595ac2c624f727f4e02b9ff0aae6ec166f4cf5d4 +-- hash: ec17b57a0353ccb2f2acde00b3f39a8983c7b388e00b574ee76db0cc11c206f7 name: language-docker -version: 6.0.4 +version: 7.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. @@ -22,7 +24,6 @@ license: GPL-3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 extra-source-files: README.md diff --git a/src/Language/Docker.hs b/src/Language/Docker.hs --- a/src/Language/Docker.hs +++ b/src/Language/Docker.hs @@ -2,6 +2,7 @@ ( Language.Docker.Syntax.Dockerfile -- * Parsing Dockerfiles (@Language.Docker.Syntax@ and @Language.Docker.Parser@) , parseText , parseFile + , parseStdin -- * Re-exports from @megaparsec@ , Text.Megaparsec.parseErrorPretty -- * Pretty-printing Dockerfiles (@Language.Docker.PrettyPrint@) @@ -86,6 +87,7 @@ , 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 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 @@ -55,9 +55,8 @@ runD :: MonadWriter [Syntax.Instruction Text] m => EInstruction (m b) -> m b runD (From bi n) = case bi of - EUntaggedImage bi' alias -> runDef Syntax.From (Syntax.UntaggedImage bi' alias) n - ETaggedImage bi' tg alias -> runDef Syntax.From (Syntax.TaggedImage bi' tg alias) n - EDigestedImage bi' d alias -> runDef Syntax.From (Syntax.DigestedImage bi' d alias) n + 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 (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 @@ -154,7 +153,7 @@ -- from "fpco/stack-build" -- @ untagged :: Text -> EBaseImage -untagged = flip EUntaggedImage Nothing . fromString . Text.unpack +untagged s = EUntaggedImage (fromString . Text.unpack $ s) Nothing Nothing -- | Use a specific tag for a docker image. This function is meant -- to be used as an infix operator. @@ -163,10 +162,19 @@ -- from $ "fpco/stack-build" `tagged` "lts-10.3" -- @ tagged :: Syntax.Image -> Syntax.Tag -> EBaseImage -tagged imageName tag = ETaggedImage imageName tag Nothing +tagged imageName tag = ETaggedImage imageName tag Nothing Nothing -digested :: Syntax.Image -> Text -> EBaseImage -digested imageName hash = EDigestedImage imageName hash 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 image d = + case image of + EUntaggedImage n _ alias -> EUntaggedImage n (Just d) alias + ETaggedImage n t _ alias -> ETaggedImage n t (Just d) alias -- | Alias a FROM instruction to be used as a build stage. -- This function is meant to be used as an infix operator. @@ -174,12 +182,11 @@ -- @ -- from $ "fpco/stack-build" `aliased` "builder" -- @ -aliased :: EBaseImage -> Text -> EBaseImage +aliased :: EBaseImage -> Syntax.ImageAlias -> EBaseImage aliased image alias = case image of - EUntaggedImage n _ -> EUntaggedImage n (Just $ Syntax.ImageAlias alias) - ETaggedImage n t _ -> ETaggedImage n t (Just $ Syntax.ImageAlias alias) - EDigestedImage n h _ -> EDigestedImage n h (Just $ Syntax.ImageAlias alias) + EUntaggedImage n d _ -> EUntaggedImage n d (Just alias) + ETaggedImage n t d _ -> ETaggedImage n t d (Just alias) -- | Create a RUN instruction with the given arguments. -- 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 @@ -9,17 +9,16 @@ data EBaseImage = EUntaggedImage Syntax.Image + (Maybe Syntax.Digest) (Maybe Syntax.ImageAlias) | ETaggedImage Syntax.Image Syntax.Tag + (Maybe Syntax.Digest) (Maybe Syntax.ImageAlias) - | EDigestedImage Syntax.Image - Text - (Maybe Syntax.ImageAlias) deriving (Show, Eq, Ord) instance IsString EBaseImage where - fromString = flip EUntaggedImage Nothing . fromString + fromString s = EUntaggedImage (fromString s) 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 @@ -5,6 +5,7 @@ module Language.Docker.Parser ( parseText , parseFile + , parseStdin , Parser , Error , DockerfileError(..) @@ -163,35 +164,30 @@ registryName <- (Just <$> try parseRegistry) <|> return Nothing name <- someUnless "the image name with a tag" (\c -> c == '@' || c == ':') void $ char ':' - tag <- someUnless "the image tag" (== ':') + tag <- someUnless "the image tag" (\c -> c == '@' || c == ':') + maybeDigest <- (Just <$> try digest) <|> return Nothing maybeAlias <- maybeImageAlias - return $ TaggedImage (Image registryName name) (Tag tag) maybeAlias + return $ TaggedImage (Image registryName name) (Tag tag) maybeDigest maybeAlias -digestedImage :: Parser BaseImage -digestedImage = do - name <- someUnless "the image name with a digest" (\c -> c == '@' || c == ':') +digest :: Parser Digest +digest = do void $ char '@' - digest <- someUnless "the image digest" (== '@') - maybeAlias <- maybeImageAlias - return $ DigestedImage (Image Nothing name) digest maybeAlias + 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 - notInvalidDigest name + maybeDigest <- (Just <$> try digest) <|> return Nothing maybeAlias <- maybeImageAlias - return $ UntaggedImage (Image registryName name) maybeAlias + return $ UntaggedImage (Image registryName name) maybeDigest maybeAlias where notInvalidTag :: Text -> Parser () notInvalidTag name = try (notFollowedBy $ string ":") "no ':' or a valid image tag string (example: " ++ T.unpack name ++ ":valid-tag)" - notInvalidDigest :: Text -> Parser () - notInvalidDigest name = - try (notFollowedBy $ string "@") "no '@' or a valid digest hash (example: " ++ - T.unpack name ++ "@a3f42f2de)" maybeImageAlias :: Parser (Maybe ImageAlias) maybeImageAlias = Just <$> (spaces1 >> imageAlias) <|> return Nothing @@ -203,10 +199,7 @@ return $ ImageAlias alias baseImage :: Parser BaseImage -baseImage = - try digestedImage <|> -- Let's try each version - try taggedImage <|> - untaggedImage +baseImage = try taggedImage <|> untaggedImage from :: Parser Instr from = do @@ -398,7 +391,7 @@ (try portInt "a valid port number") ports :: Parser Ports -ports = Ports <$> port `sepEndBy1` (char ' ' <|> char '\t') +ports = Ports <$> port `sepEndBy` spaces1 portRange :: Parser Port portRange = do @@ -602,3 +595,10 @@ where doParse = parse (contents dockerfile) file . normalizeEscapedLines . 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 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 @@ -55,18 +55,15 @@ prettyPrintBaseImage :: BaseImage -> Doc ann prettyPrintBaseImage b = case b of - DigestedImage img digest alias -> do - prettyPrintImage img - pretty '@' - pretty digest - prettyAlias alias - UntaggedImage img alias -> do + UntaggedImage img digest alias -> do prettyPrintImage img + prettyDigest digest prettyAlias alias - TaggedImage img (Tag tag) alias -> do + TaggedImage img (Tag tag) digest alias -> do prettyPrintImage img pretty ':' pretty tag + prettyDigest digest prettyAlias alias where (>>) = (<>) @@ -75,9 +72,15 @@ case maybeAlias of Nothing -> mempty Just (ImageAlias alias) -> " AS " <> pretty alias + prettyDigest maybeDigest = + case maybeDigest of + Nothing -> mempty + Just (Digest d) -> "@" <> pretty d prettyPrintPairs :: Pairs -> Doc ann -prettyPrintPairs ps = hsep $ fmap prettyPrintPair ps +prettyPrintPairs ps = align $ sepLine $ fmap prettyPrintPair ps + where + sepLine = concatWith (\x y -> x <> " \\" <> line <> y) prettyPrintPair :: (Text, Text) -> Doc ann prettyPrintPair (k, v) = pretty k <> pretty '=' <> doubleQoute v 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 @@ -36,6 +36,10 @@ { unTag :: Text } deriving (Show, Eq, Ord, IsString) +newtype Digest = Digest + { unDigest :: Text + } deriving (Show, Eq, Ord, IsString) + data Protocol = TCP | UDP @@ -67,13 +71,12 @@ data BaseImage = UntaggedImage !Image + !(Maybe Digest) !(Maybe ImageAlias) | TaggedImage !Image !Tag + !(Maybe Digest) !(Maybe ImageAlias) - | DigestedImage !Image - !Text - !(Maybe ImageAlias) deriving (Eq, Ord, Show) -- | Type of the Dockerfile AST diff --git a/src/Language/Docker/Syntax/Lift.hs b/src/Language/Docker/Syntax/Lift.hs --- a/src/Language/Docker/Syntax/Lift.hs +++ b/src/Language/Docker/Syntax/Lift.hs @@ -38,6 +38,8 @@ deriveLift ''Tag +deriveLift ''Digest + deriveLift ''BaseImage deriveLift ''Arguments 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) + df `shouldBe` [ From (UntaggedImage "node" Nothing Nothing) , Run "apt-get update" , Cmd ["node", "something.js"] ] @@ -33,7 +33,7 @@ CMD node something.js |] df = map instruction (toDockerfile d) - df `shouldBe` [ From (UntaggedImage "node" (Just $ ImageAlias "node-build")) + df `shouldBe` [ From (UntaggedImage "node" Nothing (Just "node-build")) , 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 @@ -28,6 +28,7 @@ r `shouldBe` [ Syntax.From $ Syntax.UntaggedImage "node" 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 @@ -22,35 +22,43 @@ describe "parse FROM" $ do it "parse untagged image" $ - assertAst "FROM busybox" [From (UntaggedImage "busybox" Nothing)] + assertAst "FROM busybox" [From (UntaggedImage "busybox" Nothing Nothing)] it "parse tagged image" $ assertAst "FROM busybox:5.12-dev" - [From (TaggedImage "busybox" "5.12-dev" Nothing)] + [From (TaggedImage "busybox" "5.12-dev" Nothing Nothing)] it "parse digested image" $ assertAst "FROM ubuntu@sha256:0ef2e08ed3fab" - [From (DigestedImage "ubuntu" "sha256:0ef2e08ed3fab" Nothing)] + [From (UntaggedImage "ubuntu" (Just "sha256:0ef2e08ed3fab") Nothing)] + it "parse digested image with tag" $ + assertAst + "FROM ubuntu:14.04@sha256:0ef2e08ed3fab" + [From (TaggedImage "ubuntu" "14.04" (Just "sha256:0ef2e08ed3fab") Nothing)] describe "parse aliased FROM" $ do it "parse untagged image" $ - assertAst "FROM busybox as foo" [From (UntaggedImage "busybox" (Just $ ImageAlias "foo"))] + assertAst "FROM busybox as foo" [From (UntaggedImage "busybox" Nothing (Just "foo"))] it "parse tagged image" $ - assertAst "FROM busybox:5.12-dev AS foo-bar" [From (TaggedImage "busybox" "5.12-dev" (Just $ ImageAlias "foo-bar"))] + assertAst "FROM busybox:5.12-dev AS foo-bar" + [ From (TaggedImage "busybox" "5.12-dev" Nothing (Just "foo-bar")) + ] it "parse diggested image" $ - assertAst "FROM ubuntu@sha256:0ef2e08ed3fab AS foo" [From (DigestedImage "ubuntu" "sha256:0ef2e08ed3fab" (Just $ ImageAlias "foo"))] + assertAst "FROM ubuntu@sha256:0ef2e08ed3fab AS foo" + [ From (UntaggedImage "ubuntu" (Just "sha256:0ef2e08ed3fab") (Just "foo")) + ] describe "parse FROM with registry" $ do it "registry without port" $ - assertAst "FROM foo.com/node" [From (UntaggedImage (Image (Just "foo.com") "node") Nothing)] + assertAst "FROM foo.com/node" [From (UntaggedImage (Image (Just "foo.com") "node") Nothing Nothing)] it "parse with port and tag" $ assertAst "FROM myregistry.com:5000/imagename:5.12-dev" - [From (TaggedImage (Image (Just "myregistry.com:5000") "imagename") "5.12-dev" Nothing)] + [From (TaggedImage (Image (Just "myregistry.com:5000") "imagename") "5.12-dev" Nothing Nothing)] it "Not a registry if no TLD" $ assertAst "FROM myfolder/imagename:5.12-dev" - [From (TaggedImage (Image Nothing "myfolder/imagename") "5.12-dev" Nothing)] + [From (TaggedImage (Image Nothing "myfolder/imagename") "5.12-dev" Nothing Nothing)] describe "parse LABEL" $ do it "parse label" $ assertAst "LABEL foo=bar" [Label[("foo", "bar")]] @@ -85,7 +93,7 @@ , "ENV NODE_VERSION=v5.7.1 \\" , "DEBIAN_FRONTEND=noninteractive" ] - ast = [ From (UntaggedImage "busybox" Nothing) + ast = [ From (UntaggedImage "busybox" Nothing Nothing) , Env[("NODE_VERSION", "v5.7.1"), ("DEBIAN_FRONTEND", "noninteractive")] ] in assertAst dockerfile ast @@ -213,12 +221,12 @@ it "maintainer of untagged scratch image" $ assertAst "FROM scratch\nMAINTAINER hudu@mail.com" - [From (UntaggedImage "scratch" Nothing), Maintainer "hudu@mail.com"] + [From (UntaggedImage "scratch" Nothing Nothing), Maintainer "hudu@mail.com"] it "maintainer with mail" $ assertAst "MAINTAINER hudu@mail.com" [Maintainer "hudu@mail.com"] it "maintainer only mail after from" $ let maintainerFromProg = "FROM busybox\nMAINTAINER hudu@mail.com" - maintainerFromAst = [From (UntaggedImage "busybox" Nothing), Maintainer "hudu@mail.com"] + maintainerFromAst = [From (UntaggedImage "busybox" Nothing Nothing), Maintainer "hudu@mail.com"] in assertAst maintainerFromProg maintainerFromAst describe "parse # comment " $ do it "multiple comments before run" $ @@ -278,7 +286,7 @@ , "RUN echo\\ " , " hello" ] - in assertAst dockerfile [ From (UntaggedImage "busybox" Nothing) + in assertAst dockerfile [ From (UntaggedImage "busybox" Nothing Nothing) , Run "echo hello" ] describe "expose" $ do @@ -300,11 +308,24 @@ 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" Nothing)] + in assertAst content [From (UntaggedImage "ubuntu" Nothing Nothing)] describe "ADD" $ do it "simple ADD" $