{-# language BangPatterns #-}
{-# language MagicHash #-}
{-# language UnboxedTuples #-}
{-# 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 Data.Bits ((.|.))
import GHC.Exts (RealWorld,ByteArray#,MutableByteArray#,Addr#)
import GHC.Exts (Int(I#))
import System.Posix.Types (Fd(..),CSsize(..))
import Foreign.C.Types (CInt(..),CSize(..),CUInt(..))
import Foreign.C.Error (Errno,getErrno)
import Foreign.C.String (CString)
import Data.Primitive (MutableByteArray(..),ByteArray(..))
import Data.Bytes.Types (Bytes(Bytes))
import Posix.File.Types (CreationFlags(..),AccessMode(..),StatusFlags(..))
import qualified GHC.Exts as Exts
import qualified Data.Primitive as PM
import qualified Control.Monad.Primitive as PM
import qualified Posix.File.Types as F

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 -- ^ NULL-terminated name of queue, must start with slash
  -> AccessMode -- ^ Access mode
  -> CreationFlags -- ^ Creation flags
  -> StatusFlags -- ^ Status flags
  -> 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 forall a. Bits a => a -> a -> a
.|. CInt
y forall a. Bits a => a -> a -> a
.|. CInt
z) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Fd -> IO (Either Errno Fd)
errorsFromFd

uninterruptibleReceiveByteArray ::
     Fd -- ^ Message queue
  -> CSize -- ^ Maximum length of message
  -> 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# ) <- 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) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 <- forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
PM.unsafeFreezeByteArray MutableByteArray RealWorld
m
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ByteArray
a)

uninterruptibleSendBytes ::
     Fd -- ^ Message queue
  -> Bytes -- ^ Message
  -> CUInt -- ^ Priority
  -> 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
    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) =
  forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
PM.primitive_ (forall d. MutableByteArray# d -> Int# -> State# d -> State# d
Exts.shrinkMutableByteArray# MutableByteArray# RealWorld
arr Int#
sz)

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

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

intToCSize :: Int -> CSize
intToCSize :: Int -> CSize
intToCSize = 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 forall a. Eq a => a -> a -> Bool
== CInt
0
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ())
  else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 forall a. Ord a => a -> a -> Bool
> (-Fd
1)
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right Fd
r)
  else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left IO Errno
getErrno