@@ -0,0 +1,463 @@
1+-- |
2+-- Module : Streamly.Internal.FileSystem.Event.Windows
3+-- Copyright : (c) 2020 Composewell Technologies
4+--
5+-- License : BSD3
6+-- Maintainer : streamly@composewell.com
7+-- Stability : experimental
8+-- Portability : GHC
9+--
10+-- Just report all events under the paths provided as arguments
11+
12+module Streamly.Internal.FileSystem.Event.Windows
13+ (
14+ -- * Subscribing to events
15+
16+ -- ** Default configuration
17+ Config
18+ , Event
19+ , Toggle (..)
20+ , setFlag
21+ , defaultConfig
22+ , getConfigFlag
23+ , setAllEvents
24+
25+ -- ** Watch Behavior
26+ , setRecursiveMode
27+
28+ -- ** Events of Interest
29+ -- *** Root Level Events
30+ , setModifiedFileName
31+ , setModifiedDirName
32+ , setModifiedAttribute
33+ , setModifiedSize
34+ , setModifiedLastWrite
35+ , setModifiedSecurity
36+
37+ -- ** Watch APIs
38+ , watchPaths
39+ , watchPathsWith
40+ , watchTrees
41+ , watchTreesWith
42+
43+ -- * Handling Events
44+ , getRelPath
45+ , getRoot
46+
47+ -- ** Item CRUD events
48+ , isCreated
49+ , isDeleted
50+ , isMovedFrom
51+ , isMovedTo
52+ , isModified
53+
54+ -- ** Exception Conditions
55+ , isOverflow
56+
57+ -- * Debugging
58+ , showEvent
59+ )
60+where
61+
62+import Control.Monad.IO.Class (MonadIO(liftIO))
63+import Data.Bits ((.|.), (.&.), complement)
64+import Data.Functor.Identity (runIdentity)
65+import Data.List.NonEmpty (NonEmpty)
66+import Data.Word (Word8)
67+import Foreign.C.String (peekCWStringLen)
68+import Foreign.Marshal.Alloc (alloca, allocaBytes)
69+import Foreign.Storable (peekByteOff)
70+import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr)
71+import Streamly.Prelude (SerialT, parallel)
72+import System.Win32.File
73+ ( FileNotificationFlag
74+ , LPOVERLAPPED
75+ , closeHandle
76+ , createFile
77+ , fILE_FLAG_BACKUP_SEMANTICS
78+ , fILE_LIST_DIRECTORY
79+ , fILE_NOTIFY_CHANGE_FILE_NAME
80+ , fILE_NOTIFY_CHANGE_DIR_NAME
81+ , fILE_NOTIFY_CHANGE_ATTRIBUTES
82+ , fILE_NOTIFY_CHANGE_SIZE
83+ , fILE_NOTIFY_CHANGE_LAST_WRITE
84+ , fILE_NOTIFY_CHANGE_SECURITY
85+ , fILE_SHARE_READ
86+ , fILE_SHARE_WRITE
87+ , oPEN_EXISTING
88+ )
89+import System.Win32.Types (BOOL, DWORD, HANDLE, LPVOID, LPDWORD, failIfFalse_)
90+import qualified Data.List.NonEmpty as NonEmpty
91+import qualified Streamly.Internal.Data.Stream.IsStream as S
92+import qualified Streamly.Internal.Unicode.Stream as U
93+import qualified Streamly.Internal.Data.Array.Storable.Foreign as A
94+import Streamly.Internal.Data.Array.Storable.Foreign (Array)
95+
96+-- | Watch configuration, used to specify the events of interest and the
97+-- behavior of the watch.
98+--
99+-- /Internal/
100+--
101+data Config = Config
102+ { watchRec :: BOOL
103+ , createFlags :: DWORD
104+ }
105+
106+-------------------------------------------------------------------------------
107+-- Boolean settings
108+-------------------------------------------------------------------------------
109+
110+-- | Whether a setting is 'On' or 'Off'.
111+--
112+-- /Internal/
113+--
114+data Toggle = On | Off
115+
116+setFlag :: DWORD -> Toggle -> Config -> Config
117+setFlag mask status cfg@Config{..} =
118+ let flags =
119+ case status of
120+ On -> createFlags .|. mask
121+ Off -> createFlags .&. complement mask
122+ in cfg {createFlags = flags}
123+
124+-- | Set watch event on directory recursively.
125+--
126+-- /default: On/
127+--
128+-- /Internal/
129+--
130+setRecursiveMode :: BOOL -> Config -> Config
131+setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}
132+
133+-- | Report when a file name is modified.
134+--
135+-- /default: On/
136+--
137+-- /Internal/
138+--
139+setModifiedFileName :: Toggle -> Config -> Config
140+setModifiedFileName = setFlag fILE_NOTIFY_CHANGE_FILE_NAME
141+
142+-- | Report when a directory name is modified.
143+--
144+-- /default: On/
145+--
146+-- /Internal/
147+--
148+setModifiedDirName :: Toggle -> Config -> Config
149+setModifiedDirName = setFlag fILE_NOTIFY_CHANGE_DIR_NAME
150+
151+-- | Report when a file attribute is modified.
152+--
153+-- /default: On/
154+--
155+-- /Internal/
156+--
157+setModifiedAttribute :: Toggle -> Config -> Config
158+setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES
159+
160+-- | Report when a file size is changed.
161+--
162+-- /default: On/
163+--
164+-- /Internal/
165+--
166+setModifiedSize :: Toggle -> Config -> Config
167+setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
168+
169+-- | Report when a file last write time is changed.
170+--
171+-- /default: On/
172+--
173+-- /Internal/
174+--
175+setModifiedLastWrite :: Toggle -> Config -> Config
176+setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
177+
178+-- | Report when a file Security attributes is changed.
179+--
180+-- /default: On/
181+--
182+-- /Internal/
183+--
184+setModifiedSecurity :: Toggle -> Config -> Config
185+setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY
186+
187+-- | Set all events 'On' or 'Off'.
188+--
189+-- /default: On/
190+--
191+-- /Internal/
192+--
193+setAllEvents :: Toggle -> Config -> Config
194+setAllEvents s =
195+ setModifiedFileName s
196+ . setModifiedDirName s
197+ . setModifiedAttribute s
198+ . setModifiedSize s
199+ . setModifiedLastWrite s
200+ . setModifiedSecurity s
201+
202+defaultConfig :: Config
203+defaultConfig = setAllEvents On $ Config {watchRec = True, createFlags = 0}
204+
205+getConfigFlag :: Config -> DWORD
206+getConfigFlag Config{..} = createFlags
207+
208+getConfigRecMode :: Config -> BOOL
209+getConfigRecMode Config{..} = watchRec
210+
211+data Event = Event
212+ { eventFlags :: DWORD
213+ , eventRelPath :: String
214+ , eventRootPath :: String
215+ , totalBytes :: DWORD
216+ } deriving (Show, Ord, Eq)
217+
218+-- For reference documentation see:
219+--
220+-- See https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information
221+data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION
222+ { fniNextEntryOffset :: DWORD
223+ , fniAction :: DWORD
224+ , fniFileName :: String
225+ } deriving Show
226+
227+type LPOVERLAPPED_COMPLETION_ROUTINE =
228+ FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())
229+
230+-- | A handle for a watch.
231+getWatchHandle :: FilePath -> IO (HANDLE, FilePath)
232+getWatchHandle dir = do
233+ h <- createFile dir
234+ -- Access mode
235+ fILE_LIST_DIRECTORY
236+ -- Share mode
237+ (fILE_SHARE_READ .|. fILE_SHARE_WRITE)
238+ -- Security attributes
239+ Nothing
240+ -- Create mode, we want to look at an existing directory
241+ oPEN_EXISTING
242+ -- File attribute, NOT using OVERLAPPED since we work synchronously
243+ fILE_FLAG_BACKUP_SEMANTICS
244+ -- No template file
245+ Nothing
246+ return (h, dir)
247+
248+-- For reference documentation see:
249+--
250+-- See https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-readdirectorychangesw
251+-- Note that this API uses UTF-16 for file system paths:
252+-- 1. https://docs.microsoft.com/en-us/windows/win32/intl/unicode-in-the-windows-api
253+-- 2. https://docs.microsoft.com/en-us/windows/win32/intl/unicode
254+foreign import ccall safe
255+ "windows.h ReadDirectoryChangesW" c_ReadDirectoryChangesW ::
256+ HANDLE -> LPVOID -> DWORD -> BOOL -> DWORD -> LPDWORD
257+ -> LPOVERLAPPED -> LPOVERLAPPED_COMPLETION_ROUTINE -> IO BOOL
258+
259+readDirectoryChangesW ::
260+ HANDLE -> Ptr FILE_NOTIFY_INFORMATION -> DWORD
261+ -> BOOL -> FileNotificationFlag -> LPDWORD -> IO ()
262+
263+readDirectoryChangesW h buf bufSize wst f br =
264+ failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf)
265+ bufSize wst f br nullPtr nullFunPtr
266+
267+peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION
268+peekFNI buf = do
269+ neof <- peekByteOff buf 0
270+ acti <- peekByteOff buf 4
271+ fnle <- peekByteOff buf 8
272+ fnam <- peekCWStringLen
273+ -- start of array
274+ (buf `plusPtr` 12,
275+ -- fnle is the length in *bytes*, and a WCHAR is 2 bytes
276+ fromEnum (fnle :: DWORD) `div` 2)
277+ return $ FILE_NOTIFY_INFORMATION neof acti fnam
278+
279+readChangeEvents :: Ptr FILE_NOTIFY_INFORMATION -> String -> DWORD -> IO [Event]
280+readChangeEvents pfni root bytesRet = do
281+ fni <- peekFNI pfni
282+ let entry = Event
283+ { eventFlags = fniAction fni
284+ , eventRelPath = fniFileName fni
285+ , eventRootPath = root
286+ , totalBytes = bytesRet
287+ }
288+ nioff = fromEnum $ fniNextEntryOffset fni
289+ entries <- if nioff == 0
290+ then return []
291+ else readChangeEvents (pfni `plusPtr` nioff) root bytesRet
292+ return $ entry :entries
293+
294+readDirectoryChanges ::
295+ String -> HANDLE -> Bool -> FileNotificationFlag -> IO [Event]
296+readDirectoryChanges root h wst mask = do
297+ let maxBuf = 63 * 1024
298+ allocaBytes maxBuf $ \buffer -> do
299+ alloca $ \bret -> do
300+ readDirectoryChangesW h buffer (toEnum maxBuf) wst mask bret
301+ bytesRet <- peekByteOff bret 0
302+ readChangeEvents buffer root bytesRet
303+
304+type FileAction = DWORD
305+
306+fILE_ACTION_ADDED :: FileAction
307+fILE_ACTION_ADDED = 1
308+
309+fILE_ACTION_REMOVED :: FileAction
310+fILE_ACTION_REMOVED = 2
311+
312+fILE_ACTION_MODIFIED :: FileAction
313+fILE_ACTION_MODIFIED = 3
314+
315+fILE_ACTION_RENAMED_OLD_NAME :: FileAction
316+fILE_ACTION_RENAMED_OLD_NAME = 4
317+
318+fILE_ACTION_RENAMED_NEW_NAME :: FileAction
319+fILE_ACTION_RENAMED_NEW_NAME = 5
320+
321+eventStreamAggr :: (HANDLE, FilePath, Config) -> SerialT IO Event
322+eventStreamAggr (handle, rootPath, cfg) = do
323+ let recMode = getConfigRecMode cfg
324+ flagMasks = getConfigFlag cfg
325+ S.concatMap S.fromList $ S.repeatM
326+ $ readDirectoryChanges rootPath handle recMode flagMasks
327+
328+pathsToHandles ::
329+ NonEmpty FilePath -> Config -> SerialT IO (HANDLE, FilePath, Config)
330+pathsToHandles paths cfg = do
331+ let pathStream = S.fromList (NonEmpty.toList paths)
332+ st2 = S.mapM getWatchHandle pathStream
333+ S.map (\(h, f) -> (h, f, cfg)) st2
334+
335+-------------------------------------------------------------------------------
336+-- Utilities
337+-------------------------------------------------------------------------------
338+utf8ToString :: Array Word8 -> FilePath
339+utf8ToString = runIdentity . S.toList . U.decodeUtf8 . A.toStream
340+
341+utf8ToStringList :: NonEmpty (Array Word8) -> NonEmpty FilePath
342+utf8ToStringList = NonEmpty.map utf8ToString
343+
344+-- | Close a Directory handle.
345+--
346+-- /Internal/
347+--
348+closePathHandleStream :: SerialT IO (HANDLE, FilePath, Config) -> IO ()
349+closePathHandleStream = S.mapM_ (\(h, _, _) -> closeHandle h)
350+
351+-- | Start monitoring a list of file system paths for file system events with
352+-- the supplied configuration operation over the 'defaultConfig'. The
353+-- paths could be files or directories. When the path is a directory, only the
354+-- files and directories directly under the watched directory are monitored,
355+-- contents of subdirectories are not monitored. Monitoring starts from the
356+-- current time onwards.
357+--
358+-- /Internal/
359+--
360+watchPathsWith ::
361+ (Config -> Config)
362+ -> NonEmpty (Array Word8)
363+ -> SerialT IO Event
364+watchPathsWith f paths =
365+ S.bracket before after (S.concatMapWith parallel eventStreamAggr)
366+
367+ where
368+
369+ before = return $ pathsToHandles (utf8ToStringList paths)
370+ (f $ setRecursiveMode False defaultConfig)
371+ after = liftIO . closePathHandleStream
372+
373+-- | Like 'watchPathsWith' but uses the 'defaultConfig' options.
374+--
375+-- @
376+-- watchPaths = watchPathsWith id
377+-- @
378+--
379+-- /Internal/
380+--
381+watchPaths :: NonEmpty (Array Word8) -> SerialT IO Event
382+watchPaths = watchPathsWith id
383+
384+-- | Start monitoring a list of file system paths for file system events with
385+-- the supplied configuration operation over the 'defaultConfig'. The
386+-- paths could be files or directories. When the path is a directory, the
387+-- whole directory tree under it is watched recursively. Monitoring starts from
388+-- the current time onwards.
389+--
390+-- /Internal/
391+--
392+watchTreesWith ::
393+ (Config -> Config)
394+ -> NonEmpty (Array Word8)
395+ -> SerialT IO Event
396+watchTreesWith f paths =
397+ S.bracket before after (S.concatMapWith parallel eventStreamAggr)
398+
399+ where
400+
401+ before = return $ pathsToHandles (utf8ToStringList paths)
402+ (f $ setRecursiveMode True defaultConfig)
403+ after = liftIO . closePathHandleStream
404+
405+-- | Like 'watchTreesWith' but uses the 'defaultConfig' options.
406+--
407+-- @
408+-- watchTrees = watchTreesWith id
409+-- @
410+--
411+watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event
412+watchTrees = watchTreesWith id
413+
414+
415+getFlag :: DWORD -> Event -> Bool
416+getFlag mask Event{..} = eventFlags == mask
417+
418+getRelPath :: Event -> String
419+getRelPath Event{..} = eventRelPath
420+
421+getRoot :: Event -> String
422+getRoot Event{..} = eventRootPath
423+
424+isCreated :: Event -> Bool
425+isCreated = getFlag fILE_ACTION_ADDED
426+
427+isDeleted :: Event -> Bool
428+isDeleted = getFlag fILE_ACTION_REMOVED
429+
430+isMovedFrom :: Event -> Bool
431+isMovedFrom = getFlag fILE_ACTION_RENAMED_OLD_NAME
432+
433+isMovedTo :: Event -> Bool
434+isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME
435+
436+isModified :: Event -> Bool
437+isModified = getFlag fILE_ACTION_MODIFIED
438+
439+-- | If the buffer overflows, ReadDirectoryChangesW will still return true,
440+-- but the entire contents of the buffer are discarded.
441+isOverflow :: Event -> Bool
442+isOverflow Event{..} = totalBytes == 0
443+
444+-------------------------------------------------------------------------------
445+-- Debugging
446+-------------------------------------------------------------------------------
447+
448+-- | Convert an 'Event' record to a String representation.
449+showEvent :: Event -> String
450+showEvent ev@Event{..} =
451+ "--------------------------"
452+ ++ "\nRoot = " ++ show (getRoot ev)
453+ ++ "\nPath = " ++ show (getRelPath ev)
454+ ++ "\nFlags " ++ show eventFlags
455+ ++ showev isOverflow "Overflow"
456+ ++ showev isCreated "Created"
457+ ++ showev isDeleted "Deleted"
458+ ++ showev isModified "Modified"
459+ ++ showev isMovedFrom "MovedFrom"
460+ ++ showev isMovedTo "MovedTo"
461+ ++ "\n"
462+
463+ where showev f str = if f ev then "\n" ++ str else ""