From d8995adf1d428e5d6d9931ab46d19fc32feb40e7 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 12 Aug 2022 13:48:42 +0200 Subject: [PATCH 01/12] Improved to-directory tree * Added a new command line flag --allow-path-separators for the to-directory-tree command. This flag controls whether path separators in names are allowed. In that case we also create all parent directories of a file. * Added a new way building directory trees using a fixpoint approach. This method allows one to set the user, group and permissions on some OS. * Added unix-compat as a new dependency of the dhall package --- .gitignore | 1 + dhall/dhall.cabal | 2 + dhall/src/Dhall/DirectoryTree.hs | 386 +++++++++++++++++- dhall/src/Dhall/Main.hs | 12 +- dhall/tests/Dhall/Test/DirectoryTree.hs | 89 ++++ dhall/tests/Dhall/Test/Main.hs | 2 + .../to-directory-tree/fixpoint-empty.dhall | 3 + .../to-directory-tree/fixpoint-helper.dhall | 26 ++ .../to-directory-tree/fixpoint-metadata.dhall | 26 ++ .../to-directory-tree/fixpoint-simple.dhall | 25 ++ 10 files changed, 552 insertions(+), 20 deletions(-) create mode 100644 dhall/tests/Dhall/Test/DirectoryTree.hs create mode 100644 dhall/tests/to-directory-tree/fixpoint-empty.dhall create mode 100644 dhall/tests/to-directory-tree/fixpoint-helper.dhall create mode 100644 dhall/tests/to-directory-tree/fixpoint-metadata.dhall create mode 100644 dhall/tests/to-directory-tree/fixpoint-simple.dhall diff --git a/.gitignore b/.gitignore index 868e96f42..78a67da72 100644 --- a/.gitignore +++ b/.gitignore @@ -28,3 +28,4 @@ docs result result-* report.html +/dhall/tests/to-directory-tree/*.out/ diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index a594b3f44..e9667d98c 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -250,6 +250,7 @@ Common common th-lift-instances >= 0.1.13 && < 0.2 , time >= 1.1.4 && < 1.13, transformers >= 0.5.2.0 && < 0.6 , + unix-compat >= 0.4.2 && < 0.7 , unordered-containers >= 0.1.3.0 && < 0.3 , uri-encode < 1.6 , vector >= 0.11.0.0 && < 0.14 @@ -411,6 +412,7 @@ Test-Suite tasty Other-Modules: Dhall.Test.Dhall Dhall.Test.Diff + Dhall.Test.DirectoryTree Dhall.Test.Tags Dhall.Test.Format Dhall.Test.Freeze diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 4f152a7a4..b5bf2906e 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} -- | Implementation of the @dhall to-directory-tree@ subcommand @@ -12,9 +18,16 @@ module Dhall.DirectoryTree import Control.Applicative (empty) import Control.Exception (Exception) +import Control.Monad (when, unless) +import Data.Either (isRight) +import Data.Maybe (fromMaybe) +import Data.Functor.Identity (Identity(..)) +import Data.Sequence (Seq) +import Data.Text (Text) import Data.Void (Void) -import Dhall.Syntax (Chunks (..), Expr (..), RecordField (..)) +import Dhall.Syntax (Chunks (..), Expr (..), FieldSelection(..), FunctionBinding(..), RecordField(..), Var(..)) import System.FilePath (()) +import System.PosixCompat.Types (FileMode, GroupID, UserID) import qualified Control.Exception as Exception import qualified Data.Foldable as Foldable @@ -22,10 +35,15 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Dhall.Map as Map import qualified Dhall.Pretty +import qualified Dhall.TH as TH +import qualified Dhall.TypeCheck as TypeCheck import qualified Dhall.Util as Util import qualified Prettyprinter.Render.String as Pretty import qualified System.Directory as Directory import qualified System.FilePath as FilePath +import qualified System.PosixCompat.Files as Posix +import qualified System.PosixCompat.Types as Posix +import qualified System.PosixCompat.User as Posix {-| Attempt to transform a Dhall record into a directory tree where: @@ -37,6 +55,9 @@ import qualified System.FilePath as FilePath * @Optional@ values are omitted if @None@ + * There is a more advanced way construction directory trees using a fixpoint + encoding. See the documentation below on that. + For example, the following Dhall record: > { dir = { `hello.txt` = "Hello\n" } @@ -59,8 +80,7 @@ import qualified System.FilePath as FilePath > Goodbye Use this in conjunction with the Prelude's support for rendering JSON/YAML - in "pure Dhall" so that you can generate files containing JSON. For - example: + in "pure Dhall" so that you can generate files containing JSON. For example: > let JSON = > https://prelude.dhall-lang.org/v12.0.0/JSON/package.dhall sha256:843783d29e60b558c2de431ce1206ce34bdfde375fcf06de8ec5bf77092fdef7 @@ -81,12 +101,63 @@ import qualified System.FilePath as FilePath > ! "bar": null > ! "foo": "Hello" - This utility does not take care of type-checking and normalizing the - provided expression. This will raise a `FilesystemError` exception upon + /Advanced construction of directory trees/ + + In addition to the ways described above using 'simple' Dhall values to + construct the directory tree there is one based on a fixpoint encoding. It + works by passing a value of the following type to the interpreter: + + > let User = < UserId : Natural | UserName : Text > + > + > let Group = < GroupId : Natural | GroupName : Text > + > + > let Access = + > { execute : Optional Bool + > , read : Optional Bool + > , write : Optional Bool + > } + > + > let Mode = + > { user : Optional Access + > , group : Optional Access + > , other : Optional Access + > } + > + > let Entry = + > \(content : Type) -> + > { name : Text + > , content : content + > , user : Optional User + > , group : Optional Group + > , mode : Optional Mode + > } + > + > in forall (r : Type) -> + > forall ( make + > : { directory : Entry (List r) -> r + > , file : Entry Text -> r + > } + > ) -> + > List r + + The fact that the metadata for filesystem entries is modeled after the POSIX + permission model comes with the unfortunate downside that it might not apply + to other systems: There, changes to the metadata (user, group, permissions) + might be a no-op and __no warning will be issued__. + This is a leaking abstraction of the + [unix-compat](https://hackage.haskell.org/package/unix-compat) package used + internally. + + __NOTE__: This utility does not take care of type-checking and normalizing + the provided expression. This will raise a `FilesystemError` exception upon encountering an expression that cannot be converted as-is. -} -toDirectoryTree :: FilePath -> Expr Void Void -> IO () -toDirectoryTree path expression = case expression of +toDirectoryTree + :: Bool -- ^ Whether to allow path separators in file names or not + -> FilePath + -> Expr Void Void + -> IO () +toDirectoryTree allowSeparators path expression = case expression of RecordLit keyValues -> Map.unorderedTraverseWithKey_ process $ recordFieldValue <$> keyValues @@ -102,14 +173,18 @@ toDirectoryTree path expression = case expression of Text.IO.writeFile path text Some value -> - toDirectoryTree path value + toDirectoryTree allowSeparators path value - App (Field (Union _) _) value -> - toDirectoryTree path value + App (Field (Union _) _) value -> do + toDirectoryTree allowSeparators path value App None _ -> return () + Lam _ _ (Lam _ (functionBindingVariable -> make) body) + | isFixpointedDirectoryTree expression + -> applyFilesystemEntryList allowSeparators path $ extractFilesystemEntryList make body + _ -> die where @@ -124,18 +199,292 @@ toDirectoryTree path expression = case expression of empty process key value = do - if Text.isInfixOf (Text.pack [ FilePath.pathSeparator ]) key - then die - else return () + when (not allowSeparators && Text.isInfixOf (Text.pack [ FilePath.pathSeparator ]) key) $ + die - Directory.createDirectoryIfMissing False path + Directory.createDirectoryIfMissing allowSeparators path - toDirectoryTree (path Text.unpack key) value + toDirectoryTree allowSeparators (path Text.unpack key) value die = Exception.throwIO FilesystemError{..} where unexpectedExpression = expression +isFixpointedDirectoryTree :: Expr Void Void -> Bool +isFixpointedDirectoryTree expr = isRight $ TypeCheck.typeOf $ Annot expr $ + [TH.dhall| + let User = < UserId : Natural | UserName : Text > + + let Group = < GroupId : Natural | GroupName : Text > + + let Access = + { execute : Optional Bool + , read : Optional Bool + , write : Optional Bool + } + + let Mode = + { user : Optional Access + , group : Optional Access + , other : Optional Access + } + + let Entry = + \(content : Type) -> + { name : Text + , content : content + , user : Optional User + , group : Optional Group + , mode : Optional Mode + } + + in forall (r : Type) -> + forall ( make + : { directory : Entry (List r) -> r + , file : Entry Text -> r + } + ) -> + List r + |] + +data FilesystemEntry + = DirectoryEntry (Entry (Seq FilesystemEntry)) + | FileEntry (Entry Text) + deriving Show + +extractFilesystemEntry :: Text -> Expr Void Void -> FilesystemEntry +extractFilesystemEntry make (App (Field (Var (V make' 0)) (fieldSelectionLabel -> label)) entry) + | make' == make + , label == "directory" = DirectoryEntry $ extractEntry (extractList (extractFilesystemEntry make)) entry + | make' == make + , label == "file" = FileEntry $ extractEntry extractText entry +extractFilesystemEntry _ expr = Exception.throw (FilesystemError expr) + +extractFilesystemEntryList :: Text -> Expr Void Void -> Seq FilesystemEntry +extractFilesystemEntryList make = extractList (extractFilesystemEntry make) + +data Entry a = Entry + { entryName :: String + , entryContent :: a + , entryUser :: Maybe User + , entryGroup :: Maybe Group + , entryMode :: Maybe (Mode Maybe) + } + deriving Show + +extractEntry :: (Expr Void Void -> a) -> Expr Void Void -> Entry a +extractEntry extractContent (RecordLit (Map.toList -> + [ ("content", recordFieldValue -> contentExpr) + , ("group", recordFieldValue -> groupExpr) + , ("mode", recordFieldValue -> modeExpr) + , ("name", recordFieldValue -> nameExpr) + , ("user", recordFieldValue -> userExpr) + ])) = Entry + { entryName = extractString nameExpr + , entryContent = extractContent contentExpr + , entryUser = extractMaybe extractUser userExpr + , entryGroup = extractMaybe extractGroup groupExpr + , entryMode = extractMaybe extractMode modeExpr + } +extractEntry _ expr = Exception.throw (FilesystemError expr) + +data User + = UserId UserID + | UserName String + deriving Show + +pattern UserP :: Text -> Expr Void Void -> Expr Void Void +pattern UserP label v <- App (Field (Union (Map.toList -> + [ ("UserId", Just Natural) + , ("UserName",Just Text)])) + (fieldSelectionLabel -> label)) + v + +extractUser :: Expr Void Void -> User +extractUser (UserP "UserId" (NaturalLit n)) = UserId $ Posix.CUid (fromIntegral n) +extractUser (UserP "UserName" (TextLit (Chunks [] text))) = UserName $ Text.unpack text +extractUser expr = Exception.throw (FilesystemError expr) + +getUser :: User -> IO UserID +getUser (UserId uid) = return uid +getUser (UserName name) = Posix.userID <$> Posix.getUserEntryForName name + +data Group + = GroupId GroupID + | GroupName String + deriving Show + +pattern GroupP :: Text -> Expr Void Void -> Expr Void Void +pattern GroupP label v <- App (Field (Union (Map.toList -> + [ ("GroupId", Just Natural) + , ("GroupName", Just Text)])) + (fieldSelectionLabel -> label)) + v + +extractGroup :: Expr Void Void -> Group +extractGroup (GroupP "GroupId" (NaturalLit n)) = GroupId $ Posix.CGid (fromIntegral n) +extractGroup (GroupP "GroupName" (TextLit (Chunks [] text))) = GroupName $ Text.unpack text +extractGroup expr = Exception.throw (FilesystemError expr) + +getGroup :: Group -> IO GroupID +getGroup (GroupId gid) = return gid +getGroup (GroupName name) = Posix.groupID <$> Posix.getGroupEntryForName name + +data Mode f = Mode + { modeUser :: f (Access f) + , modeGroup :: f (Access f) + , modeOther :: f (Access f) + } + +deriving instance Eq (Mode Identity) +deriving instance Eq (Mode Maybe) +deriving instance Show (Mode Identity) +deriving instance Show (Mode Maybe) + +extractMode :: Expr Void Void -> Mode Maybe +extractMode (RecordLit (Map.toList -> + [ ("group", recordFieldValue -> groupExpr) + , ("other", recordFieldValue -> otherExpr) + , ("user", recordFieldValue -> userExpr) + ])) = Mode + { modeUser = extractMaybe extractAccess userExpr + , modeGroup = extractMaybe extractAccess groupExpr + , modeOther = extractMaybe extractAccess otherExpr + } +extractMode expr = Exception.throw (FilesystemError expr) + +data Access f = Access + { accessExecute :: f Bool + , accessRead :: f Bool + , accessWrite :: f Bool + } + +deriving instance Eq (Access Identity) +deriving instance Eq (Access Maybe) +deriving instance Show (Access Identity) +deriving instance Show (Access Maybe) + +extractAccess :: Expr Void Void -> Access Maybe +extractAccess (RecordLit (Map.toList -> + [ ("execute", recordFieldValue -> executeExpr) + , ("read", recordFieldValue -> readExpr) + , ("write", recordFieldValue -> writeExpr) + ])) = Access + { accessExecute = extractMaybe extractBool executeExpr + , accessRead = extractMaybe extractBool readExpr + , accessWrite = extractMaybe extractBool writeExpr + } +extractAccess expr = Exception.throw (FilesystemError expr) + +extractBool :: Expr Void Void -> Bool +extractBool (BoolLit b) = b +extractBool expr = Exception.throw (FilesystemError expr) + +extractList :: (Expr Void Void -> a) -> Expr Void Void -> Seq a +extractList _ (ListLit (Just _) _) = mempty +extractList f (ListLit _ xs) = fmap f xs +extractList _ expr = Exception.throw (FilesystemError expr) + +extractMaybe :: (Expr Void Void -> a) -> Expr Void Void -> Maybe a +extractMaybe _ (App None _) = Nothing +extractMaybe f (Some expr) = Just (f expr) +extractMaybe _ expr = Exception.throw (FilesystemError expr) + +extractString :: Expr Void Void -> String +extractString = Text.unpack . extractText + +extractText :: Expr Void Void -> Text +extractText (TextLit (Chunks [] text)) = text +extractText expr = Exception.throw (FilesystemError expr) + +applyFilesystemEntry :: Bool -> FilePath -> FilesystemEntry -> IO () +applyFilesystemEntry allowSeparators path (DirectoryEntry entry) = do + let path' = path entryName entry + Directory.createDirectoryIfMissing allowSeparators path' + applyFilesystemEntryList allowSeparators path' $ entryContent entry + -- It is important that we write the metadata after we wrote the content of + -- the directories/files below this directory as we might lock ourself out + -- by changing ownership or permissions. + unsafeApplyMetadata entry path' +applyFilesystemEntry _ path (FileEntry entry) = do + let path' = path entryName entry + Text.IO.writeFile path' $ entryContent entry + -- It is important that we write the metadata after we wrote the content of + -- the file as we might lock ourself out by changing ownership or + -- permissions. + unsafeApplyMetadata entry path' + +applyFilesystemEntryList :: Bool -> FilePath -> Seq FilesystemEntry -> IO () +applyFilesystemEntryList allowSeparators path = Foldable.traverse_ (applyFilesystemEntry allowSeparators path) + +unsafeApplyMetadata :: Entry a -> FilePath -> IO () +unsafeApplyMetadata entry fp = do + s <- Posix.getFileStatus fp + let user = Posix.fileOwner s + group = Posix.fileGroup s + mode = fileModeToMode $ Posix.fileMode s + + user' <- getUser $ fromMaybe (UserId user) (entryUser entry) + group' <- getGroup $ fromMaybe (GroupId group) (entryGroup entry) + unless ((user', group') == (user, group)) $ + Posix.setOwnerAndGroup fp user' group' + + let mode' = maybe mode (updateModeWith mode) (entryMode entry) + unless (mode' == mode) $ + Posix.setFileMode fp $ modeToFileMode mode' + +updateModeWith :: Mode Identity -> Mode Maybe -> Mode Identity +updateModeWith x y = Mode + { modeUser = combine modeUser modeUser + , modeGroup = combine modeGroup modeGroup + , modeOther = combine modeOther modeOther + } + where + combine f g = maybe (f x) (Identity . updateAccessWith (runIdentity $ f x)) (g y) + +updateAccessWith :: Access Identity -> Access Maybe -> Access Identity +updateAccessWith x y = Access + { accessExecute = combine accessExecute accessExecute + , accessRead = combine accessRead accessRead + , accessWrite = combine accessWrite accessWrite + } + where + combine f g = maybe (f x) Identity (g y) + +fileModeToMode :: FileMode -> Mode Identity +fileModeToMode mode = Mode + { modeUser = Identity $ Access + { accessExecute = Identity $ mode `hasFileMode` Posix.ownerExecuteMode + , accessRead = Identity $ mode `hasFileMode` Posix.ownerReadMode + , accessWrite = Identity $ mode `hasFileMode` Posix.ownerReadMode + } + , modeGroup = Identity $ Access + { accessExecute = Identity $ mode `hasFileMode` Posix.groupExecuteMode + , accessRead = Identity $ mode `hasFileMode` Posix.groupReadMode + , accessWrite = Identity $ mode `hasFileMode` Posix.groupReadMode + } + , modeOther = Identity $ Access + { accessExecute = Identity $ mode `hasFileMode` Posix.otherExecuteMode + , accessRead = Identity $ mode `hasFileMode` Posix.otherReadMode + , accessWrite = Identity $ mode `hasFileMode` Posix.otherReadMode + } + } + +modeToFileMode :: Mode Identity -> FileMode +modeToFileMode mode = foldr Posix.unionFileModes Posix.nullFileMode $ + [ Posix.ownerExecuteMode | runIdentity $ accessExecute (runIdentity $ modeUser mode) ] <> + [ Posix.ownerReadMode | runIdentity $ accessRead (runIdentity $ modeUser mode) ] <> + [ Posix.ownerWriteMode | runIdentity $ accessWrite (runIdentity $ modeUser mode) ] <> + [ Posix.groupExecuteMode | runIdentity $ accessExecute (runIdentity $ modeGroup mode) ] <> + [ Posix.groupReadMode | runIdentity $ accessRead (runIdentity $ modeGroup mode) ] <> + [ Posix.groupWriteMode | runIdentity $ accessWrite (runIdentity $ modeGroup mode) ] <> + [ Posix.otherExecuteMode | runIdentity $ accessExecute (runIdentity $ modeOther mode) ] <> + [ Posix.otherReadMode | runIdentity $ accessRead (runIdentity $ modeOther mode) ] <> + [ Posix.otherWriteMode | runIdentity $ accessWrite (runIdentity $ modeOther mode) ] + +hasFileMode :: FileMode -> FileMode -> Bool +hasFileMode mode x = (mode `Posix.intersectFileModes` x) == Posix.nullFileMode + {- | This error indicates that you supplied an invalid Dhall expression to the `toDirectoryTree` function. The Dhall expression could not be translated to a directory tree. @@ -155,8 +504,11 @@ instance Show FilesystemError where \❰Text❱ literals can be converted to files, and ❰Optional❱ values are included if \n\ \❰Some❱ and omitted if ❰None❱. Values of union types can also be converted if \n\ \they are an alternative which has a non-nullary constructor whose argument is of \n\ - \an otherwise convertible type. No other type of value can be translated to a \n\ - \directory tree. \n\ + \an otherwise convertible type. Furthermore, there is a more advanced approach to \n\ + \constructing a directory tree utilizing a fixpoint encoding. Consult the upstream \n\ + \documentation of the `toDirectoryTree` function in the Dhall.Directory module for \n\ + \further information on that. \n\ + \No other type of value can be translated to a directory tree. \n\ \ \n\ \For example, this is a valid expression that can be translated to a directory \n\ \tree: \n\ diff --git a/dhall/src/Dhall/Main.hs b/dhall/src/Dhall/Main.hs index c97f91917..d68b76beb 100644 --- a/dhall/src/Dhall/Main.hs +++ b/dhall/src/Dhall/Main.hs @@ -159,7 +159,7 @@ data Mode | Encode { file :: Input, json :: Bool } | Decode { file :: Input, json :: Bool, quiet :: Bool } | Text { file :: Input, output :: Output } - | DirectoryTree { file :: Input, path :: FilePath } + | DirectoryTree { allowSeparators :: Bool, file :: Input, path :: FilePath } | Schemas { file :: Input, outputMode :: OutputMode, schemas :: Text } | SyntaxTree { file :: Input, noted :: Bool } @@ -269,7 +269,7 @@ parseMode = Generate "to-directory-tree" "Convert nested records of Text literals into a directory tree" - (DirectoryTree <$> parseFile <*> parseDirectoryTreeOutput) + (DirectoryTree <$> parseDirectoryTreeAllowSeparators <*> parseFile <*> parseDirectoryTreeOutput) <|> subcommand Interpret "resolve" @@ -533,6 +533,12 @@ parseMode = <> Options.Applicative.metavar "EXPR" ) + parseDirectoryTreeAllowSeparators = + Options.Applicative.switch + ( Options.Applicative.long "allow-path-separators" + <> Options.Applicative.help "Whether to allow path separators in file names" + ) + parseDirectoryTreeOutput = Options.Applicative.strOption ( Options.Applicative.long "output" @@ -997,7 +1003,7 @@ command (Options {..}) = do let normalizedExpression = Dhall.Core.normalize resolvedExpression - DirectoryTree.toDirectoryTree path normalizedExpression + DirectoryTree.toDirectoryTree allowSeparators path normalizedExpression Dhall.Main.Schemas{..} -> Dhall.Schemas.schemasCommand Dhall.Schemas.Schemas{ input = file, ..} diff --git a/dhall/tests/Dhall/Test/DirectoryTree.hs b/dhall/tests/Dhall/Test/DirectoryTree.hs new file mode 100644 index 000000000..c8c842a0a --- /dev/null +++ b/dhall/tests/Dhall/Test/DirectoryTree.hs @@ -0,0 +1,89 @@ +module Dhall.Test.DirectoryTree (tests) where + +import Control.Monad +import Data.Either (partitionEithers) +import Lens.Family (set) +import System.FilePath (()) +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.Text.IO +import qualified Dhall +import qualified Dhall.Core +import qualified Dhall.DirectoryTree +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import qualified System.PosixCompat.Files as Files + +tests :: TestTree +tests = testGroup "to-directory-tree" + [ testGroup "fixpointed" + [ fixpointedEmpty + , fixpointedSimple + , fixpointedMetadata + ] + ] + +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 @?= [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 @?= + [ Directory outDir + , File $ outDir "file" + , Directory $ outDir "directory" + ] + +fixpointedMetadata :: TestTree +fixpointedMetadata = testCase "metadata" $ do + let outDir = "./tests/to-directory-tree/fixpoint-metadata.out" + path = "./tests/to-directory-tree/fixpoint-metadata.dhall" + entries <- runDirectoryTree False outDir path + entries @?= + [ Directory outDir + , File $ outDir "file" + ] + s <- Files.getFileStatus $ outDir "file" + let mode = Files.fileMode s `Files.intersectFileModes` Files.accessModes + mode @?= Files.ownerModes + +runDirectoryTree :: Bool -> FilePath -> FilePath -> IO [FilesystemEntry] +runDirectoryTree allowSeparators outDir path = do + doesOutDirExist <- Directory.doesDirectoryExist outDir + when doesOutDirExist $ + Directory.removeDirectoryRecursive outDir + Directory.createDirectoryIfMissing True outDir + + text <- Data.Text.IO.readFile path + let inputSettings + = set Dhall.rootDirectory (FilePath.takeDirectory path) + . set Dhall.sourceName path + $ Dhall.defaultInputSettings + expr <- Dhall.inputExprWithSettings inputSettings text + + Dhall.DirectoryTree.toDirectoryTree allowSeparators outDir $ Dhall.Core.denote expr + + walkFsTree outDir + +data FilesystemEntry + = Directory FilePath + | File FilePath + deriving (Eq, Show) + +walkFsTree :: FilePath -> IO [FilesystemEntry] +walkFsTree dir = do + entries <- Directory.listDirectory dir + (ds, fs) <- fmap partitionEithers $ forM entries $ \path -> do + let path' = dir path + isDirectory <- Directory.doesDirectoryExist path' + return $ if isDirectory then Left path' else Right (File path') + entries' <- traverse walkFsTree ds + return $ Directory dir : fs <> concat entries' diff --git a/dhall/tests/Dhall/Test/Main.hs b/dhall/tests/Dhall/Test/Main.hs index 12f3c40f9..892d7849e 100644 --- a/dhall/tests/Dhall/Test/Main.hs +++ b/dhall/tests/Dhall/Test/Main.hs @@ -5,6 +5,7 @@ import Test.Tasty (TestTree) import qualified Dhall.Test.Dhall import qualified Dhall.Test.Diff +import qualified Dhall.Test.DirectoryTree import qualified Dhall.Test.Format import qualified Dhall.Test.Freeze import qualified Dhall.Test.Import @@ -62,6 +63,7 @@ getAllTests = do , tagsTests , freezeTests , schemaTests + , Dhall.Test.DirectoryTree.tests , Dhall.Test.Regression.tests , Dhall.Test.Tutorial.tests , Dhall.Test.QuickCheck.tests diff --git a/dhall/tests/to-directory-tree/fixpoint-empty.dhall b/dhall/tests/to-directory-tree/fixpoint-empty.dhall new file mode 100644 index 000000000..2b8b5ef8f --- /dev/null +++ b/dhall/tests/to-directory-tree/fixpoint-empty.dhall @@ -0,0 +1,3 @@ +let Make = (./fixpoint-helper.dhall).Make + +in \(r : Type) -> \(make : Make r) -> [] : List r diff --git a/dhall/tests/to-directory-tree/fixpoint-helper.dhall b/dhall/tests/to-directory-tree/fixpoint-helper.dhall new file mode 100644 index 000000000..8d846cb72 --- /dev/null +++ b/dhall/tests/to-directory-tree/fixpoint-helper.dhall @@ -0,0 +1,26 @@ +let User = < UserId : Natural | UserName : Text > + +let Group = < GroupId : Natural | GroupName : Text > + +let Access = + { execute : Optional Bool, read : Optional Bool, write : Optional Bool } + +let Mode = + { user : Optional Access + , group : Optional Access + , other : Optional Access + } + +let Entry = + \(content : Type) -> + { name : Text + , content : content + , user : Optional User + , group : Optional Group + , mode : Optional Mode + } + +let Make = + \(r : Type) -> { directory : Entry (List r) -> r, file : Entry Text -> r } + +in { User, Group, Access, Mode, Entry, Make } diff --git a/dhall/tests/to-directory-tree/fixpoint-metadata.dhall b/dhall/tests/to-directory-tree/fixpoint-metadata.dhall new file mode 100644 index 000000000..76e7d18cd --- /dev/null +++ b/dhall/tests/to-directory-tree/fixpoint-metadata.dhall @@ -0,0 +1,26 @@ +let User = (./fixpoint-helper.dhall).User + +let Group = (./fixpoint-helper.dhall).Group + +let Access = (./fixpoint-helper.dhall).Access + +let Make = (./fixpoint-helper.dhall).Make + +let no-access = { execute = Some False, read = Some False, write = Some False } + +let full-access = { execute = Some True, read = Some True, write = Some True } + +in \(r : Type) -> + \(make : Make r) -> + [ make.file + { name = "file" + , content = "" + , user = None User + , group = None Group + , mode = Some + { user = Some full-access + , group = Some no-access + , other = Some no-access + } + } + ] diff --git a/dhall/tests/to-directory-tree/fixpoint-simple.dhall b/dhall/tests/to-directory-tree/fixpoint-simple.dhall new file mode 100644 index 000000000..384fe1191 --- /dev/null +++ b/dhall/tests/to-directory-tree/fixpoint-simple.dhall @@ -0,0 +1,25 @@ +let User = (./fixpoint-helper.dhall).User + +let Group = (./fixpoint-helper.dhall).Group + +let Mode = (./fixpoint-helper.dhall).Mode + +let Make = (./fixpoint-helper.dhall).Make + +in \(r : Type) -> + \(make : Make r) -> + [ make.file + { name = "file" + , content = "" + , user = None User + , group = None Group + , mode = None Mode + } + , make.directory + { name = "directory" + , content = [] : List r + , user = None User + , group = None Group + , mode = None Mode + } + ] From f325eb139edc1a49f1e78d42f7b2df488a811d15 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 15 Aug 2022 00:14:32 +0200 Subject: [PATCH 02/12] Run stylish-haskell on dhall package --- dhall/src/Dhall/DirectoryTree.hs | 47 ++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index b5bf2906e..3797bbe05 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | Implementation of the @dhall to-directory-tree@ subcommand module Dhall.DirectoryTree @@ -16,17 +16,24 @@ module Dhall.DirectoryTree , FilesystemError(..) ) where -import Control.Applicative (empty) -import Control.Exception (Exception) -import Control.Monad (when, unless) -import Data.Either (isRight) -import Data.Maybe (fromMaybe) -import Data.Functor.Identity (Identity(..)) -import Data.Sequence (Seq) -import Data.Text (Text) -import Data.Void (Void) -import Dhall.Syntax (Chunks (..), Expr (..), FieldSelection(..), FunctionBinding(..), RecordField(..), Var(..)) -import System.FilePath (()) +import Control.Applicative (empty) +import Control.Exception (Exception) +import Control.Monad (unless, when) +import Data.Either (isRight) +import Data.Functor.Identity (Identity (..)) +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Syntax + ( Chunks (..) + , Expr (..) + , FieldSelection (..) + , FunctionBinding (..) + , RecordField (..) + , Var (..) + ) +import System.FilePath (()) import System.PosixCompat.Types (FileMode, GroupID, UserID) import qualified Control.Exception as Exception From 5d694d2b102a1e6f1253d35deba57bae77d59ab9 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 15 Aug 2022 15:48:58 +0200 Subject: [PATCH 03/12] Added some Haddocks Also fixed a minor bug in `Dhall.DirectoryTree.hasMode`. --- dhall/src/Dhall/DirectoryTree.hs | 60 +++++++++++++++++++++++++------- 1 file changed, 48 insertions(+), 12 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 3797bbe05..66b75ae2c 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -190,7 +190,8 @@ toDirectoryTree allowSeparators path expression = case expression of Lam _ _ (Lam _ (functionBindingVariable -> make) body) | isFixpointedDirectoryTree expression - -> applyFilesystemEntryList allowSeparators path $ extractFilesystemEntryList make body + -> processFilesystemEntryList allowSeparators path $ + extractFilesystemEntryList make body _ -> die @@ -217,6 +218,7 @@ toDirectoryTree allowSeparators path expression = case expression of where unexpectedExpression = expression +-- | Check if an expression is a valid fixpoint directory-tree. isFixpointedDirectoryTree :: Expr Void Void -> Bool isFixpointedDirectoryTree expr = isRight $ TypeCheck.typeOf $ Annot expr $ [TH.dhall| @@ -254,11 +256,13 @@ isFixpointedDirectoryTree expr = isRight $ TypeCheck.typeOf $ Annot expr $ List r |] +-- | A filesystem entry. data FilesystemEntry = DirectoryEntry (Entry (Seq FilesystemEntry)) | FileEntry (Entry Text) deriving Show +-- | Extract a `FilesystemEntry` from an expression. extractFilesystemEntry :: Text -> Expr Void Void -> FilesystemEntry extractFilesystemEntry make (App (Field (Var (V make' 0)) (fieldSelectionLabel -> label)) entry) | make' == make @@ -267,9 +271,11 @@ extractFilesystemEntry make (App (Field (Var (V make' 0)) (fieldSelectionLabel - , label == "file" = FileEntry $ extractEntry extractText entry extractFilesystemEntry _ expr = Exception.throw (FilesystemError expr) +-- | Extract a list of `FilesystemEntry`s from an expression. extractFilesystemEntryList :: Text -> Expr Void Void -> Seq FilesystemEntry extractFilesystemEntryList make = extractList (extractFilesystemEntry make) +-- | A generic filesystem entry parameterized over the content. data Entry a = Entry { entryName :: String , entryContent :: a @@ -279,6 +285,7 @@ data Entry a = Entry } deriving Show +-- | Extract an `Entry` from an expression. extractEntry :: (Expr Void Void -> a) -> Expr Void Void -> Entry a extractEntry extractContent (RecordLit (Map.toList -> [ ("content", recordFieldValue -> contentExpr) @@ -295,6 +302,7 @@ extractEntry extractContent (RecordLit (Map.toList -> } extractEntry _ expr = Exception.throw (FilesystemError expr) +-- | A user identified either by id or name. data User = UserId UserID | UserName String @@ -307,15 +315,18 @@ pattern UserP label v <- App (Field (Union (Map.toList -> (fieldSelectionLabel -> label)) v +-- | Extract a `User` from an expression. extractUser :: Expr Void Void -> User extractUser (UserP "UserId" (NaturalLit n)) = UserId $ Posix.CUid (fromIntegral n) extractUser (UserP "UserName" (TextLit (Chunks [] text))) = UserName $ Text.unpack text extractUser expr = Exception.throw (FilesystemError expr) +-- | Resolve a `User` to a numerical id. getUser :: User -> IO UserID getUser (UserId uid) = return uid getUser (UserName name) = Posix.userID <$> Posix.getUserEntryForName name +-- | A group identified either by id or name. data Group = GroupId GroupID | GroupName String @@ -328,15 +339,20 @@ pattern GroupP label v <- App (Field (Union (Map.toList -> (fieldSelectionLabel -> label)) v +-- | Extract a `Group` from an expression. extractGroup :: Expr Void Void -> Group extractGroup (GroupP "GroupId" (NaturalLit n)) = GroupId $ Posix.CGid (fromIntegral n) extractGroup (GroupP "GroupName" (TextLit (Chunks [] text))) = GroupName $ Text.unpack text extractGroup expr = Exception.throw (FilesystemError expr) +-- | Resolve a `Group` to a numerical id. getGroup :: Group -> IO GroupID getGroup (GroupId gid) = return gid getGroup (GroupName name) = Posix.groupID <$> Posix.getGroupEntryForName name +-- | A filesystem mode. See chmod(1). +-- The parameter is meant to be instantiated by either `Identity` or `Maybe` +-- depending on the completeness of the information. data Mode f = Mode { modeUser :: f (Access f) , modeGroup :: f (Access f) @@ -348,6 +364,7 @@ deriving instance Eq (Mode Maybe) deriving instance Show (Mode Identity) deriving instance Show (Mode Maybe) +-- | Extract a `Mode` from an expression. extractMode :: Expr Void Void -> Mode Maybe extractMode (RecordLit (Map.toList -> [ ("group", recordFieldValue -> groupExpr) @@ -360,6 +377,7 @@ extractMode (RecordLit (Map.toList -> } extractMode expr = Exception.throw (FilesystemError expr) +-- | The permissions for a subject (user/group/other). data Access f = Access { accessExecute :: f Bool , accessRead :: f Bool @@ -371,6 +389,7 @@ deriving instance Eq (Access Maybe) deriving instance Show (Access Identity) deriving instance Show (Access Maybe) +-- | Extract a `Access` from an expression. extractAccess :: Expr Void Void -> Access Maybe extractAccess (RecordLit (Map.toList -> [ ("execute", recordFieldValue -> executeExpr) @@ -383,49 +402,61 @@ extractAccess (RecordLit (Map.toList -> } extractAccess expr = Exception.throw (FilesystemError expr) +-- | Helper function to extract a `Bool` value. extractBool :: Expr Void Void -> Bool extractBool (BoolLit b) = b extractBool expr = Exception.throw (FilesystemError expr) +-- | Helper function to extract a list of some values. +-- The first argument is used to extract the items. extractList :: (Expr Void Void -> a) -> Expr Void Void -> Seq a extractList _ (ListLit (Just _) _) = mempty extractList f (ListLit _ xs) = fmap f xs extractList _ expr = Exception.throw (FilesystemError expr) +-- | Helper function to extract optional values. +-- The first argument is used to extract the items. extractMaybe :: (Expr Void Void -> a) -> Expr Void Void -> Maybe a extractMaybe _ (App None _) = Nothing extractMaybe f (Some expr) = Just (f expr) extractMaybe _ expr = Exception.throw (FilesystemError expr) +-- | Helper function to extract a `String` value. extractString :: Expr Void Void -> String extractString = Text.unpack . extractText +-- | Helper function to extract a `Text` value. extractText :: Expr Void Void -> Text extractText (TextLit (Chunks [] text)) = text extractText expr = Exception.throw (FilesystemError expr) -applyFilesystemEntry :: Bool -> FilePath -> FilesystemEntry -> IO () -applyFilesystemEntry allowSeparators path (DirectoryEntry entry) = do +-- | Process a `FilesystemEntry`. Writes the content to disk and apply the +-- metadata to the newly created item. +processFilesystemEntry :: Bool -> FilePath -> FilesystemEntry -> IO () +processFilesystemEntry allowSeparators path (DirectoryEntry entry) = do let path' = path entryName entry Directory.createDirectoryIfMissing allowSeparators path' - applyFilesystemEntryList allowSeparators path' $ entryContent entry + processFilesystemEntryList allowSeparators path' $ entryContent entry -- It is important that we write the metadata after we wrote the content of -- the directories/files below this directory as we might lock ourself out -- by changing ownership or permissions. - unsafeApplyMetadata entry path' -applyFilesystemEntry _ path (FileEntry entry) = do + applyMetadata entry path' +processFilesystemEntry _ path (FileEntry entry) = do let path' = path entryName entry Text.IO.writeFile path' $ entryContent entry -- It is important that we write the metadata after we wrote the content of -- the file as we might lock ourself out by changing ownership or -- permissions. - unsafeApplyMetadata entry path' + applyMetadata entry path' -applyFilesystemEntryList :: Bool -> FilePath -> Seq FilesystemEntry -> IO () -applyFilesystemEntryList allowSeparators path = Foldable.traverse_ (applyFilesystemEntry allowSeparators path) +-- | Process a list of `FilesystemEntry`s. +processFilesystemEntryList :: Bool -> FilePath -> Seq FilesystemEntry -> IO () +processFilesystemEntryList allowSeparators path = Foldable.traverse_ + (processFilesystemEntry allowSeparators path) -unsafeApplyMetadata :: Entry a -> FilePath -> IO () -unsafeApplyMetadata entry fp = do +-- | Set the metadata of an object referenced by a path. +applyMetadata :: Entry a -> FilePath -> IO () +applyMetadata entry fp = do s <- Posix.getFileStatus fp let user = Posix.fileOwner s group = Posix.fileGroup s @@ -440,6 +471,7 @@ unsafeApplyMetadata entry fp = do unless (mode' == mode) $ Posix.setFileMode fp $ modeToFileMode mode' +-- | Calculate the new `Mode` from the current mode and the changes specified by the user. updateModeWith :: Mode Identity -> Mode Maybe -> Mode Identity updateModeWith x y = Mode { modeUser = combine modeUser modeUser @@ -449,6 +481,7 @@ updateModeWith x y = Mode where combine f g = maybe (f x) (Identity . updateAccessWith (runIdentity $ f x)) (g y) +-- | Calculate the new `Access` from the current permissions and the changes specified by the user. updateAccessWith :: Access Identity -> Access Maybe -> Access Identity updateAccessWith x y = Access { accessExecute = combine accessExecute accessExecute @@ -458,6 +491,7 @@ updateAccessWith x y = Access where combine f g = maybe (f x) Identity (g y) +-- | Convert a filesystem mode given as a bitmask (`FileMode`) to an ADT (`Mode`). fileModeToMode :: FileMode -> Mode Identity fileModeToMode mode = Mode { modeUser = Identity $ Access @@ -477,6 +511,7 @@ fileModeToMode mode = Mode } } +-- | Convert a filesystem mode given as an ADT (`Mode`) to a bitmask (`FileMode`). modeToFileMode :: Mode Identity -> FileMode modeToFileMode mode = foldr Posix.unionFileModes Posix.nullFileMode $ [ Posix.ownerExecuteMode | runIdentity $ accessExecute (runIdentity $ modeUser mode) ] <> @@ -489,8 +524,9 @@ modeToFileMode mode = foldr Posix.unionFileModes Posix.nullFileMode $ [ Posix.otherReadMode | runIdentity $ accessRead (runIdentity $ modeOther mode) ] <> [ Posix.otherWriteMode | runIdentity $ accessWrite (runIdentity $ modeOther mode) ] +-- | Check whether the second `FileMode` is contained in the first one. hasFileMode :: FileMode -> FileMode -> Bool -hasFileMode mode x = (mode `Posix.intersectFileModes` x) == Posix.nullFileMode +hasFileMode mode x = (mode `Posix.intersectFileModes` x) == x {- | This error indicates that you supplied an invalid Dhall expression to the `toDirectoryTree` function. The Dhall expression could not be translated From 943b1ab0025b61d65de50d46daab8e6cd84db90b Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 15 Aug 2022 17:57:42 +0200 Subject: [PATCH 04/12] Fixed haddocks --- dhall/src/Dhall/DirectoryTree.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 66b75ae2c..91688a1e6 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -110,7 +110,7 @@ import qualified System.PosixCompat.User as Posix /Advanced construction of directory trees/ - In addition to the ways described above using 'simple' Dhall values to + In addition to the ways described above using "simple" Dhall values to construct the directory tree there is one based on a fixpoint encoding. It works by passing a value of the following type to the interpreter: @@ -275,7 +275,8 @@ extractFilesystemEntry _ expr = Exception.throw (FilesystemError expr) extractFilesystemEntryList :: Text -> Expr Void Void -> Seq FilesystemEntry extractFilesystemEntryList make = extractList (extractFilesystemEntry make) --- | A generic filesystem entry parameterized over the content. +-- | A generic filesystem entry. This type holds the metadata that apply to all entries. +-- It is parametric over the content of such an entry. data Entry a = Entry { entryName :: String , entryContent :: a @@ -352,7 +353,10 @@ getGroup (GroupName name) = Posix.groupID <$> Posix.getGroupEntryForName name -- | A filesystem mode. See chmod(1). -- The parameter is meant to be instantiated by either `Identity` or `Maybe` --- depending on the completeness of the information. +-- depending on the completeness of the information: +-- * For data read from the filesystem it will be `Identity`. +-- * For user-supplied data it will be `Maybe` as we want to be able to set +-- only specific bits. data Mode f = Mode { modeUser :: f (Access f) , modeGroup :: f (Access f) @@ -402,7 +406,7 @@ extractAccess (RecordLit (Map.toList -> } extractAccess expr = Exception.throw (FilesystemError expr) --- | Helper function to extract a `Bool` value. +-- | Helper function to extract a `Prelude.Bool` value. extractBool :: Expr Void Void -> Bool extractBool (BoolLit b) = b extractBool expr = Exception.throw (FilesystemError expr) @@ -421,11 +425,11 @@ extractMaybe _ (App None _) = Nothing extractMaybe f (Some expr) = Just (f expr) extractMaybe _ expr = Exception.throw (FilesystemError expr) --- | Helper function to extract a `String` value. +-- | Helper function to extract a `Prelude.String` value. extractString :: Expr Void Void -> String extractString = Text.unpack . extractText --- | Helper function to extract a `Text` value. +-- | Helper function to extract a `Text.Text` value. extractText :: Expr Void Void -> Text extractText (TextLit (Chunks [] text)) = text extractText expr = Exception.throw (FilesystemError expr) From 2088fdde024914997a5f2d810f6ceeb4385f8959 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 15 Aug 2022 21:20:38 +0200 Subject: [PATCH 05/12] Use the common Dhall decoding facilities in Dhall.DirectoryTree Also added FromDhall instance for Identity. --- dhall/src/Dhall/DirectoryTree.hs | 255 +++++++++++++----------------- dhall/src/Dhall/Marshal/Decode.hs | 4 + 2 files changed, 111 insertions(+), 148 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 91688a1e6..255cde11c 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -1,14 +1,18 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + -- | Implementation of the @dhall to-directory-tree@ subcommand module Dhall.DirectoryTree ( -- * Filesystem @@ -19,14 +23,24 @@ module Dhall.DirectoryTree import Control.Applicative (empty) import Control.Exception (Exception) import Control.Monad (unless, when) -import Data.Either (isRight) +import Data.Either.Validation (Validation (..)) import Data.Functor.Identity (Identity (..)) import Data.Maybe (fromMaybe) import Data.Sequence (Seq) import Data.Text (Text) import Data.Void (Void) +import Dhall.Marshal.Decode + ( Decoder (..) + , Expector + , FromDhall (..) + , Generic + , InputNormalizer + , InterpretOptions (..) + ) +import Dhall.Src (Src) import Dhall.Syntax ( Chunks (..) + , Const (..) , Expr (..) , FieldSelection (..) , FunctionBinding (..) @@ -40,9 +54,10 @@ import qualified Control.Exception as Exception import qualified Data.Foldable as Foldable import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO +import qualified Dhall.Core as Core import qualified Dhall.Map as Map +import qualified Dhall.Marshal.Decode as Decode import qualified Dhall.Pretty -import qualified Dhall.TH as TH import qualified Dhall.TypeCheck as TypeCheck import qualified Dhall.Util as Util import qualified Prettyprinter.Render.String as Pretty @@ -188,10 +203,34 @@ toDirectoryTree allowSeparators path expression = case expression of App None _ -> return () - Lam _ _ (Lam _ (functionBindingVariable -> make) body) - | isFixpointedDirectoryTree expression - -> processFilesystemEntryList allowSeparators path $ - extractFilesystemEntryList make body + -- If this pattern matches we assume the user wants to use the fixpoint + -- approach, hence we typecheck it and output error messages like we would + -- do for every other Dhall program. + Lam _ (functionBindingVariable -> r) (Lam _ (functionBindingVariable -> make) body) -> do + let body' = Core.renote body + let expression' = Core.renote expression + + expected' <- case directoryTreeType of + Success x -> return x + Failure e -> Exception.throwIO e + + _ <- Core.throws $ TypeCheck.typeOf $ Annot expression' expected' + + let expr = rename r "result" $ rename make "make" body' + + entries <- case Decode.extract decoder expr of + Success x -> return x + Failure e -> Exception.throwIO e + + processFilesystemEntryList allowSeparators path entries + where + decoder :: Decoder (Seq FilesystemEntry) + decoder = Decode.auto + + rename :: Text -> Text -> Expr s a -> Expr s a + rename a b expr + | a /= b = Core.subst (V a 0) (Var (V b 0)) (Core.shift 1 (V b 0) expr) + | otherwise = expr _ -> die @@ -218,43 +257,23 @@ toDirectoryTree allowSeparators path expression = case expression of where unexpectedExpression = expression --- | Check if an expression is a valid fixpoint directory-tree. -isFixpointedDirectoryTree :: Expr Void Void -> Bool -isFixpointedDirectoryTree expr = isRight $ TypeCheck.typeOf $ Annot expr $ - [TH.dhall| - let User = < UserId : Natural | UserName : Text > - - let Group = < GroupId : Natural | GroupName : Text > - - let Access = - { execute : Optional Bool - , read : Optional Bool - , write : Optional Bool - } - - let Mode = - { user : Optional Access - , group : Optional Access - , other : Optional Access - } - - let Entry = - \(content : Type) -> - { name : Text - , content : content - , user : Optional User - , group : Optional Group - , mode : Optional Mode - } - - in forall (r : Type) -> - forall ( make - : { directory : Entry (List r) -> r - , file : Entry Text -> r - } - ) -> - List r - |] +directoryTreeType :: Expector (Expr Src Void) +directoryTreeType = Pi Nothing "result" (Const Type) + <$> (Pi Nothing "make" <$> makeType <*> pure (App List (Var (V "result" 0)))) + +makeType :: Expector (Expr Src Void) +makeType = Record . Map.fromList <$> sequenceA + [ makeConstructor "directory" (Decode.auto :: Decoder DirectoryEntry) + , makeConstructor "file" (Decode.auto :: Decoder FileEntry) + ] + where + makeConstructor :: Text -> Decoder b -> Expector (Text, RecordField Src Void) + makeConstructor name dec = (name,) . Core.makeRecordField + <$> (Pi Nothing "_" <$> expected dec <*> pure (Var (V "result" 0))) + +type DirectoryEntry = Entry (Seq FilesystemEntry) + +type FileEntry = Entry Text -- | A filesystem entry. data FilesystemEntry @@ -262,18 +281,16 @@ data FilesystemEntry | FileEntry (Entry Text) deriving Show --- | Extract a `FilesystemEntry` from an expression. -extractFilesystemEntry :: Text -> Expr Void Void -> FilesystemEntry -extractFilesystemEntry make (App (Field (Var (V make' 0)) (fieldSelectionLabel -> label)) entry) - | make' == make - , label == "directory" = DirectoryEntry $ extractEntry (extractList (extractFilesystemEntry make)) entry - | make' == make - , label == "file" = FileEntry $ extractEntry extractText entry -extractFilesystemEntry _ expr = Exception.throw (FilesystemError expr) - --- | Extract a list of `FilesystemEntry`s from an expression. -extractFilesystemEntryList :: Text -> Expr Void Void -> Seq FilesystemEntry -extractFilesystemEntryList make = extractList (extractFilesystemEntry make) +instance FromDhall FilesystemEntry where + autoWith normalizer = Decoder + { expected = pure $ Var (V "result" 0) + , extract = \case + App (Field (Var (V "make" 0)) (fieldSelectionLabel -> "directory")) entry -> + DirectoryEntry <$> extract (autoWith normalizer) entry + App (Field (Var (V "make" 0)) (fieldSelectionLabel -> "file")) entry -> + FileEntry <$> extract (autoWith normalizer) entry + expr -> Decode.typeError (expected (Decode.autoWith normalizer :: Decoder FilesystemEntry)) expr + } -- | A generic filesystem entry. This type holds the metadata that apply to all entries. -- It is parametric over the content of such an entry. @@ -284,43 +301,23 @@ data Entry a = Entry , entryGroup :: Maybe Group , entryMode :: Maybe (Mode Maybe) } - deriving Show + deriving (Generic, Show) --- | Extract an `Entry` from an expression. -extractEntry :: (Expr Void Void -> a) -> Expr Void Void -> Entry a -extractEntry extractContent (RecordLit (Map.toList -> - [ ("content", recordFieldValue -> contentExpr) - , ("group", recordFieldValue -> groupExpr) - , ("mode", recordFieldValue -> modeExpr) - , ("name", recordFieldValue -> nameExpr) - , ("user", recordFieldValue -> userExpr) - ])) = Entry - { entryName = extractString nameExpr - , entryContent = extractContent contentExpr - , entryUser = extractMaybe extractUser userExpr - , entryGroup = extractMaybe extractGroup groupExpr - , entryMode = extractMaybe extractMode modeExpr - } -extractEntry _ expr = Exception.throw (FilesystemError expr) +instance FromDhall a => FromDhall (Entry a) where + autoWith = Decode.genericAutoWithInputNormalizer Decode.defaultInterpretOptions + { fieldModifier = Text.toLower . Text.drop (Text.length "entry") + } -- | A user identified either by id or name. data User = UserId UserID | UserName String - deriving Show + deriving (Generic, Show) -pattern UserP :: Text -> Expr Void Void -> Expr Void Void -pattern UserP label v <- App (Field (Union (Map.toList -> - [ ("UserId", Just Natural) - , ("UserName",Just Text)])) - (fieldSelectionLabel -> label)) - v +instance FromDhall User --- | Extract a `User` from an expression. -extractUser :: Expr Void Void -> User -extractUser (UserP "UserId" (NaturalLit n)) = UserId $ Posix.CUid (fromIntegral n) -extractUser (UserP "UserName" (TextLit (Chunks [] text))) = UserName $ Text.unpack text -extractUser expr = Exception.throw (FilesystemError expr) +instance FromDhall Posix.CUid where + autoWith normalizer = Posix.CUid <$> autoWith normalizer -- | Resolve a `User` to a numerical id. getUser :: User -> IO UserID @@ -331,20 +328,12 @@ getUser (UserName name) = Posix.userID <$> Posix.getUserEntryForName name data Group = GroupId GroupID | GroupName String - deriving Show + deriving (Generic, Show) -pattern GroupP :: Text -> Expr Void Void -> Expr Void Void -pattern GroupP label v <- App (Field (Union (Map.toList -> - [ ("GroupId", Just Natural) - , ("GroupName", Just Text)])) - (fieldSelectionLabel -> label)) - v +instance FromDhall Group --- | Extract a `Group` from an expression. -extractGroup :: Expr Void Void -> Group -extractGroup (GroupP "GroupId" (NaturalLit n)) = GroupId $ Posix.CGid (fromIntegral n) -extractGroup (GroupP "GroupName" (TextLit (Chunks [] text))) = GroupName $ Text.unpack text -extractGroup expr = Exception.throw (FilesystemError expr) +instance FromDhall Posix.CGid where + autoWith normalizer = Posix.CGid <$> autoWith normalizer -- | Resolve a `Group` to a numerical id. getGroup :: Group -> IO GroupID @@ -362,24 +351,23 @@ data Mode f = Mode , modeGroup :: f (Access f) , modeOther :: f (Access f) } + deriving Generic deriving instance Eq (Mode Identity) deriving instance Eq (Mode Maybe) deriving instance Show (Mode Identity) deriving instance Show (Mode Maybe) --- | Extract a `Mode` from an expression. -extractMode :: Expr Void Void -> Mode Maybe -extractMode (RecordLit (Map.toList -> - [ ("group", recordFieldValue -> groupExpr) - , ("other", recordFieldValue -> otherExpr) - , ("user", recordFieldValue -> userExpr) - ])) = Mode - { modeUser = extractMaybe extractAccess userExpr - , modeGroup = extractMaybe extractAccess groupExpr - , modeOther = extractMaybe extractAccess otherExpr +instance FromDhall (Mode Identity) where + autoWith = modeDecoder + +instance FromDhall (Mode Maybe) where + autoWith = modeDecoder + +modeDecoder :: FromDhall (f (Access f)) => InputNormalizer -> Decoder (Mode f) +modeDecoder = Decode.genericAutoWithInputNormalizer Decode.defaultInterpretOptions + { fieldModifier = Text.toLower . Text.drop (Text.length "mode") } -extractMode expr = Exception.throw (FilesystemError expr) -- | The permissions for a subject (user/group/other). data Access f = Access @@ -387,52 +375,23 @@ data Access f = Access , accessRead :: f Bool , accessWrite :: f Bool } + deriving Generic deriving instance Eq (Access Identity) deriving instance Eq (Access Maybe) deriving instance Show (Access Identity) deriving instance Show (Access Maybe) --- | Extract a `Access` from an expression. -extractAccess :: Expr Void Void -> Access Maybe -extractAccess (RecordLit (Map.toList -> - [ ("execute", recordFieldValue -> executeExpr) - , ("read", recordFieldValue -> readExpr) - , ("write", recordFieldValue -> writeExpr) - ])) = Access - { accessExecute = extractMaybe extractBool executeExpr - , accessRead = extractMaybe extractBool readExpr - , accessWrite = extractMaybe extractBool writeExpr +instance FromDhall (Access Identity) where + autoWith = accessDecoder + +instance FromDhall (Access Maybe) where + autoWith = accessDecoder + +accessDecoder :: FromDhall (f Bool) => InputNormalizer -> Decoder (Access f) +accessDecoder = Decode.genericAutoWithInputNormalizer Decode.defaultInterpretOptions + { fieldModifier = Text.toLower . Text.drop (Text.length "access") } -extractAccess expr = Exception.throw (FilesystemError expr) - --- | Helper function to extract a `Prelude.Bool` value. -extractBool :: Expr Void Void -> Bool -extractBool (BoolLit b) = b -extractBool expr = Exception.throw (FilesystemError expr) - --- | Helper function to extract a list of some values. --- The first argument is used to extract the items. -extractList :: (Expr Void Void -> a) -> Expr Void Void -> Seq a -extractList _ (ListLit (Just _) _) = mempty -extractList f (ListLit _ xs) = fmap f xs -extractList _ expr = Exception.throw (FilesystemError expr) - --- | Helper function to extract optional values. --- The first argument is used to extract the items. -extractMaybe :: (Expr Void Void -> a) -> Expr Void Void -> Maybe a -extractMaybe _ (App None _) = Nothing -extractMaybe f (Some expr) = Just (f expr) -extractMaybe _ expr = Exception.throw (FilesystemError expr) - --- | Helper function to extract a `Prelude.String` value. -extractString :: Expr Void Void -> String -extractString = Text.unpack . extractText - --- | Helper function to extract a `Text.Text` value. -extractText :: Expr Void Void -> Text -extractText (TextLit (Chunks [] text)) = text -extractText expr = Exception.throw (FilesystemError expr) -- | Process a `FilesystemEntry`. Writes the content to disk and apply the -- metadata to the newly created item. diff --git a/dhall/src/Dhall/Marshal/Decode.hs b/dhall/src/Dhall/Marshal/Decode.hs index 6c4f0cddc..246733f5d 100644 --- a/dhall/src/Dhall/Marshal/Decode.hs +++ b/dhall/src/Dhall/Marshal/Decode.hs @@ -146,6 +146,7 @@ import Data.Functor.Contravariant , Op (..) , Predicate (..) ) +import Data.Functor.Identity (Identity (..)) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty (..)) import Data.Typeable (Proxy (..), Typeable) @@ -314,6 +315,9 @@ instance FromDhall Data.Text.Lazy.Text where instance FromDhall Text where autoWith _ = strictText +instance FromDhall a => FromDhall (Identity a) where + autoWith opts = Identity <$> autoWith opts + instance FromDhall a => FromDhall (Maybe a) where autoWith opts = maybe (autoWith opts) From bda136e3e49f70d255e2e857ec25b1eed9989d43 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 15 Aug 2022 21:47:20 +0200 Subject: [PATCH 06/12] Added test for type of fixpoint directory tree expressions Also updated Haddocks of Dhall.DirectoryTree. --- dhall/src/Dhall/DirectoryTree.hs | 22 +++++++++++++++------- dhall/tests/Dhall/Test/DirectoryTree.hs | 14 +++++++++++++- 2 files changed, 28 insertions(+), 8 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 255cde11c..8429d83e3 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -18,6 +17,9 @@ module Dhall.DirectoryTree ( -- * Filesystem toDirectoryTree , FilesystemError(..) + + -- * Exported for testing only + , directoryTreeType ) where import Control.Applicative (empty) @@ -257,10 +259,12 @@ toDirectoryTree allowSeparators path expression = case expression of where unexpectedExpression = expression +-- | The type of a fixpoint directory tree expression. directoryTreeType :: Expector (Expr Src Void) directoryTreeType = Pi Nothing "result" (Const Type) <$> (Pi Nothing "make" <$> makeType <*> pure (App List (Var (V "result" 0)))) +-- | The type of make part of a fixpoint directory tree expression. makeType :: Expector (Expr Src Void) makeType = Record . Map.fromList <$> sequenceA [ makeConstructor "directory" (Decode.auto :: Decoder DirectoryEntry) @@ -292,8 +296,8 @@ instance FromDhall FilesystemEntry where expr -> Decode.typeError (expected (Decode.autoWith normalizer :: Decoder FilesystemEntry)) expr } --- | A generic filesystem entry. This type holds the metadata that apply to all entries. --- It is parametric over the content of such an entry. +-- | A generic filesystem entry. This type holds the metadata that apply to all +-- entries. It is parametric over the content of such an entry. data Entry a = Entry { entryName :: String , entryContent :: a @@ -434,7 +438,8 @@ applyMetadata entry fp = do unless (mode' == mode) $ Posix.setFileMode fp $ modeToFileMode mode' --- | Calculate the new `Mode` from the current mode and the changes specified by the user. +-- | Calculate the new `Mode` from the current mode and the changes specified by +-- the user. updateModeWith :: Mode Identity -> Mode Maybe -> Mode Identity updateModeWith x y = Mode { modeUser = combine modeUser modeUser @@ -444,7 +449,8 @@ updateModeWith x y = Mode where combine f g = maybe (f x) (Identity . updateAccessWith (runIdentity $ f x)) (g y) --- | Calculate the new `Access` from the current permissions and the changes specified by the user. +-- | Calculate the new `Access` from the current permissions and the changes +-- specified by the user. updateAccessWith :: Access Identity -> Access Maybe -> Access Identity updateAccessWith x y = Access { accessExecute = combine accessExecute accessExecute @@ -454,7 +460,8 @@ updateAccessWith x y = Access where combine f g = maybe (f x) Identity (g y) --- | Convert a filesystem mode given as a bitmask (`FileMode`) to an ADT (`Mode`). +-- | Convert a filesystem mode given as a bitmask (`FileMode`) to an ADT +-- (`Mode`). fileModeToMode :: FileMode -> Mode Identity fileModeToMode mode = Mode { modeUser = Identity $ Access @@ -474,7 +481,8 @@ fileModeToMode mode = Mode } } --- | Convert a filesystem mode given as an ADT (`Mode`) to a bitmask (`FileMode`). +-- | Convert a filesystem mode given as an ADT (`Mode`) to a bitmask +-- (`FileMode`). modeToFileMode :: Mode Identity -> FileMode modeToFileMode mode = foldr Posix.unionFileModes Posix.nullFileMode $ [ Posix.ownerExecuteMode | runIdentity $ accessExecute (runIdentity $ modeUser mode) ] <> diff --git a/dhall/tests/Dhall/Test/DirectoryTree.hs b/dhall/tests/Dhall/Test/DirectoryTree.hs index c8c842a0a..e3fc02ce8 100644 --- a/dhall/tests/Dhall/Test/DirectoryTree.hs +++ b/dhall/tests/Dhall/Test/DirectoryTree.hs @@ -2,6 +2,7 @@ module Dhall.Test.DirectoryTree (tests) where import Control.Monad import Data.Either (partitionEithers) +import Data.Either.Validation import Lens.Family (set) import System.FilePath (()) import Test.Tasty @@ -18,12 +19,23 @@ import qualified System.PosixCompat.Files as Files tests :: TestTree tests = testGroup "to-directory-tree" [ testGroup "fixpointed" - [ fixpointedEmpty + [ fixpointedType + , fixpointedEmpty , fixpointedSimple , fixpointedMetadata ] ] +fixpointedType :: TestTree +fixpointedType = testCase "Type is as expected" $ do + let file = "./tests/to-directory-tree/type.dhall" + text <- Data.Text.IO.readFile file + ref <- Dhall.inputExpr text + expected' <- case Dhall.DirectoryTree.directoryTreeType of + Failure e -> assertFailure $ show e + Success expr -> return expr + assertBool "Type mismatch" $ expected' `Dhall.Core.judgmentallyEqual` ref + fixpointedEmpty :: TestTree fixpointedEmpty = testCase "empty" $ do let outDir = "./tests/to-directory-tree/fixpoint-empty.out" From 39ed619621e1cf65a6577a120f679c1e3187fcaf Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Mon, 15 Aug 2022 22:46:59 +0200 Subject: [PATCH 07/12] Added missing test data --- dhall/tests/to-directory-tree/type.dhall | 31 ++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 dhall/tests/to-directory-tree/type.dhall diff --git a/dhall/tests/to-directory-tree/type.dhall b/dhall/tests/to-directory-tree/type.dhall new file mode 100644 index 000000000..b4b6d14e4 --- /dev/null +++ b/dhall/tests/to-directory-tree/type.dhall @@ -0,0 +1,31 @@ +let User = < UserId : Natural | UserName : Text > + +let Group = < GroupId : Natural | GroupName : Text > + +let Access = + { execute : Optional Bool, read : Optional Bool, write : Optional Bool } + +let Mode = + { user : Optional Access + , group : Optional Access + , other : Optional Access + } + +let Entry = + \(content : Type) -> + { name : Text + , content : content + , user : Optional User + , group : Optional Group + , mode : Optional Mode + } + +in forall (result : Type) -> + let DirectoryEntry = Entry (List result) + + let FileEntry = Entry Text + + let Make = + { directory : DirectoryEntry -> result, file : FileEntry -> result } + + in forall (make : Make) -> List result From f174211693794fcd9c076e230511393abc4d8e0f Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 7 Sep 2022 08:31:27 +0200 Subject: [PATCH 08/12] Applied suggestion Co-authored-by: Gabriella Gonzalez --- dhall/src/Dhall/DirectoryTree.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 8429d83e3..e87dfa87c 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -79,7 +79,7 @@ import qualified System.PosixCompat.User as Posix * @Optional@ values are omitted if @None@ - * There is a more advanced way construction directory trees using a fixpoint + * There is a more advanced way to construct directory trees using a fixpoint encoding. See the documentation below on that. For example, the following Dhall record: From ac1f61104e7c9a0c11cc891f2aec341d01c68e43 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 7 Sep 2022 08:31:53 +0200 Subject: [PATCH 09/12] Applied suggestion Co-authored-by: Gabriella Gonzalez --- dhall/src/Dhall/DirectoryTree.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index e87dfa87c..dc57885d6 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -156,13 +156,13 @@ import qualified System.PosixCompat.User as Posix > , mode : Optional Mode > } > - > in forall (r : Type) -> + > in forall (tree : Type) -> > forall ( make - > : { directory : Entry (List r) -> r - > , file : Entry Text -> r + > : { directory : Entry (List tree) -> tree + > , file : Entry Text -> tree > } > ) -> - > List r + > List tree The fact that the metadata for filesystem entries is modeled after the POSIX permission model comes with the unfortunate downside that it might not apply From cbb0e9385c35069371156e9f83492ea36bd28c56 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 7 Sep 2022 11:10:08 +0200 Subject: [PATCH 10/12] Alpha-normalize expressions in toDirectoryTree --- dhall/src/Dhall/DirectoryTree.hs | 36 +++++++++++++++----------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index dc57885d6..28cea20b3 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -45,7 +46,6 @@ import Dhall.Syntax , Const (..) , Expr (..) , FieldSelection (..) - , FunctionBinding (..) , RecordField (..) , Var (..) ) @@ -173,15 +173,16 @@ import qualified System.PosixCompat.User as Posix internally. __NOTE__: This utility does not take care of type-checking and normalizing - the provided expression. This will raise a `FilesystemError` exception upon - encountering an expression that cannot be converted as-is. + the provided expression. This will raise a `FilesystemError` exception or a + `DhallErrors` exception upon encountering an expression that cannot be + converted as-is. -} toDirectoryTree :: Bool -- ^ Whether to allow path separators in file names or not -> FilePath -> Expr Void Void -> IO () -toDirectoryTree allowSeparators path expression = case expression of +toDirectoryTree allowSeparators path expression = case Core.alphaNormalize expression of RecordLit keyValues -> Map.unorderedTraverseWithKey_ process $ recordFieldValue <$> keyValues @@ -208,7 +209,7 @@ toDirectoryTree allowSeparators path expression = case expression of -- If this pattern matches we assume the user wants to use the fixpoint -- approach, hence we typecheck it and output error messages like we would -- do for every other Dhall program. - Lam _ (functionBindingVariable -> r) (Lam _ (functionBindingVariable -> make) body) -> do + Lam _ _ (Lam _ _ body) -> do let body' = Core.renote body let expression' = Core.renote expression @@ -218,9 +219,7 @@ toDirectoryTree allowSeparators path expression = case expression of _ <- Core.throws $ TypeCheck.typeOf $ Annot expression' expected' - let expr = rename r "result" $ rename make "make" body' - - entries <- case Decode.extract decoder expr of + entries <- case Decode.extract decoder body' of Success x -> return x Failure e -> Exception.throwIO e @@ -229,11 +228,6 @@ toDirectoryTree allowSeparators path expression = case expression of decoder :: Decoder (Seq FilesystemEntry) decoder = Decode.auto - rename :: Text -> Text -> Expr s a -> Expr s a - rename a b expr - | a /= b = Core.subst (V a 0) (Var (V b 0)) (Core.shift 1 (V b 0) expr) - | otherwise = expr - _ -> die where @@ -261,8 +255,8 @@ toDirectoryTree allowSeparators path expression = case expression of -- | The type of a fixpoint directory tree expression. directoryTreeType :: Expector (Expr Src Void) -directoryTreeType = Pi Nothing "result" (Const Type) - <$> (Pi Nothing "make" <$> makeType <*> pure (App List (Var (V "result" 0)))) +directoryTreeType = Pi Nothing "tree" (Const Type) + <$> (Pi Nothing "make" <$> makeType <*> pure (App List (Var (V "tree" 0)))) -- | The type of make part of a fixpoint directory tree expression. makeType :: Expector (Expr Src Void) @@ -273,7 +267,11 @@ makeType = Record . Map.fromList <$> sequenceA where makeConstructor :: Text -> Decoder b -> Expector (Text, RecordField Src Void) makeConstructor name dec = (name,) . Core.makeRecordField - <$> (Pi Nothing "_" <$> expected dec <*> pure (Var (V "result" 0))) + <$> (Pi Nothing "_" <$> expected dec <*> pure (Var (V "tree" 0))) + +-- | Utility pattern synonym to match on filesystem entry constructors +pattern Make :: Text -> Expr s a -> Expr s a +pattern Make label entry <- App (Field (Var (V "_" 0)) (fieldSelectionLabel -> label)) entry type DirectoryEntry = Entry (Seq FilesystemEntry) @@ -287,11 +285,11 @@ data FilesystemEntry instance FromDhall FilesystemEntry where autoWith normalizer = Decoder - { expected = pure $ Var (V "result" 0) + { expected = pure $ Var (V "tree" 0) , extract = \case - App (Field (Var (V "make" 0)) (fieldSelectionLabel -> "directory")) entry -> + Make "directory" entry -> DirectoryEntry <$> extract (autoWith normalizer) entry - App (Field (Var (V "make" 0)) (fieldSelectionLabel -> "file")) entry -> + Make "file" entry -> FileEntry <$> extract (autoWith normalizer) entry expr -> Decode.typeError (expected (Decode.autoWith normalizer :: Decoder FilesystemEntry)) expr } From faf01b0f2d4c700f5e10db605527caa6f9d7c999 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 7 Sep 2022 11:14:32 +0200 Subject: [PATCH 11/12] Added example for fixpointed to-directory-tree command --- dhall/examples/to-directory-tree.dhall | 119 +++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100644 dhall/examples/to-directory-tree.dhall diff --git a/dhall/examples/to-directory-tree.dhall b/dhall/examples/to-directory-tree.dhall new file mode 100644 index 000000000..3aadb4d85 --- /dev/null +++ b/dhall/examples/to-directory-tree.dhall @@ -0,0 +1,119 @@ +-- This is an example on how to build a directory tree using the so-called +-- fixpointed method. See the documenatation of the `Dhall.DirectoryTree` module +-- for further information on it. + +-- First, define some types recognized by the `dhall to-directory-tree` command. + +-- A user, either identified by its numeric user id or its name. +let User = < UserId : Natural | UserName : Text > + +-- Similarly, a group. +let Group = < GroupId : Natural | GroupName : Text > + +-- The following two type aliases are a well-typed represenation of the bitmask +-- for permissions used by the DAC access control found on Unix systems. See for +-- example the chmod(5) manual entry. + +-- How much access we do grant... +let Access = + { execute : Optional Bool, read : Optional Bool, write : Optional Bool } + +-- ... for whom. +let Mode = + { user : Optional Access + , group : Optional Access + , other : Optional Access + } + +-- A generic file system entry. It consists of a name, an abstract content and +-- some metadata which might be set (Some) or not (None). +let Entry = + \(content : Type) -> + { name : Text + , content : content + , user : Optional User + , group : Optional Group + , mode : Optional Mode + } + +-- This is the main program constructing our directory tree. It is a fixpoint +-- definition similar to how we deal with recursive types in arbitrary Dhall +-- programs but specialised to our use case. The first argument is the type of a +-- directory tree and the second one is a record where each field is a +-- constructor for a specific filesystem entry. +in \(tree : Type) -> + \ ( make + : { directory : Entry (List tree) -> tree, file : Entry Text -> tree } + ) -> + + -- Before we define the actual directory tree we define some Dhall schemas + -- and shortcuts for convenience. + + -- A schema suitable for a directory... + let Directory = + { Type = + { name : Text + , content : List tree + , user : Optional User + , group : Optional Group + , mode : Optional Mode + } + , default = + { content = [] : List tree + , user = None User + , group = None Group + , mode = None Mode + } + } + + -- ... and one for a file. + let File = + { Type = + { name : Text + , content : Text + , user : Optional User + , group : Optional Group + , mode : Optional Mode + } + , default = + { content = "" + , user = None User + , group = None Group + , mode = None Mode + } + } + + -- Give someone full access to an filesystem entry. + let full_access + : Access + = { execute = Some True, read = Some True, write = Some True } + + -- Give someone no access at all to an filesystem entry. + let no_access + : Access + = { execute = Some False, read = Some False, write = Some False } + + -- These permissions + -- * grant full access to the user. + -- * retain the permissions of the primary group of the user. + -- * deny access to everyone else. + let semi_private + : Mode + = { user = Some full_access, group = None Access, other = Some no_access } + + -- Now let's start with the directory tree ... + in [ -- Some file with a gentle greeting. No metadata is set explicitly. + make.file File::{ name = "some file", content = "Hello world!" } + -- A directory with some metadata set explicitely. + , make.directory + Directory::{ + , name = "my private directory" + -- How owns the new directory: just_me + , user = Some (User.UserName "just_me") + -- We stick with the user's default group here. + , group = None Group + , mode = Some semi_private + , content = [] : List tree + } + ] + : List tree From 05a0569e4461a3b68e099bfa1483b6f95b8a8130 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Wed, 21 Sep 2022 00:35:28 +0200 Subject: [PATCH 12/12] Fixed haddocks --- dhall/src/Dhall/DirectoryTree.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 28cea20b3..5dbe2c6d6 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -174,8 +174,8 @@ import qualified System.PosixCompat.User as Posix __NOTE__: This utility does not take care of type-checking and normalizing the provided expression. This will raise a `FilesystemError` exception or a - `DhallErrors` exception upon encountering an expression that cannot be - converted as-is. + `Dhall.Marshal.Decode.DhallErrors` exception upon encountering an expression + that cannot be converted as-is. -} toDirectoryTree :: Bool -- ^ Whether to allow path separators in file names or not