packages feed

posix-api 0.3.2.0 → 0.3.3.0

raw patch · 8 files changed

+224/−1 lines, 8 filesdep +byteslice

Dependencies added: byteslice

Files

CHANGELOG.md view
@@ -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.
cbits/HaskellPosix.c view
@@ -1,4 +1,5 @@ #define _GNU_SOURCE+#include <mqueue.h> #include <sys/socket.h> #include <string.h> #include <netinet/in.h>@@ -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);+}
posix-api.cabal view
@@ -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
+ src/Linux/MessageQueue.hs view
@@ -0,0 +1,5 @@+module Linux.MessageQueue+  ( module X+  ) where++import Linux.MessageQueue.Types as X
+ src/Linux/MessageQueue/Types.hsc view
@@ -0,0 +1,18 @@+{-# language DataKinds #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language BinaryLiterals #-}+{-# language TypeApplications #-}++#include <mqueue.h>+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}
+ src/Linux/Systemd.hs view
@@ -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
+ src/Posix/MessageQueue.hs view
@@ -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+
+ src/Posix/MessageQueue/Types.hsc view
@@ -0,0 +1,45 @@+#include <sys/types.h>+#include <sys/stat.h>+#include <fcntl.h>+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)+