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.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. diff --git a/cbits/HaskellPosix.c b/cbits/HaskellPosix.c --- a/cbits/HaskellPosix.c +++ b/cbits/HaskellPosix.c @@ -1,9 +1,12 @@ #define _GNU_SOURCE #include -#include -#include #include #include +#include +#include +#include +#include +#include #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); } 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.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 diff --git a/src-assertions/Assertion.hs b/src-assertions/Assertion.hs --- a/src-assertions/Assertion.hs +++ b/src-assertions/Assertion.hs @@ -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" diff --git a/src-noassertions/Assertion.hs b/src-noassertions/Assertion.hs --- a/src-noassertions/Assertion.hs +++ b/src-noassertions/Assertion.hs @@ -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 diff --git a/src/Posix/File.hs b/src/Posix/File.hs new file mode 100644 --- /dev/null +++ b/src/Posix/File.hs @@ -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 diff --git a/src/Posix/File/Types.hsc b/src/Posix/File/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Posix/File/Types.hsc @@ -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 +#include +#include +#include + +-- | 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}