Skip to content

Followup for PR #2448 #2682

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
mmhat merged 1 commit into from
Jan 31, 2026
+87 −43
Merged

Followup for PR #2448 #2682

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
79 changes: 48 additions & 31 deletions dhall/src/Dhall/DirectoryTree.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -38,7 +40,7 @@
, RecordField (..)
, Var (..)
)
import System.FilePath ((</>))
import System.FilePath ((</>), isAbsolute, splitDirectories, takeDirectory)
import System.PosixCompat.Types (FileMode, GroupID, UserID)

import qualified Control.Exception as Exception
Expand All @@ -63,11 +65,31 @@
#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

Expand Down Expand Up @@ -122,10 +144,11 @@
/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/

Expand Down Expand Up @@ -180,16 +203,16 @@
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 options path expression = case expression of
RecordLit keyValues ->
Map.unorderedTraverseWithKey_ process $ recordFieldValue <$> keyValues

ListLit (Just (App List (Record [ ("mapKey", recordFieldValue -> Text), ("mapValue", _) ]))) [] ->
Directory.createDirectoryIfMissing allowSeparators path
Directory.createDirectoryIfMissing (allowSeparators options) path

ListLit _ records
| not (null records)
Expand All @@ -200,10 +223,10 @@
Text.IO.writeFile path text

Some value ->
toDirectoryTree allowSeparators path value
toDirectoryTree options path value

App (Field (Union _) _) value -> do
toDirectoryTree allowSeparators path value
toDirectoryTree options path value

App None _ ->
return ()
Expand All @@ -214,7 +237,8 @@
Lam _ _ (Lam _ _ _) -> do
entries <- decodeDirectoryTree expression

processFilesystemEntryList allowSeparators path entries
-- TODO: Support allowAbsolute and allowParent as well ?
processFilesystemEntryList (allowSeparators options) path entries

_ ->
die
Expand All @@ -230,31 +254,24 @@
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 options) && 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 options) && ".." `elem` keyPathSegments) die

let dirPath =
Foldable.foldl' (</>) path dirPathSegments
-- Fail if separators are not allowed by the option.
when (not (allowSeparators options) && length keyPathSegments > 1) die

Directory.createDirectoryIfMissing True dirPath
Directory.createDirectoryIfMissing (allowSeparators options) (takeDirectory path')

toDirectoryTree allowSeparators (dirPath </> fileName) value
toDirectoryTree options path' value

die = Exception.throwIO FilesystemError{..}
where
Expand Down Expand Up @@ -297,7 +314,7 @@
-- | Resolve a `User` to a numerical id.
getUser :: User -> IO UserID
getUser (UserId uid) = return uid
getUser (UserName name) =

Check warning on line 317 in dhall/src/Dhall/DirectoryTree.hs

View workflow job for this annotation

GitHub Actions / windows-latest - stack.yaml 

Defined but not used: `name'
#ifdef mingw32_HOST_OS
ioError $ mkIOError illegalOperationErrorType x Nothing Nothing
where x = "System.Posix.User.getUserEntryForName: not supported"
Expand All @@ -308,7 +325,7 @@
-- | Resolve a `Group` to a numerical id.
getGroup :: Group -> IO GroupID
getGroup (GroupId gid) = return gid
getGroup (GroupName name) =

Check warning on line 328 in dhall/src/Dhall/DirectoryTree.hs

View workflow job for this annotation

GitHub Actions / windows-latest - stack.yaml 

Defined but not used: `name'
#ifdef mingw32_HOST_OS
ioError $ mkIOError illegalOperationErrorType x Nothing Nothing
where x = "System.Posix.User.getGroupEntryForName: not supported"
Expand Down
18 changes: 13 additions & 5 deletions dhall/src/Dhall/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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"
Expand Down Expand Up @@ -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"
)
Expand Down Expand Up @@ -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, ..}
Expand Down
32 changes: 25 additions & 7 deletions dhall/tests/Dhall/Test/DirectoryTree.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,9 @@
, fixpointedUserGroup
#endif
]
, testGroup "path separators"
[ issue1305
]
]

fixpointedType :: TestTree
Expand All @@ -48,14 +51,14 @@
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 <- runDirectoryTree defaultDirectoryTreeOptions outDir path
entries @?= Data.List.sort
[ Directory outDir
, File $ outDir </> "file"
Expand All @@ -66,7 +69,10 @@
fixpointedAllowPathSeparators = testCase "allow-path-separators" $ do
let outDir = "./tests/to-directory-tree/fixpoint-allow-path-separators.out"
path = "./tests/to-directory-tree/fixpoint-allow-path-separators.dhall"
entries <- runDirectoryTree True outDir path
options = defaultDirectoryTreeOptions
{ allowSeparators = True
}
entries <- runDirectoryTree options outDir path
entries @?= Data.List.sort
[ Directory outDir
, Directory $ outDir </> "non-existent-1"
Expand All @@ -81,10 +87,10 @@
but got: 438
-}
fixpointedPermissions :: TestTree
fixpointedPermissions = testCase "permissions" $ do

Check warning on line 90 in dhall/tests/Dhall/Test/DirectoryTree.hs

View workflow job for this annotation

GitHub Actions / windows-latest - stack.yaml 

Defined but not used: `fixpointedPermissions'
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"
Expand All @@ -94,7 +100,7 @@
prettyFileMode mode @?= prettyFileMode Files.ownerModes

fixpointedUserGroup :: TestTree
fixpointedUserGroup = testCase "user and group" $ do

Check warning on line 103 in dhall/tests/Dhall/Test/DirectoryTree.hs

View workflow job for this annotation

GitHub Actions / windows-latest - stack.yaml 

Defined but not used: `fixpointedUserGroup'
let file = "./tests/to-directory-tree/fixpoint-usergroup.dhall"
expr <- Dhall.inputExpr file
entries <- decodeDirectoryTree expr
Expand All @@ -115,8 +121,20 @@
}
]

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
Expand All @@ -129,7 +147,7 @@
$ 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

Expand Down
1 change: 1 addition & 0 deletions dhall/tests/to-directory-tree/T1305.dhall
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
[ { mapKey = "A/B", mapValue = "" } ]
Loading