module System.Posix.MQueue (
WriteBuffer
, ReadBuffer
, Shared (..)
, putBuffer
, getBuffer
, putBufferList
, getAvailable
) where
import System.Posix.CircularBuffer (Shared (..))
import Control.Applicative
import Control.Monad
import Data.Bits
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Data.Int
import Data.Word
type MQD = Int32
data WriteBuffer a = WB String !MQD
data ReadBuffer a = RB String !MQD
foreign import ccall "mq_open"
c_mq_open_c :: CString -> CInt -> CInt -> Ptr () -> IO MQD
foreign import ccall "mq_open"
c_mq_open :: CString -> CInt -> IO MQD
foreign import ccall "mq_close"
c_mq_close :: MQD -> IO CInt
foreign import ccall "mq_unlink"
c_mq_unlink :: CString -> IO CInt
foreign import ccall "mq_send"
c_mq_send :: MQD -> Ptr () -> Word64 -> CInt -> IO CInt
foreign import ccall "mq_receive"
c_mq_receive :: MQD -> Ptr () -> Word64 -> Ptr CInt -> IO CInt
cREAT, eXCL, rONLY, wRONLY :: CInt
cREAT = 64
eXCL = 128
rONLY = 0
wRONLY = 1
mkAttr :: forall a b. Storable a => a -> Int -> (Ptr () -> IO b) -> IO b
mkAttr a sz f = allocaBytes (64) $ \attrP -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) attrP (0 :: Int64)
(\hsc_ptr -> pokeByteOff hsc_ptr 8) attrP sz
(\hsc_ptr -> pokeByteOff hsc_ptr 16) attrP (sizeOf a)
(\hsc_ptr -> pokeByteOff hsc_ptr 24) attrP (0 :: Int64)
f attrP
instance Storable a => Shared (WriteBuffer a) where
createBuffer name _ sz fmode = do
x <- withCString name $ \cName -> throwErrnoIfMinus1 "createBuffer: WriteBuffer" $ mkAttr (undefined :: a) sz $ c_mq_open_c cName (wRONLY .|. cREAT .|. eXCL) (fromIntegral fmode)
return $ WB name x
openBuffer name _ _ _fmode = do
WB name <$> withCString name (\cName -> c_mq_open cName wRONLY)
closeBuffer (WB _ mqd) = void $ throwErrnoIfMinus1 "closeBuffer: WriteBuffer" $ c_mq_close mqd
removeBuffer wb = closeBuffer wb >> unlinkBuffer wb
unlinkBuffer (WB name _) = void $ withCString name $ throwErrnoIfMinus1 "unlinkBuffer: WriteBuffer" . c_mq_unlink
instance Storable a => Shared (ReadBuffer a) where
createBuffer name _ sz fmode = do
x <- withCString name $ \cName -> throwErrnoIfMinus1 "createBuffer: ReadBuffer" $ mkAttr (undefined :: a) sz $ c_mq_open_c cName (rONLY .|. cREAT .|. eXCL) (fromIntegral fmode)
return $ RB name x
openBuffer name _ _ _fmode = do
RB name <$> withCString name (\cName -> c_mq_open cName rONLY)
closeBuffer (RB _ mqd) = void $ throwErrnoIfMinus1 "closeBuffer: ReadBuffer" $ c_mq_close mqd
removeBuffer wb = closeBuffer wb >> unlinkBuffer wb
unlinkBuffer (RB name _) = void $ withCString name $ throwErrnoIfMinus1 "unlinkBuffer: ReadBuffer" . c_mq_unlink
putBuffer :: Storable a => WriteBuffer a -> a -> IO ()
putBuffer (WB _ mqd) val = alloca $ \msgP -> do
poke msgP val
void $ throwErrnoIfMinus1 "putBuffer" $ c_mq_send mqd (castPtr msgP) (fromIntegral $ sizeOf val) 1
getBuffer :: forall a. Storable a => ReadBuffer a -> IO a
getBuffer (RB _ mqd) = alloca $ \msgP -> do
let sz = sizeOf (undefined :: a)
numBytes <- throwErrnoIfMinus1 "getBuffer" $ c_mq_receive mqd (castPtr msgP) (fromIntegral sz) nullPtr
when (numBytes /= fromIntegral sz) $ error "getBuffer: too few bytes"
peek msgP
putBufferList :: Storable a => WriteBuffer a -> [a] -> IO ()
putBufferList wb = mapM_ (putBuffer wb)
getAvailable :: Storable a => ReadBuffer a -> IO [a]
getAvailable (RB _ _) = error "getAvailable: not implemented"