git.iko.soy/streamly
on a608695 help sign in
streamly/src/Streamly/Internal/FileSystem/Event/Windows.hs
463 lines 14 kB history raw
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
12module Streamly.Internal.FileSystem.Event.Windows
13 (
14 -- * Subscribing to events
16 -- ** Default configuration
17 Config
18 , Event
19 , Toggle (..)
20 , setFlag
21 , defaultConfig
22 , getConfigFlag
23 , setAllEvents
25 -- ** Watch Behavior
26 , setRecursiveMode
28 -- ** Events of Interest
29 -- *** Root Level Events
30 , setModifiedFileName
31 , setModifiedDirName
32 , setModifiedAttribute
33 , setModifiedSize
34 , setModifiedLastWrite
35 , setModifiedSecurity
37 -- ** Watch APIs
38 , watchPaths
39 , watchPathsWith
40 , watchTrees
41 , watchTreesWith
43 -- * Handling Events
44 , getRelPath
45 , getRoot
47 -- ** Item CRUD events
48 , isCreated
49 , isDeleted
50 , isMovedFrom
51 , isMovedTo
52 , isModified
54 -- ** Exception Conditions
55 , isOverflow
57 -- * Debugging
58 , showEvent
59 )
60where
62import Control.Monad.IO.Class (MonadIO(liftIO))
63import Data.Bits ((.|.), (.&.), complement)
64import Data.Functor.Identity (runIdentity)
65import Data.List.NonEmpty (NonEmpty)
66import Data.Word (Word8)
67import Foreign.C.String (peekCWStringLen)
68import Foreign.Marshal.Alloc (alloca, allocaBytes)
69import Foreign.Storable (peekByteOff)
70import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr)
71import Streamly.Prelude (SerialT, parallel)
72import 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 )
89import System.Win32.Types (BOOL, DWORD, HANDLE, LPVOID, LPDWORD, failIfFalse_)
90import qualified Data.List.NonEmpty as NonEmpty
91import qualified Streamly.Internal.Data.Stream.IsStream as S
92import qualified Streamly.Internal.Unicode.Stream as U
93import qualified Streamly.Internal.Data.Array.Storable.Foreign as A
94import Streamly.Internal.Data.Array.Storable.Foreign (Array)
96-- | Watch configuration, used to specify the events of interest and the
97-- behavior of the watch.
98--
99-- /Internal/
100--
101data Config = Config
102 { watchRec :: BOOL
103 , createFlags :: DWORD
104 }
106-------------------------------------------------------------------------------
107-- Boolean settings
108-------------------------------------------------------------------------------
110-- | Whether a setting is 'On' or 'Off'.
111--
112-- /Internal/
113--
114data Toggle = On | Off
116setFlag :: DWORD -> Toggle -> Config -> Config
117setFlag 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}
124-- | Set watch event on directory recursively.
125--
126-- /default: On/
127--
128-- /Internal/
129--
130setRecursiveMode :: BOOL -> Config -> Config
131setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}
133-- | Report when a file name is modified.
134--
135-- /default: On/
136--
137-- /Internal/
138--
139setModifiedFileName :: Toggle -> Config -> Config
140setModifiedFileName = setFlag fILE_NOTIFY_CHANGE_FILE_NAME
142-- | Report when a directory name is modified.
143--
144-- /default: On/
145--
146-- /Internal/
147--
148setModifiedDirName :: Toggle -> Config -> Config
149setModifiedDirName = setFlag fILE_NOTIFY_CHANGE_DIR_NAME
151-- | Report when a file attribute is modified.
152--
153-- /default: On/
154--
155-- /Internal/
156--
157setModifiedAttribute :: Toggle -> Config -> Config
158setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES
160-- | Report when a file size is changed.
161--
162-- /default: On/
163--
164-- /Internal/
165--
166setModifiedSize :: Toggle -> Config -> Config
167setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
169-- | Report when a file last write time is changed.
170--
171-- /default: On/
172--
173-- /Internal/
174--
175setModifiedLastWrite :: Toggle -> Config -> Config
176setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
178-- | Report when a file Security attributes is changed.
179--
180-- /default: On/
181--
182-- /Internal/
183--
184setModifiedSecurity :: Toggle -> Config -> Config
185setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY
187-- | Set all events 'On' or 'Off'.
188--
189-- /default: On/
190--
191-- /Internal/
192--
193setAllEvents :: Toggle -> Config -> Config
194setAllEvents s =
195 setModifiedFileName s
196 . setModifiedDirName s
197 . setModifiedAttribute s
198 . setModifiedSize s
199 . setModifiedLastWrite s
200 . setModifiedSecurity s
202defaultConfig :: Config
203defaultConfig = setAllEvents On $ Config {watchRec = True, createFlags = 0}
205getConfigFlag :: Config -> DWORD
206getConfigFlag Config{..} = createFlags
208getConfigRecMode :: Config -> BOOL
209getConfigRecMode Config{..} = watchRec
211data Event = Event
212 { eventFlags :: DWORD
213 , eventRelPath :: String
214 , eventRootPath :: String
215 , totalBytes :: DWORD
216 } deriving (Show, Ord, Eq)
218-- For reference documentation see:
219--
220-- See https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information
221data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION
222 { fniNextEntryOffset :: DWORD
223 , fniAction :: DWORD
224 , fniFileName :: String
225 } deriving Show
227type LPOVERLAPPED_COMPLETION_ROUTINE =
228 FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())
230-- | A handle for a watch.
231getWatchHandle :: FilePath -> IO (HANDLE, FilePath)
232getWatchHandle 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)
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
254foreign import ccall safe
255 "windows.h ReadDirectoryChangesW" c_ReadDirectoryChangesW ::
256 HANDLE -> LPVOID -> DWORD -> BOOL -> DWORD -> LPDWORD
257 -> LPOVERLAPPED -> LPOVERLAPPED_COMPLETION_ROUTINE -> IO BOOL
259readDirectoryChangesW ::
260 HANDLE -> Ptr FILE_NOTIFY_INFORMATION -> DWORD
261 -> BOOL -> FileNotificationFlag -> LPDWORD -> IO ()
263readDirectoryChangesW h buf bufSize wst f br =
264 failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf)
265 bufSize wst f br nullPtr nullFunPtr
267peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION
268peekFNI 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
279readChangeEvents :: Ptr FILE_NOTIFY_INFORMATION -> String -> DWORD -> IO [Event]
280readChangeEvents 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
294readDirectoryChanges ::
295 String -> HANDLE -> Bool -> FileNotificationFlag -> IO [Event]
296readDirectoryChanges 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
304type FileAction = DWORD
306fILE_ACTION_ADDED :: FileAction
307fILE_ACTION_ADDED = 1
309fILE_ACTION_REMOVED :: FileAction
310fILE_ACTION_REMOVED = 2
312fILE_ACTION_MODIFIED :: FileAction
313fILE_ACTION_MODIFIED = 3
315fILE_ACTION_RENAMED_OLD_NAME :: FileAction
316fILE_ACTION_RENAMED_OLD_NAME = 4
318fILE_ACTION_RENAMED_NEW_NAME :: FileAction
319fILE_ACTION_RENAMED_NEW_NAME = 5
321eventStreamAggr :: (HANDLE, FilePath, Config) -> SerialT IO Event
322eventStreamAggr (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
328pathsToHandles ::
329 NonEmpty FilePath -> Config -> SerialT IO (HANDLE, FilePath, Config)
330pathsToHandles 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
335-------------------------------------------------------------------------------
336-- Utilities
337-------------------------------------------------------------------------------
338utf8ToString :: Array Word8 -> FilePath
339utf8ToString = runIdentity . S.toList . U.decodeUtf8 . A.toStream
341utf8ToStringList :: NonEmpty (Array Word8) -> NonEmpty FilePath
342utf8ToStringList = NonEmpty.map utf8ToString
344-- | Close a Directory handle.
345--
346-- /Internal/
347--
348closePathHandleStream :: SerialT IO (HANDLE, FilePath, Config) -> IO ()
349closePathHandleStream = S.mapM_ (\(h, _, _) -> closeHandle h)
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--
360watchPathsWith ::
361 (Config -> Config)
362 -> NonEmpty (Array Word8)
363 -> SerialT IO Event
364watchPathsWith f paths =
365 S.bracket before after (S.concatMapWith parallel eventStreamAggr)
367 where
369 before = return $ pathsToHandles (utf8ToStringList paths)
370 (f $ setRecursiveMode False defaultConfig)
371 after = liftIO . closePathHandleStream
373-- | Like 'watchPathsWith' but uses the 'defaultConfig' options.
374--
375-- @
376-- watchPaths = watchPathsWith id
377-- @
378--
379-- /Internal/
380--
381watchPaths :: NonEmpty (Array Word8) -> SerialT IO Event
382watchPaths = watchPathsWith id
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--
392watchTreesWith ::
393 (Config -> Config)
394 -> NonEmpty (Array Word8)
395 -> SerialT IO Event
396watchTreesWith f paths =
397 S.bracket before after (S.concatMapWith parallel eventStreamAggr)
399 where
401 before = return $ pathsToHandles (utf8ToStringList paths)
402 (f $ setRecursiveMode True defaultConfig)
403 after = liftIO . closePathHandleStream
405-- | Like 'watchTreesWith' but uses the 'defaultConfig' options.
406--
407-- @
408-- watchTrees = watchTreesWith id
409-- @
410--
411watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event
412watchTrees = watchTreesWith id
415getFlag :: DWORD -> Event -> Bool
416getFlag mask Event{..} = eventFlags == mask
418getRelPath :: Event -> String
419getRelPath Event{..} = eventRelPath
421getRoot :: Event -> String
422getRoot Event{..} = eventRootPath
424isCreated :: Event -> Bool
425isCreated = getFlag fILE_ACTION_ADDED
427isDeleted :: Event -> Bool
428isDeleted = getFlag fILE_ACTION_REMOVED
430isMovedFrom :: Event -> Bool
431isMovedFrom = getFlag fILE_ACTION_RENAMED_OLD_NAME
433isMovedTo :: Event -> Bool
434isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME
436isModified :: Event -> Bool
437isModified = getFlag fILE_ACTION_MODIFIED
439-- | If the buffer overflows, ReadDirectoryChangesW will still return true,
440-- but the entire contents of the buffer are discarded.
441isOverflow :: Event -> Bool
442isOverflow Event{..} = totalBytes == 0
444-------------------------------------------------------------------------------
445-- Debugging
446-------------------------------------------------------------------------------
448-- | Convert an 'Event' record to a String representation.
449showEvent :: Event -> String
450showEvent 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"
463 where showev f str = if f ev then "\n" ++ str else ""