Move types needed in Dhall.DirectoryTree to own module (#2455)

In order to fix the Windows builds observed in #2452 we only include the `FromDhall CUid` and `FromDhall CGid` instance only if we are on that platform. Those types are not available there which caused the CI failure. Fixes #2452 * Use unsafe coercion for FromDhall instances of UserID/GroupID * Added more to-directory-tree tests * Warn on mismatch of file permissions on Windows
dhall-lang · Oct 1, 2022 · 01c07b0 · 01c07b0
1 parent b2613b2
commit 01c07b0
Show file tree

Hide file tree

Showing 7 changed files with 364 additions and 192 deletions.
diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal
@@ -353,6 +353,7 @@ Library
         Exposed-Modules:
           Dhall.Deriving
     Other-Modules:
+        Dhall.DirectoryTree.Types
         Dhall.Eval
         Dhall.Import.Types
         Dhall.Import.Headers

diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs
@@ -1,15 +1,8 @@
-{-# LANGUAGE DataKinds          #-}
-{-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE DerivingVia        #-}
-{-# LANGUAGE FlexibleInstances  #-}
-{-# LANGUAGE LambdaCase         #-}
-{-# LANGUAGE OverloadedLists    #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE PatternSynonyms    #-}
-{-# LANGUAGE RecordWildCards    #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections      #-}
-{-# LANGUAGE ViewPatterns       #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -19,38 +12,33 @@ module Dhall.DirectoryTree
       toDirectoryTree
     , FilesystemError(..)
 
-      -- * Exported for testing only
+      -- * Low-level types and functions
+    , module Dhall.DirectoryTree.Types
+    , decodeDirectoryTree
     , directoryTreeType
     ) where
 
-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 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.DirectoryTree.Types
+import Dhall.Marshal.Decode      (Decoder (..), Expector)
+import Dhall.Src                 (Src)
 import Dhall.Syntax
     ( Chunks (..)
     , Const (..)
     , Expr (..)
-    , FieldSelection (..)
     , RecordField (..)
     , Var (..)
     )
-import System.FilePath          ((</>))
-import System.PosixCompat.Types (FileMode, GroupID, UserID)
+import System.FilePath           ((</>))
+import System.PosixCompat.Types  (FileMode, GroupID, UserID)
 
 import qualified Control.Exception           as Exception
 import qualified Data.Foldable               as Foldable
@@ -66,7 +54,6 @@ 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:
@@ -182,7 +169,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
 
@@ -209,24 +196,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
@@ -253,6 +226,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)
@@ -269,132 +259,16 @@ makeType = Record . Map.fromList <$> sequenceA
         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 ()
@@ -434,7 +308,7 @@ applyMetadata entry fp = do
 
     let mode' = maybe mode (updateModeWith mode) (entryMode entry)
     unless (mode' == mode) $
-        Posix.setFileMode fp $ modeToFileMode mode'
+        setFileMode fp $ modeToFileMode mode'
 
 -- | Calculate the new `Mode` from the current mode and the changes specified by
 -- the user.