git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/FSType.hs
102 lines 3.7 kB history raw
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
5module ProjectM36.FSType where
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
13import System.Win32.Types
14import Foreign.ForeignPtr
15import Data.Word
16import Data.Bits
17import Foreign.Storable
19foreign import WINDOWS_CCONV unsafe "windows.h GetVolumePathNameW"
20 c_GetVolumePathName :: LPCTSTR -> LPTSTR -> DWORD -> IO BOOL
22foreign import WINDOWS_CCONV unsafe "windows.h GetVolumeInformationW"
23 c_GetVolumeInformation :: LPCTSTR -> LPTSTR -> DWORD -> LPDWORD -> LPDWORD -> LPDWORD -> LPTSTR -> DWORD -> IO BOOL
25#define FILE_SUPPORTS_USN_JOURNAL 0x02000000
27getVolumePathName :: FilePath -> IO String
28getVolumePathName 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
36fsTypeSupportsJournaling :: FilePath -> IO Bool
37fsTypeSupportsJournaling 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)
47#elif darwin_HOST_OS
48import Foreign.C.Error
49import Foreign.C.String
50import Foreign.C.Types
52--Darwin reports journaling directly in the fs flags
54type CStatFS = ()
55foreign import ccall unsafe "cDarwinFSJournaled"
56 c_DarwinFSJournaled :: CString -> IO CInt
58fsTypeSupportsJournaling :: FilePath -> IO Bool
59fsTypeSupportsJournaling path =
60 withCString path $ \c_path -> do
61 ret <- throwErrnoIfMinus1 "statfs" (c_DarwinFSJournaled c_path)
62 pure (ret > (0 :: CInt))
64#elif linux_HOST_OS
65import Foreign
66import Foreign.C.Error
67import Foreign.C.String
68import Foreign.C.Types
70#include "MachDeps.h"
71--Linux cannot report journaling, so we just check the filesystem type as a proxy
72type CStatFS = ()
73foreign import ccall unsafe "sys/vfs.h statfs"
74 c_statfs :: CString -> Ptr CStatFS -> IO CInt
76#if WORD_SIZE_IN_BITS == 64
77type CFSType = Word64
78sizeofStructStatFS :: Int
79sizeofStructStatFS = 120
80#else
81#error 32-bit not supported due to sizeof struct statfs missing
82type CFSType = Word32
83sizeofStructStatFS :: Int
84sizeofStructStatFS = undefined
85#endif
87fsTypeSupportsJournaling :: FilePath -> IO Bool
88fsTypeSupportsJournaling path = do
89 struct_statfs <- mallocForeignPtrBytes sizeofStructStatFS
90 withCString path $ \c_path -> do
91 withForeignPtr struct_statfs $ \ptr_statfs -> do
92 throwErrnoIfMinus1_ "statfs" (c_statfs c_path ptr_statfs)
93 cfstype <- peekByteOff ptr_statfs 0 :: IO CFSType
94 let journaledFS = [0xEF53, --EXT3+4
95 0x5346544e, --NTFS
96 0x52654973, --REISERFS
97 0x58465342, --XFS
98 0x3153464a --JFS
99 ]
100 pure (elem cfstype journaledFS)
101#endif