System/Event/KQueue.hsc

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