git.iko.soy/streamly
on bb74cdd help sign in
streamly/src/Streamly/Internal/FileSystem/Event/Windows.hs
577 lines 17 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 : pre-release
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 , Toggle (..)
52 , defaultConfig
54 -- ** Watch Behavior
55 , setRecursiveMode
57 -- ** Events of Interest
58 , setRootMoved
59 , setModifiedFileName
60 , setModifiedAttribute
61 , setModifiedSize
62 , setModifiedLastWrite
63 , setModifiedSecurity
65 -- ** Watch APIs
66 , watch
67 , watchRecursive
68 , watchWith
70 -- * Handling Events
71 , Event(..)
72 , getRoot
73 , getRelPath
74 , getAbsPath
76 -- ** Item CRUD events
77 , isCreated
78 , isDeleted
79 , isModified
80 , isMoved
81 , isMovedFrom
82 , isMovedTo
84 -- ** Exception Conditions
85 , isEventsLost
87 -- * Debugging
88 , showEvent
89 )
90where
92import Control.Monad.IO.Class (MonadIO(liftIO))
93import Data.Bits ((.|.), (.&.), complement)
94import Data.Functor.Identity (runIdentity)
95import Data.List.NonEmpty (NonEmpty)
96import Data.Word (Word8)
97import Foreign.C.String (peekCWStringLen)
98import Foreign.Marshal.Alloc (alloca, allocaBytes)
99import Foreign.Storable (peekByteOff)
100import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr)
101import Streamly.Prelude (SerialT, parallel)
102import System.Win32.File
103 ( FileNotificationFlag
104 , LPOVERLAPPED
105 , closeHandle
106 , createFile
107 , fILE_FLAG_BACKUP_SEMANTICS
108 , fILE_LIST_DIRECTORY
109 , fILE_NOTIFY_CHANGE_FILE_NAME
110 , fILE_NOTIFY_CHANGE_DIR_NAME
111 , fILE_NOTIFY_CHANGE_ATTRIBUTES
112 , fILE_NOTIFY_CHANGE_SIZE
113 , fILE_NOTIFY_CHANGE_LAST_WRITE
114 , fILE_NOTIFY_CHANGE_SECURITY
115 , fILE_SHARE_READ
116 , fILE_SHARE_WRITE
117 , oPEN_EXISTING
118 )
119import System.Win32.Types (BOOL, DWORD, HANDLE, LPVOID, LPDWORD, failIfFalse_)
120import qualified Data.List.NonEmpty as NonEmpty
121import qualified Streamly.Internal.Data.Stream.IsStream as S
122import qualified Streamly.Internal.Unicode.Stream as U
123import qualified Streamly.Internal.Unicode.Utf8 as UTF8
124import qualified Streamly.Internal.Data.Array.Foreign as A
125import Streamly.Internal.Data.Array.Foreign (Array)
127-- | Watch configuration, used to specify the events of interest and the
128-- behavior of the watch.
129--
130-- /Pre-release/
131--
132data Config = Config
133 { watchRec :: BOOL
134 , createFlags :: DWORD
135 }
137-------------------------------------------------------------------------------
138-- Boolean settings
139-------------------------------------------------------------------------------
141-- | Whether a setting is 'On' or 'Off'.
142--
143-- /Pre-release/
144--
145data Toggle = On | Off
147setFlag :: DWORD -> Toggle -> Config -> Config
148setFlag mask status cfg@Config{..} =
149 let flags =
150 case status of
151 On -> createFlags .|. mask
152 Off -> createFlags .&. complement mask
153 in cfg {createFlags = flags}
155-- | Set watch event on directory recursively.
156--
157-- /default: On/
158--
159-- /Pre-release/
160--
161setRecursiveMode :: BOOL -> Config -> Config
162setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}
164-- | Report when a file name is modified.
165--
166-- /default: On/
167--
168-- /Pre-release/
169--
170setModifiedFileName :: Toggle -> Config -> Config
171setModifiedFileName = setFlag fILE_NOTIFY_CHANGE_FILE_NAME
173-- | Report when a directory name is modified.
174--
175-- /default: On/
176--
177-- /Pre-release/
178--
179setRootMoved :: Toggle -> Config -> Config
180setRootMoved = setFlag fILE_NOTIFY_CHANGE_DIR_NAME
182-- | Report when a file attribute is modified.
183--
184-- /default: On/
185--
186-- /Pre-release/
187--
188setModifiedAttribute :: Toggle -> Config -> Config
189setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES
191-- | Report when a file size is changed.
192--
193-- /default: On/
194--
195-- /Pre-release/
196--
197setModifiedSize :: Toggle -> Config -> Config
198setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
200-- | Report when a file last write time is changed.
201--
202-- /default: On/
203--
204-- /Pre-release/
205--
206setModifiedLastWrite :: Toggle -> Config -> Config
207setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
209-- | Report when a file Security attribute changes.
210--
211-- /default: On/
212--
213-- /Pre-release/
214--
215setModifiedSecurity :: Toggle -> Config -> Config
216setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY
218-- | Set all tunable events 'On' or 'Off'. Equivalent to setting:
219--
220-- * setModifiedFileName
221-- * setRootMoved
222-- * setModifiedAttribute
223-- * setModifiedSize
224-- * setModifiedLastWrite
225-- * setModifiedSecurity
226--
227-- /Pre-release/
228--
229setAllEvents :: Toggle -> Config -> Config
230setAllEvents s =
231 setModifiedFileName s
232 . setRootMoved s
233 . setModifiedAttribute s
234 . setModifiedSize s
235 . setModifiedLastWrite s
236 . setModifiedSecurity s
238-- | The tunable events that are enabled by default are:
239--
240-- * setModifiedFileName On
241--
242-- /Pre-release/
243--
244defaultConfig :: Config
245defaultConfig =
246 setModifiedFileName On
247 $ Config {watchRec = True, createFlags = 0}
249getConfigFlag :: Config -> DWORD
250getConfigFlag Config{..} = createFlags
252getConfigRecMode :: Config -> BOOL
253getConfigRecMode Config{..} = watchRec
255data Event = Event
256 { eventFlags :: DWORD
257 , eventRelPath :: String
258 , eventRootPath :: String
259 , totalBytes :: DWORD
260 } deriving (Show, Ord, Eq)
262-- For reference documentation see:
263--
264-- See https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information
265data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION
266 { fniNextEntryOffset :: DWORD
267 , fniAction :: DWORD
268 , fniFileName :: String
269 } deriving Show
271type LPOVERLAPPED_COMPLETION_ROUTINE =
272 FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())
274-- | A handle for a watch.
275getWatchHandle :: FilePath -> IO (HANDLE, FilePath)
276getWatchHandle dir = do
277 h <- createFile dir
278 -- Access mode
279 fILE_LIST_DIRECTORY
280 -- Share mode
281 (fILE_SHARE_READ .|. fILE_SHARE_WRITE)
282 -- Security attributes
283 Nothing
284 -- Create mode, we want to look at an existing directory
285 oPEN_EXISTING
286 -- File attribute, NOT using OVERLAPPED since we work synchronously
287 fILE_FLAG_BACKUP_SEMANTICS
288 -- No template file
289 Nothing
290 return (h, dir)
292-- For reference documentation see:
293--
294-- See https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-readdirectorychangesw
295-- Note that this API uses UTF-16 for file system paths:
296-- 1. https://docs.microsoft.com/en-us/windows/win32/intl/unicode-in-the-windows-api
297-- 2. https://docs.microsoft.com/en-us/windows/win32/intl/unicode
298foreign import ccall safe
299 "windows.h ReadDirectoryChangesW" c_ReadDirectoryChangesW ::
300 HANDLE
301 -> LPVOID
302 -> DWORD
303 -> BOOL
304 -> DWORD
305 -> LPDWORD
306 -> LPOVERLAPPED
307 -> LPOVERLAPPED_COMPLETION_ROUTINE
308 -> IO BOOL
310readDirectoryChangesW ::
311 HANDLE
312 -> Ptr FILE_NOTIFY_INFORMATION
313 -> DWORD
314 -> BOOL
315 -> FileNotificationFlag
316 -> LPDWORD
317 -> IO ()
318readDirectoryChangesW h buf bufSize wst f br =
319 let res = c_ReadDirectoryChangesW
320 h (castPtr buf) bufSize wst f br nullPtr nullFunPtr
321 in failIfFalse_ "ReadDirectoryChangesW" res
323peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION
324peekFNI buf = do
325 neof <- peekByteOff buf 0
326 acti <- peekByteOff buf 4
327 fnle <- peekByteOff buf 8
328 -- Note: The path is UTF-16 encoded C WChars, peekCWStringLen converts
329 -- UTF-16 to UTF-32 Char String
330 fnam <- peekCWStringLen
331 -- start of array
332 (buf `plusPtr` 12,
333 -- fnle is the length in *bytes*, and a WCHAR is 2 bytes
334 fromEnum (fnle :: DWORD) `div` 2)
335 return $ FILE_NOTIFY_INFORMATION neof acti fnam
337readChangeEvents ::
338 Ptr FILE_NOTIFY_INFORMATION -> String -> DWORD -> IO [Event]
339readChangeEvents pfni root bytesRet = do
340 fni <- peekFNI pfni
341 let entry = Event
342 { eventFlags = fniAction fni
343 , eventRelPath = fniFileName fni
344 , eventRootPath = root
345 , totalBytes = bytesRet
346 }
347 nioff = fromEnum $ fniNextEntryOffset fni
348 entries <-
349 if nioff == 0
350 then return []
351 else readChangeEvents (pfni `plusPtr` nioff) root bytesRet
352 return $ entry : entries
354readDirectoryChanges ::
355 String -> HANDLE -> Bool -> FileNotificationFlag -> IO [Event]
356readDirectoryChanges root h wst mask = do
357 let maxBuf = 63 * 1024
358 allocaBytes maxBuf $ \buffer -> do
359 alloca $ \bret -> do
360 readDirectoryChangesW h buffer (toEnum maxBuf) wst mask bret
361 bytesRet <- peekByteOff bret 0
362 readChangeEvents buffer root bytesRet
364type FileAction = DWORD
366fILE_ACTION_ADDED :: FileAction
367fILE_ACTION_ADDED = 1
369fILE_ACTION_REMOVED :: FileAction
370fILE_ACTION_REMOVED = 2
372fILE_ACTION_MODIFIED :: FileAction
373fILE_ACTION_MODIFIED = 3
375fILE_ACTION_RENAMED_OLD_NAME :: FileAction
376fILE_ACTION_RENAMED_OLD_NAME = 4
378fILE_ACTION_RENAMED_NEW_NAME :: FileAction
379fILE_ACTION_RENAMED_NEW_NAME = 5
381eventStreamAggr :: (HANDLE, FilePath, Config) -> SerialT IO Event
382eventStreamAggr (handle, rootPath, cfg) = do
383 let recMode = getConfigRecMode cfg
384 flagMasks = getConfigFlag cfg
385 S.concatMap S.fromList $ S.repeatM
386 $ readDirectoryChanges rootPath handle recMode flagMasks
388pathsToHandles ::
389 NonEmpty FilePath -> Config -> SerialT IO (HANDLE, FilePath, Config)
390pathsToHandles paths cfg = do
391 let pathStream = S.fromList (NonEmpty.toList paths)
392 st2 = S.mapM getWatchHandle pathStream
393 S.map (\(h, f) -> (h, f, cfg)) st2
395-------------------------------------------------------------------------------
396-- Utilities
397-------------------------------------------------------------------------------
399utf8ToString :: Array Word8 -> FilePath
400utf8ToString = runIdentity . S.toList . U.decodeUtf8 . A.toStream
402utf8ToStringList :: NonEmpty (Array Word8) -> NonEmpty FilePath
403utf8ToStringList = NonEmpty.map utf8ToString
405-- | Close a Directory handle.
406--
407closePathHandleStream :: SerialT IO (HANDLE, FilePath, Config) -> IO ()
408closePathHandleStream = S.mapM_ (\(h, _, _) -> closeHandle h)
410-- XXX
411-- Document the path treatment for Linux/Windows/macOS modules.
412-- Remove the utf-8 encoding requirement of paths? It can be encoding agnostic
413-- "\" separated bytes, the application can decide what encoding to use.
414-- Instead of always using widechar (-W) APIs can we call the underlying APIs
415-- based on the configured code page?
416-- https://docs.microsoft.com/en-us/windows/uwp/design/globalizing/use-utf8-code-page
417--
418-- | Start monitoring a list of file system paths for file system events with
419-- the supplied configuration modifier operation over the' defaultConfig'. The
420-- paths could be files or directories.
421--
422-- When recursive mode is True and the path is a directory, the whole directory
423-- tree under it is watched recursively. When recursive mode is False and the
424-- path is a directory, only the files and directories directly under the
425-- watched directory are monitored, contents of subdirectories are not
426-- monitored. Monitoring starts from the current time onwards. The paths are
427-- specified as UTF-8 encoded 'Array' of 'Word8'.
428--
429-- @
430-- watchWith
431-- ('setModifiedAttribute' On . 'setModifiedLastWrite' Off)
432-- [Array.fromCString\# "dir"#]
433-- @
434--
435-- /Pre-release/
436--
437watchWith :: (Config -> Config) -> NonEmpty (Array Word8) -> SerialT IO Event
438watchWith f paths =
439 S.bracket before after (S.concatMapWith parallel eventStreamAggr)
441 where
443 before = return $ pathsToHandles (utf8ToStringList paths) $ f defaultConfig
444 after = liftIO . closePathHandleStream
446-- | Same as 'watchWith' using 'defaultConfig' and recursive mode.
447--
448-- >>> watchRecursive = watchWith id
449--
450-- /Pre-release/
451--
452watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event
453watchRecursive = watchWith id
455-- | Same as 'watchWith' using defaultConfig and non-recursive mode.
456--
457-- /Pre-release/
458--
459watch :: NonEmpty (Array Word8) -> SerialT IO Event
460watch = watchWith (setRecursiveMode False)
462getFlag :: DWORD -> Event -> Bool
463getFlag mask Event{..} = eventFlags == mask
465-- XXX Change the type to Array Word8 to make it compatible with other APIs.
466--
467-- | Get the file system object path for which the event is generated, relative
468-- to the watched root. The path is a UTF-8 encoded array of bytes.
469--
470-- /Pre-release/
471--
472getRelPath :: Event -> Array Word8
473getRelPath Event{..} = (UTF8.toArray . UTF8.pack) eventRelPath
475-- XXX Change the type to Array Word8 to make it compatible with other APIs.
476--
477-- | Get the watch root directory to which this event belongs.
478--
479-- /Pre-release/
480--
481getRoot :: Event -> Array Word8
482getRoot Event{..} = (UTF8.toArray . UTF8.pack) eventRootPath
484getAbsPath :: Event -> Array Word8
485getAbsPath ev = getRoot ev <> A.fromCString# "\\"# <> getRelPath ev
487-- XXX need to document the exact semantics of these.
488--
489-- | This event is generated when a file or directory is created in a watched
490-- directory or directory tree when in recursive watch mode. Creating a hard
491-- link also generates this event.
492--
493-- /Pre-release/
494--
495isCreated :: Event -> Bool
496isCreated = getFlag fILE_ACTION_ADDED
498-- | This event is generated when a file or directory is deleted from the
499-- watched directory or directory tree when in recursive mode. This event is
500-- generated even when a hard link is deleted.
501--
502-- /Pre-release/
503--
504isDeleted :: Event -> Bool
505isDeleted = getFlag fILE_ACTION_REMOVED
507-- | Generated for the original path when an object is moved from under a
508-- monitored directory.
509--
510-- /Pre-release/
511--
512isMovedFrom :: Event -> Bool
513isMovedFrom = getFlag fILE_ACTION_RENAMED_OLD_NAME
515-- | Generated for the new path when an object is moved under a monitored
516-- directory.
517--
518-- /Pre-release/
519--
520isMovedTo :: Event -> Bool
521isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME
523-- | Generated for a path that is moved from or moved to the monitored
524-- directory.
525--
526-- >>> isMoved ev = isMovedFrom ev || isMovedTo ev
527--
528-- /Occurs only for an object inside the watched directory/
529--
530-- /Pre-release/
531--
532isMoved :: Event -> Bool
533isMoved ev = isMovedFrom ev || isMovedTo ev
535-- XXX This event is generated only for files and not directories?
536--
537-- | Determine whether the event indicates modification of an object within the
538-- monitored path. This event is generated when a file or directory contents
539-- are modified. In non-recursive mode this event is not generated for
540-- directories. In recursive mode this event is generated for the parent
541-- directory if a file or directory inside it is created or renamed.
542--
543-- /Pre-release/
544--
545isModified :: Event -> Bool
546isModified = getFlag fILE_ACTION_MODIFIED
548-- | If the buffer overflows, entire contents of the buffer are discarded,
549-- therefore, events are lost. The user application must scan everything under
550-- the watched paths to know the current state.
551--
552-- /Pre-release/
553--
554isEventsLost :: Event -> Bool
555isEventsLost Event{..} = totalBytes == 0
557-------------------------------------------------------------------------------
558-- Debugging
559-------------------------------------------------------------------------------
561-- | Convert an 'Event' record to a String representation.
562showEvent :: Event -> String
563showEvent ev@Event{..} =
564 "--------------------------"
565 ++ "\nRoot = " ++ utf8ToString (getRoot ev)
566 ++ "\nPath = " ++ utf8ToString (getRelPath ev)
567 ++ "\ngetAbsPath = " ++ utf8ToString (getAbsPath ev)
568 ++ "\nFlags " ++ show eventFlags
569 ++ showev isEventsLost "Overflow"
570 ++ showev isCreated "Created"
571 ++ showev isDeleted "Deleted"
572 ++ showev isModified "Modified"
573 ++ showev isMovedFrom "MovedFrom"
574 ++ showev isMovedTo "MovedTo"
575 ++ "\n"
577 where showev f str = if f ev then "\n" ++ str else ""