{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}

module Linux.Epoll
  ( -- * Functions

    -- ** Create
    uninterruptibleCreate
  , uninterruptibleCreate1

    -- ** Wait
  , waitMutablePrimArray
  , uninterruptibleWaitMutablePrimArray

    -- ** Control
  , uninterruptibleControlMutablePrimArray

    -- * Types
  , EpollFlags (..)
  , ControlOperation (..)
  , Events (..)
  , Event (..)
  , Exchange (..)

    -- * Classes
  , PrimEpollData

    -- * Constants
  , T.closeOnExec
  , T.add
  , T.modify
  , T.delete
  , T.input
  , T.output
  , T.priority
  , T.hangup
  , T.readHangup
  , T.error
  , T.edgeTriggered

    -- * Events Combinators
  , T.containsAnyEvents
  , T.containsAllEvents

    -- * Marshalling
  , T.sizeofEvent
  , T.peekEventEvents
  , T.peekEventDataFd
  , T.peekEventDataPtr
  , T.peekEventDataU32
  , T.peekEventDataU64
  , T.pokeEventDataU64
  ) where

import Prelude hiding (error)

import Assertion (assertMutablePrimArrayPinned)
import Data.Primitive (MutablePrimArray (..))
import Foreign.C.Error (Errno, getErrno)
import Foreign.C.Types (CInt (..))
import GHC.Exts (MutableByteArray#, RealWorld)
import Linux.Epoll.Types (ControlOperation (..), EpollFlags (..), Event (..), Events (..), Exchange (..), PrimEpollData (..))
import System.Posix.Types (Fd (..))

import qualified Linux.Epoll.Types as T

foreign import ccall unsafe "sys/epoll.h epoll_create"
  c_epoll_create :: CInt -> IO Fd

foreign import ccall unsafe "sys/epoll.h epoll_create1"
  c_epoll_create1 :: EpollFlags -> IO Fd

foreign import ccall unsafe "sys/epoll.h epoll_wait"
  c_epoll_wait_unsafe :: Fd -> MutableByteArray# RealWorld -> CInt -> CInt -> IO CInt

foreign import ccall safe "sys/epoll.h epoll_wait"
  c_epoll_wait_safe :: Fd -> MutableByteArray# RealWorld -> CInt -> CInt -> IO CInt

foreign import ccall unsafe "sys/epoll.h epoll_ctl"
  c_epoll_ctl_unsafe :: Fd -> ControlOperation -> Fd -> MutableByteArray# RealWorld -> IO CInt

-- -- | Write @data.u64@ from @struct epoll_event@.
-- writeEventEvents ::
--      MutableByteArray RealWorld
--   -> Int -- ^ Index. Element are @struct epoll_event@.
--   -> Events e
--   -> IO ()
-- writeEventEvents !arr !ix !payload = do
--   -- See the comments on readEventDataU64
--   PM.writeByteArray arr (ix * 3 + 1) (word64ToWord32 (unsafeShiftR payload 32))
--   PM.writeByteArray arr (ix * 3 + 2) (word64ToWord32 payload)

uninterruptibleCreate ::
  -- | Size, ignored since Linux 2.6.8
  CInt ->
  IO (Either Errno Fd)
{-# INLINE uninterruptibleCreate #-}
uninterruptibleCreate :: CInt -> IO (Either Errno Fd)
uninterruptibleCreate !CInt
sz = CInt -> IO Fd
c_epoll_create CInt
sz IO Fd -> (Fd -> IO (Either Errno Fd)) -> IO (Either Errno Fd)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fd -> IO (Either Errno Fd)
errorsFromFd

uninterruptibleCreate1 ::
  -- | Flags
  EpollFlags ->
  IO (Either Errno Fd)
{-# INLINE uninterruptibleCreate1 #-}
uninterruptibleCreate1 :: EpollFlags -> IO (Either Errno Fd)
uninterruptibleCreate1 !EpollFlags
flags =
  EpollFlags -> IO Fd
c_epoll_create1 EpollFlags
flags IO Fd -> (Fd -> IO (Either Errno Fd)) -> IO (Either Errno Fd)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fd -> IO (Either Errno Fd)
errorsFromFd

{- | Wait for an I/O event on an epoll file descriptor. The
  <https://linux.die.net/man/2/epoll_wait Linux man page>
  includes more details. The @timeout@ argument is omitted
  since it is nonsense to choose anything other than 0 when
  using the unsafe FFI.
-}
uninterruptibleWaitMutablePrimArray ::
  -- | EPoll file descriptor
  Fd ->
  -- | Event buffer
  MutablePrimArray RealWorld (Event 'Response a) ->
  -- | Maximum events
  CInt ->
  -- | Number of events received
  IO (Either Errno CInt)
{-# INLINE uninterruptibleWaitMutablePrimArray #-}
uninterruptibleWaitMutablePrimArray :: forall a.
Fd
-> MutablePrimArray RealWorld (Event 'Response a)
-> CInt
-> IO (Either Errno CInt)
uninterruptibleWaitMutablePrimArray !Fd
epfd (MutablePrimArray MutableByteArray# RealWorld
evs) !CInt
maxEvents =
  Fd -> MutableByteArray# RealWorld -> CInt -> CInt -> IO CInt
c_epoll_wait_unsafe Fd
epfd MutableByteArray# RealWorld
evs CInt
maxEvents CInt
0 IO CInt
-> (CInt -> IO (Either Errno CInt)) -> IO (Either Errno CInt)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO (Either Errno CInt)
errorsFromInt

{- | Wait for an I/O event on an epoll file descriptor. The
  <https://linux.die.net/man/2/epoll_wait Linux man page>
  includes more details. The event buffer must be a pinned
  byte array.
-}
waitMutablePrimArray ::
  -- | EPoll file descriptor
  Fd ->
  -- | Event buffer, must be pinned
  MutablePrimArray RealWorld (Event 'Response a) ->
  -- | Maximum events
  CInt ->
  -- | Timeout in milliseconds, use @-1@ to block forever.
  CInt ->
  -- | Number of events received
  IO (Either Errno CInt)
{-# INLINE waitMutablePrimArray #-}
waitMutablePrimArray :: forall a.
Fd
-> MutablePrimArray RealWorld (Event 'Response a)
-> CInt
-> CInt
-> IO (Either Errno CInt)
waitMutablePrimArray !Fd
epfd !MutablePrimArray RealWorld (Event 'Response a)
evs !CInt
maxEvents !CInt
timeout =
  let !(MutablePrimArray MutableByteArray# RealWorld
evs#) = MutablePrimArray RealWorld (Event 'Response a)
-> MutablePrimArray RealWorld (Event 'Response a)
forall s a. MutablePrimArray s a -> MutablePrimArray s a
assertMutablePrimArrayPinned MutablePrimArray RealWorld (Event 'Response a)
evs
   in Fd -> MutableByteArray# RealWorld -> CInt -> CInt -> IO CInt
c_epoll_wait_safe Fd
epfd MutableByteArray# RealWorld
evs# CInt
maxEvents CInt
timeout IO CInt
-> (CInt -> IO (Either Errno CInt)) -> IO (Either Errno CInt)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO (Either Errno CInt)
errorsFromInt

{- | Add, modify, or remove entries in the interest list of the
  epoll instance referred to by the file descriptor @epfd@.
  <https://linux.die.net/man/2/epoll_ctl Linux man page>
  includes more details.
-}
uninterruptibleControlMutablePrimArray ::
  -- | EPoll file descriptor (@epfd@)
  Fd ->
  -- | Operation: @EPOLL_CTL_ADD@, @EPOLL_CTL_MOD@, or @EPOLL_CTL_DEL@
  ControlOperation ->
  -- | File descriptor whose registration will be affected
  Fd ->
  -- | A single event. This is read from, not written to.
  MutablePrimArray RealWorld (Event 'Request a) ->
  IO (Either Errno ())
{-# INLINE uninterruptibleControlMutablePrimArray #-}
uninterruptibleControlMutablePrimArray :: forall a.
Fd
-> ControlOperation
-> Fd
-> MutablePrimArray RealWorld (Event 'Request a)
-> IO (Either Errno ())
uninterruptibleControlMutablePrimArray !Fd
epfd !ControlOperation
op !Fd
fd (MutablePrimArray MutableByteArray# RealWorld
ev) =
  Fd
-> ControlOperation -> Fd -> MutableByteArray# RealWorld -> IO CInt
c_epoll_ctl_unsafe Fd
epfd ControlOperation
op Fd
fd MutableByteArray# RealWorld
ev IO CInt -> (CInt -> IO (Either Errno ())) -> IO (Either Errno ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO (Either Errno ())
errorsFromInt_

errorsFromFd :: Fd -> IO (Either Errno Fd)
{-# INLINE errorsFromFd #-}
errorsFromFd :: Fd -> IO (Either Errno Fd)
errorsFromFd Fd
r =
  if Fd
r Fd -> Fd -> Bool
forall a. Ord a => a -> a -> Bool
> (-Fd
1)
    then Either Errno Fd -> IO (Either Errno Fd)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fd -> Either Errno Fd
forall a b. b -> Either a b
Right Fd
r)
    else (Errno -> Either Errno Fd) -> IO Errno -> IO (Either Errno Fd)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Errno -> Either Errno Fd
forall a b. a -> Either a b
Left IO Errno
getErrno

errorsFromInt :: CInt -> IO (Either Errno CInt)
{-# INLINE errorsFromInt #-}
errorsFromInt :: CInt -> IO (Either Errno CInt)
errorsFromInt CInt
r =
  if CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> (-CInt
1)
    then Either Errno CInt -> IO (Either Errno CInt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt -> Either Errno CInt
forall a b. b -> Either a b
Right CInt
r)
    else (Errno -> Either Errno CInt) -> IO Errno -> IO (Either Errno CInt)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Errno -> Either Errno CInt
forall a b. a -> Either a b
Left IO Errno
getErrno

-- Sometimes, functions that return an int use zero to indicate
-- success and negative one to indicate failure without including
-- additional information in the value.
errorsFromInt_ :: CInt -> IO (Either Errno ())
{-# INLINE errorsFromInt_ #-}
errorsFromInt_ :: CInt -> IO (Either Errno ())
errorsFromInt_ CInt
r =
  if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
    then Either Errno () -> IO (Either Errno ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either Errno ()
forall a b. b -> Either a b
Right ())
    else (Errno -> Either Errno ()) -> IO Errno -> IO (Either Errno ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Errno -> Either Errno ()
forall a b. a -> Either a b
Left IO Errno
getErrno