1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
{-# LANGUAGE ForeignFunctionInterface #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE InterruptibleFFI #-}
#endif
{-# LANGUAGE LambdaCase #-}
module System.Win32.FileNotify (
Handle
, Action(..)
, getWatchHandle
, readDirectoryChanges
) where
import Data.Char (isSpace)
import Foreign ((.|.), Ptr, FunPtr, alloca, allocaBytes, castPtr, nullFunPtr, peekByteOff, plusPtr)
import Foreign.C (peekCWStringLen)
import Numeric (showHex)
import System.Win32.File (
FileNotificationFlag
, LPOVERLAPPED
, createFile
, oPEN_EXISTING
, fILE_FLAG_BACKUP_SEMANTICS
, fILE_LIST_DIRECTORY
, fILE_SHARE_READ
, fILE_SHARE_WRITE
)
import System.Win32.Types (
BOOL
, DWORD
, ErrCode
, HANDLE
, LPDWORD
, LPVOID
, getErrorMessage
, getLastError
, localFree
, nullPtr
)
import System.Win32.Types (peekTString)
#include <windows.h>
type Handle = HANDLE
getWatchHandle :: FilePath -> IO Handle
getWatchHandle dir = createFile dir
fILE_LIST_DIRECTORY -- Access mode
(fILE_SHARE_READ .|. fILE_SHARE_WRITE) -- Share mode
Nothing -- security attributes
oPEN_EXISTING -- Create mode, we want to look at an existing directory
fILE_FLAG_BACKUP_SEMANTICS -- File attribute, nb NOT using OVERLAPPED since we work synchronously
Nothing -- No template file
readDirectoryChanges :: Handle -> Bool -> FileNotificationFlag -> IO (Either (ErrCode, String) [(Action, String)])
readDirectoryChanges h watchSubTree mask = do
let maxBuf = 16384
allocaBytes maxBuf $ \buffer -> do
alloca $ \bret -> do
readDirectoryChangesW h buffer (toEnum maxBuf) watchSubTree mask bret >>= \case
Left err -> return $ Left err
Right () -> Right <$> readChanges buffer
data Action = FileAdded | FileRemoved | FileModified | FileRenamedOld | FileRenamedNew
deriving (Show, Read, Eq, Ord, Enum)
readChanges :: Ptr FILE_NOTIFY_INFORMATION -> IO [(Action, String)]
readChanges pfni = do
fni <- peekFNI pfni
let entry = (faToAction $ fniAction fni, fniFileName fni)
nioff = fromEnum $ fniNextEntryOffset fni
entries <- if nioff == 0 then return [] else readChanges $ pfni `plusPtr` nioff
return $ entry:entries
faToAction :: FileAction -> Action
faToAction fa = toEnum $ fromEnum fa - 1
-------------------------------------------------------------------
-- Low-level stuff that binds to notifications in the Win32 API
-- Defined in System.Win32.File, but with too few cases:
-- type AccessMode = UINT
#if !(MIN_VERSION_Win32(2,4,0))
#{enum AccessMode,
, fILE_LIST_DIRECTORY = FILE_LIST_DIRECTORY
}
-- there are many more cases but I only need this one.
#endif
type FileAction = DWORD
#{enum FileAction,
, _fILE_ACTION_ADDED = FILE_ACTION_ADDED
, _fILE_ACTION_REMOVED = FILE_ACTION_REMOVED
, _fILE_ACTION_MODIFIED = FILE_ACTION_MODIFIED
, _fILE_ACTION_RENAMED_OLD_NAME = FILE_ACTION_RENAMED_OLD_NAME
, _fILE_ACTION_RENAMED_NEW_NAME = FILE_ACTION_RENAMED_NEW_NAME
}
-- type WCHAR = Word16
-- This is a bit overkill for now, I'll only use nullFunPtr anyway,
-- but who knows, maybe someday I'll want asynchronous callbacks on the OS level.
type LPOVERLAPPED_COMPLETION_ROUTINE = FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())
data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION
{ fniNextEntryOffset, fniAction :: DWORD
, fniFileName :: String
}
-- instance Storable FILE_NOTIFY_INFORMATION where
-- ... well, we can't write an instance since the struct is not of fix size,
-- so we'll have to do it the hard way, and not get anything for free. Sigh.
-- sizeOfFNI :: FILE_NOTIFY_INFORMATION -> Int
-- sizeOfFNI fni = (#size FILE_NOTIFY_INFORMATION) + (#size WCHAR) * (length (fniFileName fni) - 1)
peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION
peekFNI buf = do
neof <- (#peek FILE_NOTIFY_INFORMATION, NextEntryOffset) buf
acti <- (#peek FILE_NOTIFY_INFORMATION, Action) buf
fnle <- (#peek FILE_NOTIFY_INFORMATION, FileNameLength) buf
fnam <- peekCWStringLen
(buf `plusPtr` (#offset FILE_NOTIFY_INFORMATION, FileName), -- start of array
fromEnum (fnle :: DWORD) `div` 2 ) -- fnle is the length in *bytes*, and a WCHAR is 2 bytes
return $ FILE_NOTIFY_INFORMATION neof acti fnam
readDirectoryChangesW :: Handle -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag -> LPDWORD -> IO (Either (ErrCode, String) ())
readDirectoryChangesW h buf bufSize watchSubTree f br =
c_ReadDirectoryChangesW h (castPtr buf) bufSize watchSubTree f br nullPtr nullFunPtr >>= \case
True -> return $ Right ()
False -> do
-- Extract the failure message, as done in https://hackage.haskell.org/package/Win32-2.14.0.0/docs/src/System.Win32.WindowsString.Types.html#errorWin
err_code <- getLastError
msg <- getErrorMessage err_code >>= \case
x | x == nullPtr -> return $ "Error 0x" ++ Numeric.showHex err_code ""
c_msg -> do
msg <- peekTString c_msg
-- We ignore failure of freeing c_msg, given we're already failing
_ <- localFree c_msg
return msg
let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n
return $ Left (err_code, msg')
{-
asynchReadDirectoryChangesW :: Handle -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag
-> LPOVERLAPPED -> IO ()
asynchReadDirectoryChangesW h buf bufSize watchSubTree f over =
failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf) bufSize watchSubTree f nullPtr over nullFunPtr
cbReadDirectoryChangesW :: Handle -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag
-> LPOVERLAPPED -> IO BOOL
cbReadDirectoryChanges
-}
-- The interruptible qualifier will keep threads listening for events from hanging blocking when killed
#if __GLASGOW_HASKELL__ >= 701
foreign import stdcall interruptible "windows.h ReadDirectoryChangesW"
#else
foreign import stdcall safe "windows.h ReadDirectoryChangesW"
#endif
c_ReadDirectoryChangesW :: Handle -> LPVOID -> DWORD -> BOOL -> DWORD -> LPDWORD -> LPOVERLAPPED -> LPOVERLAPPED_COMPLETION_ROUTINE -> IO BOOL
{-
type CompletionRoutine :: (DWORD, DWORD, LPOVERLAPPED) -> IO ()
foreign import ccall "wrapper"
mkCompletionRoutine :: CompletionRoutine -> IO (FunPtr CompletionRoutine)
type LPOVERLAPPED = Ptr OVERLAPPED
type LPOVERLAPPED_COMPLETION_ROUTINE = FunPtr CompletionRoutine
data OVERLAPPED = OVERLAPPED
{
}
-- In System.Win32.File, but missing a crucial case:
-- type FileNotificationFlag = DWORD
-}
-- See https://msdn.microsoft.com/en-us/library/windows/desktop/aa365465(v=vs.85).aspx
#{enum FileNotificationFlag,
, _fILE_NOTIFY_CHANGE_FILE_NAME = FILE_NOTIFY_CHANGE_FILE_NAME
, _fILE_NOTIFY_CHANGE_DIR_NAME = FILE_NOTIFY_CHANGE_DIR_NAME
, _fILE_NOTIFY_CHANGE_ATTRIBUTES = FILE_NOTIFY_CHANGE_ATTRIBUTES
, _fILE_NOTIFY_CHANGE_SIZE = FILE_NOTIFY_CHANGE_SIZE
, _fILE_NOTIFY_CHANGE_LAST_WRITE = FILE_NOTIFY_CHANGE_LAST_WRITE
, _fILE_NOTIFY_CHANGE_LAST_ACCESS = FILE_NOTIFY_CHANGE_LAST_ACCESS
, _fILE_NOTIFY_CHANGE_CREATION = FILE_NOTIFY_CHANGE_CREATION
, _fILE_NOTIFY_CHANGE_SECURITY = FILE_NOTIFY_CHANGE_SECURITY
}
|
