posix-api 0.3.3.0 → 0.3.4.0

raw patch · 7 files changed

+196/−6 lines, 7 files

Files

• CHANGELOG.md +5/−0
• cbits/HaskellPosix.c +16/−2
• posix-api.cabal +4/−2
• src-assertions/Assertion.hs +7/−1
• src-noassertions/Assertion.hs +5/−1
• src/Posix/File.hs +104/−0
• src/Posix/File/Types.hsc +55/−0

@@ -7,6 +7,11 @@  This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.3.4.0] - 2020-03-09++- Add `Posix.File`+- Add lower bound for `hsc2hs` build tool+ ## [0.3.3.0] - 2019-12-18  - Support several POSIX message queue functions.

@@ -1,9 +1,12 @@ #define _GNU_SOURCE #include <mqueue.h>-#include <sys/socket.h>-#include <string.h> #include <netinet/in.h> #include <stdint.h>+#include <string.h>+#include <sys/socket.h>+#include <sys/stat.h>+#include <sys/types.h>+#include <unistd.h> #include "HaskellPosix.h" #include "Rts.h" @@ -23,6 +26,9 @@ // way to support providing an offset (without just copying the bytes // into pinned memory) is to use a wrapper. +ssize_t write_offset(int fd, const char *message, HsInt offset, size_t length){+  return write(fd, (const void*)(message + offset), length);+} ssize_t recv_offset(int socket, char *buffer, int offset, size_t length, int flags) {   return recv(socket, (void*)(buffer + offset), length, flags); }@@ -271,4 +277,12 @@  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);+}++int hs_get_fd_flags(int fd) {+  return fcntl(fd,F_GETFD);+}++int hs_get_fl_flags(int fd) {+  return fcntl(fd,F_GETFL); }

@@ -1,6 +1,6 @@ cabal-version: 2.2 name: posix-api-version: 0.3.3.0+version: 0.3.4.0 synopsis: posix bindings description:   This library provides a very thin wrapper around POSIX APIs. It can be@@ -83,6 +83,7 @@     Linux.Socket     Linux.Systemd     Posix.Directory+    Posix.File     Posix.MessageQueue     Posix.Poll     Posix.Select@@ -92,6 +93,7 @@     Linux.Epoll.Types     Linux.MessageQueue.Types     Linux.Socket.Types+    Posix.File.Types     Posix.MessageQueue.Types     Posix.Poll.Types     Posix.Socket.Platform@@ -117,7 +119,7 @@   include-dirs: include   includes: HaskellPosix.h   extra-libraries: systemd-  build-tool-depends: hsc2hs:hsc2hs+  build-tool-depends: hsc2hs:hsc2hs >= 0.68.5  test-suite test   type: exitcode-stdio-1.0

@@ -2,7 +2,8 @@ {-# language UnboxedTuples #-}  module Assertion-  ( assertMutablePrimArrayPinned+  ( assertByteArrayPinned+  , assertMutablePrimArrayPinned   ) where  import GHC.Exts (isTrue#)@@ -17,3 +18,8 @@  isMutablePrimArrayPinned :: PM.MutablePrimArray s a -> Bool isMutablePrimArrayPinned (PM.MutablePrimArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#)++assertByteArrayPinned :: PM.ByteArray -> PM.ByteArray+assertByteArrayPinned x = if PM.isByteArrayPinned x+  then x+  else error "assertByteArrayPinned"

@@ -1,8 +1,12 @@ module Assertion-  ( assertMutablePrimArrayPinned+  ( assertByteArrayPinned+  , assertMutablePrimArrayPinned   ) where  import qualified Data.Primitive as PM  assertMutablePrimArrayPinned :: PM.MutablePrimArray s a -> PM.MutablePrimArray s a assertMutablePrimArrayPinned = id++assertByteArrayPinned :: PM.ByteArray -> PM.ByteArray+assertByteArrayPinned = id

@@ -0,0 +1,104 @@+{-# language BangPatterns #-}+{-# language BinaryLiterals #-}+{-# language MagicHash #-}+{-# language UnliftedFFITypes #-}++module Posix.File+  ( -- * Functions+    uninterruptibleGetDescriptorFlags+  , uninterruptibleGetStatusFlags+  , uninterruptibleWriteByteArray+  , writeByteArray+    -- * Types+  , DescriptorFlags(..)+  , StatusFlags(..)+    -- * File Descriptor Flags+  , Types.nonblocking+  , Types.append+  , isReadOnly+  , isWriteOnly+  , isReadWrite+  ) where++import Assertion (assertByteArrayPinned)+import Data.Bits ((.&.))+import Posix.File.Types (DescriptorFlags(..),StatusFlags(..))+import System.Posix.Types (Fd(..),CSsize(..))+import Foreign.C.Error (Errno,getErrno)+import Foreign.C.Types (CInt(..),CSize(..))+import Data.Primitive (ByteArray(..))+import GHC.Exts (ByteArray#)++import qualified Posix.File.Types as Types++-- | Get file descriptor flags. This uses the unsafe FFI to+-- perform @fcntl(fd,F_GETFD)@.+uninterruptibleGetDescriptorFlags :: Fd -> IO (Either Errno DescriptorFlags)+uninterruptibleGetDescriptorFlags !fd = c_getFdFlags fd >>= errorsFromDescriptorFlags++-- | Get file status flags. This uses the unsafe FFI to+-- perform @fcntl(fd,F_GETFL)@.+uninterruptibleGetStatusFlags :: Fd -> IO (Either Errno StatusFlags)+uninterruptibleGetStatusFlags !fd = c_getFlFlags fd >>= errorsFromStatusFlags++foreign import ccall unsafe "HaskellPosix.h hs_get_fd_flags"+  c_getFdFlags :: Fd -> IO DescriptorFlags++foreign import ccall unsafe "HaskellPosix.h hs_get_fl_flags"+  c_getFlFlags :: Fd -> IO StatusFlags++foreign import ccall unsafe "HaskellPosix.h write_offset"+  c_unsafe_bytearray_write :: Fd -> ByteArray# -> Int -> CSize -> IO CSsize++foreign import ccall safe "HaskellPosix.h write_offset"+  c_safe_bytearray_write :: Fd -> ByteArray# -> Int -> CSize -> IO CSsize++errorsFromDescriptorFlags :: DescriptorFlags -> IO (Either Errno DescriptorFlags)+errorsFromDescriptorFlags r@(DescriptorFlags x) = if x > (-1)+  then pure (Right r)+  else fmap Left getErrno++errorsFromStatusFlags :: StatusFlags -> IO (Either Errno StatusFlags)+errorsFromStatusFlags r@(StatusFlags x) = if x > (-1)+  then pure (Right r)+  else fmap Left getErrno++-- | Wrapper for @write(2)@ that takes a byte array and an offset.+-- The byte array does not need to be pinned.+uninterruptibleWriteByteArray :: +     Fd -- ^ Socket+  -> ByteArray -- ^ Source byte array+  -> Int -- ^ Offset into source array+  -> CSize -- ^ Length in bytes+  -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer+uninterruptibleWriteByteArray !fd (ByteArray buf) !off !len =+  c_unsafe_bytearray_write fd buf off len >>= errorsFromSize++-- | Wrapper for @write(2)@ that takes a byte array and an offset. Uses @safe@ FFI. The byte array must be pinned.+writeByteArray :: +     Fd -- ^ Socket+  -> ByteArray -- ^ Source byte array+  -> Int -- ^ Offset into source array+  -> CSize -- ^ Length in bytes+  -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer+writeByteArray !fd !buf0 !off !len =+  let !(ByteArray buf1) = assertByteArrayPinned buf0+   in c_safe_bytearray_write fd buf1 off len >>= errorsFromSize++errorsFromSize :: CSsize -> IO (Either Errno CSize)+errorsFromSize r = if r > (-1)+  then pure (Right (cssizeToCSize r))+  else fmap Left getErrno++-- only call this when it is known that the argument is non-negative+cssizeToCSize :: CSsize -> CSize+cssizeToCSize = fromIntegral++isReadOnly :: StatusFlags -> Bool+isReadOnly (StatusFlags x) = x .&. 0b11 == 0++isWriteOnly :: StatusFlags -> Bool+isWriteOnly (StatusFlags x) = x .&. 0b11 == 1++isReadWrite :: StatusFlags -> Bool+isReadWrite (StatusFlags x) = x .&. 0b11 == 2

@@ -0,0 +1,55 @@+{-# language DataKinds #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language GADTSyntax #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language KindSignatures #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}+{-# language NamedFieldPuns #-}++-- This is needed because hsc2hs does not currently handle ticked+-- promoted data constructors correctly.+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}++#include <fcntl.h>+#include <unistd.h>+#include <sys/types.h>+#include <sys/stat.h>++-- | All of the data constructors provided by this module are unsafe.+--   Only use them if you really know what you are doing.+module Posix.File.Types+  ( DescriptorFlags(..)+  , StatusFlags(..)+    -- * File Status Flags+  , nonblocking+  , append+  ) where++import Data.Bits (Bits,(.|.))+import Foreign.C.Types (CInt)++-- | File Descriptor Flags+newtype DescriptorFlags = DescriptorFlags CInt+  deriving stock (Eq)+  deriving newtype (Bits)++-- | File Status Flags+newtype StatusFlags = StatusFlags CInt+  deriving stock (Eq)+  deriving newtype (Bits)++instance Semigroup DescriptorFlags where (<>) = (.|.)+instance Monoid DescriptorFlags where mempty = DescriptorFlags 0++instance Semigroup StatusFlags where (<>) = (.|.)+instance Monoid StatusFlags where mempty = StatusFlags 0++-- | The @O_NONBLOCK@ flag+nonblocking :: StatusFlags+nonblocking = StatusFlags #{const O_NONBLOCK}++-- | The @O_APPEND@ flag+append :: StatusFlags+append = StatusFlags #{const O_APPEND}