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/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 diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 4f152a7a4..5dbe2c6d6 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -1,31 +1,73 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- | Implementation of the @dhall to-directory-tree@ subcommand module Dhall.DirectoryTree ( -- * Filesystem toDirectoryTree , FilesystemError(..) + + -- * Exported for testing only + , directoryTreeType ) where -import Control.Applicative (empty) -import Control.Exception (Exception) -import Data.Void (Void) -import Dhall.Syntax (Chunks (..), Expr (..), RecordField (..)) -import System.FilePath (()) +import Control.Applicative (empty) +import Control.Exception (Exception) +import Control.Monad (unless, when) +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 (..) + , RecordField (..) + , Var (..) + ) +import System.FilePath (()) +import System.PosixCompat.Types (FileMode, GroupID, UserID) 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.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 +79,9 @@ import qualified System.FilePath as FilePath * @Optional@ values are omitted if @None@ + * 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: > { dir = { `hello.txt` = "Hello\n" } @@ -59,8 +104,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 +125,64 @@ 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 - encountering an expression that cannot be converted as-is. + /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 (tree : Type) -> + > forall ( make + > : { directory : Entry (List tree) -> tree + > , file : Entry Text -> tree + > } + > ) -> + > 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 + 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 or a + `Dhall.Marshal.Decode.DhallErrors` 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 Core.alphaNormalize expression of RecordLit keyValues -> Map.unorderedTraverseWithKey_ process $ recordFieldValue <$> keyValues @@ -102,14 +198,36 @@ 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 () + -- 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 _ _ (Lam _ _ 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' + + entries <- case Decode.extract decoder body' of + Success x -> return x + Failure e -> Exception.throwIO e + + processFilesystemEntryList allowSeparators path entries + where + decoder :: Decoder (Seq FilesystemEntry) + decoder = Decode.auto + _ -> die where @@ -124,18 +242,261 @@ 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 +-- | The type of a fixpoint directory tree expression. +directoryTreeType :: Expector (Expr Src Void) +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) +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 "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) + +type FileEntry = Entry Text + +-- | A filesystem entry. +data FilesystemEntry + = DirectoryEntry (Entry (Seq FilesystemEntry)) + | FileEntry (Entry Text) + deriving Show + +instance FromDhall FilesystemEntry where + autoWith normalizer = Decoder + { expected = pure $ Var (V "tree" 0) + , extract = \case + Make "directory" entry -> + DirectoryEntry <$> extract (autoWith normalizer) entry + Make "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. +data Entry a = Entry + { entryName :: String + , entryContent :: a + , entryUser :: Maybe User + , entryGroup :: Maybe Group + , entryMode :: Maybe (Mode Maybe) + } + deriving (Generic, Show) + +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 (Generic, Show) + +instance FromDhall User + +instance FromDhall Posix.CUid where + autoWith normalizer = Posix.CUid <$> autoWith normalizer + +-- | 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 + deriving (Generic, Show) + +instance FromDhall Group + +instance FromDhall Posix.CGid where + autoWith normalizer = Posix.CGid <$> autoWith normalizer + +-- | 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: +-- * 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) + , 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) + +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") + } + +-- | The permissions for a subject (user/group/other). +data Access f = Access + { accessExecute :: f Bool + , 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) + +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") + } + +-- | 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' + 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. + 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. + applyMetadata entry path' + +-- | Process a list of `FilesystemEntry`s. +processFilesystemEntryList :: Bool -> FilePath -> Seq FilesystemEntry -> IO () +processFilesystemEntryList allowSeparators path = Foldable.traverse_ + (processFilesystemEntry allowSeparators path) + +-- | 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 + 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' + +-- | 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 + , modeGroup = combine modeGroup modeGroup + , modeOther = combine modeOther modeOther + } + 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 + , accessRead = combine accessRead accessRead + , accessWrite = combine accessWrite accessWrite + } + 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 + { 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 + } + } + +-- | 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) ] <> + [ 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) ] + +-- | Check whether the second `FileMode` is contained in the first one. +hasFileMode :: FileMode -> FileMode -> Bool +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 to a directory tree. @@ -155,8 +516,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/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) diff --git a/dhall/tests/Dhall/Test/DirectoryTree.hs b/dhall/tests/Dhall/Test/DirectoryTree.hs new file mode 100644 index 000000000..e3fc02ce8 --- /dev/null +++ b/dhall/tests/Dhall/Test/DirectoryTree.hs @@ -0,0 +1,101 @@ +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 +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" + [ 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" + 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 + } + ] 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