@@ -1,25 +1,58 @@
1+-- Some code snippets are adapted from the fsnotify package.
2+-- http://hackage.haskell.org/package/fsnotify-0.3.0.1/
3+--
14-- |
25-- Module : Streamly.Internal.FileSystem.Event.Windows
36-- Copyright : (c) 2020 Composewell Technologies
4−--
5−-- License : BSD3
7+-- (c) 2012, Mark Dittmer
8+-- License : BSD-3-Clause
69-- Maintainer : streamly@composewell.com
710-- Stability : experimental
811-- Portability : GHC
912--
10−-- Just report all events under the paths provided as arguments
13+-- =Overview
14+--
15+-- Use 'watchTrees'or 'watchPaths' with a list of file system paths you want to
16+-- watch as argument. It returns a stream of 'Event' representing the file
17+-- system events occurring under the watched paths.
18+--
19+-- @
20+-- {-\# LANGUAGE MagicHash #-}
21+-- Stream.mapM_ (putStrLn . 'showEvent') $ 'watchTrees' [Array.fromCString\# "path"#]
22+-- @
23+--
24+-- 'Event' is an opaque type. Accessor functions (e.g. 'showEvent' above)
25+-- provided in this module are used to determine the attributes of the event.
26+--
27+-- =Design notes
28+--
29+-- For Windows reference documentation see:
30+--
31+-- * <https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information file notify information>
32+-- * <https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-readdirectorychangesw read directory changes>
33+--
34+-- We try to keep the macOS\/Linux/Windows event handling APIs and defaults
35+-- semantically and syntactically as close as possible.
36+--
37+-- =Availability
38+--
39+-- As per the Windows reference docs, the fs event notification API is
40+-- available in:
41+--
42+-- * Minimum supported client: Windows XP [desktop apps | UWP apps]
43+-- * Minimum supported server: Windows Server 2003 [desktop apps | UWP apps
1144
1245module Streamly.Internal.FileSystem.Event.Windows
13− (
46+ (
1447 -- * Subscribing to events
1548
16− -- ** Default configuration
49+ -- ** Default configuration
1750 Config
1851 , Event
1952 , Toggle (..)
20− , setFlag
53+ , setFlag
2154 , defaultConfig
22− , getConfigFlag
55+ , getConfigFlag
2356 , setAllEvents
2457
2558 -- ** Watch Behavior
@@ -32,44 +65,44 @@ module Streamly.Internal.FileSystem.Event.Windows
3265 , setModifiedAttribute
3366 , setModifiedSize
3467 , setModifiedLastWrite
35− , setModifiedSecurity
68+ , setModifiedSecurity
3669
3770 -- ** Watch APIs
3871 , watchPaths
3972 , watchPathsWith
4073 , watchTrees
41− , watchTreesWith
42−
74+ , watchTreesWith
75+
4376 -- * Handling Events
44− , getRelPath
77+ , getRelPath
4578 , getRoot
4679
4780 -- ** Item CRUD events
4881 , isCreated
49− , isDeleted
82+ , isDeleted
5083 , isMovedFrom
5184 , isMovedTo
52− , isModified
85+ , isModified
5386
5487 -- ** Exception Conditions
5588 , isOverflow
5689
5790 -- * Debugging
58− , showEvent
59− )
91+ , showEvent
92+ )
6093where
6194
6295import Control.Monad.IO.Class (MonadIO(liftIO))
63−import Data.Bits ((.|.), (.&.), complement)
64−import Data.Functor.Identity (runIdentity)
96+import Data.Bits ((.|.), (.&.), complement)
97+import Data.Functor.Identity (runIdentity)
6598import Data.List.NonEmpty (NonEmpty)
6699import Data.Word (Word8)
67100import Foreign.C.String (peekCWStringLen)
68101import Foreign.Marshal.Alloc (alloca, allocaBytes)
69−import Foreign.Storable (peekByteOff)
70−import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr)
102+import Foreign.Storable (peekByteOff)
103+import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr)
71104import Streamly.Prelude (SerialT, parallel)
72−import System.Win32.File
105+import System.Win32.File
73106 ( FileNotificationFlag
74107 , LPOVERLAPPED
75108 , closeHandle
@@ -81,10 +114,10 @@ import System.Win32.File
81114 , fILE_NOTIFY_CHANGE_ATTRIBUTES
82115 , fILE_NOTIFY_CHANGE_SIZE
83116 , fILE_NOTIFY_CHANGE_LAST_WRITE
84− , fILE_NOTIFY_CHANGE_SECURITY
117+ , fILE_NOTIFY_CHANGE_SECURITY
85118 , fILE_SHARE_READ
86119 , fILE_SHARE_WRITE
87− , oPEN_EXISTING
120+ , oPEN_EXISTING
88121 )
89122import System.Win32.Types (BOOL, DWORD, HANDLE, LPVOID, LPDWORD, failIfFalse_)
90123import qualified Data.List.NonEmpty as NonEmpty
@@ -100,7 +133,7 @@ import Streamly.Internal.Data.Array.Storable.Foreign (Array)
100133--
101134data Config = Config
102135 { watchRec :: BOOL
103− , createFlags :: DWORD
136+ , createFlags :: DWORD
104137 }
105138
106139-------------------------------------------------------------------------------
@@ -164,7 +197,7 @@ setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES
164197-- /Internal/
165198--
166199setModifiedSize :: Toggle -> Config -> Config
167−setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
200+setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
168201
169202-- | Report when a file last write time is changed.
170203--
@@ -173,7 +206,7 @@ setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
173206-- /Internal/
174207--
175208setModifiedLastWrite :: Toggle -> Config -> Config
176−setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
209+setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
177210
178211-- | Report when a file Security attributes is changed.
179212--
@@ -182,7 +215,7 @@ setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
182215-- /Internal/
183216--
184217setModifiedSecurity :: Toggle -> Config -> Config
185−setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY
218+setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY
186219
187220-- | Set all events 'On' or 'Off'.
188221--
@@ -197,7 +230,7 @@ setAllEvents s =
197230 . setModifiedAttribute s
198231 . setModifiedSize s
199232 . setModifiedLastWrite s
200− . setModifiedSecurity s
233+ . setModifiedSecurity s
201234
202235defaultConfig :: Config
203236defaultConfig = setAllEvents On $ Config {watchRec = True, createFlags = 0}
@@ -209,22 +242,22 @@ getConfigRecMode :: Config -> BOOL
209242getConfigRecMode Config{..} = watchRec
210243
211244data Event = Event
212− { eventFlags :: DWORD
213− , eventRelPath :: String
214− , eventRootPath :: String
245+ { eventFlags :: DWORD
246+ , eventRelPath :: String
247+ , eventRootPath :: String
215248 , totalBytes :: DWORD
216− } deriving (Show, Ord, Eq)
249+ } deriving (Show, Ord, Eq)
217250
218251-- For reference documentation see:
219−--
252+--
220253-- See https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information
221254data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION
222255 { fniNextEntryOffset :: DWORD
223256 , fniAction :: DWORD
224257 , fniFileName :: String
225− } deriving Show
258+ } deriving Show
226259
227−type LPOVERLAPPED_COMPLETION_ROUTINE =
260+type LPOVERLAPPED_COMPLETION_ROUTINE =
228261 FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())
229262
230263-- | A handle for a watch.
@@ -232,64 +265,80 @@ getWatchHandle :: FilePath -> IO (HANDLE, FilePath)
232265getWatchHandle dir = do
233266 h <- createFile dir
234267 -- Access mode
235− fILE_LIST_DIRECTORY
268+ fILE_LIST_DIRECTORY
236269 -- Share mode
237− (fILE_SHARE_READ .|. fILE_SHARE_WRITE)
270+ (fILE_SHARE_READ .|. fILE_SHARE_WRITE)
238271 -- Security attributes
239− Nothing
272+ Nothing
240273 -- Create mode, we want to look at an existing directory
241− oPEN_EXISTING
274+ oPEN_EXISTING
242275 -- File attribute, NOT using OVERLAPPED since we work synchronously
243− fILE_FLAG_BACKUP_SEMANTICS
276+ fILE_FLAG_BACKUP_SEMANTICS
244277 -- No template file
245− Nothing
278+ Nothing
246279 return (h, dir)
247−
280+
248281-- For reference documentation see:
249282--
250283-- 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:
284+-- Note that this API uses UTF-16 for file system paths:
252285-- 1. https://docs.microsoft.com/en-us/windows/win32/intl/unicode-in-the-windows-api
253286-- 2. https://docs.microsoft.com/en-us/windows/win32/intl/unicode
254−foreign import ccall safe
287+foreign import ccall safe
255288 "windows.h ReadDirectoryChangesW" c_ReadDirectoryChangesW ::
256− HANDLE -> LPVOID -> DWORD -> BOOL -> DWORD -> LPDWORD
257− -> LPOVERLAPPED -> LPOVERLAPPED_COMPLETION_ROUTINE -> IO BOOL
289+ HANDLE
290+ -> LPVOID
291+ -> DWORD
292+ -> BOOL
293+ -> DWORD
294+ -> LPDWORD
295+ -> LPOVERLAPPED
296+ -> LPOVERLAPPED_COMPLETION_ROUTINE
297+ -> IO BOOL
258298
259299readDirectoryChangesW ::
260− HANDLE -> Ptr FILE_NOTIFY_INFORMATION -> DWORD
261− -> BOOL -> FileNotificationFlag -> LPDWORD -> IO ()
262−
300+ HANDLE
301+ -> Ptr FILE_NOTIFY_INFORMATION
302+ -> DWORD
303+ -> BOOL
304+ -> FileNotificationFlag
305+ -> LPDWORD
306+ -> IO ()
263307readDirectoryChangesW h buf bufSize wst f br =
264− failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf)
265− bufSize wst f br nullPtr nullFunPtr
308+ let res = c_ReadDirectoryChangesW
309+ h (castPtr buf) bufSize wst f br nullPtr nullFunPtr
310+ in failIfFalse_ "ReadDirectoryChangesW" res
266311
267312peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION
268313peekFNI buf = do
269314 neof <- peekByteOff buf 0
270315 acti <- peekByteOff buf 4
271316 fnle <- peekByteOff buf 8
317+ -- Note: The path is UTF-16 encoded C WChars, peekCWStringLen converts
318+ -- UTF-16 to UTF-32 Char String
272319 fnam <- peekCWStringLen
273320 -- start of array
274321 (buf `plusPtr` 12,
275322 -- fnle is the length in *bytes*, and a WCHAR is 2 bytes
276− fromEnum (fnle :: DWORD) `div` 2)
323+ fromEnum (fnle :: DWORD) `div` 2)
277324 return $ FILE_NOTIFY_INFORMATION neof acti fnam
278325
279−readChangeEvents :: Ptr FILE_NOTIFY_INFORMATION -> String -> DWORD -> IO [Event]
280−readChangeEvents pfni root bytesRet = do
326+readChangeEvents ::
327+ Ptr FILE_NOTIFY_INFORMATION -> String -> DWORD -> IO [Event]
328+readChangeEvents pfni root bytesRet = do
281329 fni <- peekFNI pfni
282330 let entry = Event
283− { eventFlags = fniAction fni
284− , eventRelPath = fniFileName fni
331+ { eventFlags = fniAction fni
332+ , eventRelPath = fniFileName fni
285333 , eventRootPath = root
286334 , 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
335+ }
336+ nioff = fromEnum $ fniNextEntryOffset fni
337+ entries <-
338+ if nioff == 0
339+ then return []
340+ else readChangeEvents (pfni `plusPtr` nioff) root bytesRet
341+ return $ entry : entries
293342
294343readDirectoryChanges ::
295344 String -> HANDLE -> Bool -> FileNotificationFlag -> IO [Event]
@@ -300,7 +349,7 @@ readDirectoryChanges root h wst mask = do
300349 readDirectoryChangesW h buffer (toEnum maxBuf) wst mask bret
301350 bytesRet <- peekByteOff bret 0
302351 readChangeEvents buffer root bytesRet
303−
352+
304353type FileAction = DWORD
305354
306355fILE_ACTION_ADDED :: FileAction
@@ -322,19 +371,20 @@ eventStreamAggr :: (HANDLE, FilePath, Config) -> SerialT IO Event
322371eventStreamAggr (handle, rootPath, cfg) = do
323372 let recMode = getConfigRecMode cfg
324373 flagMasks = getConfigFlag cfg
325− S.concatMap S.fromList $ S.repeatM
374+ S.concatMap S.fromList $ S.repeatM
326375 $ readDirectoryChanges rootPath handle recMode flagMasks
327376
328−pathsToHandles ::
377+pathsToHandles ::
329378 NonEmpty FilePath -> Config -> SerialT IO (HANDLE, FilePath, Config)
330379pathsToHandles paths cfg = do
331380 let pathStream = S.fromList (NonEmpty.toList paths)
332381 st2 = S.mapM getWatchHandle pathStream
333− S.map (\(h, f) -> (h, f, cfg)) st2
382+ S.map (\(h, f) -> (h, f, cfg)) st2
334383
335384-------------------------------------------------------------------------------
336385-- Utilities
337386-------------------------------------------------------------------------------
387+
338388utf8ToString :: Array Word8 -> FilePath
339389utf8ToString = runIdentity . S.toList . U.decodeUtf8 . A.toStream
340390
@@ -357,17 +407,18 @@ closePathHandleStream = S.mapM_ (\(h, _, _) -> closeHandle h)
357407--
358408-- /Internal/
359409--
360−watchPathsWith ::
361− (Config -> Config)
362− -> NonEmpty (Array Word8)
410+watchPathsWith ::
411+ (Config -> Config)
412+ -> NonEmpty (Array Word8)
363413 -> SerialT IO Event
364414watchPathsWith f paths =
365415 S.bracket before after (S.concatMapWith parallel eventStreamAggr)
366416
367417 where
368418
369− before = return $ pathsToHandles (utf8ToStringList paths)
370− (f $ setRecursiveMode False defaultConfig)
419+ before =
420+ let cfg = f $ setRecursiveMode False defaultConfig
421+ in return $ pathsToHandles (utf8ToStringList paths) cfg
371422 after = liftIO . closePathHandleStream
372423
373424-- | Like 'watchPathsWith' but uses the 'defaultConfig' options.
@@ -389,17 +440,18 @@ watchPaths = watchPathsWith id
389440--
390441-- /Internal/
391442--
392−watchTreesWith ::
393− (Config -> Config)
394− -> NonEmpty (Array Word8)
395− -> SerialT IO Event
396−watchTreesWith f paths =
443+watchTreesWith ::
444+ (Config -> Config)
445+ -> NonEmpty (Array Word8)
446+ -> SerialT IO Event
447+watchTreesWith f paths =
397448 S.bracket before after (S.concatMapWith parallel eventStreamAggr)
398449
399450 where
400451
401− before = return $ pathsToHandles (utf8ToStringList paths)
402− (f $ setRecursiveMode True defaultConfig)
452+ before =
453+ let cfg = f $ setRecursiveMode True defaultConfig
454+ in return $ pathsToHandles (utf8ToStringList paths) cfg
403455 after = liftIO . closePathHandleStream
404456
405457-- | Like 'watchTreesWith' but uses the 'defaultConfig' options.
@@ -409,35 +461,78 @@ watchTreesWith f paths =
409461-- @
410462--
411463watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event
412−watchTrees = watchTreesWith id
413−
464+watchTrees = watchTreesWith id
414465
415466getFlag :: DWORD -> Event -> Bool
416467getFlag mask Event{..} = eventFlags == mask
417468
469+-- XXX Change the type to Array Word8 to make it compatible with other APIs.
470+--
471+-- | Get the file system object path for which the event is generated, relative
472+-- to the watched root. The path is a UTF-8 encoded array of bytes.
473+--
474+-- /Internal/
475+--
418476getRelPath :: Event -> String
419477getRelPath Event{..} = eventRelPath
420478
479+-- XXX Change the type to Array Word8 to make it compatible with other APIs.
480+--
481+-- | Get the watch root directory to which this event belongs.
482+--
483+-- /Internal/
484+--
421485getRoot :: Event -> String
422486getRoot Event{..} = eventRootPath
423487
488+-- XXX need to document the exact semantics of these.
489+--
490+-- | File/directory created in watched directory.
491+--
492+-- /Internal/
493+--
424494isCreated :: Event -> Bool
425495isCreated = getFlag fILE_ACTION_ADDED
426496
497+-- | File/directory deleted from watched directory.
498+--
499+-- /Internal/
500+--
427501isDeleted :: Event -> Bool
428502isDeleted = getFlag fILE_ACTION_REMOVED
429503
504+-- | Generated for the original path when an object is moved from under a
505+-- monitored directory.
506+--
507+-- /Internal/
508+--
430509isMovedFrom :: Event -> Bool
431510isMovedFrom = getFlag fILE_ACTION_RENAMED_OLD_NAME
432511
512+-- | Generated for the new path when an object is moved under a monitored
513+-- directory.
514+--
515+-- /Internal/
516+--
433517isMovedTo :: Event -> Bool
434518isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME
435519
520+-- XXX This event is generated only for files and not directories?
521+--
522+-- | Determine whether the event indicates modification of an object within the
523+-- monitored path.
524+--
525+-- /Internal/
526+--
436527isModified :: Event -> Bool
437528isModified = getFlag fILE_ACTION_MODIFIED
438529
439−-- | If the buffer overflows, ReadDirectoryChangesW will still return true,
440−-- but the entire contents of the buffer are discarded.
530+-- | If the buffer overflows, entire contents of the buffer are discarded,
531+-- therefore, events are lost. The user application must scan everything under
532+-- the watched paths to know the current state.
533+--
534+-- /Internal/
535+--
441536isOverflow :: Event -> Bool
442537isOverflow Event{..} = totalBytes == 0
443538
@@ -447,11 +542,11 @@ isOverflow Event{..} = totalBytes == 0
447542
448543-- | Convert an 'Event' record to a String representation.
449544showEvent :: Event -> String
450−showEvent ev@Event{..} =
545+showEvent ev@Event{..} =
451546 "--------------------------"
452547 ++ "\nRoot = " ++ show (getRoot ev)
453548 ++ "\nPath = " ++ show (getRelPath ev)
454− ++ "\nFlags " ++ show eventFlags
549+ ++ "\nFlags " ++ show eventFlags
455550 ++ showev isOverflow "Overflow"
456551 ++ showev isCreated "Created"
457552 ++ showev isDeleted "Deleted"
@@ -460,4 +555,4 @@ showEvent ev@Event{..} =
460555 ++ showev isMovedTo "MovedTo"
461556 ++ "\n"
462557
463− where showev f str = if f ev then "\n" ++ str else ""
558+ where showev f str = if f ev then "\n" ++ str else ""