mirror of
https://github.com/ilyakooo0/streamly.git
synced 2024-10-26 09:59:48 +03:00
Overhaul file system event testing
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:
parent
bb74cdd2a6
commit
4512fa476f
8
hie.yaml
8
hie.yaml
@ -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"
|
||||
|
@ -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/
|
||||
--
|
||||
|
@ -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"
|
||||
|
@ -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"
|
||||
|
@ -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/
|
||||
--
|
||||
|
@ -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
|
||||
|
@ -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
418
test/Streamly/Test/FileSystem/Event/Common.hs
Normal 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
85
test/Streamly/Test/FileSystem/Event/Darwin.hs
Normal 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
|
@ -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
|
||||
|
@ -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
|
@ -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)
|
||||
|
@ -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
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user