@@ -0,0 +1,98 @@
1+{-# LANGUAGE CPP #-}
2+-- confirm that the filesystem type is a journaled FS type expected by Project:M36
3+-- use statfs on Linux and macOS and GetVolumeInformation on Windows
4+-- this could still be fooled with symlinks or by disabling journaling on filesystems that support that
5+module ProjectM36.FSType where
6+
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
18+
19+foreign import WINDOWS_CCONV unsafe "windows.h GetVolumePathNameW"
20+ c_GetVolumePathName :: LPCTSTR -> LPTSTR -> DWORD -> IO BOOL
21+
22+foreign import WINDOWS_CCONV unsafe "windows.h GetVolumeInformationW"
23+ c_GetVolumeInformation :: LPCTSTR -> LPTSTR -> DWORD -> LPDWORD -> LPDWORD -> LPDWORD -> LPTSTR -> DWORD -> IO BOOL
24+
25+#define FILE_SUPPORTS_USN_JOURNAL 0x02000000
26+
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
35+
36+fsTypeSupportsJournaling :: FilePath -> IO Bool
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)
46+
47+#elif darwin_HOST_OS
48+--Darwin reports journaling directly in the fs flags
49+
50+type CStatFS = ()
51+foreign import ccall unsafe "cDarwinFSJournaled"
52+ c_DarwinFSJournaled :: CString -> IO CInt
53+
54+fsTypeSupportsJournaling :: FilePath -> IO Bool
55+fsTypeSupportsJournaling path =
56+ withCString path $ \c_path -> do
57+ ret <- throwErrnoIfMinus1 "statfs" (c_DarwinFSJournaled c_path)
58+ pure (ret > (0 :: CInt))
59+
60+#elif linux_HOST_OS
61+import Foreign
62+import Foreign.C.Error
63+import Foreign.C.String
64+import Foreign.C.Types
65+
66+#include "MachDeps.h"
67+--Linux cannot report journaling, so we just check the filesystem type as a proxy
68+type CStatFS = ()
69+foreign import ccall unsafe "sys/vfs.h statfs"
70+ c_statfs :: CString -> Ptr CStatFS -> IO CInt
71+
72+#if WORD_SIZE_IN_BITS == 64
73+type CFSType = Word64
74+sizeofStructStatFS :: Int
75+sizeofStructStatFS = 120
76+#else
77+#error 32-bit not supported due to sizeof struct statfs missing
78+type CFSType = Word32
79+sizeofStructStatFS :: Int
80+sizeofStructStatFS = undefined
81+#endif
82+
83+fsTypeSupportsJournaling :: FilePath -> IO Bool
84+fsTypeSupportsJournaling path = do
85+ struct_statfs <- mallocForeignPtrBytes sizeofStructStatFS
86+ withCString path $ \c_path -> do
87+ withForeignPtr struct_statfs $ \ptr_statfs -> do
88+ throwErrnoIfMinus1_ "statfs" (c_statfs c_path ptr_statfs)
89+ cfstype <- peekByteOff ptr_statfs 0 :: IO CFSType
90+ let journaledFS = [0xEF53, --EXT3+4
91+ 0x5346544e, --NTFS
92+ 0x52654973, --REISERFS
93+ 0x58465342, --XFS
94+ 0x3153464a --JFS
95+ ]
96+ pure (elem cfstype journaledFS)
97+#endif
98+