{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}

module Posix.MessageQueue
  ( open
  , uninterruptibleReceiveByteArray
  , uninterruptibleSendBytes

    -- * Types
  , AccessMode (..)
  , CreationFlags (..)
  , StatusFlags (..)

    -- * Open Access Mode
  , F.readOnly
  , F.writeOnly
  , F.readWrite

    -- * Open Flags
  , F.nonblocking
  ) where

import qualified Control.Monad.Primitive as PM
import Data.Bits ((.|.))
import Data.Bytes.Types (Bytes (Bytes))
import Data.Primitive (ByteArray (..), MutableByteArray (..))
import qualified Data.Primitive as PM
import Foreign.C.Error (Errno, getErrno)
import Foreign.C.String (CString)
import Foreign.C.Types (CInt (..), CSize (..), CUInt (..))
import GHC.Exts (Addr#, ByteArray#, Int (I#), MutableByteArray#, RealWorld)
import qualified GHC.Exts as Exts
import Posix.File.Types (AccessMode (..), CreationFlags (..), StatusFlags (..))
import qualified Posix.File.Types as F
import System.Posix.Types (CSsize (..), Fd (..))

foreign import ccall unsafe "mqueue.h mq_receive"
  c_unsafe_mq_receive ::
    Fd ->
    MutableByteArray# RealWorld ->
    CSize ->
    Addr# ->
    IO CSsize

foreign import ccall unsafe "mqueue.h mq_send_offset"
  c_unsafe_mq_send_offset ::
    Fd ->
    ByteArray# ->
    Int ->
    CSize ->
    CUInt ->
    IO CInt

foreign import ccall safe "mqueue.h mq_open"
  c_safe_mq_open :: CString -> CInt -> IO Fd

open ::
  -- | NULL-terminated name of queue, must start with slash
  CString ->
  -- | Access mode
  AccessMode ->
  -- | Creation flags
  CreationFlags ->
  -- | Status flags
  StatusFlags ->
  IO (Either Errno Fd)
open :: CString
-> AccessMode
-> CreationFlags
-> StatusFlags
-> IO (Either Errno Fd)
open !CString
name (AccessMode CInt
x) (CreationFlags CInt
y) (StatusFlags CInt
z) =
  CString -> CInt -> IO Fd
c_safe_mq_open CString
name (CInt
x CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
y CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
z) 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

uninterruptibleReceiveByteArray ::
  -- | Message queue
  Fd ->
  -- | Maximum length of message
  CSize ->
  IO (Either Errno ByteArray)
uninterruptibleReceiveByteArray :: Fd -> CSize -> IO (Either Errno ByteArray)
uninterruptibleReceiveByteArray !Fd
fd !CSize
len = do
  m :: MutableByteArray RealWorld
m@(MutableByteArray MutableByteArray# RealWorld
m#) <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PM.newByteArray (CSize -> Int
csizeToInt CSize
len)
  CSsize
r <- Fd -> MutableByteArray# RealWorld -> CSize -> Addr# -> IO CSsize
c_unsafe_mq_receive Fd
fd MutableByteArray# RealWorld
m# CSize
len Addr#
Exts.nullAddr#
  case CSsize
r of
    (-1) -> (Errno -> Either Errno ByteArray)
-> IO Errno -> IO (Either Errno ByteArray)
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 ByteArray
forall a b. a -> Either a b
Left IO Errno
getErrno
    CSsize
_ -> do
      let sz :: Int
sz = CSsize -> Int
cssizeToInt CSsize
r
      MutableByteArray RealWorld -> Int -> IO ()
shrinkMutableByteArray MutableByteArray RealWorld
m Int
sz
      ByteArray
a <- MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
PM.unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
m
      Either Errno ByteArray -> IO (Either Errno ByteArray)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteArray -> Either Errno ByteArray
forall a b. b -> Either a b
Right ByteArray
a)

uninterruptibleSendBytes ::
  -- | Message queue
  Fd ->
  -- | Message
  Bytes ->
  -- | Priority
  CUInt ->
  IO (Either Errno ())
uninterruptibleSendBytes :: Fd -> Bytes -> CUInt -> IO (Either Errno ())
uninterruptibleSendBytes !Fd
fd (Bytes (ByteArray ByteArray#
arr) Int
off Int
len) CUInt
pri =
  Fd -> ByteArray# -> Int -> CSize -> CUInt -> IO CInt
c_unsafe_mq_send_offset Fd
fd ByteArray#
arr Int
off (Int -> CSize
intToCSize Int
len) CUInt
pri
    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_

shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO ()
shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO ()
shrinkMutableByteArray (MutableByteArray MutableByteArray# RealWorld
arr) (I# Int#
sz) =
  (State# (PrimState IO) -> State# (PrimState IO)) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
PM.primitive_ (MutableByteArray# RealWorld
-> Int# -> State# RealWorld -> State# RealWorld
forall d. MutableByteArray# d -> Int# -> State# d -> State# d
Exts.shrinkMutableByteArray# MutableByteArray# RealWorld
arr Int#
sz)

cssizeToInt :: CSsize -> Int
cssizeToInt :: CSsize -> Int
cssizeToInt = CSsize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

csizeToInt :: CSize -> Int
csizeToInt :: CSize -> Int
csizeToInt = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

intToCSize :: Int -> CSize
intToCSize :: Int -> CSize
intToCSize = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- 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 ())
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

errorsFromFd :: Fd -> IO (Either Errno Fd)
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