@@ -0,0 +1,463 @@
2+-- Module : Streamly.Internal.FileSystem.Event.Windows
3+-- Copyright : (c) 2020 Composewell Technologies
6+-- Maintainer : streamly@composewell.com
7+-- Stability : experimental
10+-- Just report all events under the paths provided as arguments
12+module Streamly.Internal.FileSystem.Event.Windows
14+ -- * Subscribing to events
16+ -- ** Default configuration
28+ -- ** Events of Interest
29+ -- *** Root Level Events
30+ , setModifiedFileName
32+ , setModifiedAttribute
34+ , setModifiedLastWrite
35+ , setModifiedSecurity
47+ -- ** Item CRUD events
54+ -- ** Exception Conditions
62+import Control.Monad.IO.Class (MonadIO(liftIO))
63+import Data.Bits ((.|.), (.&.), complement)
64+import Data.Functor.Identity (runIdentity)
65+import Data.List.NonEmpty (NonEmpty)
66+import Data.Word (Word8)
67+import Foreign.C.String (peekCWStringLen)
68+import Foreign.Marshal.Alloc (alloca, allocaBytes)
69+import Foreign.Storable (peekByteOff)
70+import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr)
71+import Streamly.Prelude (SerialT, parallel)
72+import System.Win32.File
73+ ( FileNotificationFlag
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
89+import System.Win32.Types (BOOL, DWORD, HANDLE, LPVOID, LPDWORD, failIfFalse_)
90+import qualified Data.List.NonEmpty as NonEmpty
91+import qualified Streamly.Internal.Data.Stream.IsStream as S
92+import qualified Streamly.Internal.Unicode.Stream as U
93+import qualified Streamly.Internal.Data.Array.Storable.Foreign as A
94+import Streamly.Internal.Data.Array.Storable.Foreign (Array)
96+-- | Watch configuration, used to specify the events of interest and the
97+-- behavior of the watch.
103+ , createFlags :: DWORD
106+-------------------------------------------------------------------------------
108+-------------------------------------------------------------------------------
110+-- | Whether a setting is 'On' or 'Off'.
114+data Toggle = On | Off
116+setFlag :: DWORD -> Toggle -> Config -> Config
117+setFlag mask status cfg@Config{..} =
120+ On -> createFlags .|. mask
121+ Off -> createFlags .&. complement mask
122+ in cfg {createFlags = flags}
124+-- | Set watch event on directory recursively.
130+setRecursiveMode :: BOOL -> Config -> Config
131+setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}
133+-- | Report when a file name is modified.
139+setModifiedFileName :: Toggle -> Config -> Config
140+setModifiedFileName = setFlag fILE_NOTIFY_CHANGE_FILE_NAME
142+-- | Report when a directory name is modified.
148+setModifiedDirName :: Toggle -> Config -> Config
149+setModifiedDirName = setFlag fILE_NOTIFY_CHANGE_DIR_NAME
151+-- | Report when a file attribute is modified.
157+setModifiedAttribute :: Toggle -> Config -> Config
158+setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES
160+-- | Report when a file size is changed.
166+setModifiedSize :: Toggle -> Config -> Config
167+setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
169+-- | Report when a file last write time is changed.
175+setModifiedLastWrite :: Toggle -> Config -> Config
176+setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
178+-- | Report when a file Security attributes is changed.
184+setModifiedSecurity :: Toggle -> Config -> Config
185+setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY
187+-- | Set all events 'On' or 'Off'.
193+setAllEvents :: Toggle -> Config -> Config
195+ setModifiedFileName s
196+ . setModifiedDirName s
197+ . setModifiedAttribute s
199+ . setModifiedLastWrite s
200+ . setModifiedSecurity s
202+defaultConfig :: Config
203+defaultConfig = setAllEvents On $ Config {watchRec = True, createFlags = 0}
205+getConfigFlag :: Config -> DWORD
206+getConfigFlag Config{..} = createFlags
208+getConfigRecMode :: Config -> BOOL
209+getConfigRecMode Config{..} = watchRec
212+ { eventFlags :: DWORD
213+ , eventRelPath :: String
214+ , eventRootPath :: String
215+ , totalBytes :: DWORD
216+ } deriving (Show, Ord, Eq)
218+-- For reference documentation see:
220+-- See https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information
221+data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION
222+ { fniNextEntryOffset :: DWORD
223+ , fniAction :: DWORD
224+ , fniFileName :: String
227+type LPOVERLAPPED_COMPLETION_ROUTINE =
228+ FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())
230+-- | A handle for a watch.
231+getWatchHandle :: FilePath -> IO (HANDLE, FilePath)
232+getWatchHandle dir = do
237+ (fILE_SHARE_READ .|. fILE_SHARE_WRITE)
238+ -- Security attributes
240+ -- Create mode, we want to look at an existing directory
242+ -- File attribute, NOT using OVERLAPPED since we work synchronously
243+ fILE_FLAG_BACKUP_SEMANTICS
248+-- For reference documentation see:
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
254+foreign import ccall safe
255+ "windows.h ReadDirectoryChangesW" c_ReadDirectoryChangesW ::
256+ HANDLE -> LPVOID -> DWORD -> BOOL -> DWORD -> LPDWORD
257+ -> LPOVERLAPPED -> LPOVERLAPPED_COMPLETION_ROUTINE -> IO BOOL
259+readDirectoryChangesW ::
260+ HANDLE -> Ptr FILE_NOTIFY_INFORMATION -> DWORD
261+ -> BOOL -> FileNotificationFlag -> LPDWORD -> IO ()
263+readDirectoryChangesW h buf bufSize wst f br =
264+ failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf)
265+ bufSize wst f br nullPtr nullFunPtr
267+peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION
269+ neof <- peekByteOff buf 0
270+ acti <- peekByteOff buf 4
271+ fnle <- peekByteOff buf 8
272+ fnam <- peekCWStringLen
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
279+readChangeEvents :: Ptr FILE_NOTIFY_INFORMATION -> String -> DWORD -> IO [Event]
280+readChangeEvents pfni root bytesRet = do
283+ { eventFlags = fniAction fni
284+ , eventRelPath = fniFileName fni
285+ , eventRootPath = root
286+ , totalBytes = bytesRet
288+ nioff = fromEnum $ fniNextEntryOffset fni
289+ entries <- if nioff == 0
291+ else readChangeEvents (pfni `plusPtr` nioff) root bytesRet
292+ return $ entry :entries
294+readDirectoryChanges ::
295+ String -> HANDLE -> Bool -> FileNotificationFlag -> IO [Event]
296+readDirectoryChanges 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
304+type FileAction = DWORD
306+fILE_ACTION_ADDED :: FileAction
307+fILE_ACTION_ADDED = 1
309+fILE_ACTION_REMOVED :: FileAction
310+fILE_ACTION_REMOVED = 2
312+fILE_ACTION_MODIFIED :: FileAction
313+fILE_ACTION_MODIFIED = 3
315+fILE_ACTION_RENAMED_OLD_NAME :: FileAction
316+fILE_ACTION_RENAMED_OLD_NAME = 4
318+fILE_ACTION_RENAMED_NEW_NAME :: FileAction
319+fILE_ACTION_RENAMED_NEW_NAME = 5
321+eventStreamAggr :: (HANDLE, FilePath, Config) -> SerialT IO Event
322+eventStreamAggr (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
329+ NonEmpty FilePath -> Config -> SerialT IO (HANDLE, FilePath, Config)
330+pathsToHandles 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+-------------------------------------------------------------------------------
337+-------------------------------------------------------------------------------
338+utf8ToString :: Array Word8 -> FilePath
339+utf8ToString = runIdentity . S.toList . U.decodeUtf8 . A.toStream
341+utf8ToStringList :: NonEmpty (Array Word8) -> NonEmpty FilePath
342+utf8ToStringList = NonEmpty.map utf8ToString
344+-- | Close a Directory handle.
348+closePathHandleStream :: SerialT IO (HANDLE, FilePath, Config) -> IO ()
349+closePathHandleStream = 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.
362+ -> NonEmpty (Array Word8)
364+watchPathsWith f paths =
365+ S.bracket before after (S.concatMapWith parallel eventStreamAggr)
369+ before = return $ pathsToHandles (utf8ToStringList paths)
370+ (f $ setRecursiveMode False defaultConfig)
371+ after = liftIO . closePathHandleStream
373+-- | Like 'watchPathsWith' but uses the 'defaultConfig' options.
376+-- watchPaths = watchPathsWith id
381+watchPaths :: NonEmpty (Array Word8) -> SerialT IO Event
382+watchPaths = 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.
394+ -> NonEmpty (Array Word8)
396+watchTreesWith f paths =
397+ S.bracket before after (S.concatMapWith parallel eventStreamAggr)
401+ before = return $ pathsToHandles (utf8ToStringList paths)
402+ (f $ setRecursiveMode True defaultConfig)
403+ after = liftIO . closePathHandleStream
405+-- | Like 'watchTreesWith' but uses the 'defaultConfig' options.
408+-- watchTrees = watchTreesWith id
411+watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event
412+watchTrees = watchTreesWith id
415+getFlag :: DWORD -> Event -> Bool
416+getFlag mask Event{..} = eventFlags == mask
418+getRelPath :: Event -> String
419+getRelPath Event{..} = eventRelPath
421+getRoot :: Event -> String
422+getRoot Event{..} = eventRootPath
424+isCreated :: Event -> Bool
425+isCreated = getFlag fILE_ACTION_ADDED
427+isDeleted :: Event -> Bool
428+isDeleted = getFlag fILE_ACTION_REMOVED
430+isMovedFrom :: Event -> Bool
431+isMovedFrom = getFlag fILE_ACTION_RENAMED_OLD_NAME
433+isMovedTo :: Event -> Bool
434+isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME
436+isModified :: Event -> Bool
437+isModified = getFlag fILE_ACTION_MODIFIED
439+-- | If the buffer overflows, ReadDirectoryChangesW will still return true,
440+-- but the entire contents of the buffer are discarded.
441+isOverflow :: Event -> Bool
442+isOverflow Event{..} = totalBytes == 0
444+-------------------------------------------------------------------------------
446+-------------------------------------------------------------------------------
448+-- | Convert an 'Event' record to a String representation.
449+showEvent :: Event -> String
450+showEvent 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"
463+ where showev f str = if f ev then "\n" ++ str else ""