From ed4d66c80036f09bdb92eaf67153279edc53052e Mon Sep 17 00:00:00 2001
From: Mann mit Hut <github+mmhat@with-h.at>
Date: Thu, 29 Sep 2022 04:12:54 +0200
Subject: [PATCH] Disable setting file permissions on Windows

It is currently broken; See the discussion of https://github.com/dhall-lang/dhall-haskell/issues/2452
---
 dhall/src/Dhall/DirectoryTree.hs        |  2 +-
 dhall/src/Dhall/DirectoryTree/Types.hs  | 15 ++++++++++++++-
 dhall/tests/Dhall/Test/DirectoryTree.hs | 20 +++++++++++++++++++-
 3 files changed, 34 insertions(+), 3 deletions(-)

diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs
index 9713d1fb4..a01d1a3d4 100644
--- a/dhall/src/Dhall/DirectoryTree.hs
+++ b/dhall/src/Dhall/DirectoryTree.hs
@@ -311,7 +311,7 @@ applyMetadata entry fp = do
 
     let mode' = maybe mode (updateModeWith mode) (entryMode entry)
     unless (mode' == mode) $
-        Posix.setFileMode fp $ modeToFileMode mode'
+        setFileModeOnUnix fp $ modeToFileMode mode'
 
 -- | Calculate the new `Mode` from the current mode and the changes specified by
 -- the user.
diff --git a/dhall/src/Dhall/DirectoryTree/Types.hs b/dhall/src/Dhall/DirectoryTree/Types.hs
index fe19db595..5a5b7b411 100644
--- a/dhall/src/Dhall/DirectoryTree/Types.hs
+++ b/dhall/src/Dhall/DirectoryTree/Types.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP                #-}
-{-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE LambdaCase         #-}
@@ -21,6 +20,8 @@ module Dhall.DirectoryTree.Types
     , Group(..)
     , Mode(..)
     , Access(..)
+
+    , setFileModeOnUnix
     ) where
 
 import Data.Functor.Identity    (Identity (..))
@@ -45,9 +46,11 @@ import qualified Dhall.Marshal.Decode        as Decode
 
 #ifdef mingw32_HOST_OS
 import Data.Word (Word32)
+import System.IO (hPutStrLn, stderr)
 
 import qualified Unsafe.Coerce
 #else
+import qualified System.PosixCompat.Files as Posix
 import qualified System.PosixCompat.Types as Posix
 #endif
 
@@ -179,3 +182,13 @@ accessDecoder :: FromDhall (f Bool) => InputNormalizer -> Decoder (Access f)
 accessDecoder = Decode.genericAutoWithInputNormalizer Decode.defaultInterpretOptions
     { fieldModifier = Text.toLower . Text.drop (Text.length "access")
     }
+
+
+
+-- | Set file permissions if we are not on Windows as it is currently not supported.
+setFileModeOnUnix :: FilePath -> Posix.FileMode -> IO ()
+#ifdef mingw32_HOST_OS
+setFileModeOnUnix fp _ = hPutStrLn stderr $ "Warning: Feature is not supported on your platform; Failed to set permissions for " <> fp
+#else
+setFileModeOnUnix fp mode = Posix.setFileMode fp mode
+#endif
diff --git a/dhall/tests/Dhall/Test/DirectoryTree.hs b/dhall/tests/Dhall/Test/DirectoryTree.hs
index ff9fc8644..e1a8894e9 100644
--- a/dhall/tests/Dhall/Test/DirectoryTree.hs
+++ b/dhall/tests/Dhall/Test/DirectoryTree.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -9,6 +10,7 @@ import Data.Either.Validation
 import Dhall.DirectoryTree (Entry(..), Group(..), User(..))
 import Lens.Family (set)
 import System.FilePath ((</>))
+import System.PosixCompat.Types (FileMode)
 import Test.Tasty
 import Test.Tasty.HUnit
 
@@ -26,7 +28,9 @@ tests = testGroup "to-directory-tree"
         [ fixpointedType
         , fixpointedEmpty
         , fixpointedSimple
+#ifndef mingw32_HOST_OS
         , fixpointedPermissions
+#endif
         , fixpointedUserGroup
         ]
     ]
@@ -58,6 +62,11 @@ fixpointedSimple = testCase "simple" $ do
         , Directory $ outDir </> "directory"
         ]
 
+{-
+This test is disabled on Windows for now as it fails:
+    expected: 448
+    but got: 438
+-}
 fixpointedPermissions :: TestTree
 fixpointedPermissions = testCase "permissions" $ do
     let outDir = "./tests/to-directory-tree/fixpoint-permissions.out"
@@ -69,7 +78,16 @@ fixpointedPermissions = testCase "permissions" $ do
         ]
     s <- Files.getFileStatus $ outDir </> "file"
     let mode = Files.fileMode s `Files.intersectFileModes` Files.accessModes
-    mode @?= Files.ownerModes
+    prettyMode mode @?= prettyMode Files.ownerModes
+    where
+        prettyMode :: FileMode -> String
+        prettyMode m =
+            [ 'r' | isBitSet Files.ownerExecuteMode m ] <>
+            [ 'w' | isBitSet Files.ownerExecuteMode m ] <>
+            [ 'x' | isBitSet Files.ownerExecuteMode m ]
+
+        isBitSet :: FileMode -> FileMode -> Bool
+        isBitSet mask m = mask `Files.intersectFileModes` m == Files.nullFileMode
 
 fixpointedUserGroup :: TestTree
 fixpointedUserGroup = testCase "user and group" $ do