diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Erik Hesselink + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Erik Hesselink nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT +OWNER 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/MonitorDirectory.hs b/examples/MonitorDirectory.hs new file mode 100644 --- /dev/null +++ b/examples/MonitorDirectory.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +-- This file shows how to monitor a single file (name) through +-- creation and deletion. The actual code calling the kqueue functions +-- is in System.KQueue.HighLevel. +import Control.Monad +import System.Directory +import System.Environment +import System.FilePath +import System.KQueue.HighLevel + +-- Monitor the file command line argument or ./foo for changes until +-- ctrl-C is received. Prints the events as they are received. The +-- file can be created or deleted during a run, and this is also +-- reported. +main :: IO () +main = + do args <- getArgs + let file = if null args then "foo" else head args + (dir, filename) <- splitFileName `liftM` canonicalizePath file + putStrLn $ "Watching file " ++ filename + putStrLn $ "Watching in " ++ dir + watcher <- watchFile file (\chg -> putStrLn ("File " ++ filename ++ " was " ++ show chg)) + waitForTermination + stopWatching watcher + +-- Copied from happstack. +waitForTermination :: IO () +waitForTermination + = do +#ifdef UNIX + istty <- queryTerminal stdInput + mv <- newEmptyMVar + installHandler softwareTermination (CatchOnce (putMVar mv ())) Nothing + case istty of + True -> do installHandler keyboardSignal (CatchOnce (putMVar mv ())) Nothing + return () + False -> return () + takeMVar mv +#else + let loop 'e' = return () + loop _ = getChar >>= loop + loop 'c' +#endif diff --git a/examples/MonitorFile.hs b/examples/MonitorFile.hs new file mode 100644 --- /dev/null +++ b/examples/MonitorFile.hs @@ -0,0 +1,30 @@ +import Control.Monad +import Foreign.Ptr +import System.KQueue +import System.Posix.IO + +-- Monitor file 'foo for changes until it is deleted. Prints the +-- events as they are received. The file has to exist when this +-- program is started. +main = do + -- Initialize the queue. + kq <- kqueue + -- Open file descriptor. + fd <- openFd "foo" ReadOnly Nothing defaultFileFlags + -- Construct the event to monitor. + let event = KEvent + { ident = fromIntegral fd + , evfilter = EvfiltVnode + , flags = [EvAdd, EvOneshot] + , fflags = [NoteDelete, NoteExtend, NoteWrite, NoteAttrib, NoteRename] + , data_ = 0 + , udata = nullPtr + } + let poll = do + -- Add or poll the event. + chgs <- kevent kq [event] 1 Nothing + -- If something happened, print it. + when (not . null $ chgs) (print chgs) + -- If the file was deleted, stop. Otherwise, continue polling. + when (not (NoteDelete `elem` fflags (head chgs))) poll + poll diff --git a/kqueue.cabal b/kqueue.cabal new file mode 100644 --- /dev/null +++ b/kqueue.cabal @@ -0,0 +1,30 @@ +Name: kqueue +Version: 0.1 +Synopsis: A binding to the kqueue event library. +Description: A low-level binding to the kqueue library as + found in BSD and Mac OS X. It provides, among + other things, a way of monitoring files and + directories for changes. +Homepage: http://github.com/hesselink/kqueue +License: BSD3 +License-file: LICENSE +Author: Erik Hesselink +Maintainer: hesselink@gmail.com +Category: System +Build-type: Simple +Cabal-version: >=1.6 +Extra-source-files: examples/MonitorFile.hs + examples/MonitorDirectory.hs + +Library + Hs-Source-Dirs: src + Exposed-modules: System.KQueue + System.KQueue.HighLevel + Build-depends: base >= 4.0 && < 4.4 + , directory >= 1.0 && < 1.2 + , filepath >= 1.1 && < 1.3 + , mtl >= 1.1 && < 2.1 + , time >= 1.1 && < 1.3 + , unix >= 2.3 && < 2.5 + Build-tools: c2hs + GHC-Options: -Wall diff --git a/src/System/KQueue.chs b/src/System/KQueue.chs new file mode 100644 --- /dev/null +++ b/src/System/KQueue.chs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveDataTypeable + , EmptyDataDecls + , ForeignFunctionInterface + #-} +-- | This module contains a low-level binding to the kqueue interface. +-- It stays close to the C API, changing the types to more native +-- Haskell types, but not significantly changing it. +-- See the kqueue man page or the examples in @examples/@ for usage +-- information. +-- For a higher-level binding, see "System.KQueue.HighLevel". +module System.KQueue + ( KQueue + , kqueue + , KEvent (..) + , Filter (..) + , Flag (..) + , FFlag (..) + , kevent + , KQueueException + ) where + +#include +#include + +import Control.Applicative ( (<$>), (<*>) ) +import Control.Exception ( Exception, throwIO ) +import Data.List ( foldl' ) +import Data.Maybe ( mapMaybe ) +import Data.Time.Clock ( NominalDiffTime ) +import Data.Typeable ( Typeable ) +import Foreign ( (.|.) + , Ptr + , Storable (..) + , allocaArray + , bit + , bitSize + , maybeWith + , testBit + , peekArray + , with + , withArray + ) +import Foreign.C ( CInt + , CLong + , CShort + , CTime + , CUInt + , CULong + , CUShort + ) + +-- | A kernel event queue. +newtype KQueue = KQueue CInt -- The descriptor + +-- | Create a new KQueue. +kqueue :: IO KQueue +kqueue = KQueue <$> {#call kqueue as kqueue_ #} + +-- | A kernel event. +data KEvent = KEvent + { ident :: CULong -- ^ The identifier for the event, often a file descriptor. + , evfilter :: Filter -- ^ The kernel filter (type of event). + , flags :: [Flag] -- ^ Actions to perform on the event. + , fflags :: [FFlag] -- ^ Filter-specific flags. + , data_ :: CLong -- ^ Filter-specific data value. + , udata :: Ptr () -- ^ User-defined data, passed through unchanged. + } deriving (Show, Eq) + +-- TODO: nicer types for ident, data_ and udata. + +#c +enum Filter + { EvfiltRead = EVFILT_READ + , EvfiltWrite = EVFILT_WRITE + , EvfiltAio = EVFILT_AIO + , EvfiltVnode = EVFILT_VNODE + , EvfiltProc = EVFILT_PROC + , EvfiltSignal = EVFILT_SIGNAL + , EvfiltTimer = EVFILT_TIMER +// Not on Mac OS X +// , EvfiltUser = EVFILT_USER + }; +#endc + +-- | The types of kernel events. +{#enum Filter {} deriving (Show, Eq) #} + +#c +enum Flag + { EvAdd = EV_ADD + , EvEnable = EV_ENABLE + , EvDisable = EV_DISABLE +// Not on Mac OS X +// , EvDispatch = EV_DISPATCH + , EvDelete = EV_DELETE + , EvReceipt = EV_RECEIPT + , EvOneshot = EV_ONESHOT + , EvClear = EV_CLEAR + , EvEof = EV_EOF + , EvError = EV_ERROR + }; +#endc + +-- | The actions to perform on the event. +{#enum Flag {} deriving (Show, Eq) #} + +#c +enum FFlag + { NoteDelete = NOTE_DELETE + , NoteWrite = NOTE_WRITE + , NoteExtend = NOTE_EXTEND + , NoteAttrib = NOTE_ATTRIB + , NoteLink = NOTE_LINK + , NoteRename = NOTE_RENAME + , NoteRevoke = NOTE_REVOKE +// Seems to have the same value as NoteDelete +// , NoteLowat = NOTE_LOWAT + , NoteExit = NOTE_EXIT + , NoteFork = NOTE_FORK + , NoteExec = NOTE_EXEC + , NoteSignal = NOTE_SIGNAL + , NoteReap = NOTE_REAP + }; +#endc + +-- | The filter specific flags. +{#enum FFlag {} deriving (Show, Eq) #} + +-- | Convert a list of enumeration values to an integer by combining +-- them with bitwise 'or'. +enumToBitmask :: Enum a => [a] -> Int +enumToBitmask = foldl' (.|.) 0 . map fromEnum + +-- | Convert an integer to a list of enumeration values by testing +-- each bit, and if set, convert it to an enumeration member. +bitmaskToEnum :: Enum a => Int -> [a] +bitmaskToEnum bm = mapMaybe maybeBit [0 .. bitSize bm - 1] + where + maybeBit b | testBit bm b = Just . toEnum . bit $ b + | otherwise = Nothing + +#c +typedef struct kevent kevent_t; +#endc + +instance Storable KEvent where + sizeOf _ = {#sizeof kevent_t #} + alignment _ = 24 + peek e = KEvent <$> ({#get kevent_t->ident #} e) + <*> fmap (toEnum . fromIntegral) ({#get kevent_t->filter #} e) + <*> fmap (bitmaskToEnum . fromIntegral) ({#get kevent_t->flags #} e) + <*> fmap (bitmaskToEnum . fromIntegral) ({#get kevent_t->fflags #} e) + <*> ({#get kevent_t->data #} e) + <*> ({#get kevent_t->udata #} e) + poke e ev = + do {#set kevent_t->ident #} e (ident ev) + {#set kevent_t->filter #} e (fromIntegral . fromEnum . evfilter $ ev) + {#set kevent_t->flags #} e (fromIntegral . enumToBitmask . flags $ ev) + {#set kevent_t->fflags #} e (fromIntegral . enumToBitmask . fflags $ ev) + {#set kevent_t->data #} e (data_ ev) + {#set kevent_t->udata #} e (udata ev) + +newtype TimeSpec = TimeSpec NominalDiffTime + deriving (Show, Eq) + +#c +typedef struct timespec timespec_t; +#endc + +-- TODO: waarom krijg ik geen CTime maar een CLong als seconds bij gebruik van #get/#set? +instance Storable TimeSpec where + sizeOf _ = {#sizeof timespec_t #} + alignment _ = 8 + peek t = mkTimeSpec + <$> (\ptr -> peekByteOff ptr 0 :: IO CTime) t + <*> {#get timespec_t->tv_nsec #} t + where + mkTimeSpec s ns = TimeSpec $ realToFrac s + realToFrac ns/1000000000 + poke t (TimeSpec dt) = + do (\ptr val -> pokeByteOff ptr 0 (val :: CTime)) t (fromInteger s) + {#set timespec_t->tv_nsec #} t (floor . (* 1000000000) $ ns) + where + (s, ns) = properFraction dt + +foreign import ccall "kevent" kevent_ :: CInt -> Ptr KEvent -> CInt -> Ptr KEvent -> CInt -> Ptr TimeSpec -> IO CInt + +data KQueueException = KQueueException + deriving (Show, Typeable) + +instance Exception KQueueException + +-- | Add events to monitor, or retrieve events from the kqueue. If an +-- error occurs, will throw a 'KQueueException' if there is no room in +-- the returned event list. Otherwise, will set 'EvError' on the event +-- and add it to the returned event list. +kevent :: KQueue -- ^ The kernel queue to operate on. + -> [KEvent] -- ^ The list of events to start monitoring, or changes to retrieve. + -> Int -- ^ The maximum number of events to retrieve. + -> Maybe NominalDiffTime -- ^ Timeout. When nothing, blocks until an event has occurred. + -> IO [KEvent] -- ^ A list of events that have occurred. +kevent (KQueue kq) changelist nevents mtimeout = + withArray changelist $ \chArray -> + allocaArray nevents $ \evArray -> + maybeWith with (TimeSpec <$> mtimeout) $ \timeout -> + do ret <- kevent_ kq chArray (fromIntegral . length $ changelist) evArray (fromIntegral nevents) timeout + case ret of + -- Error while processing changelist, and no room in return array. + -1 -> throwIO KQueueException + -- Timeout. + 0 -> return [] + -- Returned n events. Can contain errors. The change that + -- failed will be in the event list. EV_ERROR will be set on the + -- event. + n -> peekArray (fromIntegral n) evArray diff --git a/src/System/KQueue/HighLevel.hs b/src/System/KQueue/HighLevel.hs new file mode 100644 --- /dev/null +++ b/src/System/KQueue/HighLevel.hs @@ -0,0 +1,159 @@ +-- | This module contains higher-level abstraction for monitoring file +-- system changes, built on top of the bindings from "System.KQueue". +module System.KQueue.HighLevel + ( watchFile + , stopWatching + , EventType (..) + , Watcher + ) where + +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Monad.State (StateT, evalStateT, forever, get, liftIO, liftM, put, when) +import Data.List (intersect) +import Foreign.Ptr (nullPtr) +import System.Directory (canonicalizePath, doesFileExist) +import System.FilePath (takeDirectory) +import System.Posix.IO (OpenMode (ReadOnly), defaultFileFlags, openFd) +import System.Posix.Types (Fd) + +import System.KQueue + +-- | The type of file change that occurred. +data EventType = Changed | Created | Deleted deriving Show + +-- | An identifier for the watcher of a file. Allows you to stop +-- watching it later. +newtype Watcher = Watcher ThreadId + +-- | Watch a file for changes. The file doesn't have to exist, but the +-- directory it is in, does. Returns immediately. You can stop +-- watching by passing the 'Watcher' to 'stopWatching'. +watchFile :: FilePath -> (EventType -> IO ()) -> IO Watcher +watchFile file callback = + do kq <- kqueue + dir <- takeDirectory `liftM` canonicalizePath file + tid <- forkIO $ watchDirectoryForFile kq dir file callback + return $ Watcher tid + +-- | Stop a watcher from watching. +stopWatching :: Watcher -> IO () +stopWatching (Watcher tid) = killThread tid + +-- | Watch a directory and a file for changes to that file. This +-- function does some initialization, and then runs 'monitorChanges' +-- forever. +watchDirectoryForFile :: KQueue -> FilePath -> FilePath -> (EventType -> IO ()) -> IO () +watchDirectoryForFile kq dir file callback = + do -- Event structures for the directory and file to monitor + dfd <- openFd dir ReadOnly Nothing defaultFileFlags + let dirEvent = KEvent + { ident = fromIntegral dfd + , evfilter = EvfiltVnode + , flags = [EvOneshot] + , fflags = [NoteWrite] + , data_ = 0 + , udata = nullPtr + } + mkFileEvent ffd = KEvent + { ident = fromIntegral ffd + , evfilter = EvfiltVnode + , flags = [EvOneshot] + , fflags = [NoteDelete, NoteWrite, NoteRename] + , data_ = 0 + , udata = nullPtr + } + -- Initialize IORef holding possible file descriptor if the file + -- we're monitoring exists + exists <- doesFileExist file + mFd <- + if exists + then Just `liftM` openFd file ReadOnly Nothing defaultFileFlags + else return Nothing + -- Add the event(s) to the queue. + let eventsToAdd = dirEvent : maybe [] (return . mkFileEvent) mFd + _ <- kevent kq (map (setFlag EvAdd) eventsToAdd) 0 Nothing + -- Forever listen to the events, calling the relevant callbacks. + flip evalStateT mFd . forever $ monitorChanges kq dirEvent mkFileEvent callback file + +-- | Monitor changes on a file and directory. This is just a wrapper +-- for the state updates; the actual work is done in +-- 'monitorChangesIO'. +monitorChanges :: KQueue -> KEvent -> (Fd -> KEvent) -> (EventType -> IO ()) -> FilePath -> StateT (Maybe Fd) IO () +monitorChanges kq dirEvent mkFileEvent callback file = + do mFd <- get + newMFd <- liftIO $ monitorChangesIO kq dirEvent mkFileEvent callback file mFd + put newMFd + +-- | Monitor changes on a file and directory. Calls the callback when +-- the file has changed, or has been created or removed. Returns the +-- file descriptor of the file, if it exists. +monitorChangesIO :: KQueue -> KEvent -> (Fd -> KEvent) -> (EventType -> IO ()) -> FilePath -> Maybe Fd -> IO (Maybe Fd) +monitorChangesIO kq dirEvent mkFileEvent callback file mFd = + do -- Figure out which events we're currently monitoring. + let eventsToMonitor = dirEvent : maybe [] (return . mkFileEvent) mFd + -- Block until we get at least one event. + [firstChg] <- kevent kq eventsToMonitor 1 Nothing + -- Collect all other events that occurred at the same time. + otherChgs <- getAllEvents kq (map (setFlag EvAdd) eventsToMonitor) + let chgs = firstChg : otherChgs + -- If the file was written to, we call the relevant callback. + when (NoteWrite `elem` [ fflag | fileChg <- chgs, ident fileChg /= ident dirEvent, fflag <- fflags fileChg]) $ + callback Changed + -- If the file was created, we just get a NoteWrite + -- on the directory. So we compare the existence of the file + -- before and after the directory event. Delete is done in the + -- same way for simplicity. Modifications are sometimes more + -- difficult, see third case. + exists <- doesFileExist file + case (exists, mFd) of + (True, Nothing) -> -- The file was created. + do callback Created + -- Start monitoring it. + fd <- openFd file ReadOnly Nothing defaultFileFlags + _ <- kevent kq [setFlag EvAdd (mkFileEvent fd)] 0 Nothing + return (Just fd) + (False, Just fd) -> -- The file was deleted. + do callback Deleted + -- Stop monitoring it. + _ <- kevent kq [setFlag EvDelete (mkFileEvent fd)] 0 Nothing + return Nothing + -- Sometimes (for example, when vi writes a file) we get a + -- NoteRename, a NoteDelete, and a NoteWrite on the directory + -- (the file being recreated). We want to report this as a + -- change. We collect all these in one batch, so we see a + -- delete and/or rename on the file, but it exists both + -- before and after the events. + (True, Just fd) | not . null . filter (isDeleteOrRename fd) $ chgs -> + do callback Changed + -- Remove the event on the old file. + _ <- kevent kq [setFlag EvDelete (mkFileEvent fd)] 0 Nothing + -- Add the event on the new file. + newFd <- openFd file ReadOnly Nothing defaultFileFlags + _ <- kevent kq [setFlag EvAdd (mkFileEvent newFd)] 0 Nothing + return (Just newFd) + -- A directory event, but not on the file we're interested + -- in. + (_, _ ) -> return mFd + +-- | Is the KEvent a delete or rename on the file descriptor given? +isDeleteOrRename :: Fd -> KEvent -> Bool +isDeleteOrRename fd evt = fromIntegral fd == ident evt + && (not . null . intersect [NoteDelete, NoteRename] . fflags) evt + +-- | Get all events that are currently in the queue for the given +-- changelist. Waits 0.1s for new events, to consolidate multiple +-- related events on a file save. +getAllEvents :: KQueue -> [KEvent] -> IO [KEvent] +getAllEvents kq evts = go [] + where + go collectedChgs = + do chgs <- kevent kq evts 10 (Just 0.1) + if null chgs + then return collectedChgs + else go (collectedChgs ++ chgs) + +-- | Set (add) a flag on a 'KEvent'. Normally I would use fclabels +-- here, but since this is only one function, I'll define it here, so +-- I don't have to depend on the package. +setFlag :: (Flag -> KEvent -> KEvent) +setFlag flag ev = ev { flags = flag : flags ev }