module System.Linux.Epoll.Base (
EventType,
Size,
toSize,
Duration,
toDuration,
Descriptor,
Device,
Event (eventFd, eventType, eventRef, eventDesc),
(=~),
create,
close,
wait,
add,
modify,
delete,
freeDesc,
inEvent,
outEvent,
peerCloseEvent,
urgentEvent,
errorEvent,
hangupEvent,
edgeTriggeredEvent,
oneShotEvent,
combineEvents
) where
import Util
import Foreign
import Foreign.C.Types (CInt)
import Foreign.C.Error (throwErrnoIfMinus1,
throwErrnoIfMinus1_,
throwErrnoIfMinus1Retry)
import Foreign.Marshal.Array (peekArray, mallocArray)
import Foreign.Marshal.Utils (with)
import System.Posix.Types (Fd (Fd))
import System.Posix.Signals (installHandler, sigPIPE, Handler (Ignore))
newtype EventType = EventType { fromEventType :: Int } deriving (Eq, Ord)
newtype Operation = Operation { fromOp :: Int } deriving (Eq, Ord)
newtype Size = Size { fromSize :: Word32 } deriving (Eq, Ord, Show)
newtype Duration = Duration { fromDuration :: Word32 } deriving (Eq, Ord, Show)
newtype Descriptor a = Descriptor { descrPtr :: StablePtr (Fd, a) }
data Device = Device {
deviceFd :: !Fd,
eventArray :: !(Ptr EventStruct),
eventArrayLen :: !Size
} deriving (Eq, Show)
data Event a = Event {
eventFd :: !Fd,
eventType :: !EventType,
eventRef :: !a,
eventDesc :: !(Descriptor a)
}
data EventStruct = EventStruct {
epollEvents :: !Word32,
epollData :: !(Ptr ())
}
instance Storable EventStruct where
alignment _ = 1
sizeOf _ = (12)
peek p = do
evts <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
dat <- (\hsc_ptr -> peekByteOff hsc_ptr 4) p
return (EventStruct evts dat)
poke p (EventStruct evts dat) = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p evts
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p dat
inEvent :: EventType
inEvent = EventType 1
outEvent :: EventType
outEvent = EventType 4
peerCloseEvent :: EventType
peerCloseEvent = EventType 8192
urgentEvent :: EventType
urgentEvent = EventType 2
errorEvent :: EventType
errorEvent = EventType 8
hangupEvent :: EventType
hangupEvent = EventType 16
edgeTriggeredEvent :: EventType
edgeTriggeredEvent = EventType (2147483648)
oneShotEvent :: EventType
oneShotEvent = EventType 1073741824
instance Show EventType where
show e | e == inEvent = "EPOLLIN (0x001)"
| e == outEvent = "EPOLLOUT (0x004)"
| e == peerCloseEvent = "EPOLLRDHUP (0x2000)"
| e == urgentEvent = "EPOLLPRI (0x002)"
| e == errorEvent = "EPOLLERR (0x008)"
| e == hangupEvent = "EPOLLHUP (0x010)"
| e == edgeTriggeredEvent = "EPOLLET (1 << 31)"
| e == oneShotEvent = "EPOLLONESHOT (1 << 30)"
| otherwise = show $ fromEventType e
addOp :: Operation
addOp = Operation 1
modifyOp :: Operation
modifyOp = Operation 3
deleteOp :: Operation
deleteOp = Operation 2
instance Show Operation where
show op | op == addOp = "EPOLL_CTL_ADD"
| op == modifyOp = "EPOLL_CTL_MOD"
| op == deleteOp = "EPOLL_CTL_DEL"
| otherwise = show $ fromOp op
create :: Size -> IO Device
create s = do
dev <- throwErrnoIfMinus1 "create: c_epoll_create" (c_epoll_create 0)
buf <- mallocArray (fromIntegral $ fromSize s)
installHandler sigPIPE Ignore Nothing
return $ Device (Fd dev) buf s
close :: Device -> IO ()
close = free . eventArray
add :: Device -> a -> [EventType] -> Fd -> IO (Descriptor a)
add dev dat evts fd = do
p <- newStablePtr (fd, dat)
control dev addOp evts p
return $ Descriptor p
modify :: Device -> [EventType] -> Descriptor a -> IO ()
modify dev evts des = control dev modifyOp evts (descrPtr des)
delete :: Device -> Descriptor a -> IO ()
delete dev des = control dev deleteOp [] (descrPtr des)
freeDesc :: Descriptor a -> IO ()
freeDesc = freeStablePtr . descrPtr
control :: Device -> Operation -> [EventType] -> StablePtr (Fd, a) -> IO ()
control dev op evts ptr = do
(fd, _) <- deRefStablePtr ptr
throwErrnoIfMinus1_ (errMsg fd) $
with (EventStruct (fromIntegral . fromEventType $ combineEvents evts)
(castStablePtrToPtr ptr))
(c_epoll_ctl (intToNum $ deviceFd dev)
(fromIntegral $ fromOp op)
(intToNum fd))
where
errMsg fd = "control: c_epoll_ctl: fd=" ++ (show fd)
++ ", op=" ++ (show op)
++ ", events=" ++ (show evts)
wait :: Duration -> Device -> IO [Event a]
wait timeout dev = do
r <- throwErrnoIfMinus1Retry "wait: c_epoll_wait"
(c_epoll_wait (intToNum $ deviceFd dev)
(eventArray dev)
(fromIntegral . fromSize $ eventArrayLen dev)
(fromIntegral $ fromDuration timeout))
evts <- peekArray (fromIntegral r) (eventArray dev)
mapM createEvent evts
where
createEvent e = do
let ptr = castPtrToStablePtr $ epollData e
ety = EventType (fromIntegral $ epollEvents e)
(fd, ref) <- deRefStablePtr ptr
return (Event fd ety ref (Descriptor ptr))
(=~) :: EventType -> EventType -> Bool
e1 =~ e2 = fromEventType e1 .&. fromEventType e2 /= 0
infix 4 =~
toSize :: Int -> Maybe Size
toSize i = toWord32 i >>= Just . Size
toDuration :: Int -> Maybe Duration
toDuration i = toWord32 i >>= Just . Duration
combineEvents :: [EventType] -> EventType
combineEvents = EventType . foldr ((.|.) . fromEventType) 0
foreign import ccall unsafe "epoll.h epoll_create"
c_epoll_create :: CInt -> IO CInt
foreign import ccall unsafe "epoll.h epoll_ctl"
c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr EventStruct -> IO CInt
foreign import ccall safe "epoll.h epoll_wait"
c_epoll_wait :: CInt -> Ptr EventStruct -> CInt -> CInt -> IO CInt