@@ -3,50 +3,46 @@
33-- use statfs on Linux and macOS and GetVolumeInformation on Windows
44-- this could still be fooled with symlinks or by disabling journaling on filesystems that support that
55module ProjectM36.FSType where
6−import Foreign.C.Types
7−import Foreign.C.String
8−import Foreign.C.Error
96
10−#ifdef mingw32_HOST_OS
11−import System.Win32.String
12−import System.Win32.File
7+#if defined(mingw32_HOST_OS)
8+# if defined(i386_HOST_ARCH)
9+# define WINDOWS_CCONV stdcall
10+# elif defined(x86_64_HOST_ARCH)
11+# define WINDOWS_CCONV ccall
12+# endif
13+import System.Win32.Types
14+import Foreign.ForeignPtr
15+import Data.Word
16+import Data.Bits
17+import Foreign.Storable
1318
19+foreign import WINDOWS_CCONV unsafe "windows.h GetVolumePathNameW"
20+ c_GetVolumePathName :: LPCTSTR -> LPTSTR -> DWORD -> IO BOOL
21+
1422foreign import WINDOWS_CCONV unsafe "windows.h GetVolumeInformationW"
1523 c_GetVolumeInformation :: LPCTSTR -> LPTSTR -> DWORD -> LPDWORD -> LPDWORD -> LPDWORD -> LPTSTR -> DWORD -> IO BOOL
1624
17−data VolumeInformation = VolumeInformation
18− { volumeName :: String
19− , volumeSerialNumber :: DWORD
20− , maximumComponentLength :: DWORD
21− , fileSystemFlags :: DWORD
22− , fileSystemName :: String
23− } deriving Show
25+#define FILE_SUPPORTS_USN_JOURNAL 0x02000000
2426
25−-- from https://github.com/haskell/win32/blob/master/System/Win32/HardLink.hs
26−getVolumeInformation :: Maybe String -> IO VolumeInformation
27−getVolumeInformation mPath =
28− maybeWith withTString mPath $ \c_path ->
29− withTStringBufferLen 256 $ \(vnBuf, vnLen) ->
30− alloca $ \serialNum ->
31− alloca $ \maxLen ->
32− alloca $ \fsFlags ->
33− withTStringBufferLen 256 $ \(fsBuf, fsLen) -> do
34− failIfFalse_ (unwords ["GetVolumeInformationW", c_path]) $
35− c_GetVolumeInformation c_path vnBuf (fromIntegral vnLen)
36− serialNum maxLen fsFlags
37− fsBuf (fromIntegral fsLen)
38− return VolumeInformation
39− <*> peekTString vnBuf
40− <*> peek serialNum
41− <*> peek maxLen
42− <*> peek fsFlags
43− <*> peekTString fsBuf
27+getVolumePathName :: FilePath -> IO String
28+getVolumePathName path = do
29+ let maxpathlen = 260 --ANSI MAX_PATH- we only care about the drive name anyway
30+ withTString path $ \c_path -> do
31+ fp_pathout <- mallocForeignPtrBytes maxpathlen
32+ withForeignPtr fp_pathout $ \pathout -> do
33+ failIfFalse_ ("GetVolumePathNameW " ++ path) (c_GetVolumePathName c_path pathout (fromIntegral maxpathlen))
34+ peekTString pathout
4435
4536fsTypeSupportsJournaling :: FilePath -> IO Bool
46−fsTypeSupportJournaling path = do
47− info <- getVolumeInformation
48−#define FILE_SUPPORTS_USN_JOURNAL 0x02000000
49− pure (fileSystemFlags info .&. FILE_SUPPORTS_USN_JOURNAL)
37+fsTypeSupportsJournaling path = do
38+ -- get the drive path of the incoming path
39+ drive <- getVolumePathName path
40+ withTString drive $ \c_drive -> do
41+ foreign_flags <- mallocForeignPtrBytes 8
42+ withForeignPtr foreign_flags $ \ptr_fsFlags -> do
43+ failIfFalse_ (unwords ["GetVolumeInformationW", path]) (c_GetVolumeInformation c_drive nullPtr 0 nullPtr nullPtr ptr_fsFlags nullPtr 0)
44+ fsFlags <- peekByteOff ptr_fsFlags 0 :: IO Word64
45+ pure (fsFlags .&. FILE_SUPPORTS_USN_JOURNAL /= 0)
5046
5147#elif darwin_HOST_OS
5248--Darwin reports journaling directly in the fs flags
@@ -63,6 +59,10 @@ fsTypeSupportsJournaling path =
6359
6460#elif linux_HOST_OS
6561import Foreign
62+import Foreign.C.Error
63+import Foreign.C.String
64+import Foreign.C.Types
65+
6666#include "MachDeps.h"
6767--Linux cannot report journaling, so we just check the filesystem type as a proxy
6868type CStatFS = ()