diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +hinotify +====== + +hinotify-0.3.8.1 +-------------- + +- fork the library and use `ByteString` instead of `String` as filepath, see https://github.com/kolmodin/hinotify/issues/19 for more information diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) Lennart Kolmodin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,133 @@ +hinotify-bytestring: inotify for Haskell using ByteString for filepaths +============================= + +[![Build Status](https://api.travis-ci.org/hasufell/hinotify-bytestring.png?branch=master)](http://travis-ci.org/hasufell/hinotify-bytestring) + +About +----- + +hinotify-bytestring, a library to [inotify] which has been part of the Linux kernel +since 2.6.13. + +inotify provides file system event notification, simply add a watcher to +a file or directory and get an event when it is accessed or modified. + +This module is named `hinotify-bytestring`. + +See example code in the `examples` directory, distributed with the source +code. + +[inotify]: http://www.kernel.org/pub/linux/kernel/people/rml/inotify/ + +News +---- + +**hinotify 0.3.7** + +* Bug fix: When registerering a new watch on a path which is already watched, + don't overwrite the event listener from the previous watch. + +**hinotify 0.3.2** + +* Make each `WatchDescriptor` contain its `INotify`. Changes to the function types: + +> -removeWatch :: INotify -> WatchDescriptor -> IO () +> +removeWatch :: WatchDescriptor -> IO () + +* Fix typo in declaration of `Deleted` in `data Event`; + +> - { isDirecotry :: Bool +> + { isDirectory :: Bool + +**hinotify 0.3.1** + +* Use `inotify.h` from `glibc` rather than from the linux headers, as + recommended upstream. + +**hinotify 0.3** + +* Compiles with GHC 6.12, GHC 6.10.4, GHC 6.8.2 and GHC 6.6.1 + +**hinotify 0.2** + +* Updates to the API + - Function names is now in semiCamelCase + - Restructure event parameters to make it more consistent +* Small test suit in `tests/` +* Compiles with GHC 6.8.2 and GHC 6.6.1 +* Requires Cabal 1.2 + +**hinotify 0.1** +: Initial release + +API +--- + +The API basically consists of: + +```haskell +initINotify :: IO INotify +addWatch :: INotify + -> [EventVariety] -- different events to listen on + -> ByteString -- file/directory to watch + -> (Event -> IO ()) -- event handler + -> IO WatchDescriptor +removeWatch :: WatchDescriptor -> IO () +``` + +A sample program: + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import System.Posix.Env.ByteString +import System.IO + +import System.INotify + +main :: IO () +main = do + inotify <- initINotify + print inotify + home <- getEnvDefault "HOME" "/home" + wd <- addWatch + inotify + [Open,Close,Access,Modify,Move] + home + print + print wd + putStrLn "Listens to your home directory. Hit enter to terminate." + getLine + removeWatch wd +``` + +Download +-------- + +The code is available via the [homepage]: + + git clone https://github.com/hasufell/hinotify-bytestring.git + +The [API] is available online. + +I'm most grateful for feedback on the API, and what else you might have to +suggest. + +Author +------ + +Lennart Kolmodin + +`kolmodin at gmail.com` + +Legal +----- + +This software is released under a BSD-style license. See LICENSE for +more details. + +Copyright © 2007-2012 Lennart Kolmodin + +[homepage]: https://github.com/hasufell/hinotify-bytestring.git + +[API]: http://hackage.haskell.org/packages/archive/hinotify-bytestring/latest/doc/html/System-INotify.html diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/hinotify-bytestring.cabal b/hinotify-bytestring.cabal new file mode 100644 --- /dev/null +++ b/hinotify-bytestring.cabal @@ -0,0 +1,76 @@ +name: hinotify-bytestring +version: 0.3.8.1 +build-type: Simple +synopsis: Haskell binding to inotify, using ByteString filepaths +description: + This library provides a wrapper to the Linux Kernel's inotify feature, + allowing applications to subscribe to notifications when a file is + accessed or modified. Filepaths are represented as ByteStrings. +category: System +homepage: https://github.com/hasufell/hinotify-bytestring.git +license: BSD3 +license-file: LICENSE +author: Lennart Kolmodin +maintainer: Julian Ospald +extra-source-files: README.md, CHANGELOG.md +cabal-version: >= 1.8 + +source-repository head + type: git + location: git://github.com/hasufell/hinotify-bytestring.git + +library + build-depends: base >= 4.5.0.0 && < 5, bytestring, containers, directory, unix + extensions: ForeignFunctionInterface + + exposed-modules: + System.INotify + other-modules: + System.INotify.Masks + + ghc-options: -Wall + includes: sys/inotify.h + hs-source-dirs: src + + + +test-suite test001 + type: exitcode-stdio-1.0 + build-depends: base, bytestring, directory, hinotify-bytestring, posix-paths, unix, utf8-string + hs-source-dirs: src tests + main-is: test001-list-dir-contents.hs + other-modules: Utils + ghc-options: -Wall + +test-suite test002 + type: exitcode-stdio-1.0 + build-depends: base, bytestring, directory, hinotify-bytestring, posix-paths, unix, utf8-string + hs-source-dirs: src tests + main-is: test002-writefile.hs + other-modules: Utils + ghc-options: -Wall + +test-suite test003 + type: exitcode-stdio-1.0 + build-depends: base, bytestring, directory, hinotify-bytestring, posix-paths, unix, utf8-string + hs-source-dirs: src tests + main-is: test003-removefile.hs + other-modules: Utils + ghc-options: -Wall + +test-suite test004 + type: exitcode-stdio-1.0 + build-depends: base, bytestring, directory, hinotify-bytestring, posix-paths, unix, utf8-string + hs-source-dirs: src tests + main-is: test004-modify-file.hs + other-modules: Utils + ghc-options: -Wall + +test-suite test005 + type: exitcode-stdio-1.0 + build-depends: base, bytestring, directory, hinotify-bytestring, posix-paths, unix, utf8-string + hs-source-dirs: src tests + main-is: test005-move-file.hs + other-modules: Utils + ghc-options: -Wall + diff --git a/src/System/INotify.hsc b/src/System/INotify.hsc new file mode 100644 --- /dev/null +++ b/src/System/INotify.hsc @@ -0,0 +1,340 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.INotify +-- Copyright : (c) Lennart Kolmodin 2006-2012 +-- License : BSD3 +-- Maintainer : hasufell@posteo.de +-- Stability : experimental +-- Portability : hc portable, linux only +-- +-- A Haskell binding to INotify. +-- See and @man +-- inotify@. +-- +-- Use 'initINotify' to get a 'INotify', then use 'addWatch' to +-- add a watch on a file or directory. Select which events you're interested +-- in with 'EventVariety', which corresponds to the 'Event' events. +-- +-- Use 'removeWatch' once you don't want to watch a file any more. +-- +----------------------------------------------------------------------------- + +module System.INotify + ( initINotify + , killINotify + , withINotify + , addWatch + , removeWatch + , INotify + , WatchDescriptor + , Event(..) + , EventVariety(..) + , Cookie + ) where + +#include "sys/inotify.h" + +import Prelude hiding (init) +import Data.ByteString(ByteString) +import qualified Data.ByteString as BS +import Control.Monad +import Control.Concurrent +import Control.Exception as E (bracket, catch, mask_, SomeException) +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Foreign.C hiding (peekCString) +import Foreign.Marshal hiding (void) +import Foreign.Ptr +import Foreign.Storable +import System.IO +import System.IO.Error +#if __GLASGOW_HASKELL__ >= 612 +import GHC.IO.Handle.FD (fdToHandle') +import GHC.IO.Device (IODeviceType(Stream)) +#else +import GHC.Handle +import System.Posix.Internals +#endif +import System.Posix.Files.ByteString +import System.INotify.Masks + +type FD = CInt +type WD = CInt +type Masks = CUInt + +type EventMap = Map WD (Event -> IO ()) +type WDEvent = (WD, Event) + +data INotify = INotify Handle FD (MVar EventMap) ThreadId ThreadId +data WatchDescriptor = WatchDescriptor INotify WD deriving Eq + +instance Eq INotify where + (INotify _ fd1 _ _ _) == (INotify _ fd2 _ _ _) = fd1 == fd2 + +newtype Cookie = Cookie CUInt deriving (Eq,Ord) + +data FDEvent = FDEvent WD Masks CUInt{-Cookie-} (Maybe ByteString) deriving (Eq, Show) + +data Event = + -- | A file was accessed. @Accessed isDirectory file@ + Accessed + { isDirectory :: Bool + , maybeFilePath :: Maybe ByteString + } + -- | A file was modified. @Modified isDirectory file@ + | Modified + { isDirectory :: Bool + , maybeFilePath :: Maybe ByteString + } + -- | A files attributes where changed. @Attributes isDirectory file@ + | Attributes + { isDirectory :: Bool + , maybeFilePath :: Maybe ByteString + } + -- | A file was closed. @Closed isDirectory file wasWriteable@ + | Closed + { isDirectory :: Bool + , maybeFilePath :: Maybe ByteString + , wasWriteable :: Bool + } + -- | A file was opened. @Opened isDirectory maybeFilePath@ + | Opened + { isDirectory :: Bool + , maybeFilePath :: Maybe ByteString + } + -- | A file was moved away from the watched dir. @MovedFrom isDirectory from cookie@ + | MovedOut + { isDirectory :: Bool + , filePath :: ByteString + , moveCookie :: Cookie + } + -- | A file was moved into the watched dir. @MovedTo isDirectory to cookie@ + | MovedIn + { isDirectory :: Bool + , filePath :: ByteString + , moveCookie :: Cookie + } + -- | The watched file was moved. @MovedSelf isDirectory@ + | MovedSelf + { isDirectory :: Bool + } + -- | A file was created. @Created isDirectory file@ + | Created + { isDirectory :: Bool + , filePath :: ByteString + } + -- | A file was deleted. @Deleted isDirectory file@ + | Deleted + { isDirectory :: Bool + , filePath :: ByteString + } + -- | The file watched was deleted. + | DeletedSelf + -- | The file watched was unmounted. + | Unmounted + -- | The queue overflowed. + | QOverflow + | Ignored + | Unknown FDEvent + deriving (Eq, Show) + +data EventVariety + = Access + | Modify + | Attrib + | Close + | CloseWrite + | CloseNoWrite + | Open + | Move + | MoveIn + | MoveOut + | MoveSelf + | Create + | Delete + | DeleteSelf + | OnlyDir + | NoSymlink + | MaskAdd + | OneShot + | AllEvents + deriving Eq + +instance Show INotify where + show (INotify _ fd _ _ _) = + showString "" + +instance Show WatchDescriptor where + show (WatchDescriptor _ wd) = showString "" + +instance Show Cookie where + show (Cookie c) = showString "" + +initINotify :: IO INotify +initINotify = do + fd <- throwErrnoIfMinus1 "initINotify" c_inotify_init + let desc = showString "" +#if __GLASGOW_HASKELL__ < 608 + h <- openFd (fromIntegral fd) (Just Stream) False{-is_socket-} desc ReadMode True{-binary-} +#else + h <- fdToHandle' (fromIntegral fd) (Just Stream) False{-is_socket-} desc ReadMode True{-binary-} +#endif + em <- newMVar Map.empty + (tid1, tid2) <- inotify_start_thread h em + return (INotify h fd em tid1 tid2) + +addWatch :: INotify -> [EventVariety] -> ByteString -> (Event -> IO ()) -> IO WatchDescriptor +addWatch inotify@(INotify _ fd em _ _) masks fp cb = do + catch_IO (void $ + (if (NoSymlink `elem` masks) then getSymbolicLinkStatus else getFileStatus) + fp) $ \_ -> + ioError $ mkIOError doesNotExistErrorType + "can't watch what isn't there!" + Nothing + (Just $ show fp) + let mask = joinMasks (map eventVarietyToMask masks) + wd <- BS.useAsCString fp $ \fp_c -> + throwErrnoIfMinus1 "addWatch" $ + c_inotify_add_watch (fromIntegral fd) fp_c mask + let event = \e -> ignore_failure $ do + case e of + -- if the event is Ignored then we know for sure that + -- this is the last event on that WatchDescriptor + Ignored -> rm_watch inotify wd + _ -> return () + cb e + modifyMVar_ em $ \em' -> return (Map.insertWith (liftM2 (>>)) wd event em') + return (WatchDescriptor inotify wd) + where + -- catch_IO is same as catchIOError from base >= 4.5.0.0 + catch_IO :: IO a -> (IOError -> IO a) -> IO a + catch_IO = E.catch + eventVarietyToMask ev = + case ev of + Access -> inAccess + Modify -> inModify + Attrib -> inAttrib + Close -> inClose + CloseWrite -> inCloseWrite + CloseNoWrite -> inCloseNowrite + Open -> inOpen + Move -> inMove + MoveIn -> inMovedTo + MoveOut -> inMovedFrom + MoveSelf -> inMoveSelf + Create -> inCreate + Delete -> inDelete + DeleteSelf-> inDeleteSelf + OnlyDir -> inOnlydir + NoSymlink -> inDontFollow + MaskAdd -> inMaskAdd + OneShot -> inOneshot + AllEvents -> inAllEvents + + ignore_failure :: IO () -> IO () + ignore_failure action = mask_ (action `E.catch` ignore) + where + ignore :: SomeException -> IO () + ignore _ = return () + +removeWatch :: WatchDescriptor -> IO () +removeWatch (WatchDescriptor (INotify _ fd _ _ _) wd) = do + _ <- throwErrnoIfMinus1 "removeWatch" $ + c_inotify_rm_watch (fromIntegral fd) wd + return () + +rm_watch :: INotify -> WD -> IO () +rm_watch (INotify _ _ em _ _) wd = + modifyMVar_ em (return . Map.delete wd) + +read_events :: Handle -> IO [WDEvent] +read_events h = + let maxRead = 16385 in + allocaBytes maxRead $ \buffer -> do + _ <- hWaitForInput h (-1) -- wait forever + r <- hGetBufNonBlocking h buffer maxRead + read_events' buffer r + where + read_events' :: Ptr a -> Int -> IO [WDEvent] + read_events' _ r | r <= 0 = return [] + read_events' ptr r = do + wd <- (#peek struct inotify_event, wd) ptr :: IO CInt + mask <- (#peek struct inotify_event, mask) ptr :: IO CUInt + cookie <- (#peek struct inotify_event, cookie) ptr :: IO CUInt + len <- (#peek struct inotify_event, len) ptr :: IO CUInt + nameM <- if len == 0 + then return Nothing + else do + fmap Just $ BS.packCString ((#ptr struct inotify_event, name) ptr) + let event_size = (#size struct inotify_event) + (fromIntegral len) + event = cEvent2Haskell (FDEvent wd mask cookie nameM) + rest <- read_events' (ptr `plusPtr` event_size) (r - event_size) + return (event:rest) + cEvent2Haskell :: FDEvent + -> WDEvent + cEvent2Haskell fdevent@(FDEvent wd mask cookie nameM) + = (wd, event) + where + event + | isSet inAccess = Accessed isDir nameM + | isSet inModify = Modified isDir nameM + | isSet inAttrib = Attributes isDir nameM + | isSet inClose = Closed isDir nameM (isSet inCloseWrite) + | isSet inOpen = Opened isDir nameM + | isSet inMovedFrom = MovedOut isDir name (Cookie cookie) + | isSet inMovedTo = MovedIn isDir name (Cookie cookie) + | isSet inMoveSelf = MovedSelf isDir + | isSet inCreate = Created isDir name + | isSet inDelete = Deleted isDir name + | isSet inDeleteSelf = DeletedSelf + | isSet inUnmount = Unmounted + | isSet inQOverflow = QOverflow + | isSet inIgnored = Ignored + | otherwise = Unknown fdevent + isDir = isSet inIsdir + isSet bits = maskIsSet bits mask + name = fromJust nameM + +inotify_start_thread :: Handle -> MVar EventMap -> IO (ThreadId, ThreadId) +inotify_start_thread h em = do + chan_events <- newChan + tid1 <- forkIO (dispatcher chan_events) + tid2 <- forkIO (start_thread chan_events) + return (tid1,tid2) + where + start_thread :: Chan [WDEvent] -> IO () + start_thread chan_events = do + events <- read_events h + writeChan chan_events events + start_thread chan_events + dispatcher :: Chan [WDEvent] -> IO () + dispatcher chan_events = do + events <- readChan chan_events + mapM_ runHandler events + dispatcher chan_events + runHandler :: WDEvent -> IO () + runHandler (_, e@QOverflow) = do -- send overflows to all handlers + handlers <- readMVar em + mapM_ ($ e) (Map.elems handlers) + runHandler (wd, event) = do + handlers <- readMVar em + let handlerM = Map.lookup wd handlers + case handlerM of + Nothing -> putStrLn "runHandler: couldn't find handler" -- impossible? + Just handler -> handler event + +killINotify :: INotify -> IO () +killINotify (INotify h _ _ tid1 tid2) = + do killThread tid1 + killThread tid2 + hClose h + +withINotify :: (INotify -> IO a) -> IO a +withINotify = bracket initINotify killINotify + +foreign import ccall unsafe "sys/inotify.h inotify_init" c_inotify_init :: IO CInt +foreign import ccall unsafe "sys/inotify.h inotify_add_watch" c_inotify_add_watch :: CInt -> CString -> CUInt -> IO CInt +foreign import ccall unsafe "sys/inotify.h inotify_rm_watch" c_inotify_rm_watch :: CInt -> CInt -> IO CInt + diff --git a/src/System/INotify/Masks.hsc b/src/System/INotify/Masks.hsc new file mode 100644 --- /dev/null +++ b/src/System/INotify/Masks.hsc @@ -0,0 +1,93 @@ +module System.INotify.Masks + ( inAccess + , inModify + , inAttrib + , inCloseWrite + , inCloseNowrite + , inOpen + , inMovedFrom + , inMovedTo + , inMoveSelf + , inCreate + , inDelete + , inDeleteSelf + , inUnmount + , inQOverflow + , inIgnored + , inClose + , inMove + , inOnlydir + , inDontFollow + , inMaskAdd + , inIsdir + , inOneshot + , inAllEvents + , maskIsSet + , joinMasks + , Mask + ) where + +import Data.Bits +import Data.Maybe +import Foreign.C.Types + +#include "sys/inotify.h" + +data Mask + = UserSpace CUInt + | Extra CUInt + | Helper CUInt + | Special CUInt + | All CUInt + deriving (Eq,Ord) + +maskIsSet :: Mask -> CUInt -> Bool +maskIsSet mask cuint = + value mask .&. cuint > 0 + +value :: Mask -> CUInt +value (UserSpace i) = i +value (Extra i) = i +value (Helper i) = i +value (Special i) = i +value (All i) = i + +instance Show Mask where + show mask = + fromJust $ lookup mask [ + (inAccess, "IN_ACCESS"), + (inModify, "IN_MODIFY"), + (inAttrib, "IN_ATTRIB"), + (inClose, "IN_CLOSE"), + (inCloseWrite, "IN_CLOSE_WRITE"), + (inCloseNowrite, "IN_CLOSE_NOWRITE"), + (inOpen, "IN_OPEN"), + (inMove, "IN_MOVE"), + (inMovedFrom, "IN_MOVED_FROM"), + (inMovedTo, "IN_MOVED_TO"), + (inMoveSelf, "IN_MOVE_SELF"), + (inCreate, "IN_CREATE"), + (inDelete, "IN_DELETE"), + (inDeleteSelf, "IN_DELETE_SELF"), + (inUnmount, "IN_UNMOUNT"), + (inQOverflow, "IN_Q_OVERFLOW"), + (inIgnored, "IN_IGNORED"), + (inClose, "IN_CLOSE"), + (inIsdir, "IN_ISDIR"), + (inOneshot, "IN_ONESHOT")] + +joinMasks :: [Mask] -> CUInt +joinMasks = foldr (.|.) 0 . map value + +#enum Mask, UserSpace, IN_ACCESS, IN_MODIFY, IN_ATTRIB, IN_CLOSE_WRITE +#enum Mask, UserSpace, IN_CLOSE_NOWRITE, IN_OPEN, IN_MOVED_FROM, IN_MOVED_TO +#enum Mask, UserSpace, IN_CREATE, IN_DELETE, IN_DELETE_SELF, IN_MOVE_SELF + +#enum Mask, Extra, IN_UNMOUNT, IN_Q_OVERFLOW, IN_IGNORED + +#enum Mask, Helper, IN_CLOSE, IN_MOVE + +#enum Mask, Special, IN_ONLYDIR, IN_DONT_FOLLOW, IN_MASK_ADD, IN_ISDIR +#enum Mask, Special, IN_ONESHOT + +#enum Mask, All, IN_ALL_EVENTS diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Utils where + + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (fromString) + +import Control.Concurrent.Chan +import Control.Exception + +import GHC.IO.Exception ( IOErrorType(InappropriateType) ) + +import System.Environment +import System.Exit + +import System.INotify + +import System.IO.Error + ( ioeSetErrorString + , ioeSetLocation + , mkIOError + , modifyIOError ) + +import System.Posix.Directory.ByteString +import System.Posix.Directory.Traversals +import System.Posix.FilePath +import System.Posix.Files.ByteString + + + +testName :: IO ByteString +testName = do + n <- getProgName + return (fromString n `BS.append` "-playground") + +withTempDir :: (ByteString -> IO a) -> IO a +withTempDir f = do + path' <- testName + bracket + ( createDirectory path' accessModes >> return path' ) + removeDirectoryRecursive + f + +withWatch :: INotify -> [EventVariety] -> ByteString -> (Event -> IO ()) -> IO a -> IO a +withWatch inot events path action f = + bracket + ( addWatch inot events path action ) + removeWatch + ( const f ) + +inTestEnviron :: [EventVariety] -> (ByteString -> IO a) -> ([Event] -> IO b) -> IO b +inTestEnviron events action f = + withTempDir $ \testPath -> do + inot <- initINotify + chan <- newChan + withWatch inot events testPath (writeChan chan) $ do + _ <- action testPath + events' <- getChanContents chan + f events' + +(~=) :: Eq a => [a] -> [a] -> Bool +[] ~= _ = True +(x:xs) ~= (y:ys) = x == y && xs ~= ys +_ ~= _ = False + +asMany :: [a] -> [a] -> [a] +asMany xs ys = take (length xs) ys + +explainFailure :: Show a => [a] -> [a] -> String +explainFailure expected reality = unlines $ + [ "Expected:" ] ++ + [ "> " ++ show x | x <- expected ] ++ + [ "But got:" ] ++ + [ "< " ++ show x | x <- asMany expected reality ] + +testFailure, testSuccess :: IO a +testFailure = exitFailure +testSuccess = exitSuccess + + +removeDirectoryRecursive :: ByteString -> IO () +removeDirectoryRecursive path = + (`ioeSetLocation` "removeDirectoryRecursive") `modifyIOError` do + stat <- getSymbolicLinkStatus path + if System.Posix.Files.ByteString.isDirectory stat + then removeContentsRecursive path + else ioError . (`ioeSetErrorString` "not a directory") $ + mkIOError InappropriateType "" Nothing (Just $ show path) + + +removeContentsRecursive :: ByteString -> IO () +removeContentsRecursive path = + (`ioeSetLocation` "removeContentsRecursive") `modifyIOError` do + cont <- (filter (\(_, y) -> y /= "." && y /= "..")) + `fmap` getDirectoryContents path + mapM_ removePathRecursive $ fmap (\(_, y) -> path y) cont + removeDirectory path + + +removePathRecursive :: ByteString -> IO () +removePathRecursive path = + (`ioeSetLocation` "removePathRecursive") `modifyIOError` do + stat <- getSymbolicLinkStatus path + if System.Posix.Files.ByteString.isDirectory stat + then removeContentsRecursive path + else removeLink path + diff --git a/tests/test001-list-dir-contents.hs b/tests/test001-list-dir-contents.hs new file mode 100644 --- /dev/null +++ b/tests/test001-list-dir-contents.hs @@ -0,0 +1,25 @@ +module Main where + +import Control.Monad + +import System.INotify + +import qualified System.Posix.Directory.Traversals as PT + +import Utils + + +main :: IO () +main = + inTestEnviron [Open, Close] PT.getDirectoryContents $ \ events -> do + when (expected ~= events) + testSuccess + putStrLn $ explainFailure expected events + testFailure + + +expected :: [Event] +expected = + [ Opened True Nothing + , Closed True Nothing False + ] diff --git a/tests/test002-writefile.hs b/tests/test002-writefile.hs new file mode 100644 --- /dev/null +++ b/tests/test002-writefile.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Exception +import Control.Monad + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import System.INotify + +import System.Posix.Files.ByteString +import System.Posix.IO.ByteString + +import Utils + +write :: ByteString -> IO () +write path = + bracket (createFile (path `BS.append` "/hello") stdFileMode) + closeFd + (\fd -> void $ fdWrite fd " ") + +main :: IO () +main = + inTestEnviron [AllEvents] write $ \ events -> do + when (expected ~= events) + testSuccess + putStrLn $ explainFailure expected events + testFailure + +expected :: [Event] +expected = + [ Created False "hello" + , Opened False (Just "hello") + , Modified False (Just "hello") + , Closed False (Just "hello") True + ] diff --git a/tests/test003-removefile.hs b/tests/test003-removefile.hs new file mode 100644 --- /dev/null +++ b/tests/test003-removefile.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Exception +import Control.Monad + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import System.INotify + +import System.Posix.Files.ByteString +import System.Posix.IO.ByteString + +import Utils + + +file :: ByteString +file = "hello" + +write :: ByteString -> IO () +write path = + bracket (createFile (path `BS.append` "/" `BS.append` file) stdFileMode) + closeFd + (\fd -> void $ fdWrite fd " ") + +remove :: ByteString -> IO () +remove path = + removeLink (path `BS.append` "/" `BS.append` file) + +action :: ByteString -> IO () +action path = do + write path + remove path + +main :: IO () +main = + inTestEnviron [AllEvents] action $ \ events -> do + when (expected ~= events) + testSuccess + putStrLn $ explainFailure expected events + testFailure + +expected :: [Event] +expected = + [ Created False file + , Opened False (Just file) + , Modified False (Just file) + , Closed False (Just file) True + , Deleted False file + ] diff --git a/tests/test004-modify-file.hs b/tests/test004-modify-file.hs new file mode 100644 --- /dev/null +++ b/tests/test004-modify-file.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Exception +import Control.Monad + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import System.INotify + +import System.Posix.Files.ByteString +import System.Posix.IO.ByteString + +import Utils + + +file :: ByteString +file = "hello" + +write :: ByteString -> IO () +write path = + bracket (createFile (path `BS.append` "/" `BS.append` file) stdFileMode) + closeFd + (\fd -> void $ fdWrite fd " ") + +modify :: ByteString -> IO () +modify path = + bracket (openFd (path `BS.append` "/" `BS.append` file) WriteOnly + Nothing defaultFileFlags) + closeFd + (\fd -> void $ fdWrite fd "yarr!") + +remove :: ByteString -> IO () +remove path = + removeLink (path `BS.append` "/" `BS.append` file) + +action :: ByteString -> IO () +action path = do + write path + modify path + remove path + +main :: IO () +main = + inTestEnviron [AllEvents] action $ \ events -> do + when (expected ~= events) + testSuccess + putStrLn $ explainFailure expected events + testFailure + +expected :: [Event] +expected = + [ Created False file + , Opened False (Just file) + , Modified False (Just file) + , Closed False (Just file) True + , Opened False (Just file) + , Modified False (Just file) + , Closed False (Just file) True + , Deleted False file + ] diff --git a/tests/test005-move-file.hs b/tests/test005-move-file.hs new file mode 100644 --- /dev/null +++ b/tests/test005-move-file.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Exception +import Control.Monad + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import System.INotify + +import System.Posix.Files.ByteString +import System.Posix.IO.ByteString + +import Utils + + +file, file2 :: ByteString +file = "hello" +file2 = file `BS.append` "2" + +write :: ByteString -> IO () +write path = + bracket (createFile (path `BS.append` "/" `BS.append` file) stdFileMode) + closeFd + (\fd -> void $ fdWrite fd " ") + +move :: ByteString -> IO () +move path = + rename (path `BS.append` "/" `BS.append` file) + (path `BS.append` "/" `BS.append` file2) + +remove :: ByteString -> IO () +remove path = + removeLink (path `BS.append` "/" `BS.append` file2) + +action :: ByteString -> IO () +action path = do + write path + move path + remove path + +main :: IO () +main = + inTestEnviron [AllEvents] action $ \ events -> do + let cookie = head [ c | MovedOut _ _ c <- events ] + when (expected cookie ~= events) + testSuccess + putStrLn $ explainFailure (expected cookie) events + testFailure + +expected :: Cookie -> [Event] +expected cookie = + [ Created False file + , Opened False (Just file) + , Modified False (Just file) + , Closed False (Just file) True + , MovedOut False file cookie + , MovedIn False file2 cookie + , Deleted False file2 + ]