System/Event/KQueue.hsc

   1 {-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving,
   2     NoImplicitPrelude, RecordWildCards #-}
   3
   4 module System.Event.KQueue
   5     (
   6       new
   7     , available
   8     ) where
   9
  10 import qualified System.Event.Internal as E
  11
  12 #include "EventConfig.h"
  13 #if !defined(HAVE_KQUEUE)
  14 import GHC.Base
  15
  16 new :: IO E.Backend
  17 new = error "KQueue back end not implemented for this platform"
  18
  19 available :: Bool
  20 available = False
  21 {-# INLINE available #-}
  22 #else
  23
  24 import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar)
  25 import Control.Monad (when, unless)
  26 import Data.Bits (Bits(..))
  27 import Data.Word (Word16, Word32)
  28 import Foreign.C.Error (throwErrnoIfMinus1)
  29 import Foreign.C.Types (CInt, CIntPtr, CLong, CTime, CUIntPtr)
  30 import Foreign.Marshal.Alloc (alloca)
  31 import Foreign.Ptr (Ptr, nullPtr)
  32 import Foreign.Storable (Storable(..))
  33 import GHC.Base
  34 import GHC.Enum (toEnum)
  35 import GHC.Err (undefined)
  36 import GHC.Num (Num(..))
  37 import GHC.Real (ceiling, floor, fromIntegral)
  38 import GHC.Show (Show(show))
  39 import System.Event.Internal (Timeout(..))
  40 import System.Posix.Internals (c_close)
  41 import System.Posix.Types (Fd(..))
  42 import qualified System.Event.Array as A
  43
  44 #if defined(HAVE_KEVENT64)
  45 import Data.Int (Int64)
  46 import Data.Word (Word64)
  47 import Foreign.C.Types (CUInt)
  48 #endif
  49
  50 #include <sys/types.h>
  51 #include <sys/event.h>
  52 #include <sys/time.h>
  53
  54 -- Handle brokenness on some BSD variants, notably OS X up to at least
  55 -- 10.6.  If NOTE_EOF isn't available, we have no way to receive a
  56 -- notification from the kernel when we reach EOF on a plain file.
  57 #ifndef NOTE_EOF
  58 # define NOTE_EOF 0
  59 #endif
  60
  61 available :: Bool
  62 available = True
  63 {-# INLINE available #-}
  64
  65 ------------------------------------------------------------------------
  66 -- Exported interface
  67
  68 data EventQueue = EventQueue {
  69       eqFd       :: {-# UNPACK #-} !QueueFd
  70     , eqChanges  :: {-# UNPACK #-} !(MVar (A.Array Event))
  71     , eqEvents   :: {-# UNPACK #-} !(A.Array Event)
  72     }
  73
  74 new :: IO E.Backend
  75 new = do
  76   qfd <- kqueue
  77   changesArr <- A.empty
  78   changes <- newMVar changesArr
  79   events <- A.new 64
  80   let !be = E.backend poll modifyFd delete (EventQueue qfd changes events)
  81   return be
  82
  83 delete :: EventQueue -> IO ()
  84 delete q = do
  85   _ <- c_close . fromQueueFd . eqFd $ q
  86   return ()
  87
  88 modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO ()
  89 modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do
  90   let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF
  91   when (oevt `E.eventIs` E.evtRead)  $ addChange filterRead flagDelete
  92   when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete
  93   when (nevt `E.eventIs` E.evtRead)  $ addChange filterRead flagAdd
  94   when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd
  95
  96 poll :: EventQueue
  97      -> Timeout
  98      -> (Fd -> E.Event -> IO ())
  99      -> IO ()
 100 poll EventQueue{..} tout f = do
 101     changesArr <- A.empty
 102     changes <- swapMVar eqChanges changesArr
 103     changesLen <- A.length changes
 104     len <- A.length eqEvents
 105     when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen)
 106     n <- A.useAsPtr changes $ \changesPtr chLen ->
 107            A.unsafeLoad eqEvents $ \evPtr evCap ->
 108              withTimeSpec (fromTimeout tout) $
 109                kevent eqFd changesPtr chLen evPtr evCap
 110
 111     unless (n == 0) $ do
 112         cap <- A.capacity eqEvents
 113         when (n == cap) $ A.ensureCapacity eqEvents (2 * cap)
 114         A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))
 115
 116 ------------------------------------------------------------------------
 117 -- FFI binding
 118
 119 newtype QueueFd = QueueFd {
 120       fromQueueFd :: CInt
 121     } deriving (Eq, Show)
 122
 123 #if defined(HAVE_KEVENT64)
 124 data Event = KEvent64 {
 125       ident  :: {-# UNPACK #-} !Word64
 126     , filter :: {-# UNPACK #-} !Filter
 127     , flags  :: {-# UNPACK #-} !Flag
 128     , fflags :: {-# UNPACK #-} !FFlag
 129     , data_  :: {-# UNPACK #-} !Int64
 130     , udata  :: {-# UNPACK #-} !Word64
 131     , ext0   :: {-# UNPACK #-} !Word64
 132     , ext1   :: {-# UNPACK #-} !Word64
 133     } deriving Show
 134
 135 event :: Fd -> Filter -> Flag -> FFlag -> Event
 136 event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0
 137
 138 instance Storable Event where
 139     sizeOf _ = #size struct kevent64_s
 140     alignment _ = alignment (undefined :: CInt)
 141
 142     peek ptr = do
 143         ident'  <- #{peek struct kevent64_s, ident} ptr
 144         filter' <- #{peek struct kevent64_s, filter} ptr
 145         flags'  <- #{peek struct kevent64_s, flags} ptr
 146         fflags' <- #{peek struct kevent64_s, fflags} ptr
 147         data'   <- #{peek struct kevent64_s, data} ptr
 148         udata'  <- #{peek struct kevent64_s, udata} ptr
 149         ext0'   <- #{peek struct kevent64_s, ext[0]} ptr
 150         ext1'   <- #{peek struct kevent64_s, ext[1]} ptr
 151         let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data'
 152                            udata' ext0' ext1'
 153         return ev
 154
 155     poke ptr ev = do
 156         #{poke struct kevent64_s, ident} ptr (ident ev)
 157         #{poke struct kevent64_s, filter} ptr (filter ev)
 158         #{poke struct kevent64_s, flags} ptr (flags ev)
 159         #{poke struct kevent64_s, fflags} ptr (fflags ev)
 160         #{poke struct kevent64_s, data} ptr (data_ ev)
 161         #{poke struct kevent64_s, udata} ptr (udata ev)
 162         #{poke struct kevent64_s, ext[0]} ptr (ext0 ev)
 163         #{poke struct kevent64_s, ext[1]} ptr (ext1 ev)
 164 #else
 165 data Event = KEvent {
 166       ident  :: {-# UNPACK #-} !CUIntPtr
 167     , filter :: {-# UNPACK #-} !Filter
 168     , flags  :: {-# UNPACK #-} !Flag
 169     , fflags :: {-# UNPACK #-} !FFlag
 170     , data_  :: {-# UNPACK #-} !CIntPtr
 171     , udata  :: {-# UNPACK #-} !(Ptr ())
 172     } deriving Show
 173
 174 event :: Fd -> Filter -> Flag -> FFlag -> Event
 175 event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr
 176
 177 instance Storable Event where
 178     sizeOf _ = #size struct kevent
 179     alignment _ = alignment (undefined :: CInt)
 180
 181     peek ptr = do
 182         ident'  <- #{peek struct kevent, ident} ptr
 183         filter' <- #{peek struct kevent, filter} ptr
 184         flags'  <- #{peek struct kevent, flags} ptr
 185         fflags' <- #{peek struct kevent, fflags} ptr
 186         data'   <- #{peek struct kevent, data} ptr
 187         udata'  <- #{peek struct kevent, udata} ptr
 188         let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'
 189                          udata'
 190         return ev
 191
 192     poke ptr ev = do
 193         #{poke struct kevent, ident} ptr (ident ev)
 194         #{poke struct kevent, filter} ptr (filter ev)
 195         #{poke struct kevent, flags} ptr (flags ev)
 196         #{poke struct kevent, fflags} ptr (fflags ev)
 197         #{poke struct kevent, data} ptr (data_ ev)
 198         #{poke struct kevent, udata} ptr (udata ev)
 199 #endif
 200
 201 newtype FFlag = FFlag Word32
 202     deriving (Eq, Show, Storable)
 203
 204 #{enum FFlag, FFlag
 205  , noteEOF = NOTE_EOF
 206  }
 207
 208 newtype Flag = Flag Word16
 209     deriving (Eq, Show, Storable)
 210
 211 #{enum Flag, Flag
 212  , flagAdd     = EV_ADD
 213  , flagDelete  = EV_DELETE
 214  }
 215
 216 newtype Filter = Filter Word16
 217     deriving (Bits, Eq, Num, Show, Storable)
 218
 219 #{enum Filter, Filter
 220  , filterRead   = EVFILT_READ
 221  , filterWrite  = EVFILT_WRITE
 222  }
 223
 224 data TimeSpec = TimeSpec {
 225       tv_sec  :: {-# UNPACK #-} !CTime
 226     , tv_nsec :: {-# UNPACK #-} !CLong
 227     }
 228
 229 instance Storable TimeSpec where
 230     sizeOf _ = #size struct timespec
 231     alignment _ = alignment (undefined :: CInt)
 232
 233     peek ptr = do
 234         tv_sec'  <- #{peek struct timespec, tv_sec} ptr
 235         tv_nsec' <- #{peek struct timespec, tv_nsec} ptr
 236         let !ts = TimeSpec tv_sec' tv_nsec'
 237         return ts
 238
 239     poke ptr ts = do
 240         #{poke struct timespec, tv_sec} ptr (tv_sec ts)
 241         #{poke struct timespec, tv_nsec} ptr (tv_nsec ts)
 242
 243 kqueue :: IO QueueFd
 244 kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
 245
 246 -- TODO: We cannot retry on EINTR as the timeout would be wrong.
 247 -- Perhaps we should just return without calling any callbacks.
 248 kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
 249        -> IO Int
 250 kevent k chs chlen evs evlen ts
 251     = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
 252 #if defined(HAVE_KEVENT64)
 253       c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts
 254 #else
 255       c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
 256 #endif
 257
 258 withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
 259 withTimeSpec ts f =
 260     if tv_sec ts < 0 then
 261         f nullPtr
 262       else
 263         alloca $ \ptr -> poke ptr ts >> f ptr
 264
 265 fromTimeout :: Timeout -> TimeSpec
 266 fromTimeout Forever     = TimeSpec (-1) (-1)
 267 fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
 268   where
 269     sec :: Int
 270     sec     = floor s
 271
 272     nanosec :: Int
 273     nanosec = ceiling $ (s - fromIntegral sec) * 1000000000
 274
 275 toEvent :: Filter -> E.Event
 276 toEvent (Filter f)
 277     | f == (#const EVFILT_READ) = E.evtRead
 278     | f == (#const EVFILT_WRITE) = E.evtWrite
 279     | otherwise = error $ "toEvent: unknonwn filter " ++ show f
 280
 281 foreign import ccall unsafe "kqueue"
 282     c_kqueue :: IO CInt
 283
 284 #if defined(HAVE_KEVENT64)
 285 foreign import ccall safe "kevent64"
 286     c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt
 287                -> Ptr TimeSpec -> IO CInt
 288 #elif defined(HAVE_KEVENT)
 289 foreign import ccall safe "kevent"
 290     c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
 291              -> Ptr TimeSpec -> IO CInt
 292 #else
 293 #error no kevent system call available!?
 294 #endif
 295
 296 #endif /* defined(HAVE_KQUEUE) */