Merge pull request #104 from m-ildefons/gh-95

parser: allow --mount arguments in any order

Author: m-ildefons

src/Language/Docker/Parser/Run.hs

@@ -28,7 +28,7 @@ data RunMountArg
   | MountArgSharing CacheSharing
   | MountArgSource SourcePath
   | MountArgTarget TargetPath
-  | MountArgType Text
+  | MountArgType MountType
   | MountArgUid Text
   | MountArgGid Text
   deriving (Show)
@@ -39,6 +39,7 @@ data MountType
   | Tmpfs
   | Secret
   | Ssh
+  deriving (Show)
 
 parseRun :: (?esc :: Char) => Parser (Instruction Text)
 parseRun = do
@@ -83,32 +84,29 @@ runFlagNetwork = do
 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)
-
-argsParser :: (?esc :: Char) => MountType -> Parser [RunMountArg]
-argsParser mountType = mountChoices mountType `sepBy1` string ","
+  args <- mountArgs `sepBy1` string ","
+  mt <- parseTypeFromArgs args
+  case mt of
+    Bind -> BindMount <$> (bindMount $ filter (not . isMountArgType) args)
+    Cache -> CacheMount <$> (cacheMount $ filter (not . isMountArgType) args)
+    Tmpfs -> TmpfsMount <$> (tmpfsMount $ filter (not . isMountArgType) args)
+    Secret -> SecretMount <$> (secretMount $ filter (not . isMountArgType) args)
+    Ssh -> SshMount <$> (secretMount $ filter (not . isMountArgType) args)
+
+parseTypeFromArgs :: [RunMountArg] -> Parser MountType
+parseTypeFromArgs args =
+  -- `notFollowedBy eof` is a trivially succeeding parser that isn't supposed to
+  -- consume any input here. It's a hack that converts a simple type into a
+  -- parser. This allows this function to emit parse errors after analyzing its
+  -- input arguments and not consume any input.
+  case filter isMountArgType args of
+    [] -> Bind <$ notFollowedBy eof
+    [(MountArgType t)] -> t <$ notFollowedBy eof
+    _:_ -> fail $ "--mount with multiple `type` arguments"
+
+isMountArgType :: RunMountArg -> Bool
+isMountArgType (MountArgType _) = True
+isMountArgType _ = False
 
 bindMount :: [RunMountArg] -> Parser BindOpts
 bindMount args =
@@ -188,6 +186,7 @@ validArgs typeName allowed required args =
         [] -> 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 +195,22 @@ validArgs typeName allowed required args =
             (_, 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,
+      mountArgRequired,
+      mountArgSharing,
+      mountArgSource,
+      mountArgTarget,
+      mountArgType,
+      mountArgUid
+    ]
 
 stringArg :: (?esc :: Char) => Parser Text
 stringArg = choice [doubleQuotedString, someUnless "a string" (== ',')]
@@ -319,6 +302,19 @@ mountArgTarget = do
   label "target=" $ choice [string "target=", string "dst=", string "destination="]
   MountArgTarget . TargetPath <$> stringArg
 
+mountArgType :: Parser RunMountArg
+mountArgType = MountArgType <$> key "type" mountType
+
+mountType :: Parser MountType
+mountType =
+  choice
+    [ Bind <$ string "bind",
+      Cache <$ string "cache",
+      Tmpfs <$ string "tmpfs",
+      Secret <$ string "secret",
+      Ssh <$ string "ssh"
+    ]
+
 mountArgUid :: (?esc :: Char) => Parser RunMountArg
 mountArgUid = MountArgUid <$> key "uid" stringArg
 

test/Language/Docker/ParseRunSpec.hs

@@ -72,6 +72,41 @@ spec = do
               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 @@ spec = do
             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,8 @@ spec = do
             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