git.iko.soy/streamly
on bda8cac help sign in
streamly/src/Streamly/Internal/FileSystem/Event/Windows.hs
558 lines 16 kB history raw
1-- Some code snippets are adapted from the fsnotify package.
2-- http://hackage.haskell.org/package/fsnotify-0.3.0.1/
3--
4-- |
5-- Module : Streamly.Internal.FileSystem.Event.Windows
6-- Copyright : (c) 2020 Composewell Technologies
7-- (c) 2012, Mark Dittmer
8-- License : BSD-3-Clause
9-- Maintainer : streamly@composewell.com
10-- Stability : experimental
11-- Portability : GHC
12--
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
45module Streamly.Internal.FileSystem.Event.Windows
46 (
47 -- * Subscribing to events
49 -- ** Default configuration
50 Config
51 , Event
52 , Toggle (..)
53 , setFlag
54 , defaultConfig
55 , getConfigFlag
56 , setAllEvents
58 -- ** Watch Behavior
59 , setRecursiveMode
61 -- ** Events of Interest
62 -- *** Root Level Events
63 , setModifiedFileName
64 , setModifiedDirName
65 , setModifiedAttribute
66 , setModifiedSize
67 , setModifiedLastWrite
68 , setModifiedSecurity
70 -- ** Watch APIs
71 , watchPaths
72 , watchPathsWith
73 , watchTrees
74 , watchTreesWith
76 -- * Handling Events
77 , getRelPath
78 , getRoot
80 -- ** Item CRUD events
81 , isCreated
82 , isDeleted
83 , isMovedFrom
84 , isMovedTo
85 , isModified
87 -- ** Exception Conditions
88 , isOverflow
90 -- * Debugging
91 , showEvent
92 )
93where
95import Control.Monad.IO.Class (MonadIO(liftIO))
96import Data.Bits ((.|.), (.&.), complement)
97import Data.Functor.Identity (runIdentity)
98import Data.List.NonEmpty (NonEmpty)
99import Data.Word (Word8)
100import Foreign.C.String (peekCWStringLen)
101import Foreign.Marshal.Alloc (alloca, allocaBytes)
102import Foreign.Storable (peekByteOff)
103import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr)
104import Streamly.Prelude (SerialT, parallel)
105import System.Win32.File
106 ( FileNotificationFlag
107 , LPOVERLAPPED
108 , closeHandle
109 , createFile
110 , fILE_FLAG_BACKUP_SEMANTICS
111 , fILE_LIST_DIRECTORY
112 , fILE_NOTIFY_CHANGE_FILE_NAME
113 , fILE_NOTIFY_CHANGE_DIR_NAME
114 , fILE_NOTIFY_CHANGE_ATTRIBUTES
115 , fILE_NOTIFY_CHANGE_SIZE
116 , fILE_NOTIFY_CHANGE_LAST_WRITE
117 , fILE_NOTIFY_CHANGE_SECURITY
118 , fILE_SHARE_READ
119 , fILE_SHARE_WRITE
120 , oPEN_EXISTING
121 )
122import System.Win32.Types (BOOL, DWORD, HANDLE, LPVOID, LPDWORD, failIfFalse_)
123import qualified Data.List.NonEmpty as NonEmpty
124import qualified Streamly.Internal.Data.Stream.IsStream as S
125import qualified Streamly.Internal.Unicode.Stream as U
126import qualified Streamly.Internal.Data.Array.Storable.Foreign as A
127import Streamly.Internal.Data.Array.Storable.Foreign (Array)
129-- | Watch configuration, used to specify the events of interest and the
130-- behavior of the watch.
131--
132-- /Internal/
133--
134data Config = Config
135 { watchRec :: BOOL
136 , createFlags :: DWORD
137 }
139-------------------------------------------------------------------------------
140-- Boolean settings
141-------------------------------------------------------------------------------
143-- | Whether a setting is 'On' or 'Off'.
144--
145-- /Internal/
146--
147data Toggle = On | Off
149setFlag :: DWORD -> Toggle -> Config -> Config
150setFlag mask status cfg@Config{..} =
151 let flags =
152 case status of
153 On -> createFlags .|. mask
154 Off -> createFlags .&. complement mask
155 in cfg {createFlags = flags}
157-- | Set watch event on directory recursively.
158--
159-- /default: On/
160--
161-- /Internal/
162--
163setRecursiveMode :: BOOL -> Config -> Config
164setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}
166-- | Report when a file name is modified.
167--
168-- /default: On/
169--
170-- /Internal/
171--
172setModifiedFileName :: Toggle -> Config -> Config
173setModifiedFileName = setFlag fILE_NOTIFY_CHANGE_FILE_NAME
175-- | Report when a directory name is modified.
176--
177-- /default: On/
178--
179-- /Internal/
180--
181setModifiedDirName :: Toggle -> Config -> Config
182setModifiedDirName = setFlag fILE_NOTIFY_CHANGE_DIR_NAME
184-- | Report when a file attribute is modified.
185--
186-- /default: On/
187--
188-- /Internal/
189--
190setModifiedAttribute :: Toggle -> Config -> Config
191setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES
193-- | Report when a file size is changed.
194--
195-- /default: On/
196--
197-- /Internal/
198--
199setModifiedSize :: Toggle -> Config -> Config
200setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
202-- | Report when a file last write time is changed.
203--
204-- /default: On/
205--
206-- /Internal/
207--
208setModifiedLastWrite :: Toggle -> Config -> Config
209setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
211-- | Report when a file Security attributes is changed.
212--
213-- /default: On/
214--
215-- /Internal/
216--
217setModifiedSecurity :: Toggle -> Config -> Config
218setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY
220-- | Set all events 'On' or 'Off'.
221--
222-- /default: On/
223--
224-- /Internal/
225--
226setAllEvents :: Toggle -> Config -> Config
227setAllEvents s =
228 setModifiedFileName s
229 . setModifiedDirName s
230 . setModifiedAttribute s
231 . setModifiedSize s
232 . setModifiedLastWrite s
233 . setModifiedSecurity s
235defaultConfig :: Config
236defaultConfig = setAllEvents On $ Config {watchRec = True, createFlags = 0}
238getConfigFlag :: Config -> DWORD
239getConfigFlag Config{..} = createFlags
241getConfigRecMode :: Config -> BOOL
242getConfigRecMode Config{..} = watchRec
244data Event = Event
245 { eventFlags :: DWORD
246 , eventRelPath :: String
247 , eventRootPath :: String
248 , totalBytes :: DWORD
249 } deriving (Show, Ord, Eq)
251-- For reference documentation see:
252--
253-- See https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information
254data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION
255 { fniNextEntryOffset :: DWORD
256 , fniAction :: DWORD
257 , fniFileName :: String
258 } deriving Show
260type LPOVERLAPPED_COMPLETION_ROUTINE =
261 FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())
263-- | A handle for a watch.
264getWatchHandle :: FilePath -> IO (HANDLE, FilePath)
265getWatchHandle dir = do
266 h <- createFile dir
267 -- Access mode
268 fILE_LIST_DIRECTORY
269 -- Share mode
270 (fILE_SHARE_READ .|. fILE_SHARE_WRITE)
271 -- Security attributes
272 Nothing
273 -- Create mode, we want to look at an existing directory
274 oPEN_EXISTING
275 -- File attribute, NOT using OVERLAPPED since we work synchronously
276 fILE_FLAG_BACKUP_SEMANTICS
277 -- No template file
278 Nothing
279 return (h, dir)
281-- For reference documentation see:
282--
283-- See https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-readdirectorychangesw
284-- Note that this API uses UTF-16 for file system paths:
285-- 1. https://docs.microsoft.com/en-us/windows/win32/intl/unicode-in-the-windows-api
286-- 2. https://docs.microsoft.com/en-us/windows/win32/intl/unicode
287foreign import ccall safe
288 "windows.h ReadDirectoryChangesW" c_ReadDirectoryChangesW ::
289 HANDLE
290 -> LPVOID
291 -> DWORD
292 -> BOOL
293 -> DWORD
294 -> LPDWORD
295 -> LPOVERLAPPED
296 -> LPOVERLAPPED_COMPLETION_ROUTINE
297 -> IO BOOL
299readDirectoryChangesW ::
300 HANDLE
301 -> Ptr FILE_NOTIFY_INFORMATION
302 -> DWORD
303 -> BOOL
304 -> FileNotificationFlag
305 -> LPDWORD
306 -> IO ()
307readDirectoryChangesW h buf bufSize wst f br =
308 let res = c_ReadDirectoryChangesW
309 h (castPtr buf) bufSize wst f br nullPtr nullFunPtr
310 in failIfFalse_ "ReadDirectoryChangesW" res
312peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION
313peekFNI buf = do
314 neof <- peekByteOff buf 0
315 acti <- peekByteOff buf 4
316 fnle <- peekByteOff buf 8
317 -- Note: The path is UTF-16 encoded C WChars, peekCWStringLen converts
318 -- UTF-16 to UTF-32 Char String
319 fnam <- peekCWStringLen
320 -- start of array
321 (buf `plusPtr` 12,
322 -- fnle is the length in *bytes*, and a WCHAR is 2 bytes
323 fromEnum (fnle :: DWORD) `div` 2)
324 return $ FILE_NOTIFY_INFORMATION neof acti fnam
326readChangeEvents ::
327 Ptr FILE_NOTIFY_INFORMATION -> String -> DWORD -> IO [Event]
328readChangeEvents pfni root bytesRet = do
329 fni <- peekFNI pfni
330 let entry = Event
331 { eventFlags = fniAction fni
332 , eventRelPath = fniFileName fni
333 , eventRootPath = root
334 , totalBytes = bytesRet
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
343readDirectoryChanges ::
344 String -> HANDLE -> Bool -> FileNotificationFlag -> IO [Event]
345readDirectoryChanges root h wst mask = do
346 let maxBuf = 63 * 1024
347 allocaBytes maxBuf $ \buffer -> do
348 alloca $ \bret -> do
349 readDirectoryChangesW h buffer (toEnum maxBuf) wst mask bret
350 bytesRet <- peekByteOff bret 0
351 readChangeEvents buffer root bytesRet
353type FileAction = DWORD
355fILE_ACTION_ADDED :: FileAction
356fILE_ACTION_ADDED = 1
358fILE_ACTION_REMOVED :: FileAction
359fILE_ACTION_REMOVED = 2
361fILE_ACTION_MODIFIED :: FileAction
362fILE_ACTION_MODIFIED = 3
364fILE_ACTION_RENAMED_OLD_NAME :: FileAction
365fILE_ACTION_RENAMED_OLD_NAME = 4
367fILE_ACTION_RENAMED_NEW_NAME :: FileAction
368fILE_ACTION_RENAMED_NEW_NAME = 5
370eventStreamAggr :: (HANDLE, FilePath, Config) -> SerialT IO Event
371eventStreamAggr (handle, rootPath, cfg) = do
372 let recMode = getConfigRecMode cfg
373 flagMasks = getConfigFlag cfg
374 S.concatMap S.fromList $ S.repeatM
375 $ readDirectoryChanges rootPath handle recMode flagMasks
377pathsToHandles ::
378 NonEmpty FilePath -> Config -> SerialT IO (HANDLE, FilePath, Config)
379pathsToHandles paths cfg = do
380 let pathStream = S.fromList (NonEmpty.toList paths)
381 st2 = S.mapM getWatchHandle pathStream
382 S.map (\(h, f) -> (h, f, cfg)) st2
384-------------------------------------------------------------------------------
385-- Utilities
386-------------------------------------------------------------------------------
388utf8ToString :: Array Word8 -> FilePath
389utf8ToString = runIdentity . S.toList . U.decodeUtf8 . A.toStream
391utf8ToStringList :: NonEmpty (Array Word8) -> NonEmpty FilePath
392utf8ToStringList = NonEmpty.map utf8ToString
394-- | Close a Directory handle.
395--
396-- /Internal/
397--
398closePathHandleStream :: SerialT IO (HANDLE, FilePath, Config) -> IO ()
399closePathHandleStream = S.mapM_ (\(h, _, _) -> closeHandle h)
401-- | Start monitoring a list of file system paths for file system events with
402-- the supplied configuration operation over the 'defaultConfig'. The
403-- paths could be files or directories. When the path is a directory, only the
404-- files and directories directly under the watched directory are monitored,
405-- contents of subdirectories are not monitored. Monitoring starts from the
406-- current time onwards.
407--
408-- /Internal/
409--
410watchPathsWith ::
411 (Config -> Config)
412 -> NonEmpty (Array Word8)
413 -> SerialT IO Event
414watchPathsWith f paths =
415 S.bracket before after (S.concatMapWith parallel eventStreamAggr)
417 where
419 before =
420 let cfg = f $ setRecursiveMode False defaultConfig
421 in return $ pathsToHandles (utf8ToStringList paths) cfg
422 after = liftIO . closePathHandleStream
424-- | Like 'watchPathsWith' but uses the 'defaultConfig' options.
425--
426-- @
427-- watchPaths = watchPathsWith id
428-- @
429--
430-- /Internal/
431--
432watchPaths :: NonEmpty (Array Word8) -> SerialT IO Event
433watchPaths = watchPathsWith id
435-- | Start monitoring a list of file system paths for file system events with
436-- the supplied configuration operation over the 'defaultConfig'. The
437-- paths could be files or directories. When the path is a directory, the
438-- whole directory tree under it is watched recursively. Monitoring starts from
439-- the current time onwards.
440--
441-- /Internal/
442--
443watchTreesWith ::
444 (Config -> Config)
445 -> NonEmpty (Array Word8)
446 -> SerialT IO Event
447watchTreesWith f paths =
448 S.bracket before after (S.concatMapWith parallel eventStreamAggr)
450 where
452 before =
453 let cfg = f $ setRecursiveMode True defaultConfig
454 in return $ pathsToHandles (utf8ToStringList paths) cfg
455 after = liftIO . closePathHandleStream
457-- | Like 'watchTreesWith' but uses the 'defaultConfig' options.
458--
459-- @
460-- watchTrees = watchTreesWith id
461-- @
462--
463watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event
464watchTrees = watchTreesWith id
466getFlag :: DWORD -> Event -> Bool
467getFlag mask Event{..} = eventFlags == mask
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--
476getRelPath :: Event -> String
477getRelPath Event{..} = eventRelPath
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--
485getRoot :: Event -> String
486getRoot Event{..} = eventRootPath
488-- XXX need to document the exact semantics of these.
489--
490-- | File/directory created in watched directory.
491--
492-- /Internal/
493--
494isCreated :: Event -> Bool
495isCreated = getFlag fILE_ACTION_ADDED
497-- | File/directory deleted from watched directory.
498--
499-- /Internal/
500--
501isDeleted :: Event -> Bool
502isDeleted = getFlag fILE_ACTION_REMOVED
504-- | Generated for the original path when an object is moved from under a
505-- monitored directory.
506--
507-- /Internal/
508--
509isMovedFrom :: Event -> Bool
510isMovedFrom = getFlag fILE_ACTION_RENAMED_OLD_NAME
512-- | Generated for the new path when an object is moved under a monitored
513-- directory.
514--
515-- /Internal/
516--
517isMovedTo :: Event -> Bool
518isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME
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--
527isModified :: Event -> Bool
528isModified = getFlag fILE_ACTION_MODIFIED
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--
536isOverflow :: Event -> Bool
537isOverflow Event{..} = totalBytes == 0
539-------------------------------------------------------------------------------
540-- Debugging
541-------------------------------------------------------------------------------
543-- | Convert an 'Event' record to a String representation.
544showEvent :: Event -> String
545showEvent ev@Event{..} =
546 "--------------------------"
547 ++ "\nRoot = " ++ show (getRoot ev)
548 ++ "\nPath = " ++ show (getRelPath ev)
549 ++ "\nFlags " ++ show eventFlags
550 ++ showev isOverflow "Overflow"
551 ++ showev isCreated "Created"
552 ++ showev isDeleted "Deleted"
553 ++ showev isModified "Modified"
554 ++ showev isMovedFrom "MovedFrom"
555 ++ showev isMovedTo "MovedTo"
556 ++ "\n"
558 where showev f str = if f ev then "\n" ++ str else ""