Added regression test for issue #2460

Also include the improvements suggested in PR #2448:

 * Added `DirectoryTreeOptions` type that allows one to control the
   behaviout or to-directory-tree
 * Added command line flags for these options: --allow-parent-directory
   and --allow-absolute-paths
 * Simplified code a bit

Author: mmhat

dhall/src/Dhall/DirectoryTree.hs

@@ -10,7 +10,9 @@
 -- | Implementation of the @dhall to-directory-tree@ subcommand
 module Dhall.DirectoryTree
     ( -- * Filesystem
-      toDirectoryTree
+      DirectoryTreeOptions(..)
+    , defaultDirectoryTreeOptions
+    , toDirectoryTree
     , FilesystemError(..)
 
       -- * Low-level types and functions
@@ -38,7 +40,7 @@ import Dhall.Syntax
     , RecordField (..)
     , Var (..)
     )
-import System.FilePath           ((</>))
+import System.FilePath           ((</>), isAbsolute, splitDirectories, takeDirectory)
 import System.PosixCompat.Types  (FileMode, GroupID, UserID)
 
 import qualified Control.Exception           as Exception
@@ -63,11 +65,31 @@ import qualified System.Posix.User           as Posix
 #endif
 import qualified System.PosixCompat.Files    as Posix
 
+{- | Options affecting the interpretation of a directory tree specification.
+-}
+data DirectoryTreeOptions = DirectoryTreeOptions
+    { allowAbsolute :: Bool
+      -- ^ Whether to allow absolute paths in the spec.
+    , allowParent :: Bool
+      -- ^ Whether to allow ".." in the spec.
+    , allowSeparators :: Bool
+      -- ^ Whether to allow path separators in file names.
+    }
+
+-- | The default 'DirectoryTreeOptions'. All flags are set to 'False'.
+defaultDirectoryTreeOptions :: DirectoryTreeOptions
+defaultDirectoryTreeOptions = DirectoryTreeOptions
+    { allowAbsolute = False
+    , allowParent = False
+    , allowSeparators = False
+    }
+
 {-| Attempt to transform a Dhall record into a directory tree where:
 
     * Records are translated into directories
 
-    * @Map@s are translated into directory trees, if allowSeparators option is enabled
+    * @Map@s are translated into directories or whole directory trees, if
+      `allowSeparators` option is enabled
 
     * @Text@ values or fields are translated into files
 
@@ -122,10 +144,11 @@ import qualified System.PosixCompat.Files    as Posix
     /Construction of directory trees from maps/
 
     In @Map@s, the keys specify paths relative to the work dir.
-    Only forward slashes (@/@) must be used as directory separators.
-    They will be automatically transformed on Windows.
-    Absolute paths (starting with @/@) and parent directory segments (@..@)
-    are prohibited for security concerns.
+    Absolute paths and parent directory segments (@..@) are by default
+    prohibited for security concerns, but these checks can be disabled using
+    `allowAbsolute` option field (or the @--allow-absolute-paths@ CLI flag) and
+    `allowParent` option field (or the @--allow-parent-directory@ CLI flag)
+    respectively.
 
     /Advanced construction of directory trees/
 
@@ -180,11 +203,11 @@ import qualified System.PosixCompat.Files    as Posix
     that cannot be converted as-is.
 -}
 toDirectoryTree
-    :: Bool -- ^ Whether to allow path separators in file names or not
+    :: DirectoryTreeOptions
     -> FilePath
     -> Expr Void Void
     -> IO ()
-toDirectoryTree allowSeparators path expression = case expression of
+toDirectoryTree opts path expression = case expression of
     RecordLit keyValues ->
         Map.unorderedTraverseWithKey_ process $ recordFieldValue <$> keyValues
 
@@ -200,10 +223,10 @@ toDirectoryTree allowSeparators path expression = case expression of
         Text.IO.writeFile path text
 
     Some value ->
-        toDirectoryTree allowSeparators path value
+        toDirectoryTree opts path value
 
     App (Field (Union _) _) value -> do
-        toDirectoryTree allowSeparators path value
+        toDirectoryTree opts path value
 
     App None _ ->
         return ()
@@ -214,7 +237,7 @@ toDirectoryTree allowSeparators path expression = case expression of
     Lam _ _ (Lam _ _ _) -> do
         entries <- decodeDirectoryTree expression
 
-        processFilesystemEntryList allowSeparators path entries
+        processFilesystemEntryList opts path entries
 
     _ ->
         die
@@ -230,31 +253,24 @@ toDirectoryTree allowSeparators path expression = case expression of
         empty
 
     process key value = do
+        let
+            keyPath = Text.unpack key
+            keyPathSegments = splitDirectories keyPath
+            path' = path </> keyPath
+
         -- Fail if path is absolute, which is a security risk.
-        when (FilePath.isAbsolute (Text.unpack key)) die
-        
-        let keyPathSegments =
-                fmap Text.unpack $ Text.splitOn "/" key
+        when (not (allowAbsolute opts) && isAbsolute keyPath) die
 
         -- Fail if path contains attempts to go to container directory,
         -- which is a security risk.
-        when (elem ".." keyPathSegments) die
-
-        (dirPathSegments, fileName) <- case reverse keyPathSegments of
-            h : t ->
-                return (reverse t, h)
-            _ ->
-                die
-
-        -- Fail if separators are not allowed by the option but we have directories in the path.
-        when (not allowSeparators && not (null dirPathSegments)) die
+        when (not (allowParent opts) && ".." `elem` keyPathSegments) die
 
-        let dirPath =
-                Foldable.foldl' (</>) path dirPathSegments
+        -- Fail if separators are not allowed by the option.
+        when (not (allowSeparators opts) && length keyPathSegments > 1) die
 
-        Directory.createDirectoryIfMissing True dirPath
+        Directory.createDirectoryIfMissing (allowSeparators opts) (takeDirectory path')
 
-        toDirectoryTree allowSeparators (dirPath </> fileName) value
+        toDirectoryTree opts path' value
 
     die = Exception.throwIO FilesystemError{..}
       where
@@ -351,9 +367,9 @@ processEntryWith path entry f = do
     applyMetadata entry path'
 
 -- | Process a list of `FilesystemEntry`s.
-processFilesystemEntryList :: Bool -> FilePath -> Seq FilesystemEntry -> IO ()
-processFilesystemEntryList allowSeparators path = Foldable.traverse_
-    (processFilesystemEntry allowSeparators path)
+processFilesystemEntryList :: DirectoryTreeOptions -> FilePath -> Seq FilesystemEntry -> IO ()
+processFilesystemEntryList opts path = Foldable.traverse_
+    (processFilesystemEntry opts path)
 
 -- | Does this entry have some metadata set?
 hasMetadata :: Entry a -> Bool

dhall/src/Dhall/Main.hs

@@ -163,7 +163,7 @@ data Mode
     | Encode { file :: Input, json :: Bool }
     | Decode { file :: Input, json :: Bool, quiet :: Bool }
     | Text { file :: Input, output :: Output }
-    | DirectoryTree { allowSeparators :: Bool, file :: Input, path :: FilePath }
+    | DirectoryTree { directoryTreeOptions :: DirectoryTree.DirectoryTreeOptions, file :: Input, path :: FilePath }
     | Schemas { file :: Input, outputMode :: OutputMode, schemas :: Text }
     | SyntaxTree { file :: Input, noted :: Bool }
     | Package
@@ -277,7 +277,7 @@ parseMode =
             Generate
             "to-directory-tree"
             "Convert nested records of Text literals into a directory tree"
-            (DirectoryTree <$> parseDirectoryTreeAllowSeparators <*> parseFile <*> parseDirectoryTreeOutput)
+            (DirectoryTree <$> parseDirectoryTreeOptions <*> parseFile <*> parseDirectoryTreeOutput)
     <|> subcommand
             Interpret
             "resolve"
@@ -546,8 +546,16 @@ parseMode =
             <>  Options.Applicative.metavar "EXPR"
             )
 
-    parseDirectoryTreeAllowSeparators =
-        Options.Applicative.switch
+    parseDirectoryTreeOptions = DirectoryTree.DirectoryTreeOptions
+        <$> Options.Applicative.switch
+            (   Options.Applicative.long "allow-absolute-paths"
+            <>  Options.Applicative.help "Whether to allow absolute file paths"
+            )
+        <*> Options.Applicative.switch
+            (   Options.Applicative.long "allow-parent-directory"
+            <>  Options.Applicative.help "Whether to allow references to the parent directory (\"..\") in file paths"
+            )
+        <*> Options.Applicative.switch
             (   Options.Applicative.long "allow-path-separators"
             <>  Options.Applicative.help "Whether to allow path separators in file names"
             )
@@ -1043,7 +1051,7 @@ command (Options {..}) = do
 
             let normalizedExpression = Dhall.Core.normalize resolvedExpression
 
-            DirectoryTree.toDirectoryTree allowSeparators path normalizedExpression
+            DirectoryTree.toDirectoryTree directoryTreeOptions path normalizedExpression
 
         Dhall.Main.Schemas{..} ->
             Dhall.Schemas.schemasCommand Dhall.Schemas.Schemas{ input = file, ..}

dhall/tests/Dhall/Test/DirectoryTree.hs

@@ -33,6 +33,9 @@ tests = testGroup "to-directory-tree"
         , fixpointedUserGroup
 #endif
         ]
+    , testGroup "path separators"
+        [ issue1305
+        ]
     ]
 
 fixpointedType :: TestTree
@@ -48,15 +51,15 @@ fixpointedEmpty :: TestTree
 fixpointedEmpty = testCase "empty" $ do
     let outDir = "./tests/to-directory-tree/fixpoint-empty.out"
         path = "./tests/to-directory-tree/fixpoint-empty.dhall"
-    entries <- runDirectoryTree False outDir path
+    entries <- runDirectoryTree defaultDirectoryTreeOptions outDir path
     entries @?= [Directory outDir]
 
 fixpointedSimple :: TestTree
 fixpointedSimple = testCase "simple" $ do
     let outDir = "./tests/to-directory-tree/fixpoint-simple.out"
         path = "./tests/to-directory-tree/fixpoint-simple.dhall"
-    entries <- runDirectoryTree False outDir path
-    entries @?= Data.List.sort
+    entries <- runDirectoryTree defaultDirectoryTreeOptions outDir path
+    entries @?=
         [ Directory outDir
         , File $ outDir </> "file"
         , Directory $ outDir </> "directory"
@@ -84,7 +87,7 @@ fixpointedPermissions :: TestTree
 fixpointedPermissions = testCase "permissions" $ do
     let outDir = "./tests/to-directory-tree/fixpoint-permissions.out"
         path = "./tests/to-directory-tree/fixpoint-permissions.dhall"
-    entries <- runDirectoryTree False outDir path
+    entries <- runDirectoryTree defaultDirectoryTreeOptions outDir path
     entries @?=
         [ Directory outDir
         , File $ outDir </> "file"
@@ -115,8 +118,20 @@ fixpointedUserGroup = testCase "user and group" $ do
             }
         ]
 
-runDirectoryTree :: Bool -> FilePath -> FilePath -> IO [WalkEntry]
-runDirectoryTree allowSeparators outDir path = do
+issue1305 :: TestTree
+issue1305 = testCase "separators in map keys" $ do
+    let outDir = "./tests/to-directory-tree/T1305.out"
+        path = "./tests/to-directory-tree/T1305.dhall"
+        opts = defaultDirectoryTreeOptions { allowSeparators = True }
+    entries <- runDirectoryTree opts outDir path
+    entries @?=
+        [ Directory outDir
+        , Directory $ outDir </> "A"
+        , File $ outDir </> "A/B"
+        ]
+
+runDirectoryTree :: DirectoryTreeOptions -> FilePath -> FilePath -> IO [WalkEntry]
+runDirectoryTree opts outDir path = do
     doesOutDirExist <- Directory.doesDirectoryExist outDir
     when doesOutDirExist $
         Directory.removeDirectoryRecursive outDir
@@ -129,7 +144,7 @@ runDirectoryTree allowSeparators outDir path = do
             $ Dhall.defaultInputSettings
     expr <- Dhall.inputExprWithSettings inputSettings text
 
-    toDirectoryTree allowSeparators outDir $ Dhall.Core.denote expr
+    toDirectoryTree opts outDir $ Dhall.Core.denote expr
 
     Data.List.sort <$> walkFsTree outDir
 

dhall/tests/to-directory-tree/T1305.dhall

@@ -0,0 +1 @@
+[ { mapKey = "A/B", mapValue = "" } ]