System/Event/KQueue.hsc

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