kqueue (empty) → 0.1
raw patch · 7 files changed
+508/−0 lines, 7 filesdep +basedep +directorydep +filepathsetup-changed
Dependencies added: base, directory, filepath, mtl, time, unix
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/MonitorDirectory.hs +43/−0
- examples/MonitorFile.hs +30/−0
- kqueue.cabal +30/−0
- src/System/KQueue.chs +214/−0
- src/System/KQueue/HighLevel.hs +159/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/MonitorDirectory.hs view
@@ -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
+ examples/MonitorFile.hs view
@@ -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
+ kqueue.cabal view
@@ -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
+ src/System/KQueue.chs view
@@ -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 <sys/time.h>+#include <sys/event.h>++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
+ src/System/KQueue/HighLevel.hs view
@@ -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 }