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