language-docker 14.0.1 → 15.0.0

raw patch · 8 files changed

+179/−71 lines, 8 filesnew-uploaderPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +3/−3
• language-docker.cabal +1/−1
• src/Language/Docker/Parser/Run.hs +65/−59
• src/Language/Docker/PrettyPrint.hs +5/−0
• src/Language/Docker/Syntax.hs +8/−2
• test/Language/Docker/ParseExposeSpec.hs +0/−2
• test/Language/Docker/ParseHealthcheckSpec.hs +0/−2
• test/Language/Docker/ParseRunSpec.hs +97/−2

@@ -1,4 +1,4 @@-[![Build Status][travis-img]][travis]+[![Build Status][actions-img]][actions] [![Hackage][hackage-img]][hackage] [![GPL-3 licensed][license-img]][license] @@ -37,7 +37,7 @@  [hackage-img]: https://img.shields.io/hackage/v/language-docker.svg [hackage]: https://hackage.haskell.org/package/language-docker-[travis-img]: https://travis-ci.org/hadolint/language-docker.svg?branch=master-[travis]: https://travis-ci.org/hadolint/language-docker+[actions-img]: https://github.com/hadolint/language-docker/actions/workflows/haskell.yml/badge.svg+[actions]: https://github.com/hadolint/language-docker/actions/workflows/haskell.yml [license-img]: https://img.shields.io/badge/license-GPL--3-blue.svg [license]: https://tldrlegal.com/license/gnu-general-public-license-v3-(gpl-3)

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               language-docker-version:            14.0.1+version:            15.0.0 synopsis:           Dockerfile parser, pretty-printer and embedded DSL description:   All functions for parsing and pretty-printing Dockerfiles are exported through @Language.Docker@. For more fine-grained operations look for specific modules that implement a certain functionality.

@@ -28,9 +28,10 @@   | MountArgSharing CacheSharing   | MountArgSource SourcePath   | MountArgTarget TargetPath-  | MountArgType Text+  | MountArgType MountType   | MountArgUid Text   | MountArgGid Text+  | MountArgRelabel Relabel   deriving (Show)  data MountType@@ -39,6 +40,7 @@   | Tmpfs   | Secret   | Ssh+  deriving (Show)  parseRun :: (?esc :: Char) => Parser (Instruction Text) parseRun = do@@ -83,46 +85,44 @@ runFlagMount :: (?esc :: Char) => 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)+  args <- mountArgs `sepBy1` string ","+  mt <- parseTypeFromArgs args+  case mt of+    Bind -> BindMount <$> bindMount (filter (not . isMountArgType) args)+    Cache -> CacheMount <$> cacheMount (filter (not . isMountArgType) args)+    Tmpfs -> TmpfsMount <$> tmpfsMount (filter (not . isMountArgType) args)+    Secret -> SecretMount <$> secretMount (filter (not . isMountArgType) args)+    Ssh -> SshMount <$> secretMount (filter (not . isMountArgType) args) -argsParser :: (?esc :: Char) => MountType -> Parser [RunMountArg]-argsParser mountType = mountChoices mountType `sepBy1` string ","+parseTypeFromArgs :: [RunMountArg] -> Parser MountType+parseTypeFromArgs args =+  -- `notFollowedBy eof` is a trivially succeeding parser that isn't supposed to+  -- consume any input here. It's a hack that converts a simple type into a+  -- parser. This allows this function to emit parse errors after analyzing its+  -- input arguments and not consume any input.+  case filter isMountArgType args of+    [] -> Bind <$ notFollowedBy eof+    [MountArgType t] -> t <$ notFollowedBy eof+    _:_ -> fail "--mount with multiple `type` arguments" +isMountArgType :: RunMountArg -> Bool+isMountArgType (MountArgType _) = True+isMountArgType _ = False+ bindMount :: [RunMountArg] -> Parser BindOpts bindMount args =   case validArgs "bind" allowed required args of     Left e -> customError e     Right as -> return $ foldr bindOpts def as   where-    allowed = Set.fromList ["target", "source", "from", "ro"]+    allowed = Set.fromList ["target", "source", "from", "ro", "relabel"]     required = Set.singleton "target"     bindOpts :: RunMountArg -> BindOpts -> BindOpts     bindOpts (MountArgTarget path) bo = bo {bTarget = path}     bindOpts (MountArgSource path) bo = bo {bSource = Just path}     bindOpts (MountArgFromImage img) bo = bo {bFromImage = Just img}     bindOpts (MountArgReadOnly ro) bo = bo {bReadOnly = Just ro}+    bindOpts (MountArgRelabel re) bo = bo {bRelabel = Just re}     bindOpts invalid _ = error $ "unhandled " <> show invalid <> " please report this bug"  cacheMount :: [RunMountArg] -> Parser CacheOpts@@ -188,6 +188,7 @@         [] -> result         missing -> Left $ MissingArgument missing   where+    checkValidArg :: RunMountArg -> (Either DockerfileError [RunMountArg], Set.Set Text) -> (Either DockerfileError [RunMountArg], Set.Set Text)     checkValidArg _ x@(Left _, _) = x     checkValidArg a (Right as, seen) =       let name = toArgName a@@ -196,38 +197,23 @@             (_, True) -> (Left (DuplicateArgument name), seen)             (True, False) -> (Right (a : as), Set.insert name seen) -mountChoices :: (?esc :: Char) => MountType -> Parser RunMountArg-mountChoices mountType =-  choice $-    case mountType of-      Bind ->-        [ mountArgTarget,-          mountArgSource,-          mountArgFromImage,-          mountArgReadOnly-        ]-      Cache ->-        [ mountArgTarget,-          mountArgSource,-          mountArgFromImage,-          mountArgReadOnly,-          mountArgId,-          mountArgSharing,-          mountArgMode,-          mountArgUid,-          mountArgGid-        ]-      Tmpfs -> [mountArgTarget]-      _ -> -- Secret and Ssh-        [ mountArgTarget,-          mountArgId,-          mountArgRequired,-          mountArgSource,-          mountArgMode,-          mountArgUid,-          mountArgGid,-          mountArgEnv-        ]+mountArgs :: (?esc :: Char) => Parser RunMountArg+mountArgs =+  choice+    [ mountArgEnv,+      mountArgFromImage,+      mountArgGid,+      mountArgId,+      mountArgMode,+      mountArgReadOnly,+      mountArgRelabel,+      mountArgRequired,+      mountArgSharing,+      mountArgSource,+      mountArgTarget,+      mountArgType,+      mountArgUid+    ]  stringArg :: (?esc :: Char) => Parser Text stringArg = choice [doubleQuotedString, someUnless "a string" (== ',')]@@ -319,9 +305,28 @@   label "target=" $ choice [string "target=", string "dst=", string "destination="]   MountArgTarget . TargetPath <$> stringArg +mountArgType :: Parser RunMountArg+mountArgType = MountArgType <$> key "type" mountType++mountType :: Parser MountType+mountType =+  choice+    [ Bind <$ string "bind",+      Cache <$ string "cache",+      Tmpfs <$ string "tmpfs",+      Secret <$ string "secret",+      Ssh <$ string "ssh"+    ]+ mountArgUid :: (?esc :: Char) => Parser RunMountArg mountArgUid = MountArgUid <$> key "uid" stringArg +mountArgRelabel :: Parser RunMountArg+mountArgRelabel = MountArgRelabel <$> key "relabel" relabel++relabel :: Parser Relabel+relabel = choice [RelabelShared <$ string "shared", RelabelPrivate <$ string "private"]+ toArgName :: RunMountArg -> Text toArgName (MountArgEnv _) = "env" toArgName (MountArgFromImage _) = "from"@@ -335,3 +340,4 @@ toArgName (MountArgTarget _) = "target" toArgName (MountArgType _) = "type" toArgName (MountArgUid _) = "uid"+toArgName (MountArgRelabel _) = "relabel"

@@ -188,6 +188,7 @@             <> maybe mempty printSource bSource             <> maybe mempty printFromImage bFromImage             <> maybe mempty printReadOnly bReadOnly+            <> maybe mempty printRelabel bRelabel         CacheMount CacheOpts {..} ->           "type=cache"             <> printTarget cTarget@@ -237,6 +238,10 @@     printReadOnly False = ",rw"     printRequired True = ",required"     printRequired False = mempty+    printRelabel r = ",relabel="+      <> case r of+        RelabelShared -> printQuotable "shared"+        RelabelPrivate -> printQuotable "private"  prettyPrintRunNetwork :: Maybe RunNetwork -> Doc ann prettyPrintRunNetwork Nothing = mempty

@@ -119,6 +119,11 @@       }   deriving (Show, Eq, Ord, IsString) +data Relabel+  = RelabelShared+  | RelabelPrivate+  deriving (Show, Eq, Ord)+ data Checksum   = Checksum !Text   | NoChecksum@@ -271,12 +276,13 @@       { bTarget :: !TargetPath,         bSource :: !(Maybe SourcePath),         bFromImage :: !(Maybe Text),-        bReadOnly :: !(Maybe Bool)+        bReadOnly :: !(Maybe Bool),+        bRelabel :: !(Maybe Relabel)       }   deriving (Show, Eq, Ord)  instance Default BindOpts where-  def = BindOpts "" Nothing Nothing Nothing+  def = BindOpts "" Nothing Nothing Nothing Nothing  data CacheOpts   = CacheOpts

@@ -1,7 +1,5 @@ module Language.Docker.ParseExposeSpec where -import Data.Default.Class (def)-import qualified Data.Text as Text import Language.Docker.Syntax import TestHelper import Test.Hspec

@@ -1,10 +1,8 @@ module Language.Docker.ParseHealthcheckSpec where -import Data.Default.Class (def) import Language.Docker.Syntax import Test.Hspec import TestHelper-import qualified Data.Set as Set import qualified Data.Text as Text  

@@ -50,8 +50,8 @@             [ 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 = Set.singleton $ BindMount (BindOpts {bTarget = "/foo", bSource = Just "/bar", bFromImage = Just "ubuntu", bReadOnly = Just True})}+      let file = Text.unlines ["RUN --mount=type=bind,target=/foo,source=/bar,from=ubuntu,ro,relabel=shared echo foo"]+          flags = def {mount = Set.singleton $ BindMount (BindOpts {bTarget = "/foo", bSource = Just "/bar", bFromImage = Just "ubuntu", bReadOnly = Just True, bRelabel = Just RelabelShared})}        in assertAst             file             [ Run $ RunArgs (ArgumentsText "echo foo") flags@@ -72,6 +72,41 @@               Run $ RunArgs (ArgumentsText "echo foo") flags2,               Run $ RunArgs (ArgumentsText "echo foo") flags3             ]++    it "--mount=type=cache with id from variable/arg" $+      let file =+            Text.unlines+              [ "ARG debian_version=12",+                "FROM debian:bookworm-slim",+                "RUN --mount=id=debian:${debian_version},type=cache,target=/foo foo bar"+              ]+          flags = def {mount = Set.singleton $ CacheMount (def {cTarget = "/foo", cCacheId = Just "debian:${debian_version}"})}+       in assertAst+            file+            [ Arg "debian_version" (Just "12"),+              From $ BaseImage+                        { image = Image+                                    { registryName = Nothing,+                                      imageName="debian"+                                    },+                          tag = Just Tag { unTag="bookworm-slim" },+                          digest = Nothing,+                          alias = Nothing,+                          platform = Nothing+                        },+              Run $ RunArgs (ArgumentsText "foo bar") flags+            ]++    it "--mount=type=cache,dst=/foo" $+      let file = Text.unlines [ "RUN --mount=type=cache,dst=/foo echo foo" ]+          flags = def {mount = Set.singleton $ CacheMount (def {cTarget = "/foo"})}+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flags ]++    it "--mount=dst=/foo,type=cache" $+      let file = Text.unlines [ "RUN --mount=dst=/foo,type=cache echo foo" ]+          flags = def {mount = Set.singleton $ CacheMount (def {cTarget = "/foo"})}+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flags ]+     it "--mount=type=cache with all modifiers" $       let file =             Text.unlines@@ -99,6 +134,33 @@             file             [ Run $ RunArgs (ArgumentsText "echo foo") flags             ]+    it "--mount=type=cache with all modifiers, different order" $+      let file =+            Text.unlines+              [ "RUN --mount=readonly,sharing=private,id=a,type=cache,from=ubuntu,source=/bar,destination=/foo,mode=0700,uid=0,gid=0 echo foo"+              ]+          flags =+            def+              { mount =+                  Set.singleton $+                    CacheMount+                      ( def+                          { cTarget = "/foo",+                            cSharing = Just Private,+                            cCacheId = Just "a",+                            cReadOnly = Just True,+                            cFromImage = Just "ubuntu",+                            cSource = Just "/bar",+                            cMode = Just "0700",+                            cUid = Just "0",+                            cGid = Just "0"+                          }+                      )+              }+       in assertAst+            file+            [ Run $ RunArgs (ArgumentsText "echo foo") flags+            ]     it "--mount=type=tmpfs" $       let file = Text.unlines ["RUN --mount=type=tmpfs,target=/foo echo foo"]           flags = def {mount = Set.singleton $ TmpfsMount (def {tTarget = "/foo"})}@@ -639,3 +701,36 @@             file             [ Run $ RunArgs ( ArgumentsText "ls &&  cat" ) flags             ]++  describe "Parse RUN instructions - invalid cases" $ do+    it "fail because of multiple types in --mount" $+      let line = "RUN --mount=type=cache,type=tmpfs,target=/foo foo bar"+       in expectFail line++  describe "Parse RUN instructions - SELinux relabeling" $ do+    let flagsRelabelShared =+          def { mount = Set.singleton $+                  BindMount+                    ( def+                        { bTarget = "/bar",+                          bRelabel = Just RelabelShared+                        }+                    )+              }+        flagsRelabelPrivate =+          def { mount = Set.singleton $+                  BindMount+                    ( def+                        { bTarget = "/bar",+                          bRelabel = Just RelabelPrivate+                        }+                    )+              }+    it "RUN with --relabel=shared" $+      let file = Text.unlines+            ["RUN --mount=type=bind,target=/bar,relabel=shared echo foo"]+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRelabelShared ]+    it "RUN with --relabel=private" $+      let file = Text.unlines+            ["RUN --mount=type=bind,target=/bar,relabel=private echo foo"]+       in assertAst file [ Run $ RunArgs (ArgumentsText "echo foo") flagsRelabelPrivate ]