diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,11 @@ This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.3.3.0] - 2019-12-18 + +- Support several POSIX message queue functions. +- Support Linux systemd functions. + ## [0.3.2.0] - 2019-07-21 - Add more functions. diff --git a/cbits/HaskellPosix.c b/cbits/HaskellPosix.c --- a/cbits/HaskellPosix.c +++ b/cbits/HaskellPosix.c @@ -1,4 +1,5 @@ #define _GNU_SOURCE +#include #include #include #include @@ -268,3 +269,6 @@ return r; } +ssize_t mq_send_offset(mqd_t mqdes, const char *msg, HsInt offset, size_t len, unsigned int prio){ + return mq_send(mqdes, msg + offset, len, prio); +} diff --git a/posix-api.cabal b/posix-api.cabal --- a/posix-api.cabal +++ b/posix-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: posix-api -version: 0.3.2.0 +version: 0.3.3.0 synopsis: posix bindings description: This library provides a very thin wrapper around POSIX APIs. It can be @@ -79,21 +79,27 @@ library exposed-modules: Linux.Epoll + Linux.MessageQueue Linux.Socket + Linux.Systemd Posix.Directory + Posix.MessageQueue Posix.Poll Posix.Select Posix.Socket Posix.Types other-modules: Linux.Epoll.Types + Linux.MessageQueue.Types Linux.Socket.Types + Posix.MessageQueue.Types Posix.Poll.Types Posix.Socket.Platform Posix.Socket.Types Assertion build-depends: , base >=4.11.1 && <5 + , byteslice >= 0.1.3 && <0.3 , primitive >= 0.7 && <0.8 , primitive-addr >= 0.1 && <0.2 , primitive-offset >= 0.2 && <0.3 @@ -110,6 +116,7 @@ c-sources: cbits/HaskellPosix.c include-dirs: include includes: HaskellPosix.h + extra-libraries: systemd build-tool-depends: hsc2hs:hsc2hs test-suite test diff --git a/src/Linux/MessageQueue.hs b/src/Linux/MessageQueue.hs new file mode 100644 --- /dev/null +++ b/src/Linux/MessageQueue.hs @@ -0,0 +1,5 @@ +module Linux.MessageQueue + ( module X + ) where + +import Linux.MessageQueue.Types as X diff --git a/src/Linux/MessageQueue/Types.hsc b/src/Linux/MessageQueue/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Linux/MessageQueue/Types.hsc @@ -0,0 +1,18 @@ +{-# language DataKinds #-} +{-# language DerivingStrategies #-} +{-# language DuplicateRecordFields #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language BinaryLiterals #-} +{-# language TypeApplications #-} + +#include +module Linux.MessageQueue.Types + ( -- * Open flags + closeOnExec + ) where + +import Posix.MessageQueue.Types (OpenFlags(..)) + +-- | The @O_CLOEXEC@ open flag. +closeOnExec :: OpenFlags +closeOnExec = OpenFlags #{const O_CLOEXEC} diff --git a/src/Linux/Systemd.hs b/src/Linux/Systemd.hs new file mode 100644 --- /dev/null +++ b/src/Linux/Systemd.hs @@ -0,0 +1,36 @@ +module Linux.Systemd + ( listenFds + , isSocket + ) where + +import Foreign.C.Types (CInt(..)) +import System.Posix.Types (Fd(..)) +import Foreign.C.Error (Errno,getErrno) +import Posix.Socket.Types (Type(..),Domain(..)) + +foreign import ccall unsafe "systemd/sd-daemon.h sd_listen_fds" + c_listenFds :: CInt -> IO CInt + +foreign import ccall unsafe "systemd/sd-daemon.h sd_is_socket" + c_isSocket :: Fd -> Domain -> Type -> CInt -> IO CInt + +-- | Check for file descriptors passed by the system manager. Returns +-- the number of received file descriptors. If no file descriptors +-- have been received, zero is returned. +listenFds :: + CInt -- ^ unset environment (non-zero unsets @LISTEN_FDS@, @LISTEN_PID@, and @LISTEN_FDNAMES@) + -> IO (Either Errno CInt) +listenFds a = c_listenFds a >>= errorsFromInt + +isSocket :: + Fd -- ^ File descriptor + -> Domain -- ^ Socket family + -> Type -- ^ Socket type + -> CInt -- ^ Positive: require listen mode. Zero: require non-listening mode. + -> IO (Either Errno CInt) +isSocket a b c d = c_isSocket a b c d >>= errorsFromInt + +errorsFromInt :: CInt -> IO (Either Errno CInt) +errorsFromInt r = if r >= 0 + then pure (Right r) + else fmap Left getErrno diff --git a/src/Posix/MessageQueue.hs b/src/Posix/MessageQueue.hs new file mode 100644 --- /dev/null +++ b/src/Posix/MessageQueue.hs @@ -0,0 +1,103 @@ +{-# language BangPatterns #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} +{-# language UnliftedFFITypes #-} +module Posix.MessageQueue + ( open + , uninterruptibleReceiveByteArray + , uninterruptibleSendBytes + -- * Types + , OpenMode(..) + , OpenFlags(..) + -- * Bit Twiddle + , T.applyOpenFlags + -- * Open Access Mode + , T.readOnly + , T.writeOnly + , T.readWrite + -- * Open Flags + , T.nonblocking + ) where + +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.MessageQueue.Types (OpenMode(..),OpenFlags(..)) +import qualified GHC.Exts as Exts +import qualified Data.Primitive as PM +import qualified Control.Monad.Primitive as PM +import qualified Posix.MessageQueue.Types as T + +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 -> OpenMode -> IO Fd + +open :: + CString -- ^ NULL-terminated name of queue, must start with slash + -> OpenMode -- ^ Access mode and flags + -> IO (Either Errno Fd) +open !name !mode = + c_safe_mq_open name mode >>= errorsFromFd + +uninterruptibleReceiveByteArray :: + Fd -- ^ Message queue + -> CSize -- ^ Maximum length of message + -> IO (Either Errno ByteArray) +uninterruptibleReceiveByteArray !fd !len = do + m@(MutableByteArray m# ) <- PM.newByteArray (csizeToInt len) + r <- c_unsafe_mq_receive fd m# len Exts.nullAddr# + case r of + (-1) -> fmap Left getErrno + _ -> do + let sz = cssizeToInt r + shrinkMutableByteArray m sz + a <- PM.unsafeFreezeByteArray m + pure (Right a) + +uninterruptibleSendBytes :: + Fd -- ^ Message queue + -> Bytes -- ^ Message + -> CUInt -- ^ Priority + -> IO (Either Errno ()) +uninterruptibleSendBytes !fd (Bytes (ByteArray arr) off len) pri = + c_unsafe_mq_send_offset fd arr off (intToCSize len) pri + >>= errorsFromInt_ + +shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () +shrinkMutableByteArray (MutableByteArray arr) (I# sz) = + PM.primitive_ (Exts.shrinkMutableByteArray# arr sz) + +cssizeToInt :: CSsize -> Int +cssizeToInt = fromIntegral + +csizeToInt :: CSize -> Int +csizeToInt = fromIntegral + +intToCSize :: Int -> CSize +intToCSize = 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_ r = if r == 0 + then pure (Right ()) + else fmap Left getErrno + +errorsFromFd :: Fd -> IO (Either Errno Fd) +errorsFromFd r = if r > (-1) + then pure (Right r) + else fmap Left getErrno + diff --git a/src/Posix/MessageQueue/Types.hsc b/src/Posix/MessageQueue/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Posix/MessageQueue/Types.hsc @@ -0,0 +1,45 @@ +#include +#include +#include +module Posix.MessageQueue.Types + ( OpenMode(..) + , OpenFlags(..) + , applyOpenFlags + -- * Open Access Mode + , readOnly + , writeOnly + , readWrite + -- * Open Flags + , nonblocking + ) where + +import Data.Bits ((.|.)) +import Foreign.C.Types (CInt(..)) + +newtype OpenMode = OpenMode CInt + +newtype OpenFlags = OpenFlags CInt + +instance Semigroup OpenFlags where + OpenFlags x <> OpenFlags y = OpenFlags (x .|. y) +instance Monoid OpenFlags where mempty = OpenFlags 0 + +-- | The @O_RDONLY@ access mode. +readOnly :: OpenMode +readOnly = OpenMode #{const O_RDONLY} + +-- | The @O_WRONLY@ access mode. +writeOnly :: OpenMode +writeOnly = OpenMode #{const O_WRONLY} + +-- | The @O_RDWR@ access mode. +readWrite :: OpenMode +readWrite = OpenMode #{const O_RDWR} + +-- | The @O_NONBLOCK@ open flag. +nonblocking :: OpenFlags +nonblocking = OpenFlags #{const O_NONBLOCK} + +applyOpenFlags :: OpenFlags -> OpenMode -> OpenMode +applyOpenFlags (OpenFlags s) (OpenMode t) = OpenMode (s .|. t) +