ilyakooo0/streamly
1
0
Fork 0
mirror of https://github.com/ilyakooo0/streamly.git synced 2024-10-26 09:59:48 +03:00
Code Issues Packages Projects Releases Wiki Activity

Overhaul file system event testing

Browse Source 
Remove watchRecursive from common fs event module as this is unreliable
on Linux platform.

Change default config to use non-recursive watch to make it same as the
behavior of the common module.
This commit is contained in:
Harendra Kumar 2021-11-09 14:32:37 +05:30
parent bb74cdd2a6
commit 4512fa476f
14 changed files with 980 additions and 1325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
hie.yaml
View File

@ -84,6 +84,14 @@ cradle:
component: "test:Data.Unfold"
- path: "./test/Streamly/Test/FileSystem/Event.hs"
component: "test:FileSystem.Event"
- path: "./test/Streamly/Test/FileSystem/Event/Common.hs"
component: "test:FileSystem.Event"
- path: "./test/Streamly/Test/FileSystem/Event/Linux.hs"
component: "test:FileSystem.Event.Linux"
- path: "./test/Streamly/Test/FileSystem/Event/Windows.hs"
component: "test:FileSystem.Event.Windows"
- path: "./test/Streamly/Test/FileSystem/Event/Darwin.hs"
component: "test:FileSystem.Event.Darwin"
- path: "./test/Streamly/Test/FileSystem/Handle.hs"
component: "test:FileSystem.Handle"
- path: "./test/Streamly/Test/Network/Inet/TCP.hs"

45
src/Streamly/Internal/FileSystem/Event.hs
View File

@ -9,7 +9,12 @@
-- File system event notification API portable across Linux, macOS and Windows
-- platforms.
--
-- For platform specific API please see the following modules:
-- Note that recursive directory tree watch does not work reliably on Linux
-- (see notes in the Linux module), therefore, recursive watch API is not
-- provided in this module. However, you can use it from the platform specific
-- modules.
--
-- For platform specific APIs please see the following modules:
--
-- * "Streamly.Internal.FileSystem.Event.Darwin"
-- * "Streamly.Internal.FileSystem.Event.Linux"
@ -20,7 +25,7 @@ module Streamly.Internal.FileSystem.Event
-- * Creating a Watch
watch
, watchRecursive
-- , watchRecursive
-- * Handling Events
, Event
@ -100,12 +105,20 @@ import qualified Streamly.Internal.FileSystem.Event.Windows as Event
-- generated. No events are generated if the watch root itself is renamed or
-- deleted.
--
-- Note: not yet implemented on macOS, use watchRecursive instead.
-- This API watches for changes in the watch root directory only, any changes
-- in the subdirectories of the watch root are not watched. However, on macOS
-- the watch is always recursive, but do not rely on that behavior, it may
-- change without notice in future. If you want to use recursive watch please
-- use platform specific modules.
--
-- /Pre-release/
--
watch :: NonEmpty (Array Word8) -> SerialT IO Event
#if defined(CABAL_OS_DARWIN)
watch = Event.watchRecursive
#else
watch = Event.watch
#endif
-- | Like 'watch' except that if a watched path is a directory the whole
-- directory tree under it is watched recursively.
@ -114,16 +127,34 @@ watch = Event.watch
--
-- /Pre-release/
--
watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event
watchRecursive = Event.watchRecursive
_watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event
_watchRecursive = Event.watchRecursive
-------------------------------------------------------------------------------
-- Handling Events
-------------------------------------------------------------------------------
-- XXX Ensure that on all paltforms the path has same conventions. That is do
-- not have a trailing path separator on one platfrom and not on another.
--
-- XXX We should use getRelPath instead so that the behavior when the root is a
-- symlink becomes platform independent.
--
-- | Get the absolute path of the file system object for which the event is
-- generated. The path is a UTF-8 encoded array of bytes.
--
-- When the watch root is a symlink the behavior is different on different
-- platforms:
--
-- * On Linux and Windows, the absolute path returned is via the original
-- symlink.
--
-- * On macOS the absolute path returned is via the real path of the root after
-- resolving the symlink.
--
-- This API is subject to removal in future, to be replaced by a platform
-- independent @getRelPath@.
--
-- /Pre-release/
--
getAbsPath :: Event -> Array Word8
@ -135,8 +166,8 @@ getAbsPath = Event.getAbsPath
--
-- For hard links the behavior is different on different operating systems. On
-- macOS hard linking does not generate a create event, it generates an
-- 'isInodeAttrsChanged' event on the directory instead. On Linux and Windows
-- hard linking generates a create event.
-- 'isInodeAttrsChanged' event on the directory instead (see the Darwin
-- module). On Linux and Windows hard linking generates a create event.
--
-- /Pre-release/
--

88
src/Streamly/Internal/FileSystem/Event/Darwin.hs
View File

@ -114,23 +114,23 @@ module Streamly.Internal.FileSystem.Event.Darwin
, watchWith
-- * Handling Events
, Event(..)
, Event
, getEventId
, getAbsPath
-- ** Root Level Events
-- | Events that belong to the root path as a whole and not to specific
-- itmes contained in it.
, isMount -- XXX change to isRootMounted
, isUnmount -- XXX change to isRootUnmounted
-- items contained in it.
, isMounted
, isUnmounted
, isHistoryDone
, isRootPathEvent
-- ** Item Level Metadata change
, isOwnerGroupModeChanged
, isInodeAttrsChanged
, isFinderInfoChanged
, isXAttrsChanged
, isAttrsModified
, isSecurityModified
, isXAttrsModified
, isFinderInfoModified
-- ** Item Level CRUD events
, isCreated
@ -212,6 +212,7 @@ foreign import ccall safe
"FileSystem/Event/Darwin.h FSEventStreamCreateFlagNoDefer"
kFSEventStreamCreateFlagNoDefer :: Word32
-- | Determines how multiple events are batched or throttled.
data BatchInfo =
Throttle Double -- ^ Deliver an event immediately but suppress the
-- following events upto the specified time.
@ -527,24 +528,24 @@ watchToStream (Watch handle _ _) =
-- From the observed behavior it seems macOS watches the paths, whatever they
-- are pointing to at any given point of time:
--
-- * If the object pointing to the watched path is deleted and then recreated,
-- /Watch root deletion:/ If the the watch root is deleted and then recreated,
-- the newly created file or directory is automatically watched.
--
-- * If the watched path is moved to a new path, the object will no longer be
-- watched unless the new path is also being watched and was pointing to an
-- existing file at the time of starting the watch (see notes about
-- non-existing paths below).
-- /Watch root moved:/ If the watch root is moved to a new path, the object
-- will no longer be watched unless the new path is also being watched and was
-- pointing to an existing file at the time of starting the watch (see notes
-- about non-existing paths below).
--
-- /Symbolic Links:/ If the path name to be watched is a symbolic link then the
-- target of the link is watched instead of the symbolic link itself. It is
-- equivalent to as if the target of the symbolic link itself was directly
-- added to the watch API. That is, the symbolic link is resolved at the time
-- of adding the watch.
-- /Symbolic link watch root:/ If the path name to be watched is a symbolic
-- link then the target of the link is watched instead of the symbolic link
-- itself. It is equivalent to as if the target of the symbolic link itself was
-- directly added to the watch API. That is, the symbolic link is resolved at
-- the time of adding the watch.
--
-- Note that if a watched path is deleted and recreated as a symbolic link to
-- another path then the symbolic link file itself is watched, it won't be
-- resolved. The symbolic link resolution happens only at the time of adding
-- the watch.
-- Note that if a watched path is deleted and recreated as a symbolic link
-- pointing to another path then the symbolic link file itself is watched, it
-- won't be resolved. The symbolic link resolution happens only at the time of
-- adding the watch.
--
-- /Non-existing Paths:/ If a watch is started on a non-existing path then the
-- path is not watched even if it is created later. The macOS API does not
@ -618,6 +619,9 @@ isEventIdWrapped = getFlag kFSEventStreamEventFlagEventIdsWrapped
-- | Get the absolute path of the file system object for which the event is
-- generated. The path is a UTF-8 encoded array of bytes.
--
-- When the watch root is a symlink, the absolute path returned is via the real
-- path of the root after resolving the symlink.
--
-- /Pre-release/
--
getAbsPath :: Event -> Array Word8
@ -741,8 +745,8 @@ foreign import ccall safe
--
-- /Pre-release/
--
isMount :: Event -> Bool
isMount = getFlag kFSEventStreamEventFlagMount
isMounted :: Event -> Bool
isMounted = getFlag kFSEventStreamEventFlagMount
foreign import ccall safe
"FSEventStreamEventFlagUnmount"
@ -755,8 +759,8 @@ foreign import ccall safe
--
-- /Pre-release/
--
isUnmount :: Event -> Bool
isUnmount = getFlag kFSEventStreamEventFlagUnmount
isUnmounted :: Event -> Bool
isUnmounted = getFlag kFSEventStreamEventFlagUnmount
-------------------------------------------------------------------------------
-- Metadata change Events (applicable only when 'setFileEvents' is 'On')
@ -780,8 +784,8 @@ foreign import ccall safe
--
-- /Pre-release/
--
isOwnerGroupModeChanged :: Event -> Bool
isOwnerGroupModeChanged = getFlag kFSEventStreamEventFlagItemChangeOwner
isSecurityModified :: Event -> Bool
isSecurityModified = getFlag kFSEventStreamEventFlagItemChangeOwner
foreign import ccall safe
"FSEventStreamEventFlagItemInodeMetaMod"
@ -801,8 +805,8 @@ foreign import ccall safe
--
-- /Pre-release/
--
isInodeAttrsChanged :: Event -> Bool
isInodeAttrsChanged = getFlag kFSEventStreamEventFlagItemInodeMetaMod
isAttrsModified :: Event -> Bool
isAttrsModified = getFlag kFSEventStreamEventFlagItemInodeMetaMod
foreign import ccall safe
"FSEventStreamEventFlagItemFinderInfoMod"
@ -817,8 +821,8 @@ foreign import ccall safe
--
-- /Pre-release/
--
isFinderInfoChanged :: Event -> Bool
isFinderInfoChanged = getFlag kFSEventStreamEventFlagItemFinderInfoMod
isFinderInfoModified :: Event -> Bool
isFinderInfoModified = getFlag kFSEventStreamEventFlagItemFinderInfoMod
foreign import ccall safe
"FSEventStreamEventFlagItemXattrMod"
@ -835,8 +839,8 @@ foreign import ccall safe
--
-- /Pre-release/
--
isXAttrsChanged :: Event -> Bool
isXAttrsChanged = getFlag kFSEventStreamEventFlagItemXattrMod
isXAttrsModified :: Event -> Bool
isXAttrsModified = getFlag kFSEventStreamEventFlagItemXattrMod
-------------------------------------------------------------------------------
-- CRUD Events (applicable only when 'setFileEvents' is 'On')
@ -848,7 +852,7 @@ foreign import ccall safe
-- | Determine whether the event indicates creation of an object within the
-- monitored path. This event is generated when any file system object other
-- than a hard link is created. On hard linking only an 'isInodeAttrsChanged'
-- than a hard link is created. On hard linking only an 'isAttrsModified'
-- event on the directory is generated, it is not a create event. However, when
-- a hard link is deleted 'isDeleted' and 'isHardLink' both are true.
--
@ -858,7 +862,7 @@ foreign import ccall safe
-- generated, the path is not watched.
--
-- BUGS: On 10.15.1 when we use a "touch x" to create a file for the first time
-- only an 'isInodeAttrsChanged' event occurs and there is no 'isCreated'
-- only an 'isAttrsModified' event occurs and there is no 'isCreated'
-- event. However, this seems to have been fixed on 10.15.6.
--
-- /Applicable only when 'setFileEvents' is 'On'/
@ -1050,14 +1054,14 @@ showEvent ev@Event{..} =
++ showev isUserDropped "UserDropped"
++ showev isRootPathEvent "RootPathEvent"
++ showev isMount "Mount"
++ showev isUnmount "Unmount"
++ showev isMounted "Mounted"
++ showev isUnmounted "Unmounted"
++ showev isHistoryDone "HistoryDone"
++ showev isOwnerGroupModeChanged "OwnerGroupModeChanged"
++ showev isInodeAttrsChanged "InodeAttrsChanged"
++ showev isFinderInfoChanged "FinderInfoChanged"
++ showev isXAttrsChanged "XAttrsChanged"
++ showev isSecurityModified "SecurityModified"
++ showev isAttrsModified "AttrsModified"
++ showev isFinderInfoModified "FinderInfoChanged"
++ showev isXAttrsModified "XAttrsModified"
++ showev isCreated "Created"
++ showev isDeleted "Deleted"

93
src/Streamly/Internal/FileSystem/Event/Linux.hs
View File

@ -83,7 +83,7 @@ module Streamly.Internal.FileSystem.Event.Linux
, setRootPathEvents
-- *** Item Level Metadata change
, setMetadataChanged
, setAttrsModified
-- *** Item Level Access
, setAccessed
@ -124,7 +124,7 @@ module Streamly.Internal.FileSystem.Event.Linux
, isRootUnmounted
-- ** Item Level Metadata change
, isMetadataChanged
, isAttrsModified
-- ** Item Level Access
, isAccessed
@ -174,7 +174,7 @@ import GHC.IO.FD (fdFD, mkFD)
import GHC.IO.Handle.FD (mkHandleFromFD)
import Streamly.Prelude (SerialT)
import Streamly.Internal.Data.Parser (Parser)
import Streamly.Internal.Data.Array.Foreign.Type (Array(..))
import Streamly.Internal.Data.Array.Foreign.Type (Array(..), byteLength)
import System.IO (Handle, hClose, IOMode(ReadMode))
#if !MIN_VERSION_base(4,10,0)
import Control.Concurrent.MVar (readMVar)
@ -254,6 +254,9 @@ foreign import capi
-- | If the pathname to be watched is a symbolic link then watch the target of
-- the symbolic link instead of the symbolic link itself.
--
-- Note that the path location in the events is through the original symbolic
-- link path rather than the resolved path.
--
-- /default: On/
--
-- /Pre-release/
@ -382,8 +385,8 @@ foreign import capi
--
-- /Pre-release/
--
setMetadataChanged :: Toggle -> Config -> Config
setMetadataChanged = setFlag iN_ATTRIB
setAttrsModified :: Toggle -> Config -> Config
setAttrsModified = setFlag iN_ATTRIB
foreign import capi
"sys/inotify.h value IN_ACCESS" iN_ACCESS :: Word32
@ -497,7 +500,7 @@ setModified = setFlag iN_MODIFY
--
-- * setRootDeleted
-- * setRootMoved
-- * setMetadataChanged
-- * setAttrsModified
-- * setAccessed
-- * setOpened
-- * setWriteClosed
@ -511,10 +514,10 @@ setModified = setFlag iN_MODIFY
-- /Pre-release/
--
setAllEvents :: Toggle -> Config -> Config
setAllEvents s cfg =
( setRootDeleted s
setAllEvents s =
setRootDeleted s
. setRootMoved s
. setMetadataChanged s
. setAttrsModified s
. setAccessed s
. setOpened s
. setWriteClosed s
@ -524,7 +527,6 @@ setAllEvents s cfg =
. setMovedFrom s
. setMovedTo s
. setModified s
) cfg
-------------------------------------------------------------------------------
-- Default config
@ -655,9 +657,9 @@ handleToFd h = case h of
--
ensureTrailingSlash :: Array Word8 -> Array Word8
ensureTrailingSlash path =
if A.length path /= 0
if byteLength path /= 0
then
let mx = A.getIndex path (A.length path - 1)
let mx = A.getIndex path (byteLength path - 1)
in case mx of
Nothing -> error "ensureTrailingSlash: Bug: Invalid index"
Just x ->
@ -666,6 +668,20 @@ ensureTrailingSlash path =
else path
else path
removeTrailingSlash :: Array Word8 -> Array Word8
removeTrailingSlash path =
if byteLength path /= 0
then
let n = byteLength path - 1
mx = A.getIndex path n
in case mx of
Nothing -> error "removeTrailingSlash: Bug: Invalid index"
Just x ->
if x == fromIntegral (ord '/')
then A.getSliceUnsafe 0 n path
else path
else path
-- | @addToWatch cfg watch root subpath@ adds @subpath@ to the list of paths
-- being monitored under @root@ via the watch handle @watch@. @root@ must be
-- an absolute path and @subpath@ must be relative to @root@.
@ -746,7 +762,7 @@ removeFromWatch (Watch handle wdMap) path = do
where
step fd newMap (wd, v) = do
if (fst v) == path
if fst v == path
then do
let err = "removeFromWatch: " ++ show (utf8ToString path)
rm = c_inotify_rm_watch (fdFD fd) (fromIntegral wd)
@ -808,7 +824,7 @@ data Event = Event
--
readOneEvent :: Config -> Watch -> Parser IO Word8 Event
readOneEvent cfg wt@(Watch _ wdMap) = do
let headerLen = (sizeOf (undefined :: CInt)) + 12
let headerLen = sizeOf (undefined :: CInt) + 12
arr <- PR.takeEQ headerLen (A.writeN headerLen)
(ewd, eflags, cookie, pathLen) <- PR.fromEffect $ A.unsafeAsPtr arr readHeader
-- XXX need the "initial" in parsers to return a step type so that "take 0"
@ -824,7 +840,7 @@ readOneEvent cfg wt@(Watch _ wdMap) = do
PR.fromFold
$ FL.takeEndBy_ (== 0)
$ FL.take pathLen (A.writeN pathLen)
let remaining = pathLen - A.length pth - 1
let remaining = pathLen - byteLength pth - 1
when (remaining /= 0) $ PR.takeEQ remaining FL.drain
return pth
else return $ A.fromList []
@ -847,7 +863,7 @@ readOneEvent cfg wt@(Watch _ wdMap) = do
-- What if a large dir tree gets moved in to our hierarchy? Do we get a
-- single event for the top level dir in this case?
return $ Event
{ eventWd = (fromIntegral ewd)
{ eventWd = fromIntegral ewd
, eventFlags = eflags
, eventCookie = cookie
, eventRelPath = sub1
@ -888,18 +904,21 @@ watchToStream cfg wt@(Watch handle _) = do
-- recursively. Monitoring starts from the current time onwards. The paths are
-- specified as UTF-8 encoded 'Array' of 'Word8'.
--
-- Note that recrusive watch on a large directory tree could be expensive. When
-- starting a watch, the whole tree must be read and watches are started on
-- each directory in the tree. The initial time to start the watch as well as
-- the memory required is proportional to the number of directories in the
-- tree.
-- /Non-existing Paths:/ the API fails if a watch is started on a non-exsting
-- path.
--
-- When new directories are created under the tree they are added to the watch
-- on receiving the directory create event. However, the creation of a dir and
-- adding a watch for it is not atomic. The implementation takes care of this
-- and makes sure that watches are added for all directories. However, In the
-- mean time, the directory may have received more events which may get lost.
-- Handling of any such lost events is yet to be implemented.
-- /Performance:/ Note that recursive watch on a large directory tree could be
-- expensive. When starting a watch, the whole tree must be read and watches
-- are started on each directory in the tree. The initial time to start the
-- watch as well as the memory required is proportional to the number of
-- directories in the tree.
--
-- /Bugs:/ When new directories are created under the tree they are added to
-- the watch on receiving the directory create event. However, the creation of
-- a dir and adding a watch for it is not atomic. The implementation takes
-- care of this and makes sure that watches are added for all directories.
-- However, In the mean time, the directory may have received more events which
-- may get lost. Handling of any such lost events is yet to be implemented.
--
-- See the Linux __inotify__ man page for more details.
--
@ -924,6 +943,8 @@ watchWith f paths = S.bracket before after (watchToStream cfg)
--
-- >>> watchRecursive = watchWith id
--
-- See 'watchWith' for pitfalls and bugs when using recursive watch on Linux.
--
-- /Pre-release/
--
watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event
@ -953,7 +974,7 @@ watch = watchWith (setRecursiveMode False)
--
getRoot :: Event -> Array Word8
getRoot Event{..} =
if (eventWd >= 1)
if eventWd >= 1
then
case Map.lookup (fromIntegral eventWd) eventMap of
Just path -> fst path
@ -973,10 +994,18 @@ getRelPath Event{..} = eventRelPath
-- | Get the absolute file system object path for which the event is generated.
--
-- When the watch root is a symlink, the absolute path returned is via the
-- original symlink and not through the resolved path.
--
-- /Pre-release/
--
getAbsPath :: Event -> Array Word8
getAbsPath ev = ensureTrailingSlash (getRoot ev) <> getRelPath ev
getAbsPath ev =
let relpath = getRelPath ev
root = getRoot ev
in if byteLength relpath /= 0
then ensureTrailingSlash root <> relpath
else removeTrailingSlash root
-- XXX should we use a Maybe?
-- | Cookie is set when a rename occurs. The cookie value can be used to
@ -1100,8 +1129,8 @@ isRootPathEvent = getFlag (iN_DELETE_SELF .|. iN_MOVE_SELF .|. iN_UNMOUNT)
--
-- /Pre-release/
--
isMetadataChanged :: Event -> Bool
isMetadataChanged = getFlag iN_ATTRIB
isAttrsModified :: Event -> Bool
isAttrsModified = getFlag iN_ATTRIB
-------------------------------------------------------------------------------
-- Access
@ -1251,7 +1280,7 @@ showEvent ev@Event{..} =
++ showev isRootMoved "RootMoved"
++ showev isRootUnmounted "RootUnmounted"
++ showev isMetadataChanged "MetadataChanged"
++ showev isAttrsModified "AttrsModified"
++ showev isAccessed "Accessed"
++ showev isOpened "Opened"

179
src/Streamly/Internal/FileSystem/Event/Windows.hs
View File

@ -55,12 +55,13 @@ module Streamly.Internal.FileSystem.Event.Windows
, setRecursiveMode
-- ** Events of Interest
, setRootMoved
, setModifiedFileName
, setModifiedAttribute
, setModifiedSize
, setModifiedLastWrite
, setModifiedSecurity
, setFileNameEvents
, setDirNameEvents
, setAttrsModified
, setSecurityModified
, setSizeModified
, setLastWriteTimeModified
, setAllEvents
-- ** Watch APIs
, watch
@ -142,7 +143,7 @@ data Config = Config
--
-- /Pre-release/
--
data Toggle = On | Off
data Toggle = On | Off deriving (Show, Eq)
setFlag :: DWORD -> Toggle -> Config -> Config
setFlag mask status cfg@Config{..} =
@ -154,97 +155,127 @@ setFlag mask status cfg@Config{..} =
-- | Set watch event on directory recursively.
--
-- /default: On/
-- /default: Off/
--
-- /Pre-release/
--
setRecursiveMode :: BOOL -> Config -> Config
setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}
setRecursiveMode :: Toggle -> Config -> Config
setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec == On}
-- | Report when a file name is modified.
-- | Generate notify events on file create, rename or delete.
--
-- From Windows API documentation: Any file name change in the watched
-- directory or subtree causes a change notification wait operation to return.
-- Changes include renaming, creating, or deleting a file.
--
-- /default: On/
--
-- /Pre-release/
--
setModifiedFileName :: Toggle -> Config -> Config
setModifiedFileName = setFlag fILE_NOTIFY_CHANGE_FILE_NAME
setFileNameEvents :: Toggle -> Config -> Config
setFileNameEvents = setFlag fILE_NOTIFY_CHANGE_FILE_NAME
-- | Report when a directory name is modified.
-- | Generate notify events on directory create, rename or delete.
--
-- From Windows API documentaiton: Any directory-name change in the watched
-- directory or subtree causes a change notification wait operation to return.
-- Changes include creating or deleting a directory.
--
-- /default: On/
--
-- /Pre-release/
--
setRootMoved :: Toggle -> Config -> Config
setRootMoved = setFlag fILE_NOTIFY_CHANGE_DIR_NAME
setDirNameEvents :: Toggle -> Config -> Config
setDirNameEvents = setFlag fILE_NOTIFY_CHANGE_DIR_NAME
-- | Report when a file attribute is modified.
-- | Generate an 'isModified' event on any attribute change in the watched
-- directory or subtree.
--
-- /default: On/
-- /default: Off/
--
-- /Pre-release/
--
setModifiedAttribute :: Toggle -> Config -> Config
setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES
setAttrsModified :: Toggle -> Config -> Config
setAttrsModified = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES
-- | Report when a file size is changed.
-- | Generate an 'isModified' event when the file size is changed.
--
-- /default: On/
-- From Windows API documentation: Any file-size change in the watched
-- directory or subtree causes a change notification wait operation to return.
-- The operating system detects a change in file size only when the file is
-- written to the disk. For operating systems that use extensive caching,
-- detection occurs only when the cache is sufficiently flushed.
--
-- /default: Off/
--
-- /Pre-release/
--
setModifiedSize :: Toggle -> Config -> Config
setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE
setSizeModified :: Toggle -> Config -> Config
setSizeModified = setFlag fILE_NOTIFY_CHANGE_SIZE
-- | Report when a file last write time is changed.
-- | Generate an 'isModified' event when the last write timestamp of the file
-- inode is changed.
--
-- /default: On/
-- From Windows API documentation: Any change to the last write-time of files
-- in the watched directory or subtree causes a change notification wait
-- operation to return. The operating system detects a change to the last
-- write-time only when the file is written to the disk. For operating systems
-- that use extensive caching, detection occurs only when the cache is
-- sufficiently flushed.
--
-- /default: Off/
--
-- /Pre-release/
--
setModifiedLastWrite :: Toggle -> Config -> Config
setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
setLastWriteTimeModified :: Toggle -> Config -> Config
setLastWriteTimeModified = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE
-- | Report when a file Security attribute changes.
-- | Generate an 'isModified' event when any security-descriptor change occurs
-- in the watched directory or subtree.
--
-- /default: On/
-- /default: Off/
--
-- /Pre-release/
--
setModifiedSecurity :: Toggle -> Config -> Config
setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY
setSecurityModified :: Toggle -> Config -> Config
setSecurityModified = setFlag fILE_NOTIFY_CHANGE_SECURITY
-- | Set all tunable events 'On' or 'Off'. Equivalent to setting:
--
-- * setModifiedFileName
-- * setRootMoved
-- * setModifiedAttribute
-- * setModifiedSize
-- * setModifiedLastWrite
-- * setModifiedSecurity
-- * setFileNameEvents
-- * setDirNameEvents
-- * setAttrsModified
-- * setSizeModified
-- * setLastWriteTimeModified
-- * setSecurityModified
--
-- /Pre-release/
--
setAllEvents :: Toggle -> Config -> Config
setAllEvents s =
setModifiedFileName s
. setRootMoved s
. setModifiedAttribute s
. setModifiedSize s
. setModifiedLastWrite s
. setModifiedSecurity s
setFileNameEvents s
. setDirNameEvents s
. setAttrsModified s
. setSizeModified s
. setLastWriteTimeModified s
. setSecurityModified s
-- | The tunable events that are enabled by default are:
--
-- * setModifiedFileName On
-- * setFileNameEvents On
-- * setDirNameEvents On
-- * setSizeModified On
-- * setLastWriteTimeModified On
--
-- /Pre-release/
--
defaultConfig :: Config
defaultConfig =
setModifiedFileName On
$ Config {watchRec = True, createFlags = 0}
setFileNameEvents On
$ setDirNameEvents On
$ setSizeModified On
$ setLastWriteTimeModified On
$ Config {watchRec = False, createFlags = 0}
getConfigFlag :: Config -> DWORD
getConfigFlag Config{..} = createFlags
@ -361,6 +392,7 @@ readDirectoryChanges root h wst mask = do
bytesRet <- peekByteOff bret 0
readChangeEvents buffer root bytesRet
-- XXX Try to get these from windows header files
type FileAction = DWORD
fILE_ACTION_ADDED :: FileAction
@ -426,9 +458,14 @@ closePathHandleStream = S.mapM_ (\(h, _, _) -> closeHandle h)
-- monitored. Monitoring starts from the current time onwards. The paths are
-- specified as UTF-8 encoded 'Array' of 'Word8'.
--
-- /Symbolic Links:/ If the pathname to be watched is a symbolic link then
-- watch the target of the symbolic link instead of the symbolic link itself.
-- Note that the path location in the events is through the original symbolic
-- link path rather than the resolved path.
--
-- @
-- watchWith
-- ('setModifiedAttribute' On . 'setModifiedLastWrite' Off)
-- ('setAttrsModified' On . 'setLastWriteTimeModified' Off)
-- [Array.fromCString\# "dir"#]
-- @
--
@ -445,19 +482,21 @@ watchWith f paths =
-- | Same as 'watchWith' using 'defaultConfig' and recursive mode.
--
-- >>> watchRecursive = watchWith id
-- >>> watchRecursive = watchWith (setRecursiveMode On)
--
-- /Pre-release/
--
watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event
watchRecursive = watchWith id
watchRecursive = watchWith (setRecursiveMode On)
-- | Same as 'watchWith' using defaultConfig and non-recursive mode.
--
-- >>> watch = watchWith id
--
-- /Pre-release/
--
watch :: NonEmpty (Array Word8) -> SerialT IO Event
watch = watchWith (setRecursiveMode False)
watch = watchWith id
getFlag :: DWORD -> Event -> Bool
getFlag mask Event{..} = eventFlags == mask
@ -481,6 +520,13 @@ getRelPath Event{..} = (UTF8.toArray . UTF8.pack) eventRelPath
getRoot :: Event -> Array Word8
getRoot Event{..} = (UTF8.toArray . UTF8.pack) eventRootPath
-- | Get the absolute file system object path for which the event is generated.
--
-- When the watch root is a symlink, the absolute path returned is via the
-- original symlink and not through the resolved path.
--
-- /Pre-release/
--
getAbsPath :: Event -> Array Word8
getAbsPath ev = getRoot ev <> A.fromCString# "\\"# <> getRelPath ev
@ -490,6 +536,8 @@ getAbsPath ev = getRoot ev <> A.fromCString# "\\"# <> getRelPath ev
-- directory or directory tree when in recursive watch mode. Creating a hard
-- link also generates this event.
--
-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/
--
-- /Pre-release/
--
isCreated :: Event -> Bool
@ -499,6 +547,8 @@ isCreated = getFlag fILE_ACTION_ADDED
-- watched directory or directory tree when in recursive mode. This event is
-- generated even when a hard link is deleted.
--
-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/
--
-- /Pre-release/
--
isDeleted :: Event -> Bool
@ -507,6 +557,8 @@ isDeleted = getFlag fILE_ACTION_REMOVED
-- | Generated for the original path when an object is moved from under a
-- monitored directory.
--
-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/
--
-- /Pre-release/
--
isMovedFrom :: Event -> Bool
@ -515,6 +567,8 @@ isMovedFrom = getFlag fILE_ACTION_RENAMED_OLD_NAME
-- | Generated for the new path when an object is moved under a monitored
-- directory.
--
-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/
--
-- /Pre-release/
--
isMovedTo :: Event -> Bool
@ -525,6 +579,7 @@ isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME
--
-- >>> isMoved ev = isMovedFrom ev || isMovedTo ev
--
-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/
-- /Occurs only for an object inside the watched directory/
--
-- /Pre-release/
@ -534,20 +589,26 @@ isMoved ev = isMovedFrom ev || isMovedTo ev
-- XXX This event is generated only for files and not directories?
--
-- | Determine whether the event indicates modification of an object within the
-- monitored path. This event is generated when a file or directory contents
-- are modified. In non-recursive mode this event is not generated for
-- directories. In recursive mode this event is generated for the parent
-- directory if a file or directory inside it is created or renamed.
-- | This event occurs when a file or directory contents, timestamps or
-- attributes are modified. Since it can occur on multiple changes, you may
-- have to check the attributes to know what exactly changed when multiple type
-- of modified events are enabled.
--
-- In non-recursive mode this event does not occur for directories. In
-- recursive mode this event occurs for the parent directory if a file or
-- directory inside it is created or renamed.
--
-- /Occurs when one of the @set*Modified@ events is enabled/
--
-- /Pre-release/
--
isModified :: Event -> Bool
isModified = getFlag fILE_ACTION_MODIFIED
-- | If the buffer overflows, entire contents of the buffer are discarded,
-- therefore, events are lost. The user application must scan everything under
-- the watched paths to know the current state.
-- | If the kernel event buffer overflows, entire contents of the buffer are
-- discarded, therefore, events are lost. The user application must scan
-- everything under the watched paths to know the current state of the file
-- system tree.
--
-- /Pre-release/
--

4
streamly.cabal
View File

@ -93,10 +93,10 @@ extra-source-files:
test/Streamly/Test/Data/Array/Stream/Foreign.hs
test/Streamly/Test/Data/Parser/ParserD.hs
test/Streamly/Test/FileSystem/Event.hs
test/Streamly/Test/FileSystem/Event/Common.hs
test/Streamly/Test/FileSystem/Event/Darwin.hs
test/Streamly/Test/FileSystem/Event/Windows.hs
test/Streamly/Test/FileSystem/Event/Linux.hs
test/Streamly/Test/FileSystem/Event/WindowsTest.hs
test/Streamly/Test/FileSystem/Event/LinuxTest.hs
test/Streamly/Test/FileSystem/Handle.hs
test/Streamly/Test/Network/Socket.hs
test/Streamly/Test/Network/Inet/TCP.hs

27
test/Streamly/Test/FileSystem/Event.hs
View File

@ -1,23 +1,28 @@
-- |
-- Module : Streamly.Test.FileSystem.Event
-- Copyright : (c) 2020 Composewell Technologies
-- Copyright : (c) 2021 Composewell Technologies
-- License : BSD-3-Clause
-- Maintainer : streamly@composewell.com
-- Stability : experimental
-- Portability : GHC
--
module Main (main) where
module Streamly.Test.FileSystem.Event (main) where
import System.IO (BufferMode(..), hSetBuffering, stdout)
#if defined(CABAL_OS_LINUX)
import qualified Streamly.Test.FileSystem.Event.Linux as Event
#elif defined(CABAL_OS_WINDOWS)
import qualified Streamly.Test.FileSystem.Event.Windows as Event
#endif
import qualified Streamly.Internal.FileSystem.Event as Event
import Streamly.Test.FileSystem.Event.Common
moduleName :: String
moduleName = "FileSystem.Event"
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
Event.testCommonEvents
let run = runTests moduleName "non-recursive" Event.watch
run DirType commonTests
run
#if defined(CABAL_OS_DARWIN)
SymLinkResolvedPath
#else
SymLinkOrigPath
#endif
commonTests

418
test/Streamly/Test/FileSystem/Event/Common.hs Normal file
View File

@ -0,0 +1,418 @@
-- |
-- Module : Streamly.Test.FileSystem.Event.Common
-- Copyright : (c) 2020 Composewell Technologies
-- License : BSD-3-Clause
-- Maintainer : streamly@composewell.com
-- Stability : experimental
-- Portability : GHC
--
module Streamly.Test.FileSystem.Event.Common
( TestDesc
-- * Running tests
, runTests
, WatchRootType (..)
-- * Event predicates
, dirEvent
, fileEvent
-- * Tests
, dirCreate
, dirCreateWithParent
, dirDelete
, dirMove
, rootDirMove
, fileCreate
, fileCreateWithParent
, fileDelete
, fileModify
, fileMove
, rootFileMove
, commonTests
, commonRecTests
)
where
import Debug.Trace (trace)
import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar, threadDelay)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO)
import Data.Bifunctor (first)
import Data.Function ((&))
import Data.Functor.Identity (runIdentity)
import Data.List.NonEmpty (NonEmpty)
import Data.Word (Word8)
import Streamly.Data.Array.Foreign (Array)
import System.Directory
( createDirectory
, createDirectoryIfMissing
, createDirectoryLink
, removeFile
, removePathForcibly
, renameDirectory
, renamePath
)
import System.FilePath ((</>), takeDirectory)
import System.IO
( BufferMode(..), hSetBuffering, stdout, IOMode (WriteMode), openFile
, hClose)
import System.IO.Temp (withSystemTempDirectory)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Streamly.Internal.Data.Array.Foreign as Array
import qualified Streamly.Internal.Data.Stream.IsStream as Stream
import qualified Streamly.Unicode.Stream as Unicode
#if defined(FILESYSTEM_EVENT_LINUX)
import Streamly.Internal.FileSystem.Event.Linux (Event)
import qualified Streamly.Internal.FileSystem.Event.Linux as Event
#elif defined(FILESYSTEM_EVENT_DARWIN)
import Streamly.Internal.FileSystem.Event.Darwin (Event)
import qualified Streamly.Internal.FileSystem.Event.Darwin as Event
#elif defined(FILESYSTEM_EVENT_WINDOWS)
import Streamly.Internal.FileSystem.Event.Windows (Event)
import qualified Streamly.Internal.FileSystem.Event.Windows as Event
#else
import Streamly.Internal.FileSystem.Event (Event)
import qualified Streamly.Internal.FileSystem.Event as Event
#endif
import Test.Hspec
-------------------------------------------------------------------------------
-- Check generated events
-------------------------------------------------------------------------------
type EventChecker =
FilePath -- watch root
-> FilePath -- watch target, target dir if root is a symlink
-> MVar () -- mvar to sync file system ops and the watch
-> [(String, Event -> Bool)] -- expected events
-> IO ()
type EventWatcher = NonEmpty (Array Word8) -> Stream.SerialT IO Event.Event
eventMatches :: Event -> (String, Event -> Bool) -> Bool
eventMatches ev (expectedPath, f) =
trace ("paths: " ++ show evPath ++ " " ++ show expectedPath)
(evPath == expectedPath && f ev)
where
utf8ToString :: Array Word8 -> String
utf8ToString =
runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.toStream
evPath = utf8ToString (Event.getAbsPath ev)
toUtf8 :: MonadIO m => String -> m (Array Word8)
toUtf8 = Array.fromStream . Unicode.encodeUtf8' . Stream.fromList
checkEvents :: EventWatcher -> EventChecker
checkEvents watcher rootPath targetPath mvar matchList = do
putStrLn ("Watching on root [" <> rootPath
<> "] for [" <> targetPath <> "]")
let matchList1 = fmap (first (targetPath </>)) matchList
finder xs ev = filter (not . eventMatches ev) xs
paths <- mapM toUtf8 [rootPath]
watcher (NonEmpty.fromList paths)
& Stream.before (putMVar mvar ())
& Stream.trace (putStrLn . Event.showEvent)
& Stream.scanl' finder matchList1
& Stream.takeWhile (not . null)
& Stream.drain
-------------------------------------------------------------------------------
-- Run tests
-------------------------------------------------------------------------------
type TestDesc =
( String -- test description
, FilePath -> IO () -- pre test operation, arg is path of the watch root.
, FilePath -> IO () -- file system action, arg is path of the watch root.
, [(String, Event -> Bool)] -- expected events (Absolute Path, predicate)
)
-- | Whether watch root is a symlink and if so then what's the behavior
data WatchRootType =
DirType -- watch root is a directory
| FileType -- watch root is a file
| SymLinkResolvedPath -- symlink to a directory,
-- Event contains path via the resolved dir
| SymLinkOrigPath -- symlink to a directory,
-- Event contains path via the original symlink
deriving Show
driver :: EventChecker -> WatchRootType -> TestDesc -> SpecWith ()
driver checker symlinkStyle (desc, pre, ops, expected) =
it desc $ runOneTest `shouldReturn` ()
where
fseventDir :: String
fseventDir = "fsevent_dir"
runOneTest = do
sync <- newEmptyMVar
withSystemTempDirectory fseventDir $ \fp -> do
let root = fp </> "watch-root"
target <-
case symlinkStyle of
DirType -> do
createDirectory root
return root
FileType -> do
openFile root WriteMode >>= hClose
return root
SymLinkResolvedPath -> do
let tgt = fp </> "watch-root-real"
createDirectory tgt
createDirectoryLink tgt root
return tgt
SymLinkOrigPath -> do
let tgt = fp </> "watch-root-real"
createDirectory tgt
createDirectoryLink tgt root
return root
-- XXX On macOS we seem to get the watch root create events
-- even though they occur before the watch is started. Even if
-- we add a delay here.
startWatchAndCheck root target sync
startWatchAndCheck root target sync = do
pre root
-- XXX On macOS the events from pre ops also seem to be bundled
-- with the events occurred after the watch is started.
let check = checker root target sync expected
fsOps = Stream.fromEffect $ runFSOps root sync
Stream.drain $ Stream.fromEffect check `Stream.parallelFst` fsOps
runFSOps fp sync = do
-- We put the MVar before the event watcher starts to run but that does
-- not ensure that the event watcher has actually started. So we need a
-- delay as well. Do we?
takeMVar sync >> threadDelay 200000
ops fp
threadDelay 10000000
error "Time out occurred before event watcher could terminate"
-------------------------------------------------------------------------------
-- Test descriptions
-------------------------------------------------------------------------------
dirEvent, fileEvent :: (Event -> Bool) -> Event -> Bool
#if defined(FILESYSTEM_EVENT_DARWIN)
dirEvent f ev = Event.isDir ev && f ev
fileEvent f ev = Event.isFile ev && f ev
#elif defined(FILESYSTEM_EVENT_LINUX)
dirEvent f ev = Event.isDir ev && f ev
fileEvent f ev = not (Event.isDir ev) && f ev
#else
dirEvent = id
fileEvent = id
#endif
-- XXX Tests for root as a regular file instead of dir?
-- XXX Add symlink and hardlink tests
-- XXX Add exception condition tests
-------------------------------------------------------------------------------
-- Dir tests
-------------------------------------------------------------------------------
createParent :: FilePath -> FilePath -> IO ()
createParent file parent = do
createDirectoryIfMissing True (parent </> takeDirectory file)
createDirWithParent :: FilePath -> FilePath -> IO ()
createDirWithParent dir parent =
when (not (null dir)) $ createDirectoryIfMissing True (parent </> dir)
createDir :: FilePath -> FilePath -> IO ()
createDir dir parent =
when (not (null dir)) $ createDirectory (parent </> dir)
-- | Create the dir along with its parent dir during the test. This is
-- especially useful to detect a race in Linux case where the watch for a
-- directory is added in event processing, so if the the child directory is
-- created before the watch was installed then we may miss some events.
dirCreateWithParent ::
String -> (String -> [([Char], Event -> Bool)]) -> TestDesc
dirCreateWithParent dir events =
( "dir created (" ++ dir ++ ")"
, const (return ())
, createDirWithParent dir
, events dir
)
dirCreate :: String -> (String -> [([Char], Event -> Bool)]) -> TestDesc
dirCreate dir events =
( "dir created (" ++ dir ++ ")"
, createParent dir
, createDir dir
, events dir
)
dirDelete :: String -> (String -> [([Char], Event -> Bool)]) -> TestDesc
dirDelete dir events =
( "dir deleted (" ++ dir ++ ")"
, createDirWithParent dir
, \fp -> removePathForcibly (fp </> dir)
, events dir
)
dirMove ::
String
-> String
-> (String -> String -> [(String, Event -> Bool)])
-> TestDesc
dirMove dir1 dir2 events =
( "dir moved (" ++ dir1 ++ " " ++ dir2 ++ ")"
, createDirWithParent dir1
, \fp -> renameDirectory (fp </> dir1) (fp </> dir2)
, events dir1 dir2
)
rootDirMove ::
String
-> (String -> [(String, Event -> Bool)])
-> TestDesc
rootDirMove suffix events =
( "root dir moved" ++ "(" ++ suffix ++ ")"
, const (return ())
, \fp -> renameDirectory fp (fp <> suffix)
, events ""
)
-------------------------------------------------------------------------------
-- File tests
-------------------------------------------------------------------------------
createFileWithParent :: FilePath -> FilePath -> IO ()
createFileWithParent file parent = do
when (not (null file)) $
createDirectoryIfMissing True (parent </> takeDirectory file)
openFile (parent </> file) WriteMode >>= hClose
createFile :: FilePath -> FilePath -> IO ()
createFile file parent =
openFile (parent </> file) WriteMode >>= hClose
fileCreate :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
fileCreate file1 events =
( "File created (" ++ file1 ++ ")"
, createParent file1
, createFile file1
, (file1, fileEvent Event.isCreated) : events file1
)
-- | See comments in dirCreateWithParent
fileCreateWithParent ::
String -> (String -> [(String, Event -> Bool)]) -> TestDesc
fileCreateWithParent file1 events =
( "File created (" ++ file1 ++ ")"
, const (return ())
, createFileWithParent file1
, (file1, fileEvent Event.isCreated) : events file1
)
fileDelete :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
fileDelete file1 events =
( "File deleted (" ++ file1 ++ ")"
, createFileWithParent file1
, \fp -> removeFile (fp </> file1)
, events file1
)
fileModify :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
fileModify file1 events =
( "File modified (" ++ file1 ++ ")"
, createFileWithParent file1
, \fp -> writeFile (fp </> file1) "Test Data"
, (file1, fileEvent Event.isModified) : events file1
)
fileMove ::
String
-> String
-> (String -> String -> [(String, Event -> Bool)])
-> TestDesc
fileMove file1 file2 events =
( "File moved (" ++ file1 ++ " " ++ file2 ++ ")"
, createFileWithParent file1
, \fp -> renamePath (fp </> file1) (fp </> file2)
, (file1, fileEvent Event.isMoved)
: (file2, fileEvent Event.isMoved)
: events file1 file2
)
rootFileMove :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc
rootFileMove suffix events =
( "File moved (" ++ suffix ++ ")"
, const (return ())
, \fp -> renamePath fp (fp <> suffix)
, events ""
)
-------------------------------------------------------------------------------
-- Common test bundles
-------------------------------------------------------------------------------
withParent :: [Char] -> [Char] -> [Char]
withParent parent file = if null parent then file else parent </> file
testsWithParent :: String -> [TestDesc]
testsWithParent p =
[ dirCreate
(withParent p "dir") (\dir -> [(dir, dirEvent Event.isCreated)])
, dirDelete
(withParent p "dir") (\dir -> [(dir, dirEvent Event.isDeleted)])
, dirMove
(withParent p "dir1")
(withParent p "dir2")
(\dir1 dir2 ->
[ (dir1, dirEvent Event.isMoved)
, (dir2, dirEvent Event.isMoved)
]
)
, fileCreate (withParent p "file1") (const [])
, fileDelete
(withParent p "file1")
(\file -> [(file, fileEvent Event.isDeleted)])
, fileModify (withParent p "file1") (const [])
, fileMove (withParent p "file1") (withParent p "file2") (\_ _ -> [])
]
commonTests :: [TestDesc]
commonTests = testsWithParent ""
commonRecTests :: [TestDesc]
commonRecTests = testsWithParent "subdir"
-------------------------------------------------------------------------------
-- Running tests
-------------------------------------------------------------------------------
runTests ::
String
-> String
-> EventWatcher
-> WatchRootType
-> [TestDesc]
-> IO ()
runTests modName watchType watcher rootType tests = do
hSetBuffering stdout NoBuffering
hspec
$ describe modName
$ describe watchType
$ do
let checker = checkEvents watcher
describe ("Root type " ++ show rootType)
$ mapM_ (driver checker rootType) tests

85
test/Streamly/Test/FileSystem/Event/Darwin.hs Normal file
View File

@ -0,0 +1,85 @@
-- |
-- Module : Streamly.Test.FileSystem.Event.Darwin
-- Copyright : (c) 2020 Composewell Technologies
-- License : BSD-3-Clause
-- Maintainer : streamly@composewell.com
-- Stability : experimental
-- Portability : GHC
--
module Streamly.Test.FileSystem.Event.Darwin (main) where
import qualified Streamly.Internal.FileSystem.Event.Darwin as Event
import Streamly.Test.FileSystem.Event.Common
moduleName :: String
moduleName = "FileSystem.Event.Darwin"
-- TODO:
-- Creation/deletion/move of hard links
-- Deletion of last hard link
-- If a directory is a symlink is it followed in recursive mode?
main :: IO ()
main = do
let symLinkRootTests =
dirCreateWithParent "subdir/dir"
(\dir -> [(dir, dirEvent Event.isCreated)])
: fileCreateWithParent "subdir/file"
(\file ->
[ (file, fileEvent Event.isCreated)
, (file, fileEvent Event.isAttrsModified)
]
)
: fileCreate "file-create-attrs"
(\file ->
[ (file, fileEvent Event.isCreated)
, (file, fileEvent Event.isAttrsModified)
]
)
: fileModify
"file-mod-attrs"
(\file -> [(file, fileEvent Event.isAttrsModified)])
: dirDelete "dir-sec" (\dir ->
[ (dir, dirEvent Event.isDeleted)
, (dir, dirEvent Event.isSecurityModified)
]
)
: commonTests
++ commonRecTests
let regularRootTests =
dirDelete "" (\dir ->
[ (dir, dirEvent Event.isDeleted)
, (dir, dirEvent Event.isSecurityModified)
, (dir, Event.isRootPathEvent)
]
)
-- The watch root create event always seems to come even though the
-- root is created before the watch is started. That may be because
-- of batching?
-- XXX Need to create watch root after adding the watch
: dirCreate "" (\dir -> [(dir, dirEvent Event.isCreated)])
: rootDirMove "moved" (\src ->
[ (src, Event.isRootPathEvent)
, (src, Event.isMoved)
])
: symLinkRootTests
let fileRootTests =
[ fileDelete "" (\path ->
[ (path, Event.isRootPathEvent)
, (path, Event.isDeleted)
])
, rootFileMove "moved" (\path ->
[(path, Event.isRootPathEvent)
, (path, Event.isMoved)
])
, fileModify "" (const [])
]
let w = Event.watchWith (Event.setAllEvents Event.On)
run = runTests moduleName "recursive" w
run DirType regularRootTests
run SymLinkResolvedPath symLinkRootTests
run FileType fileRootTests

928
test/Streamly/Test/FileSystem/Event/Linux.hs
View File

@ -6,827 +6,147 @@
-- Stability : experimental
-- Portability : GHC
--
module Streamly.Test.FileSystem.Event.Linux (testAllEvents, testCommonEvents) where
module Streamly.Test.FileSystem.Event.Linux (main) where
import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar, threadDelay)
import Control.Monad.IO.Class (MonadIO)
import Data.Char (ord)
import Data.Functor.Identity (runIdentity)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromJust)
import Data.Word (Word8)
import System.Directory
( createDirectoryIfMissing
, createDirectoryLink
, removeFile
, removeDirectory
, removePathForcibly
, renameDirectory
, renamePath
)
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
import System.IO.Unsafe (unsafePerformIO)
import Streamly.Internal.Data.Array.Foreign (Array)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Streamly.Unicode.Stream as Unicode
import qualified Streamly.Internal.Data.Array.Foreign as Array
import qualified Streamly.Internal.Data.Fold as FL
import qualified Streamly.Internal.Data.Parser as PR
import qualified Streamly.Internal.Data.Stream.IsStream as S
import qualified Streamly.Internal.Unicode.Stream as U
import Streamly.Internal.FileSystem.Event.Linux (Event)
import qualified Streamly.Internal.FileSystem.Event.Linux as Event
import Test.Hspec
import Streamly.Test.FileSystem.Event.Common
-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------
toUtf8 :: MonadIO m => String -> m (Array Word8)
toUtf8 = Array.fromStream . Unicode.encodeUtf8' . S.fromList
utf8ToString :: Array Word8 -> String
utf8ToString = runIdentity . S.toList . U.decodeUtf8' . Array.toStream
timeout :: IO String
timeout = threadDelay 5000000 >> return "Timeout"
fseventDir :: String
fseventDir = "fsevent_dir"
eoTask :: String
eoTask = "EOTask"
-- XXX Make the getRelPath type same on windows and other platforms
eventPredicate :: Event.Event -> Bool
eventPredicate ev =
if (utf8ToString $ Event.getRelPath ev) == eoTask
then False
else True
-------------------------------------------------------------------------------
-- Event matching utilities
-------------------------------------------------------------------------------
removeTrailingSlash :: Array Word8 -> Array Word8
removeTrailingSlash path =
if Array.length path == 0
then path
else
let mx = Array.getIndex path (Array.length path - 1)
in case mx of
Nothing -> error "removeTrailingSlash: Bug: Invalid index"
Just x ->
if x == fromIntegral (ord '/')
-- XXX need array slicing
then unsafePerformIO
$ Array.fromStreamN (Array.length path - 1)
$ Array.toStream path
else path
-- XXX Return a tuple (path, flags) instead of appending flags to path. And
-- then check the flags using an event mask.
showEventShort :: Event.Event -> String
showEventShort ev@Event.Event{..} =
utf8ToString (removeTrailingSlash $ Event.getRelPath ev)
++ "_" ++ show eventFlags
-- ++ showev Event.isDir "DirX"
++ showev Event.isEventsLost "Overflow"
++ showev Event.isRootUnwatched "RootUnwatched"
++ showev Event.isRootDeleted "RootDeleted"
++ showev Event.isRootMoved "RootMoved"
++ showev Event.isRootUnmounted "RootUnmounted"
++ showev Event.isMetadataChanged "MetadataChanged"
++ showev Event.isAccessed "Accessed"
++ showev Event.isOpened "Opened"
++ showev Event.isWriteClosed "WriteClosed"
++ showev Event.isNonWriteClosed "NonWriteClosed"
++ showev Event.isCreated "Created"
++ showev Event.isDeleted "Deleted"
++ showev Event.isModified "Modified"
++ showev Event.isMovedFrom "MovedFrom"
++ showev Event.isMovedTo "MovedTo"
++ showev Event.isDir "Dir"
where showev f str = if f ev then "_" ++ str else ""
type EventChecker = FilePath -> MVar () -> [String] -> IO String
type EventWatch = NonEmpty (Array Word8) -> S.SerialT IO Event.Event
type ToEventList = S.SerialT IO Event.Event -> IO [Event.Event]
-------------------------------------------------------------------------------
-- Event Watcher
-------------------------------------------------------------------------------
eventListWithFixLen :: Int -> ToEventList
eventListWithFixLen count = S.toList . S.take count --51/20
eventListWithEOtask :: ToEventList
eventListWithEOtask = S.parse (PR.takeWhile eventPredicate FL.toList)
checkEvents :: ToEventList -> EventWatch -> EventChecker
checkEvents toEL ew rootPath m matchList = do
let args = [rootPath]
paths <- mapM toUtf8 args
putStrLn ("Watch started !!!! on Path " ++ rootPath)
events <- toEL
$ S.before (putMVar m ())
$ ew (NonEmpty.fromList paths)
let eventStr = map showEventShort events
let baseSet = Set.fromList matchList
resultSet = Set.fromList eventStr
if baseSet `Set.isSubsetOf` resultSet
then
return "PASS"
else do
putStrLn $ "baseSet " ++ show matchList
putStrLn $ "resultSet " ++ show eventStr
return "Mismatch"
-------------------------------------------------------------------------------
-- FS Event Generators
-------------------------------------------------------------------------------
checker :: S.IsStream t =>
EventChecker -> FilePath -> MVar () -> [String] -> t IO String
checker ec rootPath synch matchList =
S.fromEffect (ec rootPath synch matchList)
`S.parallelFst`
S.fromEffect timeout
-------------------------------------------------------------------------------
-- Test Drivers
-------------------------------------------------------------------------------
driver ::
EventChecker
-> ( String
, FilePath -> IO ()
, FilePath -> IO ()
, [String]
, Bool
)
-> SpecWith ()
driver ec (desc, pre, ops, events, sym) = it desc $ runTest `shouldReturn` "PASS"
where
runTest = do
sync <- newEmptyMVar
withSystemTempDirectory fseventDir $ \fp ->
if sym
then do
createDirectoryLink fp (fp ++ "SymLink")
runTest0 (fp ++ "SymLink") sync
else runTest0 fp sync
runTest0 fp sync = do
pre fp
let eventStream = checker ec fp sync events
fsOps = S.fromEffect $ runFSOps fp sync
fmap fromJust $ S.head $ eventStream `S.parallelFst` fsOps
runFSOps fp sync = do
_ <- takeMVar sync
threadDelay 200000
ops fp
-- 'EOTask Created dir' event gets out of order so need to wait here
threadDelay 200000 -- Why this delay?
createDirectoryIfMissing True (fp </> eoTask)
threadDelay 10000000
error "fs ops timed out"
-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------
testDesc,
testDescRemoveRootDir,
testDescRemoveRootDirSymLink,
testDescMoveRootDir,
testDescCommon,
testDescMoveRootDirCommon,
testDescRemoveRootDirCommon,
testDescRemoveRootDirSymLinkCommon ::
[ ( String -- test description
, FilePath -> IO () -- pre test operation
, FilePath -> IO () -- file system actions
, [String] -- expected events
, Bool ) -- SymLink
]
testDesc =
[
( "Create a single directory"
, const (return ())
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1Single_1073742080_Created_Dir"
, "dir1Single_1073741856_Opened_Dir"
, "dir1Single_1073741825_Accessed_Dir"
, "dir1Single_1073741840_NonWriteClosed_Dir"
]
, False
)
, ( "Remove a single directory"
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, \fp -> removeDirectory (fp </> "dir1Single")
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1Single_1073741856_Opened_Dir"
, "dir1Single_1073741825_Accessed_Dir"
, "dir1Single_1073741840_NonWriteClosed_Dir"
, "dir1Single_1024_RootDeleted"
, "dir1Single_32768_RootUnwatched"
, "dir1Single_1073742336_Deleted_Dir"
]
, False
)
, ( "Rename a single directory"
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, \fp ->
let spath = fp </> "dir1Single"
tpath = fp </> "dir1SingleRenamed"
in renameDirectory spath tpath
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1Single_1073741856_Opened_Dir"
, "dir1Single_1073741825_Accessed_Dir"
, "dir1Single_1073741840_NonWriteClosed_Dir"
, "dir1Single_1073741888_MovedFrom_Dir"
, "dir1SingleRenamed_1073741952_MovedTo_Dir"
, "dir1Single_2048_RootMoved"
]
, False
)
, ( "Create a nested directory"
, const (return ())
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1_1073742080_Created_Dir"
, "dir1_1073741856_Opened_Dir"
, "dir1_1073741825_Accessed_Dir"
, "dir1_1073741840_NonWriteClosed_Dir"
, "dir1/dir2_1073741856_Opened_Dir"
, "dir1/dir2_1073741825_Accessed_Dir"
, "dir1/dir2_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3_1073741856_Opened_Dir"
, "dir1/dir2/dir3_1073741825_Accessed_Dir"
, "dir1/dir2/dir3_1073741840_NonWriteClosed_Dir"
]
, False
)
, ( "Rename a nested directory"
, \fp -> createDirectoryIfMissing True
(fp </> "dir1" </> "dir2" </> "dir3")
, \fp ->
let spath = fp </> "dir1" </> "dir2" </> "dir3"
tpath = fp </> "dir1" </> "dir2" </> "dir3Renamed"
in renameDirectory spath tpath
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1_1073741856_Opened_Dir"
, "dir1_1073741825_Accessed_Dir"
, "dir1_1073741840_NonWriteClosed_Dir"
, "dir1/dir2_1073741856_Opened_Dir"
, "dir1/dir2_1073741825_Accessed_Dir"
, "dir1/dir2_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3_1073741856_Opened_Dir"
, "dir1/dir2/dir3_1073741825_Accessed_Dir"
, "dir1/dir2/dir3_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3_1073741888_MovedFrom_Dir"
, "dir1/dir2/dir3Renamed_1073741952_MovedTo_Dir"
, "dir1/dir2/dir3_2048_RootMoved"
]
, False
)
, ( "Create a file in root Dir"
, const (return ())
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "FileCreated.txt_256_Created"
, "FileCreated.txt_32_Opened"
, "FileCreated.txt_2_Modified"
, "FileCreated.txt_8_WriteClosed"
]
, False
)
, ( "Remove a file in root Dir"
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, \fp -> removeFile (fp </> "FileCreated.txt")
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "FileCreated.txt_512_Deleted"
]
, False
)
, ( "Rename a file in root Dir"
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, \fp ->
let spath = (fp </> "FileCreated.txt")
tpath = (fp </> "FileRenamed.txt")
in renamePath spath tpath
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "FileCreated.txt_64_MovedFrom"
, "FileRenamed.txt_128_MovedTo"
]
, False
)
, ( "Create a file in a nested Dir"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, \fp ->
let p = fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt"
in writeFile p "Test Data"
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1_1073741856_Opened_Dir"
, "dir1_1073741825_Accessed_Dir"
, "dir1_1073741840_NonWriteClosed_Dir"
, "dir1/dir2_1073741856_Opened_Dir"
, "dir1/dir2_1073741825_Accessed_Dir"
, "dir1/dir2_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3_1073741856_Opened_Dir"
, "dir1/dir2/dir3_1073741825_Accessed_Dir"
, "dir1/dir2/dir3_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3/FileCreated.txt_256_Created"
, "dir1/dir2/dir3/FileCreated.txt_32_Opened"
, "dir1/dir2/dir3/FileCreated.txt_2_Modified"
, "dir1/dir2/dir3/FileCreated.txt_8_WriteClosed"
]
, False
)
, ( "Remove a file in a nested Dir"
, \fp ->
let nestedDir = fp </> "dir1" </> "dir2" </> "dir3"
fpath = nestedDir </> "FileCreated.txt"
in do
createDirectoryIfMissing True nestedDir
writeFile fpath "Test Data"
, \fp ->
let p = fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt"
in removeFile p
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1_1073741856_Opened_Dir"
, "dir1_1073741825_Accessed_Dir"
, "dir1_1073741840_NonWriteClosed_Dir"
, "dir1/dir2_1073741856_Opened_Dir"
, "dir1/dir2_1073741825_Accessed_Dir"
, "dir1/dir2_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3_1073741856_Opened_Dir"
, "dir1/dir2/dir3_1073741825_Accessed_Dir"
, "dir1/dir2/dir3_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3/FileCreated.txt_512_Deleted"
]
, False
)
, ( "Rename a file in a nested Dir"
, \fp ->
let nestedDir = fp </> "dir1" </> "dir2" </> "dir3"
fpath = nestedDir </> "FileCreated.txt"
in do
createDirectoryIfMissing True nestedDir
writeFile fpath "Test Data"
, \fp ->
let s = (fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt")
t = (fp </> "dir1" </> "dir2" </> "dir3" </> "FileRenamed.txt")
in renamePath s t
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1_1073741856_Opened_Dir"
, "dir1_1073741825_Accessed_Dir"
, "dir1_1073741840_NonWriteClosed_Dir"
, "dir1/dir2_1073741856_Opened_Dir"
, "dir1/dir2_1073741825_Accessed_Dir"
, "dir1/dir2_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3_1073741856_Opened_Dir"
, "dir1/dir2/dir3_1073741825_Accessed_Dir"
, "dir1/dir2/dir3_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3/FileCreated.txt_64_MovedFrom"
, "dir1/dir2/dir3/FileRenamed.txt_128_MovedTo"
]
, False
)
, ( "Remove the nested directory"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, \fp -> removePathForcibly (fp </> "dir1")
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1_1073741856_Opened_Dir"
, "dir1_1073741825_Accessed_Dir"
, "dir1_1073741840_NonWriteClosed_Dir"
, "dir1/dir2_1073741856_Opened_Dir"
, "dir1/dir2_1073741825_Accessed_Dir"
, "dir1/dir2_1073741840_NonWriteClosed_Dir"
, "dir1/dir2/dir3_1073741856_Opened_Dir"
, "dir1/dir2/dir3_1073741825_Accessed_Dir"
, "dir1/dir2/dir3_1073741840_NonWriteClosed_Dir"
, "dir1_1073741828_MetadataChanged_Dir"
, "dir1/dir2_1073741828_MetadataChanged_Dir"
, "dir1/dir2/dir3_1073741828_MetadataChanged_Dir"
, "dir1/dir2/dir3_1024_RootDeleted"
, "dir1/dir2/dir3_32768_RootUnwatched"
, "dir1/dir2/dir3_1073742336_Deleted_Dir"
, "dir1/dir2_1024_RootDeleted"
, "dir1/dir2_32768_RootUnwatched"
, "dir1/dir2_1073742336_Deleted_Dir"
, "dir1_1024_RootDeleted"
, "dir1_32768_RootUnwatched"
, "dir1_1073742336_Deleted_Dir"
]
, False
)
]
testDescRemoveRootDir =
[ ( "Remove the root directory"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2")
, \fp -> removePathForcibly fp
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1_1073741856_Opened_Dir"
, "dir1_1073741825_Accessed_Dir"
, "dir1_1073741840_NonWriteClosed_Dir"
, "dir1/dir2_1073741856_Opened_Dir"
, "dir1/dir2_1073741825_Accessed_Dir"
, "dir1/dir2_1073741840_NonWriteClosed_Dir"
, "_1073741828_MetadataChanged_Dir"
, "dir1_1073741828_MetadataChanged_Dir"
, "dir1/dir2_1073741828_MetadataChanged_Dir"
, "dir1/dir2_1024_RootDeleted"
, "dir1/dir2_32768_RootUnwatched"
, "dir1/dir2_1073742336_Deleted_Dir"
, "dir1_1024_RootDeleted"
, "dir1_32768_RootUnwatched"
, "dir1_1073742336_Deleted_Dir"
, "_1024_RootDeleted"
]
, False
)
]
testDescMoveRootDir =
[
( "Moved the root directory"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2")
, \fp -> renameDirectory (fp </> "dir1" </> "dir2") (fp </> "dir1" </> "dir2_Moved")
, [ "_1073741856_Opened_Dir"
,"_1073741825_Accessed_Dir"
,"_1073741840_NonWriteClosed_Dir"
,"dir1_1073741856_Opened_Dir"
,"dir1_1073741825_Accessed_Dir"
,"dir1_1073741840_NonWriteClosed_Dir"
,"dir1/dir2_1073741856_Opened_Dir"
,"dir1/dir2_1073741825_Accessed_Dir"
,"dir1/dir2_1073741840_NonWriteClosed_Dir"
,"dir1/dir2_1073741888_MovedFrom_Dir"
,"dir1/dir2_Moved_1073741952_MovedTo_Dir"
,"dir1/dir2_2048_RootMoved"
]
, False
)
]
testDescRemoveRootDirSymLink =
[ ( "Remove the root directory as SymLink"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2")
, \fp -> removePathForcibly fp
, [ "_1073741856_Opened_Dir"
, "_1073741825_Accessed_Dir"
, "_1073741840_NonWriteClosed_Dir"
, "dir1_1073741856_Opened_Dir"
, "dir1_1073741825_Accessed_Dir"
, "dir1_1073741840_NonWriteClosed_Dir"
, "dir1/dir2_1073741856_Opened_Dir"
, "dir1/dir2_1073741825_Accessed_Dir"
, "dir1/dir2_1073741840_NonWriteClosed_Dir"
, "_1073741828_MetadataChanged_Dir"
]
, True
)
]
-------------------------Test Descriptor for common Event Types ---------------
testDescCommon =
[
( "Create a single directory"
, const (return ())
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, ["dir1Single_1073742080_Created_Dir"]
, False
)
, ( "Remove a single directory"
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, \fp -> removeDirectory (fp </> "dir1Single")
, [ "dir1Single_1024_RootDeleted"
, "dir1Single_32768_RootUnwatched"
, "dir1Single_1073742336_Deleted_Dir"
]
, False
)
, ( "Rename a single directory"
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, \fp ->
let spath = fp </> "dir1Single"
tpath = fp </> "dir1SingleRenamed"
in renameDirectory spath tpath
, [ "dir1Single_1073741888_MovedFrom_Dir"
, "dir1SingleRenamed_1073741952_MovedTo_Dir"
, "dir1Single_2048_RootMoved"
]
, False
)
, ( "Create a nested directory"
, const (return ())
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, ["dir1_1073742080_Created_Dir"]
, False
)
, ( "Rename a nested directory"
, \fp -> createDirectoryIfMissing True
(fp </> "dir1" </> "dir2" </> "dir3")
, \fp ->
let spath = fp </> "dir1" </> "dir2" </> "dir3"
tpath = fp </> "dir1" </> "dir2" </> "dir3Renamed"
in renameDirectory spath tpath
, [ "dir1/dir2/dir3_1073741888_MovedFrom_Dir"
, "dir1/dir2/dir3Renamed_1073741952_MovedTo_Dir"
, "dir1/dir2/dir3_2048_RootMoved"
]
, False
)
, ( "Create a file in root Dir"
, const (return ())
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, [ "FileCreated.txt_256_Created"
, "FileCreated.txt_2_Modified"
]
, False
)
, ( "Remove a file in root Dir"
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, \fp -> removeFile (fp </> "FileCreated.txt")
, ["FileCreated.txt_512_Deleted"]
, False
)
, ( "Rename a file in root Dir"
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, \fp ->
let spath = (fp </> "FileCreated.txt")
tpath = (fp </> "FileRenamed.txt")
in renamePath spath tpath
, [ "FileCreated.txt_64_MovedFrom"
, "FileRenamed.txt_128_MovedTo"
]
, False
)
, ( "Create a file in a nested Dir"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, \fp ->
let p = fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt"
in writeFile p "Test Data"
, [ "dir1/dir2/dir3/FileCreated.txt_256_Created"
, "dir1/dir2/dir3/FileCreated.txt_2_Modified"
]
, False
)
, ( "Remove a file in a nested Dir"
, \fp ->
let nestedDir = fp </> "dir1" </> "dir2" </> "dir3"
fpath = nestedDir </> "FileCreated.txt"
in do
createDirectoryIfMissing True nestedDir
writeFile fpath "Test Data"
, \fp ->
let p = fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt"
in removeFile p
, ["dir1/dir2/dir3/FileCreated.txt_512_Deleted"]
, False
)
, ( "Rename a file in a nested Dir"
, \fp ->
let nestedDir = fp </> "dir1" </> "dir2" </> "dir3"
fpath = nestedDir </> "FileCreated.txt"
in do
createDirectoryIfMissing True nestedDir
writeFile fpath "Test Data"
, \fp ->
let s = (fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt")
t = (fp </> "dir1" </> "dir2" </> "dir3" </> "FileRenamed.txt")
in renamePath s t
, [ "dir1/dir2/dir3/FileCreated.txt_64_MovedFrom"
, "dir1/dir2/dir3/FileRenamed.txt_128_MovedTo"
]
, False
)
, ( "Remove the nested directory"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, \fp -> removePathForcibly (fp </> "dir1")
, [ "dir1_1073741828_MetadataChanged_Dir"
, "dir1/dir2_1073741828_MetadataChanged_Dir"
, "dir1/dir2/dir3_1073741828_MetadataChanged_Dir"
, "dir1/dir2/dir3_1024_RootDeleted"
, "dir1/dir2/dir3_32768_RootUnwatched"
, "dir1/dir2/dir3_1073742336_Deleted_Dir"
, "dir1/dir2_1024_RootDeleted"
, "dir1/dir2_32768_RootUnwatched"
, "dir1/dir2_1073742336_Deleted_Dir"
, "dir1_1024_RootDeleted"
, "dir1_32768_RootUnwatched"
, "dir1_1073742336_Deleted_Dir"
]
, False
)
]
testDescRemoveRootDirCommon =
[ ( "Remove the root directory"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2")
, \fp -> removePathForcibly fp
, [ "_1073741828_MetadataChanged_Dir"
, "dir1_1073741828_MetadataChanged_Dir"
, "dir1/dir2_1073741828_MetadataChanged_Dir"
, "dir1/dir2_1024_RootDeleted"
, "dir1/dir2_32768_RootUnwatched"
, "dir1/dir2_1073742336_Deleted_Dir"
, "dir1_1024_RootDeleted"
, "dir1_32768_RootUnwatched"
, "dir1_1073742336_Deleted_Dir"
, "_1024_RootDeleted"
]
, False
)
]
testDescMoveRootDirCommon =
[
( "Moved the root directory"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2")
, \fp ->
renameDirectory
(fp </> "dir1" </> "dir2")
(fp </> "dir1" </> "dir2_Moved")
, [ "dir1/dir2_1073741888_MovedFrom_Dir"
, "dir1/dir2_Moved_1073741952_MovedTo_Dir"
, "dir1/dir2_2048_RootMoved"
]
, False
)
]
testDescRemoveRootDirSymLinkCommon =
[ ( "Remove the root directory as SymLink"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2")
, \fp -> removePathForcibly fp
, ["_1073741828_MetadataChanged_Dir"]
, True
)
]
-------------------------------------------------------------------------------
moduleName :: String
moduleName = "FileSystem.Event.Linux"
setAllEvents :: Event.Config -> Event.Config
setAllEvents cfg = ( Event.setAccessed Event.On
. Event.setOpened Event.On
. Event.setWriteClosed Event.On
. Event.setNonWriteClosed Event.On
)cfg
dirTouchEvents :: String -> [([Char], Event -> Bool)]
dirTouchEvents dir =
[ (dir, dirEvent Event.isOpened)
, (dir, dirEvent Event.isAccessed)
, (dir, dirEvent Event.isNonWriteClosed)
]
allEvents :: NonEmpty (Array Word8) -> S.SerialT IO Event.Event
allEvents = Event.watchWith setAllEvents
dirDelEvents :: String -> [([Char], Event -> Bool)]
dirDelEvents dir =
(dir, dirEvent Event.isDeleted)
: (dir, dirEvent Event.isAttrsModified)
: dirTouchEvents dir
-- Test cases for Linux platform
--
testAllEvents :: IO ()
testAllEvents = do
-- Test cases for regular path
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask allEvents)
testDesc
rootDirDelEvents :: String -> [([Char], Event -> Bool)]
rootDirDelEvents root =
(root, Event.isRootUnwatched)
: (root, Event.isRootDeleted)
: (root, dirEvent Event.isAttrsModified)
: dirTouchEvents root
-- Test cases for SymLink path
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask allEvents)
(map (\(a, b, c, d, _) -> (a, b, c, d, True)) testDesc)
dirMoveEvents :: [Char] -> [Char] -> [([Char], Event -> Bool)]
dirMoveEvents src dst =
[ (src, dirEvent Event.isMoved)
, (src, dirEvent Event.isMovedFrom)
, (dst, dirEvent Event.isMoved)
, (dst, dirEvent Event.isMovedTo)
]
-- Test cases for moving root path
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask allEvents)
testDescMoveRootDir
-- In recursive mode all subdirectories are roots therefore they will generate
-- isRootMoved.
rootDirMoveEvents :: [Char] -> [Char] -> [([Char], Event -> Bool)]
rootDirMoveEvents root _ =
(root, Event.isRootMoved)
: dirTouchEvents root
-- Test cases for moving root path as SymLink
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask allEvents)
(map (\(a, b, c, d, _) -> (a, b, c, d, True)) testDescMoveRootDir)
recDirMoveEvents :: [Char] -> [Char] -> [([Char], Event -> Bool)]
recDirMoveEvents src dst = dirMoveEvents src dst ++ rootDirMoveEvents src dst
-- Test cases for removing root path
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents (eventListWithFixLen 51) allEvents)
testDescRemoveRootDir
fileTouchEvents :: String -> [([Char], Event -> Bool)]
fileTouchEvents file =
[ (file, fileEvent Event.isOpened)
, (file, fileEvent Event.isModified)
, (file, fileEvent Event.isWriteClosed)
]
-- Test cases for removing root path as Symlink
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents (eventListWithFixLen 20) allEvents)
testDescRemoveRootDirSymLink
fileMoveEvents :: [Char] -> [Char] -> [([Char], Event -> Bool)]
fileMoveEvents src dst =
[ (src, fileEvent Event.isMoved)
, (src, fileEvent Event.isMovedFrom)
, (dst, fileEvent Event.isMoved)
, (dst, fileEvent Event.isMovedTo)
]
-- Test cases for Events which are common across the platforms
--
testCommonEvents :: IO ()
testCommonEvents = do
-- Test cases for regular path
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask $ Event.watchRecursive)
testDescCommon
-- TODO: add fileRoot tests from macOS test suite
-- Test cases for SymLink path
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask Event.watchRecursive)
(map (\(a, b, c, d, _) -> (a, b, c, d, True)) testDescCommon)
main :: IO ()
main = do
-- We ignore the events on root/parent dir during regular non-root dir/file
-- tests.
-- Test cases for moving root path
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask Event.watchRecursive)
testDescMoveRootDirCommon
-- Tests common to regular root and symlink root cases
let regSymTests =
fileCreate "file" fileTouchEvents
: fileMove "file1" "file2" fileMoveEvents
: dirMove "dir1" "dir2" dirMoveEvents
: dirDelete "dir" dirDelEvents
: commonTests
-- Test cases for moving root path as SymLink
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask Event.watchRecursive)
(map (\(a, b, c, d, _) -> (a, b, c, d, True)) testDescMoveRootDirCommon)
let regTests =
dirDelete "" rootDirDelEvents
: rootDirMove "moved" (\src -> [(src, Event.isRootMoved)])
: regSymTests
-- Test cases for removing root path
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents (eventListWithFixLen 12) Event.watchRecursive)
testDescRemoveRootDirCommon
let symTests =
-- when root is a symlinked dir, it does not recv touch, isDeleted
-- or rootDeleted, rootUnwatched events.
dirDelete "" (\dir -> [(dir, dirEvent Event.isAttrsModified)])
-- No events occur when a symlink root is moved
: regSymTests
-- Test cases for removing root path as Symlink
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents (eventListWithFixLen 1) Event.watchRecursive)
testDescRemoveRootDirSymLinkCommon
let w = Event.watchWith (Event.setAllEvents Event.On)
run = runTests moduleName "non-recursive" w
run DirType regTests
run SymLinkOrigPath symTests
let fileRootTests =
[ fileDelete "" (\path ->
[ (path, Event.isAttrsModified)
, (path, Event.isRootDeleted)
, (path, Event.isRootUnwatched)
])
, rootFileMove "moved" (\path -> [(path, Event.isRootMoved)])
, fileModify "" (\path -> [(path, Event.isOpened)])
]
run FileType fileRootTests
-- In recursive mode all subdirectories are roots therefore they will
-- generate isRootDeleted/isRootUnwatched. Also, for subdirectories
-- multiple events are generated, once in the parent watch and once in the
-- self watch as a root of the watch. Therefore, additional touchEvents are
-- generated in this case.
--
-- XXX We can possibly filter out the duplicate events either from the
-- parent or self.
let regSymRecTests =
-- XXX Nested file create misses the create event due to a race
-- : fileCreateWithParent "subdir/file" fileTouchEvents
fileCreate "subdir/file" fileTouchEvents
: fileMove "subdir/file1" "subdir/file2" fileMoveEvents
: dirMove "dir1" "dir2" recDirMoveEvents
: dirMove "subdir/dir1" "subdir/dir2" recDirMoveEvents
: dirDelete "dir" (\d -> rootDirDelEvents d ++ dirDelEvents d)
: dirDelete "subdir/dir" (\d -> rootDirDelEvents d ++ dirDelEvents d)
-- XXX Nested dir create misses the create event due to a race
-- : dirCreateWithParent "subdir/dir" dirTouchEvents
: dirCreate "subdir/dir"
(\dir -> (dir, dirEvent Event.isCreated) : dirTouchEvents dir)
: dirCreate "dir"
(\dir -> (dir, dirEvent Event.isCreated) : dirTouchEvents dir)
: commonRecTests
recRegTests = regTests ++ regSymRecTests
recSymTests = symTests ++ regSymRecTests
let recw = Event.watchWith
(Event.setAllEvents Event.On . Event.setRecursiveMode Event.On)
runRec = runTests moduleName "recursive" recw
runRec DirType recRegTests
runRec SymLinkOrigPath recSymTests
-- XXX This fails with exceptions, ideally it should work the same as in
-- non-recursive mode
-- runRec FileType fileRootTests

9
test/Streamly/Test/FileSystem/Event/LinuxTest.hs
View File

@ -1,9 +0,0 @@
module Main (main) where
import System.IO (BufferMode(..), hSetBuffering, stdout)
import qualified Streamly.Test.FileSystem.Event.Linux as Event
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
Event.testAllEvents

374
test/Streamly/Test/FileSystem/Event/Windows.hs
View File

@ -6,341 +6,49 @@
-- Stability : experimental
-- Portability : GHC
--
module Streamly.Test.FileSystem.Event.Windows (testCommonEvents) where
import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar, threadDelay)
import Control.Monad.IO.Class (MonadIO)
import Data.Functor.Identity (runIdentity)
import Data.Maybe (fromJust)
import Data.Word (Word8)
import System.Directory
( createDirectoryIfMissing
, createDirectoryLink
, removeFile
, removeDirectory
, removePathForcibly
, renameDirectory
, renamePath
)
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
import Streamly.Internal.Data.Array.Foreign (Array)
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Set as Set
import qualified Streamly.Unicode.Stream as Unicode
import qualified Streamly.Internal.Data.Array.Foreign as Array
import qualified Streamly.Internal.Data.Fold as FL
import qualified Streamly.Internal.Data.Parser as PR
import qualified Streamly.Internal.Data.Stream.IsStream as S
import qualified Streamly.Internal.Unicode.Stream as U
module Streamly.Test.FileSystem.Event.Windows (main) where
import qualified Streamly.Internal.FileSystem.Event.Windows as Event
import Test.Hspec
-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------
toUtf8 :: MonadIO m => String -> m (Array Word8)
toUtf8 = Array.fromStream . Unicode.encodeUtf8' . S.fromList
utf8ToString :: Array Word8 -> String
utf8ToString = runIdentity . S.toList . U.decodeUtf8' . Array.toStream
timeout :: IO String
timeout = threadDelay 5000000 >> return "Timeout"
fseventDir :: String
fseventDir = "fsevent_dir"
eoTask :: String
eoTask = "EOTask"
-- XXX Make the getRelPath type same on windows and other platforms
eventPredicate :: Event.Event -> Bool
eventPredicate ev =
if (utf8ToString $ Event.getRelPath ev) == eoTask
then False
else True
-------------------------------------------------------------------------------
-- Event matching utilities
-------------------------------------------------------------------------------
-- XXX Return a tuple (path, flags) instead of appending flags to path. And
-- then check the flags using an event mask.
showEventShort :: Event.Event -> String
-- | Convert an 'Event' record to a short representation for unit test.
showEventShort ev@Event.Event{..} =
(utf8ToString $ Event.getRelPath ev) ++ "_" ++ show eventFlags
-------------------------------------------------------------------------------
-- Event Watcher
-------------------------------------------------------------------------------
type EventChecker = FilePath -> MVar () -> [String] -> IO String
type EventWatch = NonEmpty (Array Word8) -> S.SerialT IO Event.Event
type ToEventList = S.SerialT IO Event.Event -> IO [Event.Event]
eventListWithFixLen :: Int -> ToEventList
eventListWithFixLen count = S.toList . S.take count
eventListWithEOtask :: ToEventList
eventListWithEOtask = S.parse (PR.takeWhile eventPredicate FL.toList)
checkEvents :: ToEventList -> EventWatch -> EventChecker
checkEvents toEL ew rootPath m matchList = do
let args = [rootPath]
paths <- mapM toUtf8 args
putStrLn ("Watch started !!!! on Path " ++ rootPath)
events <- toEL
$ S.before (putMVar m ())
$ ew (NonEmpty.fromList paths)
let eventStr = map showEventShort events
let baseSet = Set.fromList matchList
resultSet = Set.fromList eventStr
if baseSet `Set.isSubsetOf` resultSet
then
return "PASS"
else do
putStrLn $ "baseSet " ++ show matchList
putStrLn $ "resultSet " ++ show eventStr
return "Mismatch"
-------------------------------------------------------------------------------
-- FS Event Generators
-------------------------------------------------------------------------------
checker :: S.IsStream t =>
EventChecker -> FilePath -> MVar () -> [String] -> t IO String
checker ec rootPath synch matchList =
S.fromEffect (ec rootPath synch matchList)
`S.parallelFst`
S.fromEffect timeout
-------------------------------------------------------------------------------
-- Test Drivers
-------------------------------------------------------------------------------
driver ::
EventChecker
-> ( String
, FilePath -> IO ()
, FilePath -> IO ()
, [String]
, Bool
)
-> SpecWith ()
driver ec (desc, pre, ops, events, sym) = it desc $ runTest `shouldReturn` "PASS"
where
runTest = do
sync <- newEmptyMVar
withSystemTempDirectory fseventDir $ \fp ->
if sym
then do
createDirectoryLink fp (fp ++ "SymLink")
runTest0 (fp ++ "SymLink") sync
else runTest0 fp sync
runTest0 fp sync = do
pre fp
let eventStream = checker ec fp sync events
fsOps = S.fromEffect $ runFSOps fp sync
fmap fromJust $ S.head $ eventStream `S.parallelFst` fsOps
runFSOps fp sync = do
_ <- takeMVar sync
threadDelay 200000
ops fp
-- 'EOTask Created dir' event gets out of order so need to wait here
threadDelay 200000 -- Why this delay?
createDirectoryIfMissing True (fp </> eoTask)
threadDelay 10000000
error "fs ops timed out"
-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------
testDesc, testDescRootDir ::
[ ( String -- test description
, FilePath -> IO () -- pre test operation
, FilePath -> IO () -- file system actions
, [String] -- expected events
, Bool ) -- SymLink
]
testDesc =
[
( "Create a single directory"
, const (return ())
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, [ "dir1Single_1" ]
, False
)
, ( "Remove a single directory"
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, \fp -> removeDirectory (fp </> "dir1Single")
, [ "dir1Single_2" ]
, False
)
, ( "Rename a single directory"
, \fp -> createDirectoryIfMissing True (fp </> "dir1Single")
, \fp ->
let spath = fp </> "dir1Single"
tpath = fp </> "dir1SingleRenamed"
in renameDirectory spath tpath
, [ "dir1Single_4"
, "dir1SingleRenamed_5"
]
, False
)
, ( "Create a nested directory"
, const (return ())
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, [ "dir1_1"
, "dir1\\dir2_1"
, "dir1\\dir2\\dir3_1"
]
, False
)
, ( "Rename a nested directory"
, \fp -> createDirectoryIfMissing True
(fp </> "dir1" </> "dir2" </> "dir3")
, \fp ->
let spath = fp </> "dir1" </> "dir2" </> "dir3"
tpath = fp </> "dir1" </> "dir2" </> "dir3Renamed"
in renameDirectory spath tpath
, [ "dir1\\dir2_3"
, "dir1\\dir2\\dir3_4"
, "dir1\\dir2\\dir3Renamed_5"
, "dir1\\dir2_3"
]
, False
)
, ( "Create a file in root Dir"
, const (return ())
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, [ "FileCreated.txt_1"
, "FileCreated.txt_3"
, "FileCreated.txt_3"
]
, False
)
, ( "Remove a file in root Dir"
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, \fp -> removeFile (fp </> "FileCreated.txt")
, [ "FileCreated.txt_2" ]
, False
)
, ( "Rename a file in root Dir"
, \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"
, \fp ->
let spath = (fp </> "FileCreated.txt")
tpath = (fp </> "FileRenamed.txt")
in renamePath spath tpath
, [ "FileCreated.txt_4"
, "FileRenamed.txt_5"
]
, False
)
, ( "Create a file in a nested Dir"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, \fp ->
let p = fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt"
in writeFile p "Test Data"
, [ "dir1\\dir2\\dir3\\FileCreated.txt_1"
, "dir1\\dir2\\dir3\\FileCreated.txt_3"
]
, False
)
, ( "Remove a file in a nested Dir"
, \fp ->
let nestedDir = fp </> "dir1" </> "dir2" </> "dir3"
fpath = nestedDir </> "FileCreated.txt"
in do
createDirectoryIfMissing True nestedDir
writeFile fpath "Test Data"
, \fp ->
let p = fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt"
in removeFile p
, ["dir1\\dir2\\dir3\\FileCreated.txt_2"]
, False
)
, ( "Rename a file in a nested Dir"
, \fp ->
let nestedDir = fp </> "dir1" </> "dir2" </> "dir3"
fpath = nestedDir </> "FileCreated.txt"
in do
createDirectoryIfMissing True nestedDir
writeFile fpath "Test Data"
, \fp ->
let s = (fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt")
t = (fp </> "dir1" </> "dir2" </> "dir3" </> "FileRenamed.txt")
in renamePath s t
, [ "dir1\\dir2\\dir3_3"
, "dir1\\dir2\\dir3\\FileCreated.txt_4"
, "dir1\\dir2\\dir3\\FileRenamed.txt_5"
]
, False
)
, ( "Remove the nested directory"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")
, \fp -> removePathForcibly (fp </> "dir1")
, [ "dir1_3"
, "dir1\\dir2_3"
, "dir1\\dir2\\dir3_2"
, "dir1\\dir2_2","dir1_2"
]
, False
)
]
-- Since removel of root path as Symlink hangs for ever, testDescRootDir
-- is provided seperately.
testDescRootDir =
[ ( "Remove the root directory"
, \fp ->
createDirectoryIfMissing True (fp </> "dir1" </> "dir2")
, \fp -> removePathForcibly fp
, ["dir1_2", "dir1_3", "dir1\\dir2_2"]
, False
)
]
import Streamly.Test.FileSystem.Event.Common
moduleName :: String
moduleName = "FileSystem.Event"
moduleName = "FileSystem.Event.Windows"
testCommonEvents :: IO ()
testCommonEvents = do
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask Event.watchRecursive)
testDesc
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents (eventListWithFixLen 3) Event.watchRecursive)
testDescRootDir
-- Run test cases for SymLink
-- Remove the root directory as SymLink is not allowed, it hangs and Timeout.
hspec
$ describe moduleName
$ mapM_
(driver $ checkEvents eventListWithEOtask Event.watchRecursive)
(map (\(a, b, c, d, _) -> (a, b, c, d, True)) testDesc)
-- TODO Test isModified event for parent directories when a file is created or
-- deleted.
main :: IO ()
main = do
let regularRootTests =
commonTests
-- The following watch-root deletion test results in:
-- C:\tmp\fsevent_dir-e061f0b0a00e1696\watch-root:
-- removePathForcibly:RemoveDirectory
-- "\\\\?\\C:\\tmp\\fsevent_dir-e061f0b0a00e1696\\watch-root":
-- permission denied (The process cannot access the file because it is
-- being used by another process.)
--
-- ++ dirDelete "" (\dir -> [(dir, Event.isDeleted)])
let w = Event.watchWith (Event.setAllEvents Event.On)
run = runTests moduleName "non-recursive" w
run DirType regularRootTests
run SymLinkOrigPath commonTests
-- TODO create/modify/delete/move with root path as a regular file, copy
-- from macOS tests
-- run FileType fileRootTests
let recTests =
[ dirCreateWithParent "subdir\\dir"
(\dir -> [(dir, dirEvent Event.isCreated)])
, fileCreateWithParent "subdir\\file"
(\file -> [(file, fileEvent Event.isCreated)])
] ++ commonRecTests
let recw = Event.watchWith
(Event.setAllEvents Event.On . Event.setRecursiveMode Event.On)
runRec = runTests moduleName "recursive" recw
runRec DirType (regularRootTests ++ recTests)
runRec SymLinkOrigPath (commonTests ++ recTests)

9
test/Streamly/Test/FileSystem/Event/WindowsTest.hs
View File

@ -1,9 +0,0 @@
module Main (main) where
import System.IO (BufferMode(..), hSetBuffering, stdout)
import qualified Streamly.Test.FileSystem.Event.Windows as Event
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
Event.testCommonEvents

38
test/streamly-tests.cabal
View File

@ -277,35 +277,39 @@ test-suite Data.Unfold
test-suite FileSystem.Event
import: test-options
type: exitcode-stdio-1.0
ghc-options: -main-is Streamly.Test.FileSystem.Event
main-is: Streamly/Test/FileSystem/Event.hs
if os(linux)
other-modules: Streamly.Test.FileSystem.Event.Linux
if os(windows)
other-modules: Streamly.Test.FileSystem.Event.Windows
if os(darwin)
other-modules: Streamly.Test.FileSystem.Event.Common
test-suite FileSystem.Event.Darwin
import: test-options
type: exitcode-stdio-1.0
main-is: Streamly/Test/FileSystem/Event/Darwin.hs
other-modules: Streamly.Test.FileSystem.Event.Common
cpp-options: -DFILESYSTEM_EVENT_DARWIN
ghc-options: -main-is Streamly.Test.FileSystem.Event.Darwin
if !os(darwin)
buildable: False
test-suite FileSystem.Event.Linux
import: test-options
type: exitcode-stdio-1.0
main-is: Streamly/Test/FileSystem/Event/LinuxTest.hs
if os(linux)
other-modules: Streamly.Test.FileSystem.Event.Linux
if os(windows)
main-is: Streamly/Test/FileSystem/Event/Linux.hs
other-modules: Streamly.Test.FileSystem.Event.Common
cpp-options: -DFILESYSTEM_EVENT_LINUX
ghc-options: -main-is Streamly.Test.FileSystem.Event.Linux
if !os(linux)
buildable: False
if os(darwin)
buildable: False
test-suite FileSystem.Event.Windows
import: test-options
type: exitcode-stdio-1.0
main-is: Streamly/Test/FileSystem/Event/WindowsTest.hs
if os(windows)
other-modules: Streamly.Test.FileSystem.Event.Windows
if os(linux)
main-is: Streamly/Test/FileSystem/Event/Windows.hs
other-modules: Streamly.Test.FileSystem.Event.Common
cpp-options: -DFILESYSTEM_EVENT_WINDOWS
ghc-options: -main-is Streamly.Test.FileSystem.Event.Windows
if !os(windows)
buildable: False
if os(darwin)
buildable: False
test-suite FileSystem.Handle
import: test-options