From 45a0459824d5aced869ce764f3e6da0a7e47f161 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 29 Sep 2022 02:19:34 +0200 Subject: [PATCH] Added more to-directory-tree tests --- dhall/src/Dhall/DirectoryTree.hs | 41 +++++++++++-------- dhall/src/Dhall/DirectoryTree/Types.hs | 17 +++++--- dhall/tests/Dhall/Test/DirectoryTree.hs | 40 ++++++++++++++---- ...adata.dhall => fixpoint-permissions.dhall} | 2 - .../fixpoint-usergroup.dhall | 25 +++++++++++ 5 files changed, 92 insertions(+), 33 deletions(-) rename dhall/tests/to-directory-tree/{fixpoint-metadata.dhall => fixpoint-permissions.dhall} (93%) create mode 100644 dhall/tests/to-directory-tree/fixpoint-usergroup.dhall diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index f240d1513..9713d1fb4 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -12,7 +12,9 @@ module Dhall.DirectoryTree toDirectoryTree , FilesystemError(..) - -- * Exported for testing only + -- * Low-level types and functions + , module Dhall.DirectoryTree.Types + , decodeDirectoryTree , directoryTreeType ) where @@ -170,7 +172,7 @@ toDirectoryTree -> FilePath -> Expr Void Void -> IO () -toDirectoryTree allowSeparators path expression = case Core.alphaNormalize expression of +toDirectoryTree allowSeparators path expression = case expression of RecordLit keyValues -> Map.unorderedTraverseWithKey_ process $ recordFieldValue <$> keyValues @@ -197,24 +199,10 @@ toDirectoryTree allowSeparators path expression = case Core.alphaNormalize expre -- 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 + Lam _ _ (Lam _ _ _) -> do + entries <- decodeDirectoryTree expression processFilesystemEntryList allowSeparators path entries - where - decoder :: Decoder (Seq FilesystemEntry) - decoder = Decode.auto _ -> die @@ -241,6 +229,23 @@ toDirectoryTree allowSeparators path expression = case Core.alphaNormalize expre where unexpectedExpression = expression +-- | Decode a fixpoint directory tree from a Dhall expression. +decodeDirectoryTree :: Expr s Void -> IO (Seq FilesystemEntry) +decodeDirectoryTree (Core.alphaNormalize . Core.denote -> expression@(Lam _ _ (Lam _ _ body))) = do + expected' <- case directoryTreeType of + Success x -> return x + Failure e -> Exception.throwIO e + + _ <- Core.throws $ TypeCheck.typeOf $ Annot expression expected' + + case Decode.extract decoder body of + Success x -> return x + Failure e -> Exception.throwIO e + where + decoder :: Decoder (Seq FilesystemEntry) + decoder = Decode.auto +decodeDirectoryTree expr = Exception.throwIO $ FilesystemError $ Core.denote expr + -- | The type of a fixpoint directory tree expression. directoryTreeType :: Expector (Expr Src Void) directoryTreeType = Pi Nothing "tree" (Const Type) diff --git a/dhall/src/Dhall/DirectoryTree/Types.hs b/dhall/src/Dhall/DirectoryTree/Types.hs index b67c48b46..fe19db595 100644 --- a/dhall/src/Dhall/DirectoryTree/Types.hs +++ b/dhall/src/Dhall/DirectoryTree/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -12,9 +13,9 @@ -- | Types used by the implementation of the @to-directory-tree@ subcommand module Dhall.DirectoryTree.Types - ( DirectoryEntry + ( FilesystemEntry(..) + , DirectoryEntry , FileEntry - , FilesystemEntry(..) , Entry(..) , User(..) , Group(..) @@ -61,7 +62,7 @@ type FileEntry = Entry Text data FilesystemEntry = DirectoryEntry (Entry (Seq FilesystemEntry)) | FileEntry (Entry Text) - deriving Show + deriving (Eq, Generic, Ord, Show) instance FromDhall FilesystemEntry where autoWith normalizer = Decoder @@ -83,7 +84,7 @@ data Entry a = Entry , entryGroup :: Maybe Group , entryMode :: Maybe (Mode Maybe) } - deriving (Generic, Show) + deriving (Eq, Generic, Ord, Show) instance FromDhall a => FromDhall (Entry a) where autoWith = Decode.genericAutoWithInputNormalizer Decode.defaultInterpretOptions @@ -94,7 +95,7 @@ instance FromDhall a => FromDhall (Entry a) where data User = UserId UserID | UserName String - deriving (Generic, Show) + deriving (Eq, Generic, Ord, Show) instance FromDhall User @@ -110,7 +111,7 @@ instance FromDhall Posix.CUid where data Group = GroupId GroupID | GroupName String - deriving (Generic, Show) + deriving (Eq, Generic, Ord, Show) instance FromDhall Group @@ -137,6 +138,8 @@ data Mode f = Mode deriving instance Eq (Mode Identity) deriving instance Eq (Mode Maybe) +deriving instance Ord (Mode Identity) +deriving instance Ord (Mode Maybe) deriving instance Show (Mode Identity) deriving instance Show (Mode Maybe) @@ -161,6 +164,8 @@ data Access f = Access deriving instance Eq (Access Identity) deriving instance Eq (Access Maybe) +deriving instance Ord (Access Identity) +deriving instance Ord (Access Maybe) deriving instance Show (Access Identity) deriving instance Show (Access Maybe) diff --git a/dhall/tests/Dhall/Test/DirectoryTree.hs b/dhall/tests/Dhall/Test/DirectoryTree.hs index e3fc02ce8..ff9fc8644 100644 --- a/dhall/tests/Dhall/Test/DirectoryTree.hs +++ b/dhall/tests/Dhall/Test/DirectoryTree.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + module Dhall.Test.DirectoryTree (tests) where import Control.Monad import Data.Either (partitionEithers) import Data.Either.Validation +import Dhall.DirectoryTree (Entry(..), Group(..), User(..)) import Lens.Family (set) import System.FilePath (()) import Test.Tasty @@ -22,15 +26,15 @@ tests = testGroup "to-directory-tree" [ fixpointedType , fixpointedEmpty , fixpointedSimple - , fixpointedMetadata + , fixpointedPermissions + , fixpointedUserGroup ] ] 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 + ref <- Dhall.inputExpr file expected' <- case Dhall.DirectoryTree.directoryTreeType of Failure e -> assertFailure $ show e Success expr -> return expr @@ -54,10 +58,10 @@ fixpointedSimple = testCase "simple" $ do , 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" +fixpointedPermissions :: TestTree +fixpointedPermissions = testCase "permissions" $ do + let outDir = "./tests/to-directory-tree/fixpoint-permissions.out" + path = "./tests/to-directory-tree/fixpoint-permissions.dhall" entries <- runDirectoryTree False outDir path entries @?= [ Directory outDir @@ -67,6 +71,28 @@ fixpointedMetadata = testCase "metadata" $ do let mode = Files.fileMode s `Files.intersectFileModes` Files.accessModes mode @?= Files.ownerModes +fixpointedUserGroup :: TestTree +fixpointedUserGroup = testCase "user and group" $ do + let file = "./tests/to-directory-tree/fixpoint-usergroup.dhall" + expr <- Dhall.inputExpr file + entries <- Dhall.DirectoryTree.decodeDirectoryTree expr + entries @?= + [ Dhall.DirectoryTree.FileEntry $ Entry + { entryName = "ids" + , entryContent = "" + , entryUser = Just (UserId 0) + , entryGroup = Just (GroupId 0) + , entryMode = Nothing + } + , Dhall.DirectoryTree.FileEntry $ Entry + { entryName = "names" + , entryContent = "" + , entryUser = Just (UserName "user") + , entryGroup = Just (GroupName "group") + , entryMode = Nothing + } + ] + runDirectoryTree :: Bool -> FilePath -> FilePath -> IO [FilesystemEntry] runDirectoryTree allowSeparators outDir path = do doesOutDirExist <- Directory.doesDirectoryExist outDir diff --git a/dhall/tests/to-directory-tree/fixpoint-metadata.dhall b/dhall/tests/to-directory-tree/fixpoint-permissions.dhall similarity index 93% rename from dhall/tests/to-directory-tree/fixpoint-metadata.dhall rename to dhall/tests/to-directory-tree/fixpoint-permissions.dhall index 76e7d18cd..a191e952f 100644 --- a/dhall/tests/to-directory-tree/fixpoint-metadata.dhall +++ b/dhall/tests/to-directory-tree/fixpoint-permissions.dhall @@ -2,8 +2,6 @@ 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 } diff --git a/dhall/tests/to-directory-tree/fixpoint-usergroup.dhall b/dhall/tests/to-directory-tree/fixpoint-usergroup.dhall new file mode 100644 index 000000000..db2be4a0b --- /dev/null +++ b/dhall/tests/to-directory-tree/fixpoint-usergroup.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 = "ids" + , content = "" + , user = Some (User.UserId 0) + , group = Some (Group.GroupId 0) + , mode = None Mode + } + , make.file + { name = "names" + , content = "" + , user = Some (User.UserName "user") + , group = Some (Group.GroupName "group") + , mode = None Mode + } + ]