{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
module Posix.MessageQueue
( open
, uninterruptibleReceiveByteArray
, uninterruptibleSendBytes
, AccessMode (..)
, CreationFlags (..)
, StatusFlags (..)
, F.readOnly
, F.writeOnly
, F.readWrite
, 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 ::
CString ->
AccessMode ->
CreationFlags ->
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 ::
Fd ->
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 ::
Fd ->
Bytes ->
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
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