Add support for SELinux relabeling on bind mounts

src/Language/Docker/Parser/Run.hs

@@ -31,6 +31,7 @@ data RunMountArg
   | MountArgType MountType
   | MountArgUid Text
   | MountArgGid Text
+  | MountArgRelabel Relabel
   deriving (Show)
 
 data MountType
@@ -87,11 +88,11 @@ runFlagMount = do
   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)
+    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 =
@@ -101,8 +102,8 @@ parseTypeFromArgs args =
   -- 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"
+    [MountArgType t] -> t <$ notFollowedBy eof
+    _:_ -> fail "--mount with multiple `type` arguments"
 
 isMountArgType :: RunMountArg -> Bool
 isMountArgType (MountArgType _) = True
@@ -114,13 +115,14 @@ bindMount args =
     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
@@ -204,6 +206,7 @@ mountArgs =
       mountArgId,
       mountArgMode,
       mountArgReadOnly,
+      mountArgRelabel,
       mountArgRequired,
       mountArgSharing,
       mountArgSource,
@@ -318,6 +321,12 @@ mountType =
 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"
@@ -331,3 +340,4 @@ toArgName (MountArgSource _) = "source"
 toArgName (MountArgTarget _) = "target"
 toArgName (MountArgType _) = "type"
 toArgName (MountArgUid _) = "uid"
+toArgName (MountArgRelabel _) = "relabel"

src/Language/Docker/PrettyPrint.hs

@@ -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
@@ -290,7 +295,7 @@
       CopyArgs {sourcePaths, targetPath}
       CopyFlags {chmodFlag, chownFlag, linkFlag, sourceFlag, excludeFlags} -> do
         "COPY"
         prettyPrintChown chownFlag
         prettyPrintChmod chmodFlag
         prettyPrintLink linkFlag
         prettyPrintCopySource sourceFlag

src/Language/Docker/Syntax.hs

@@ -42,11 +42,11 @@
     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)
 
@@ -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

test/Language/Docker/ParseExposeSpec.hs

@@ -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

test/Language/Docker/ParseHealthcheckSpec.hs

@@ -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
 
 

test/Language/Docker/ParseRunSpec.hs

@@ -50,8 +50,8 @@ spec = do
             [ 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
@@ -706,3 +706,31 @@ spec = 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 ]