diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,15 @@ This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.3.5.0] - 2020-??-?? + +- Breaking: Start using pattern synonyms for macros. +- Add dedicated modules for peeking at structures. +- Make compatible with GHC 8.10 by changing the way ArrayArray# is handled + on the C side of the FFI. +- Add `uninterruptibleSetSocketOption`. +- Add socket options `SO_BINDTODEVICE` and `SO_REUSEADDR`. + ## [0.3.4.0] - 2020-03-09 - Add `Posix.File` diff --git a/cbits/HaskellPosix.c b/cbits/HaskellPosix.c --- a/cbits/HaskellPosix.c +++ b/cbits/HaskellPosix.c @@ -26,6 +26,21 @@ // way to support providing an offset (without just copying the bytes // into pinned memory) is to use a wrapper. +ssize_t write_offset_loop(int fd, const char *message, HsInt offset, size_t length){ + ssize_t r; + size_t bytesSent; + const char* buf = message + offset; + while(length > 0){ + if ((r = write(fd, (const void*)buf, length)) == -1) { + return (-1); + } else { + bytesSent = (size_t)r; + buf = buf + bytesSent; + length = length - bytesSent; + } + } + return 0; +} ssize_t write_offset(int fd, const char *message, HsInt offset, size_t length){ return write(fd, (const void*)(message + offset), length); } @@ -105,16 +120,24 @@ return setsockopt(socket,level,option_name,&option_value,sizeof(int)); } +// There are some compatibility macros in here. Before GHC 8.10, +// no offset is applied to ArrayArray#. ssize_t sendmsg_bytearrays ( int sockfd +#if __GLASGOW_HASKELL__ >= 810 + , StgArrBytes **arrs // used for input +#else , StgMutArrPtrs *arr // used for input +#endif , HsInt off // offset into input chunk array , HsInt len0 // number of chunks to send , HsInt offC // offset into first chunk , int flags ) { +#if __GLASGOW_HASKELL__ < 810 StgClosure **arrPayload = arr->payload; StgArrBytes **arrs = (StgArrBytes**)arrPayload; +#endif struct iovec bufs[MAX_BYTEARRAYS]; HsInt len1 = len0 > MAX_BYTEARRAYS ? MAX_BYTEARRAYS : len0; // We must handle the first chunk specially since @@ -194,16 +217,24 @@ return sendmsg(sockfd,&msg,flags); } +// There are some compatibility macros in here. Before GHC 8.10, +// no offset is applied to ArrayArray#. int recvmmsg_sockaddr_in ( int sockfd , int *lens // used for output , struct sockaddr_in *addrs // used for output +#if __GLASGOW_HASKELL__ >= 810 + , StgArrBytes **bufs // used for output +#else , StgMutArrPtrs *arr // used for output +#endif , unsigned int vlen , int flags ) { +#if __GLASGOW_HASKELL__ < 810 StgClosure **bufsX = arr->payload; StgArrBytes **bufs = (StgArrBytes**)bufsX; +#endif // TODO: It's probably better to statically pick // out a maximum size for these. On the C stack, // the cost of doing this is basically nothing. @@ -238,12 +269,18 @@ int recvmmsg_sockaddr_discard ( int sockfd , int *lens // used for output +#if __GLASGOW_HASKELL__ >= 810 + , StgArrBytes **bufs // used for output +#else , StgMutArrPtrs *arr // used for output +#endif , unsigned int vlen , int flags ) { +#if __GLASGOW_HASKELL__ < 810 StgClosure **bufsX = arr->payload; StgArrBytes **bufs = (StgArrBytes**)bufsX; +#endif struct mmsghdr msgs[vlen]; struct iovec vecs[vlen]; for(unsigned int i = 0; i < vlen; i++) { diff --git a/include/HaskellPosix.h b/include/HaskellPosix.h --- a/include/HaskellPosix.h +++ b/include/HaskellPosix.h @@ -12,6 +12,21 @@ int setsockopt_int(int socket, int level, int option_name, int option_value); -int recvmmsg_sockaddr_in (int sockfd , int *lens , struct sockaddr_in *addrs , StgMutArrPtrs *arr , unsigned int vlen , int flags); -int recvmmsg_sockaddr_discard (int sockfd , int *lens , StgMutArrPtrs *arr , unsigned int vlen , int flags); +// There are some compatibility macros in here. Before GHC 8.10, +// no offset is applied to ArrayArray#. +int recvmmsg_sockaddr_in (int sockfd , int *lens , struct sockaddr_in *addrs +#if __GLASGOW_HASKELL__ >= 810 + , StgArrBytes **bufs // used for output +#else + , StgMutArrPtrs *arr // used for output +#endif + , unsigned int vlen , int flags); + +int recvmmsg_sockaddr_discard (int sockfd , int *lens +#if __GLASGOW_HASKELL__ >= 810 + , StgArrBytes **bufs // used for output +#else + , StgMutArrPtrs *arr // used for output +#endif + , unsigned int vlen , int flags); 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.4.0 +version: 0.3.5.0 synopsis: posix bindings description: This library provides a very thin wrapper around POSIX APIs. It can be @@ -78,6 +78,7 @@ library exposed-modules: + Foreign.C.String.Managed Linux.Epoll Linux.MessageQueue Linux.Socket @@ -89,6 +90,8 @@ Posix.Select Posix.Socket Posix.Types + Posix.Struct.SocketAddressInternet.Peek + Posix.Struct.AddressInfo.Peek other-modules: Linux.Epoll.Types Linux.MessageQueue.Types @@ -101,11 +104,13 @@ Assertion build-depends: , base >=4.11.1 && <5 + , byte-order >= 0.1.2 && <0.2 , byteslice >= 0.1.3 && <0.3 , primitive >= 0.7 && <0.8 , primitive-addr >= 0.1 && <0.2 , primitive-offset >= 0.2 && <0.3 , primitive-unlifted >= 0.1 && <0.2 + , run-st >= 0.1.1 && <0.2 hs-source-dirs: src if flag(assertions) hs-source-dirs: src-assertions diff --git a/src/Foreign/C/String/Managed.hs b/src/Foreign/C/String/Managed.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/C/String/Managed.hs @@ -0,0 +1,138 @@ +{-# language BangPatterns #-} +{-# language DerivingStrategies #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language MagicHash #-} +{-# language MultiWayIf #-} +{-# language TypeApplications #-} +{-# language ScopedTypeVariables #-} +{-# language UnboxedTuples #-} + +module Foreign.C.String.Managed + ( ManagedCString(..) + , terminated + , terminatedU + , unterminated + , fromBytes + , fromLatinString + , pinnedFromBytes + , pin + , touch + , contents + ) where + +import Control.Monad.ST (ST) +import Control.Monad.ST.Run (runByteArrayST) +import Data.Bytes.Types (Bytes(Bytes)) +import Data.Char (ord) +import Data.Primitive (ByteArray(..),MutableByteArray) +import Data.Word (Word8) +import Foreign.C.String (CString) +import Foreign.Ptr (castPtr) +import GHC.Exts (Int(I#),Char(C#),ByteArray#,chr#,touch#) +import GHC.IO (IO(IO)) + +import qualified Data.Bytes as Bytes +import qualified Data.Primitive as PM +import qualified GHC.Exts as Exts + +-- | An unsliced byte sequence with @NUL@ as the final byte. +newtype ManagedCString = ManagedCString ByteArray + deriving newtype Eq + +instance Semigroup ManagedCString where + ManagedCString a <> ManagedCString b = ManagedCString $ runByteArrayST $ do + let lenA = PM.sizeofByteArray a + let lenB = PM.sizeofByteArray b + dst <- PM.newByteArray (lenA + lenB - 1) + PM.copyByteArray dst 0 a 0 (lenA - 1) + PM.copyByteArray dst (lenA - 1) b 0 lenB + PM.unsafeFreezeByteArray dst + +instance Monoid ManagedCString where + mempty = ManagedCString $ runByteArrayST $ do + dst <- PM.newByteArray 1 + PM.writeByteArray dst 0 (0 :: Word8) + PM.unsafeFreezeByteArray dst + +instance Exts.IsString ManagedCString where + fromString = fromLatinString + +instance Show ManagedCString where + showsPrec _ (ManagedCString arr) s0 = PM.foldrByteArray + ( \(w :: Word8) s -> + if | w == 0 -> s + | w < 32 -> '?' : s + | w > 126 -> '?' : s + | otherwise -> case fromIntegral @Word8 @Int w of + I# i -> C# (chr# i) : s + ) s0 arr + +terminatedU :: ManagedCString -> ByteArray +terminatedU (ManagedCString x) = x + +terminated :: ManagedCString -> Bytes +terminated (ManagedCString x) = Bytes.fromByteArray x + +unterminated :: ManagedCString -> Bytes +unterminated (ManagedCString x) = Bytes x 0 (PM.sizeofByteArray x - 1) + +-- | Copies the slice, appending a @NUL@ byte to the end. +fromBytes :: Bytes -> ManagedCString +fromBytes (Bytes arr off len) = ManagedCString $ runByteArrayST $ do + dst <- PM.newByteArray (len + 1) + PM.copyByteArray dst 0 arr off len + PM.writeByteArray dst len (0 :: Word8) + PM.unsafeFreezeByteArray dst + +-- | Copies the slice into pinned memory, appending a @NUL@ byte to the end. +pinnedFromBytes :: Bytes -> ManagedCString +pinnedFromBytes (Bytes arr off len) = ManagedCString $ runByteArrayST $ do + dst <- PM.newPinnedByteArray (len + 1) + PM.copyByteArray dst 0 arr off len + PM.writeByteArray dst len (0 :: Word8) + PM.unsafeFreezeByteArray dst + +pin :: ManagedCString -> ManagedCString +pin (ManagedCString x) = if PM.isByteArrayPinned x + then ManagedCString x + else ManagedCString $ runByteArrayST $ do + let len = PM.sizeofByteArray x + dst <- PM.newPinnedByteArray len + PM.copyByteArray dst 0 x 0 len + PM.unsafeFreezeByteArray dst + +touch :: ManagedCString -> IO () +touch (ManagedCString (ByteArray x)) = touchByteArray# x + +touchByteArray# :: ByteArray# -> IO () +touchByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) + +-- | Convert a 'String' consisting of only characters representable +-- by ISO-8859-1. These are encoded with ISO-8859-1. Any character +-- with a codepoint above @U+00FF@ is replaced by an unspecified byte. +fromLatinString :: String -> ManagedCString +{-# noinline fromLatinString #-} +fromLatinString str = ManagedCString $ runByteArrayST $ do + let lenPred0 = 63 + dst0 <- PM.newByteArray (lenPred0 + 1) + go str dst0 0 lenPred0 + where + go :: forall s. String -> MutableByteArray s -> Int -> Int -> ST s ByteArray + go [] !dst !ix !_ = do + PM.writeByteArray dst ix (0 :: Word8) + PM.resizeMutableByteArray dst (ix + 1) >>= PM.unsafeFreezeByteArray + go (c:cs) !dst !ix !lenPred = if ix < lenPred + then do + PM.writeByteArray dst ix (fromIntegral @Int @Word8 (ord c)) + go cs dst (ix + 1) lenPred + else do + let nextLenPred = lenPred * 2 + dst' <- PM.newByteArray (nextLenPred + 1) + PM.copyMutableByteArray dst' 0 dst 0 ix + PM.writeByteArray dst' ix (fromIntegral @Int @Word8 (ord c)) + go cs dst' (ix + 1) nextLenPred + +-- | Get a pointer to the payload of the managed C string. The behavior is +-- undefined if the argument is not pinned. +contents :: ManagedCString -> CString +contents (ManagedCString x) = castPtr (PM.byteArrayContents x) diff --git a/src/Linux/Systemd.hs b/src/Linux/Systemd.hs --- a/src/Linux/Systemd.hs +++ b/src/Linux/Systemd.hs @@ -6,13 +6,13 @@ import Foreign.C.Types (CInt(..)) import System.Posix.Types (Fd(..)) import Foreign.C.Error (Errno,getErrno) -import Posix.Socket.Types (Type(..),Domain(..)) +import Posix.Socket.Types (Type(..),Family(..)) 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 + c_isSocket :: Fd -> Family -> Type -> CInt -> IO CInt -- | Check for file descriptors passed by the system manager. Returns -- the number of received file descriptors. If no file descriptors @@ -24,7 +24,7 @@ isSocket :: Fd -- ^ File descriptor - -> Domain -- ^ Socket family + -> Family -- ^ Socket family -> Type -- ^ Socket type -> CInt -- ^ Positive: require listen mode. Zero: require non-listening mode. -> IO (Either Errno CInt) diff --git a/src/Posix/File.hs b/src/Posix/File.hs --- a/src/Posix/File.hs +++ b/src/Posix/File.hs @@ -1,6 +1,7 @@ {-# language BangPatterns #-} {-# language BinaryLiterals #-} {-# language MagicHash #-} +{-# language TypeApplications #-} {-# language UnliftedFFITypes #-} module Posix.File @@ -8,8 +9,19 @@ uninterruptibleGetDescriptorFlags , uninterruptibleGetStatusFlags , uninterruptibleWriteByteArray + , uninterruptibleWriteBytes + , uninterruptibleWriteBytesCompletely + , uninterruptibleOpen + , uninterruptibleOpenMode , writeByteArray + , close + , uninterruptibleClose + , uninterruptibleErrorlessClose + , uninterruptibleUnlink + , uninterruptibleLink -- * Types + , AccessMode(..) + , CreationFlags(..) , DescriptorFlags(..) , StatusFlags(..) -- * File Descriptor Flags @@ -18,16 +30,27 @@ , isReadOnly , isWriteOnly , isReadWrite + -- * Open Access Mode + , Types.readOnly + , Types.writeOnly + , Types.readWrite + -- * File Creation Flags + , Types.create + , Types.truncate + , Types.exclusive ) where import Assertion (assertByteArrayPinned) -import Data.Bits ((.&.)) -import Posix.File.Types (DescriptorFlags(..),StatusFlags(..)) -import System.Posix.Types (Fd(..),CSsize(..)) +import Data.Bits ((.&.),(.|.)) +import Data.Primitive (ByteArray(..)) import Foreign.C.Error (Errno,getErrno) +import Foreign.C.String.Managed (ManagedCString(..)) import Foreign.C.Types (CInt(..),CSize(..)) -import Data.Primitive (ByteArray(..)) import GHC.Exts (ByteArray#) +import Posix.File.Types (CreationFlags(..),AccessMode(..),StatusFlags(..)) +import Posix.File.Types (DescriptorFlags(..)) +import System.Posix.Types (Fd(..),CSsize(..),CMode(..)) +import Data.Bytes.Types (Bytes(Bytes)) import qualified Posix.File.Types as Types @@ -50,9 +73,49 @@ foreign import ccall unsafe "HaskellPosix.h write_offset" c_unsafe_bytearray_write :: Fd -> ByteArray# -> Int -> CSize -> IO CSsize +foreign import ccall unsafe "HaskellPosix.h write_offset_loop" + c_unsafe_bytearray_write_loop :: Fd -> ByteArray# -> Int -> CSize -> IO CInt + foreign import ccall safe "HaskellPosix.h write_offset" c_safe_bytearray_write :: Fd -> ByteArray# -> Int -> CSize -> IO CSsize +foreign import ccall unsafe "HaskellPosix.h open" + c_unsafe_open :: ByteArray# -> CInt -> IO Fd + +foreign import ccall unsafe "HaskellPosix.h open" + c_unsafe_open_mode :: ByteArray# -> CInt -> CMode -> IO Fd + +foreign import ccall unsafe "HaskellPosix.h unlink" + c_unsafe_unlink :: ByteArray# -> IO CInt + +foreign import ccall unsafe "HaskellPosix.h link" + c_unsafe_link :: ByteArray# -> ByteArray# -> IO CInt + +foreign import ccall safe "unistd.h close" + c_safe_close :: Fd -> IO CInt + +foreign import ccall unsafe "unistd.h close" + c_unsafe_close :: Fd -> IO CInt + +uninterruptibleOpen :: + ManagedCString -- ^ NULL-terminated file name + -> AccessMode -- ^ Access mode + -> CreationFlags -- ^ Creation flags + -> StatusFlags -- ^ Status flags + -> IO (Either Errno Fd) +uninterruptibleOpen (ManagedCString (ByteArray name)) (AccessMode x) (CreationFlags y) (StatusFlags z) = + c_unsafe_open name (x .|. y .|. z) >>= errorsFromFd + +uninterruptibleOpenMode :: + ManagedCString -- ^ NULL-terminated file name + -> AccessMode -- ^ Access mode, should include @O_CREAT@ + -> CreationFlags -- ^ Creation flags + -> StatusFlags -- ^ Status flags + -> CMode -- ^ Permissions assigned to newly created file + -> IO (Either Errno Fd) +uninterruptibleOpenMode (ManagedCString (ByteArray name)) (AccessMode x) (CreationFlags y) (StatusFlags z) !mode = + c_unsafe_open_mode name (x .|. y .|. z) mode >>= errorsFromFd + errorsFromDescriptorFlags :: DescriptorFlags -> IO (Either Errno DescriptorFlags) errorsFromDescriptorFlags r@(DescriptorFlags x) = if x > (-1) then pure (Right r) @@ -63,6 +126,26 @@ then pure (Right r) else fmap Left getErrno +-- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. +-- The byte array backing the slice does not need to be pinned. +uninterruptibleWriteBytesCompletely :: + Fd -- ^ File descriptor + -> Bytes -- ^ Source bytes + -> IO (Either Errno ()) +uninterruptibleWriteBytesCompletely !fd (Bytes (ByteArray buf) off len) = + c_unsafe_bytearray_write_loop fd buf off (fromIntegral @Int @CSize len) + >>= errorsFromInt_ + +-- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. +-- The byte array backing the slice does not need to be pinned. +uninterruptibleWriteBytes :: + Fd -- ^ File descriptor + -> Bytes -- ^ Source bytes + -> IO (Either Errno CSize) -- ^ Number of bytes written +uninterruptibleWriteBytes !fd (Bytes (ByteArray buf) off len) = + c_unsafe_bytearray_write fd buf off (fromIntegral @Int @CSize len) + >>= errorsFromSize + -- | Wrapper for @write(2)@ that takes a byte array and an offset. -- The byte array does not need to be pinned. uninterruptibleWriteByteArray :: @@ -74,7 +157,8 @@ 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. +-- | 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 @@ -90,6 +174,57 @@ then pure (Right (cssizeToCSize r)) else fmap Left getErrno +errorsFromFd :: Fd -> IO (Either Errno Fd) +errorsFromFd r = if r > (-1) + then pure (Right r) + else fmap Left getErrno + +uninterruptibleLink :: + ManagedCString -- ^ Path to existing file + -> ManagedCString -- ^ Path to new file + -> IO (Either Errno ()) +uninterruptibleLink (ManagedCString (ByteArray x)) (ManagedCString (ByteArray y)) = + c_unsafe_link x y >>= errorsFromInt_ + +uninterruptibleUnlink :: + ManagedCString -- ^ File name + -> IO (Either Errno ()) +uninterruptibleUnlink (ManagedCString (ByteArray x)) = + c_unsafe_unlink x >>= errorsFromInt_ + +-- | Close a file descriptor. +-- The +-- includes more details. This uses the safe FFI. +close :: + Fd -- ^ Socket + -> IO (Either Errno ()) +close fd = c_safe_close fd >>= errorsFromInt_ + +-- | Close a file descriptor. This uses the unsafe FFI. According to the +-- , +-- "If @fildes@ refers to a socket, @close()@ shall cause the socket to +-- be destroyed. If the socket is in connection-mode, and the @SO_LINGER@ +-- option is set for the socket with non-zero linger time, and the socket +-- has untransmitted data, then @close()@ shall block for up to the current +-- linger interval until all data is transmitted." +uninterruptibleClose :: + Fd -- ^ Socket + -> IO (Either Errno ()) +uninterruptibleClose fd = c_unsafe_close fd >>= errorsFromInt_ + +-- | Close a file descriptor with the unsafe FFI. Do not check for errors. +-- It is only appropriate to use this when a file descriptor is being +-- closed to handle an exceptional case. Since the user will want to +-- propogate the original exception, the exception provided by +-- 'uninterruptibleClose' would just be discarded. This function allows us +-- to potentially avoid an additional FFI call to 'getErrno'. +uninterruptibleErrorlessClose :: + Fd -- ^ Socket + -> IO () +uninterruptibleErrorlessClose fd = do + _ <- c_unsafe_close fd + pure () + -- only call this when it is known that the argument is non-negative cssizeToCSize :: CSsize -> CSize cssizeToCSize = fromIntegral @@ -102,3 +237,12 @@ isReadWrite :: StatusFlags -> Bool isReadWrite (StatusFlags x) = x .&. 0b11 == 2 + +-- 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 + diff --git a/src/Posix/File/Types.hsc b/src/Posix/File/Types.hsc --- a/src/Posix/File/Types.hsc +++ b/src/Posix/File/Types.hsc @@ -22,11 +22,23 @@ module Posix.File.Types ( DescriptorFlags(..) , StatusFlags(..) + , CreationFlags(..) + , AccessMode(..) + -- * Open Access Mode + , readOnly + , writeOnly + , readWrite -- * File Status Flags , nonblocking , append + -- * File Creation Flags + , create + , truncate + , exclusive ) where +import Prelude hiding (truncate) + import Data.Bits (Bits,(.|.)) import Foreign.C.Types (CInt) @@ -40,12 +52,35 @@ deriving stock (Eq) deriving newtype (Bits) +-- | File Creation Flags +newtype CreationFlags = CreationFlags CInt + deriving stock (Eq) + deriving newtype (Bits) + +newtype AccessMode = AccessMode CInt + deriving stock (Eq) + instance Semigroup DescriptorFlags where (<>) = (.|.) instance Monoid DescriptorFlags where mempty = DescriptorFlags 0 +instance Semigroup CreationFlags where (<>) = (.|.) +instance Monoid CreationFlags where mempty = CreationFlags 0 + instance Semigroup StatusFlags where (<>) = (.|.) instance Monoid StatusFlags where mempty = StatusFlags 0 +-- | The @O_RDONLY@ access mode. +readOnly :: AccessMode +readOnly = AccessMode #{const O_RDONLY} + +-- | The @O_WRONLY@ access mode. +writeOnly :: AccessMode +writeOnly = AccessMode #{const O_WRONLY} + +-- | The @O_RDWR@ access mode. +readWrite :: AccessMode +readWrite = AccessMode #{const O_RDWR} + -- | The @O_NONBLOCK@ flag nonblocking :: StatusFlags nonblocking = StatusFlags #{const O_NONBLOCK} @@ -53,3 +88,15 @@ -- | The @O_APPEND@ flag append :: StatusFlags append = StatusFlags #{const O_APPEND} + +-- | The @O_CREAT@ flag +create :: CreationFlags +create = CreationFlags #{const O_CREAT} + +-- | The @O_TRUNC@ flag +truncate :: CreationFlags +truncate = CreationFlags #{const O_TRUNC} + +-- | The @O_EXCL@ flag +exclusive :: CreationFlags +exclusive = CreationFlags #{const O_EXCL} diff --git a/src/Posix/MessageQueue.hs b/src/Posix/MessageQueue.hs --- a/src/Posix/MessageQueue.hs +++ b/src/Posix/MessageQueue.hs @@ -7,18 +7,18 @@ , uninterruptibleReceiveByteArray , uninterruptibleSendBytes -- * Types - , OpenMode(..) - , OpenFlags(..) - -- * Bit Twiddle - , T.applyOpenFlags + , AccessMode(..) + , CreationFlags(..) + , StatusFlags(..) -- * Open Access Mode - , T.readOnly - , T.writeOnly - , T.readWrite + , F.readOnly + , F.writeOnly + , F.readWrite -- * Open Flags - , T.nonblocking + , F.nonblocking ) where +import Data.Bits ((.|.)) import GHC.Exts (RealWorld,ByteArray#,MutableByteArray#,Addr#) import GHC.Exts (Int(I#)) import System.Posix.Types (Fd(..),CSsize(..)) @@ -27,11 +27,11 @@ import Foreign.C.String (CString) import Data.Primitive (MutableByteArray(..),ByteArray(..)) import Data.Bytes.Types (Bytes(Bytes)) -import Posix.MessageQueue.Types (OpenMode(..),OpenFlags(..)) +import Posix.File.Types (CreationFlags(..),AccessMode(..),StatusFlags(..)) 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 +import qualified Posix.File.Types as F foreign import ccall unsafe "mqueue.h mq_receive" c_unsafe_mq_receive :: Fd -> MutableByteArray# RealWorld @@ -42,14 +42,16 @@ -> ByteArray# -> Int -> CSize -> CUInt -> IO CInt foreign import ccall safe "mqueue.h mq_open" - c_safe_mq_open :: CString -> OpenMode -> IO Fd + c_safe_mq_open :: CString -> CInt -> IO Fd open :: CString -- ^ NULL-terminated name of queue, must start with slash - -> OpenMode -- ^ Access mode and flags + -> AccessMode -- ^ Access mode + -> CreationFlags -- ^ Creation flags + -> StatusFlags -- ^ Status flags -> IO (Either Errno Fd) -open !name !mode = - c_safe_mq_open name mode >>= errorsFromFd +open !name (AccessMode x) (CreationFlags y) (StatusFlags z) = + c_safe_mq_open name (x .|. y .|. z) >>= errorsFromFd uninterruptibleReceiveByteArray :: Fd -- ^ Message queue diff --git a/src/Posix/MessageQueue/Types.hsc b/src/Posix/MessageQueue/Types.hsc --- a/src/Posix/MessageQueue/Types.hsc +++ b/src/Posix/MessageQueue/Types.hsc @@ -4,11 +4,6 @@ module Posix.MessageQueue.Types ( OpenMode(..) , OpenFlags(..) - , applyOpenFlags - -- * Open Access Mode - , readOnly - , writeOnly - , readWrite -- * Open Flags , nonblocking ) where @@ -24,22 +19,6 @@ 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) - diff --git a/src/Posix/Socket.hs b/src/Posix/Socket.hs --- a/src/Posix/Socket.hs +++ b/src/Posix/Socket.hs @@ -6,6 +6,7 @@ {-# language LambdaCase #-} {-# language MagicHash #-} {-# language NamedFieldPuns #-} +{-# language PatternSynonyms #-} {-# language ScopedTypeVariables #-} {-# language UnboxedTuples #-} {-# language UnliftedFFITypes #-} @@ -32,6 +33,9 @@ uninterruptibleSocket -- ** Socket Pair , uninterruptibleSocketPair + -- ** Address Resolution + , getAddressInfo + , uninterruptibleFreeAddressInfo -- ** Bind , uninterruptibleBind -- ** Connect @@ -48,11 +52,13 @@ -- ** Get Socket Option , uninterruptibleGetSocketOption -- ** Set Socket Option + , uninterruptibleSetSocketOption + , uninterruptibleSetSocketOptionByteArray , uninterruptibleSetSocketOptionInt -- ** Close - , close - , uninterruptibleClose - , uninterruptibleErrorlessClose + , F.close + , F.uninterruptibleClose + , F.uninterruptibleErrorlessClose -- ** Shutdown , uninterruptibleShutdown -- ** Send @@ -96,7 +102,7 @@ , networkToHostLong , networkToHostShort -- * Types - , Domain(..) + , Family(..) , Type(..) , Protocol(..) , OptionName(..) @@ -105,6 +111,7 @@ , Message(..) , MessageFlags(..) , ShutdownType(..) + , AddressInfo -- * Socket Address -- ** Types , SocketAddress(..) @@ -120,10 +127,10 @@ , PSP.sizeofSocketAddressInternet -- * Data Construction -- ** Socket Domains - , PST.unix - , PST.unspecified - , PST.internet - , PST.internet6 + , pattern PST.Unix + , pattern PST.Unspecified + , pattern PST.Internet + , pattern PST.Internet6 -- ** Socket Types , PST.stream , PST.datagram @@ -151,13 +158,28 @@ , PST.levelSocket -- ** Option Names , PST.optionError + , PST.bindToDevice , PST.broadcast + , PST.reuseAddress + -- ** Address Info + -- *** Peek + , PST.peekAddressInfoFlags + -- *** Poke + , PST.pokeAddressInfoFlags + -- *** Metadata + , PST.sizeofAddressInfo -- ** Message Header -- *** Peek , PST.peekMessageHeaderName , PST.peekMessageHeaderNameLength , PST.peekMessageHeaderIOVector , PST.peekMessageHeaderIOVectorLength + , PST.peekMessageHeaderControl + , PST.peekMessageHeaderControlLength + , PST.peekMessageHeaderFlags + , PST.peekControlMessageHeaderLevel + , PST.peekControlMessageHeaderLength + , PST.peekControlMessageHeaderType -- *** Poke , PST.pokeMessageHeaderName , PST.pokeMessageHeaderNameLength @@ -188,19 +210,22 @@ import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset(..)) import Data.Word (Word8,Word16,Word32,byteSwap16,byteSwap32) import Data.Void (Void) -import Foreign.C.Error (Errno,getErrno) +import Foreign.C.Error (Errno(Errno),getErrno) +import Foreign.C.String (CString) import Foreign.C.Types (CInt(..),CSize(..)) import Foreign.Ptr (nullPtr) import GHC.Exts (Ptr,RealWorld,ByteArray#,MutableByteArray#) import GHC.Exts (Addr#,TYPE,RuntimeRep(UnliftedRep)) import GHC.Exts (ArrayArray#,MutableArrayArray#,Int(I#)) import GHC.Exts (shrinkMutableByteArray#,touch#) -import Posix.Socket.Types (Domain(..),Protocol(..),Type(..),SocketAddress(..)) +import Posix.Socket.Types (Family(..),Protocol(..),Type(..),SocketAddress(..)) import Posix.Socket.Types (SocketAddressInternet(..)) import Posix.Socket.Types (MessageFlags(..),Message(..),ShutdownType(..)) import Posix.Socket.Types (Level(..),OptionName(..),OptionValue(..)) +import Posix.Socket.Types (AddressInfo) import System.Posix.Types (Fd(..),CSsize(..)) +import qualified Posix.File as F import qualified Posix.Socket.Types as PST import qualified Data.Primitive as PM import qualified Data.Primitive.Unlifted.Array as PM @@ -211,21 +236,28 @@ -- to serialize some of various kind of socket address types. import qualified Posix.Socket.Platform as PSP +-- getaddrinfo cannot use the unsafe ffi +foreign import ccall safe "sys/socket.h getaddrinfo" + c_safe_getaddrinfo :: + CString + -> CString + -> Ptr AddressInfo + -> MutableByteArray# RealWorld -- actually a `Ptr (Ptr AddressInfo))`. + -> IO Errno + +-- | Free the @addrinfo@ at the pointer. +foreign import ccall safe "sys/socket.h freeaddrinfo" + uninterruptibleFreeAddressInfo :: Ptr AddressInfo -> IO () + foreign import ccall unsafe "sys/socket.h socket" - c_socket :: Domain -> Type -> Protocol -> IO Fd + c_socket :: Family -> Type -> Protocol -> IO Fd foreign import ccall unsafe "sys/socket.h socketpair" - c_socketpair :: Domain -> Type -> Protocol -> MutableByteArray# RealWorld -> IO CInt + c_socketpair :: Family -> Type -> Protocol -> MutableByteArray# RealWorld -> IO CInt foreign import ccall unsafe "sys/socket.h listen" c_listen :: Fd -> CInt -> IO CInt -foreign import ccall safe "unistd.h close" - c_safe_close :: Fd -> IO CInt - -foreign import ccall unsafe "unistd.h close" - c_unsafe_close :: Fd -> IO CInt - foreign import ccall unsafe "unistd.h shutdown" c_unsafe_shutdown :: Fd -> ShutdownType -> IO CInt @@ -282,6 +314,22 @@ -> CInt -- option_value -> IO CInt +foreign import ccall unsafe "sys/socket.h setsockopt" + c_unsafe_setsockopt :: Fd + -> Level + -> OptionName + -> Ptr Void -- option_val + -> CInt -- option_len + -> IO CInt + +foreign import ccall unsafe "sys/socket.h setsockopt" + c_unsafe_setsockopt_ba :: Fd + -> Level + -> OptionName + -> ByteArray# -- option_val + -> CInt -- option_len + -> IO CInt + -- Per the spec the type signature of connect is: -- int connect(int sockfd, const struct sockaddr *addr, socklen_t addrlen); -- The bytearray argument is actually SocketAddress. @@ -391,7 +439,7 @@ -- this function. The author believes that it cannot block for a prolonged -- period of time. uninterruptibleSocket :: - Domain -- ^ Communications domain (e.g. 'internet', 'unix') + Family -- ^ Communications domain (e.g. 'internet', 'unix') -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags -> Protocol -- ^ Protocol -> IO (Either Errno Fd) @@ -404,7 +452,7 @@ -- this function. The author believes that it cannot block for a prolonged -- period of time. uninterruptibleSocketPair :: - Domain -- ^ Communications domain (probably 'unix') + Family -- ^ Communications domain (probably 'unix') -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags -> Protocol -- ^ Protocol -> IO (Either Errno (Fd,Fd)) @@ -420,6 +468,24 @@ pure (Right (fd1,fd2)) else fmap Left getErrno + +-- | Given node and service, which identify an Internet host and a service, +-- @getaddrinfo()@ returns one or more @addrinfo@ structures. The type of this +-- wrapper differs slightly from the type of its C counterpart. Remember to call +-- 'uninterruptibleFreeAddressInfo' when finished with the result. +getAddressInfo :: + CString -- ^ Node, identifies an Internet host + -> CString -- ^ Service + -> Ptr AddressInfo -- ^ Hints + -> IO (Either Errno (Ptr AddressInfo)) +getAddressInfo !node !service !hints = do + resBuf@(MutableByteArray resBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: Ptr ())) + c_safe_getaddrinfo node service hints resBuf# >>= \case + Errno 0 -> do + res <- PM.readByteArray resBuf 0 + pure (Right res) + e -> pure (Left e) + -- | Assign a local socket address address to a socket identified by -- descriptor socket that has no local socket address assigned. The -- @@ -614,6 +680,33 @@ uninterruptibleSetSocketOptionInt sock level optName optValue = c_unsafe_setsockopt_int sock level optName optValue >>= errorsFromInt_ +-- | Set the value for the option specified by the 'Option' argument for +-- the socket specified by the 'Fd' argument. The +-- +-- of @getsockopt@ includes more details. +uninterruptibleSetSocketOption :: + Fd -- ^ Socket + -> Level -- ^ Socket level + -> OptionName -- ^ Option name + -> Ptr Void -- ^ Option value + -> CInt -- ^ Option value length + -> IO (Either Errno ()) +uninterruptibleSetSocketOption sock level optName optValue optLen = + c_unsafe_setsockopt sock level optName optValue optLen >>= errorsFromInt_ + +-- | Variant of 'uninterruptibleSetSocketOption' that accepts the option +-- as a byte array instead of a pointer into unmanaged memory. The argument +-- does not need to be pinned. +uninterruptibleSetSocketOptionByteArray :: + Fd -- ^ Socket + -> Level -- ^ Socket level + -> OptionName -- ^ Option name + -> ByteArray -- ^ Option value + -> CInt -- ^ Option value length + -> IO (Either Errno ()) +uninterruptibleSetSocketOptionByteArray sock level optName (ByteArray optVal) optLen = + c_unsafe_setsockopt_ba sock level optName optVal optLen >>= errorsFromInt_ + -- | Send data from a byte array over a network socket. Users -- may specify an offset and a length to send fewer bytes than are -- actually present in the array. Since this uses the safe @@ -1140,38 +1233,6 @@ touchMutableByteArray msgHdrBuf touchMutableByteArray sockAddrBuf fmap Left getErrno - --- | Close a socket. The --- includes more details. This uses the safe FFI. -close :: - Fd -- ^ Socket - -> IO (Either Errno ()) -close fd = c_safe_close fd >>= errorsFromInt_ - --- | Close a socket. This uses the unsafe FFI. According to the --- , --- "If @fildes@ refers to a socket, @close()@ shall cause the socket to --- be destroyed. If the socket is in connection-mode, and the @SO_LINGER@ --- option is set for the socket with non-zero linger time, and the socket --- has untransmitted data, then @close()@ shall block for up to the current --- linger interval until all data is transmitted." -uninterruptibleClose :: - Fd -- ^ Socket - -> IO (Either Errno ()) -uninterruptibleClose fd = c_unsafe_close fd >>= errorsFromInt_ - --- | Close a socket with the unsafe FFI. Do not check for errors. It is only --- appropriate to use this when a socket is being closed to handle an --- exceptional case. Since the user will want the propogate the original --- exception, the exception provided by 'uninterruptibleClose' would just --- be discarded. This function allows us to potentially avoid an additional --- FFI call to 'getErrno'. -uninterruptibleErrorlessClose :: - Fd -- ^ Socket - -> IO () -uninterruptibleErrorlessClose fd = do - _ <- c_unsafe_close fd - pure () -- | Shutdown a socket. This uses the unsafe FFI. uninterruptibleShutdown :: diff --git a/src/Posix/Socket/Types.hsc b/src/Posix/Socket/Types.hsc --- a/src/Posix/Socket/Types.hsc +++ b/src/Posix/Socket/Types.hsc @@ -5,6 +5,7 @@ {-# language GeneralizedNewtypeDeriving #-} {-# language KindSignatures #-} {-# language MagicHash #-} +{-# language PatternSynonyms #-} {-# language UnboxedTuples #-} {-# language NamedFieldPuns #-} @@ -13,13 +14,14 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} #include +#include #include #include "custom.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.Socket.Types - ( Domain(..) + ( Family(..) , Type(..) , Protocol(..) , Level(..) @@ -32,11 +34,14 @@ , MessageFlags(..) , Message(..) , ShutdownType(..) + , AddressInfoFlags(..) + -- * Phantom Types + , AddressInfo -- * Socket Families - , unix - , unspecified - , internet - , internet6 + , pattern Unix + , pattern Unspecified + , pattern Internet + , pattern Internet6 -- * Socket Types , stream , datagram @@ -64,7 +69,25 @@ , levelSocket -- * Option Names , optionError + , bindToDevice , broadcast + , reuseAddress + -- * AddressInfo + -- ** Peek + , peekAddressInfoFlags + , peekAddressInfoFamily + , peekAddressInfoSocketType + , peekAddressInfoProtocol + , peekAddressInfoAddressLength + , peekAddressInfoAddress + , peekAddressInfoNext + -- ** Poke + , pokeAddressInfoFlags + , pokeAddressInfoFamily + , pokeAddressInfoSocketType + , pokeAddressInfoProtocol + -- ** Metadata + , sizeofAddressInfo -- * Message Header -- ** Peek , peekMessageHeaderName @@ -105,23 +128,43 @@ import Data.Primitive.Addr (Addr(..)) import Data.Word (Word16,Word32,Word64) import Foreign.C.Types (CInt(..),CSize) -import Foreign.Storable (peekByteOff,pokeByteOff) +import Foreign.Storable (Storable,peekByteOff,pokeByteOff) import GHC.Ptr (Ptr(..)) import GHC.Exts (Int(I##),Int##,(*##),(+##)) import qualified Data.Kind import qualified Data.Primitive as PM +-- | Phantom for pointers to @addrinfo@ in address resolution functions. +-- According to POSIX: +-- +-- > struct addrinfo { +-- > int ai_flags; +-- > int ai_family; +-- > int ai_socktype; +-- > int ai_protocol; +-- > socklen_t ai_addrlen; +-- > struct sockaddr *ai_addr; +-- > char *ai_canonname; +-- > struct addrinfo *ai_next; +-- > }; +data AddressInfo + -- | A socket communications domain, sometimes referred to as a family. The spec -- mandates @AF_UNIX@, @AF_UNSPEC@, and @AF_INET@. -newtype Domain = Domain CInt +newtype Family = Family CInt + deriving newtype (Storable) -- | A socket type. The spec mandates @SOCK_STREAM@, @SOCK_DGRAM@, -- and @SOCK_SEQPACKET@. Other types may be available on a per-platform -- basis. +-- +-- TODO: Change this to SocketType newtype Type = Type CInt + deriving newtype (Storable) newtype Protocol = Protocol { getProtocol :: CInt } + deriving newtype (Storable) newtype Level = Level CInt @@ -148,6 +191,13 @@ instance Semigroup (MessageFlags m) where (<>) = (.|.) instance Monoid (MessageFlags m) where mempty = MessageFlags 0 +newtype AddressInfoFlags = AddressInfoFlags CInt + deriving newtype (Eq,Storable) + +instance Semigroup AddressInfoFlags where + AddressInfoFlags x <> AddressInfoFlags y = AddressInfoFlags (x .|. y) +instance Monoid AddressInfoFlags where mempty = AddressInfoFlags 0 + -- | The @sockaddr@ data. This is an extensible tagged union, so this library -- has chosen to represent it as byte array. It is up to platform-specific -- libraries to inhabit this type with values. The byte array backing this @@ -258,24 +308,24 @@ sequencedPacket = Type #{const SOCK_SEQPACKET} -- | The @AF_UNIX@ communications domain. -unix :: Domain -unix = Domain #{const AF_UNIX} +pattern Unix :: Family +pattern Unix = Family #{const AF_UNIX} -- | The @AF_UNSPEC@ communications domain. -unspecified :: Domain -unspecified = Domain #{const AF_UNSPEC} +pattern Unspecified :: Family +pattern Unspecified = Family #{const AF_UNSPEC} -- | The @AF_INET@ communications domain. -internet :: Domain -internet = Domain #{const AF_INET} +pattern Internet :: Family +pattern Internet = Family #{const AF_INET} -- | The @AF_INET6@ communications domain. POSIX declares raw sockets -- optional. However, they are included here for convenience. Please -- open an issue if this prevents this library from compiling on a -- POSIX-compliant operating system that anyone uses for haskell -- development. -internet6 :: Domain -internet6 = Domain #{const AF_INET6} +pattern Internet6 :: Family +pattern Internet6 = Family #{const AF_INET6} -- | The @MSG_OOB@ receive flag or send flag. outOfBand :: MessageFlags m @@ -341,6 +391,14 @@ optionError :: OptionName optionError = OptionName #{const SO_ERROR} +-- | Bind to device (e.g. @SO_BINDTODEVICE@) +bindToDevice :: OptionName +bindToDevice = OptionName #{const SO_BINDTODEVICE} + +-- | Allow reuse of local address (e.g. @SO_REUSEADDR@) +reuseAddress :: OptionName +reuseAddress = OptionName #{const SO_REUSEADDR} + -- | Transmission of broadcast messages is supported (e.g. @SO_BROADCAST@) broadcast :: OptionName broadcast = OptionName #{const SO_BROADCAST} @@ -353,6 +411,7 @@ i <- #{peek struct cmsghdr, cmsg_level} (Ptr p) pure (Level i) +-- | Get @cmsg_type@. peekControlMessageHeaderType :: Addr -> IO Type peekControlMessageHeaderType (Addr p) = do i <- #{peek struct cmsghdr, cmsg_type} (Ptr p) @@ -363,17 +422,75 @@ -- advanceControlMessageHeaderData p = -- PM.plusAddr p (#{size struct cmsghdr}) +-- | Get @iov_base@. peekIOVectorBase :: Addr -> IO Addr peekIOVectorBase (Addr p) = do Ptr x <- #{peek struct iovec, iov_base} (Ptr p) pure (Addr x) +-- | Get @iov_len@. peekIOVectorLength :: Addr -> IO CSize peekIOVectorLength (Addr p) = #{peek struct iovec, iov_len} (Ptr p) -- | The size of a serialized @msghdr@. sizeofMessageHeader :: CInt sizeofMessageHeader = #{size struct msghdr} + +-- | Get @ai_flags@. +peekAddressInfoFlags :: Ptr AddressInfo -> IO AddressInfoFlags +peekAddressInfoFlags ptr = do + x <- #{peek struct addrinfo, ai_flags} ptr + pure (AddressInfoFlags x) + +-- | Set @ai_flags@. +pokeAddressInfoFlags :: Ptr AddressInfo -> AddressInfoFlags -> IO () +pokeAddressInfoFlags ptr (AddressInfoFlags x) = #{poke struct addrinfo, ai_flags} ptr x + +-- | Get @ai_family@. +peekAddressInfoFamily :: Ptr AddressInfo -> IO Family +peekAddressInfoFamily ptr = do + x <- #{peek struct addrinfo, ai_family} ptr + pure (Family x) + +-- | Get @ai_socktype@. +peekAddressInfoSocketType :: Ptr AddressInfo -> IO Type +peekAddressInfoSocketType ptr = do + x <- #{peek struct addrinfo, ai_socktype} ptr + pure (Type x) + +-- | Get @ai_protocol@. +peekAddressInfoProtocol :: Ptr AddressInfo -> IO Protocol +peekAddressInfoProtocol ptr = do + x <- #{peek struct addrinfo, ai_protocol} ptr + pure (Protocol x) + +-- | Get @ai_addrlen@. +peekAddressInfoAddressLength :: Ptr AddressInfo -> IO CInt +peekAddressInfoAddressLength ptr = #{peek struct addrinfo, ai_addrlen} ptr + +-- | Get @ai_addr@. +peekAddressInfoAddress :: Ptr AddressInfo -> IO (Ptr SocketAddress) +peekAddressInfoAddress ptr = #{peek struct addrinfo, ai_addr} ptr + +-- | Get @ai_next@. +peekAddressInfoNext :: Ptr AddressInfo -> IO (Ptr AddressInfo) +peekAddressInfoNext ptr = #{peek struct addrinfo, ai_next} ptr + +-- | Set @ai_family@. +pokeAddressInfoFamily :: Ptr AddressInfo -> Family -> IO () +pokeAddressInfoFamily ptr (Family x) = #{poke struct addrinfo, ai_family} ptr x + +-- | Set @ai_socktype@. +pokeAddressInfoSocketType :: Ptr AddressInfo -> Type -> IO () +pokeAddressInfoSocketType ptr (Type x) = #{poke struct addrinfo, ai_socktype} ptr x + +-- | Set @ai_protocol@. +pokeAddressInfoProtocol :: Ptr AddressInfo -> Protocol -> IO () +pokeAddressInfoProtocol ptr (Protocol x) = #{poke struct addrinfo, ai_protocol} ptr x + +-- | The size of a serialized @addrinfo@. +sizeofAddressInfo :: Int +sizeofAddressInfo = #{size struct addrinfo} -- | The size of a serialized @iovec@. sizeofIOVector :: CInt diff --git a/src/Posix/Struct/AddressInfo/Peek.hsc b/src/Posix/Struct/AddressInfo/Peek.hsc new file mode 100644 --- /dev/null +++ b/src/Posix/Struct/AddressInfo/Peek.hsc @@ -0,0 +1,60 @@ +#include +#include +#include + +{-# language DataKinds #-} + +-- | Accessors for reading from @struct addrinfo@: +-- +-- > struct addrinfo { +-- > int ai_flags; +-- > int ai_family; +-- > int ai_socktype; +-- > int ai_protocol; +-- > socklen_t ai_addrlen; +-- > struct sockaddr *ai_addr; +-- > char *ai_canonname; +-- > struct addrinfo *ai_next; +-- > }; +module Posix.Struct.AddressInfo.Peek + ( flags + , family + , socketType + , protocol + , addressLength + , address + , next + ) where + +import Posix.Socket.Types (AddressInfoFlags(..),SocketAddress,Family,Type,AddressInfo,Protocol) +import Foreign.C.Types (CInt) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peekByteOff) + +-- | Get @ai_flags@. +flags :: Ptr AddressInfo -> IO AddressInfoFlags +flags ptr = #{peek struct addrinfo, ai_flags} ptr + +-- | Get @ai_family@. +family :: Ptr AddressInfo -> IO Family +family ptr = #{peek struct addrinfo, ai_family} ptr + +-- | Get @ai_socktype@. +socketType :: Ptr AddressInfo -> IO Type +socketType ptr = #{peek struct addrinfo, ai_socktype} ptr + +-- | Get @ai_protocol@. +protocol :: Ptr AddressInfo -> IO Protocol +protocol ptr = #{peek struct addrinfo, ai_protocol} ptr + +-- | Get @ai_addrlen@. +addressLength :: Ptr AddressInfo -> IO CInt +addressLength ptr = #{peek struct addrinfo, ai_addrlen} ptr + +-- | Get @ai_addr@. +address :: Ptr AddressInfo -> IO (Ptr SocketAddress) +address ptr = #{peek struct addrinfo, ai_addr} ptr + +-- | Get @ai_next@. +next :: Ptr AddressInfo -> IO (Ptr AddressInfo) +next ptr = #{peek struct addrinfo, ai_next} ptr diff --git a/src/Posix/Struct/SocketAddressInternet/Peek.hsc b/src/Posix/Struct/SocketAddressInternet/Peek.hsc new file mode 100644 --- /dev/null +++ b/src/Posix/Struct/SocketAddressInternet/Peek.hsc @@ -0,0 +1,38 @@ +#include +#include +#include + +{-# language DataKinds #-} + +-- | Accessors for reading from @struct sockaddr_in@: +-- +-- > struct sockaddr_in { +-- > sa_family_t sin_family; /* address family: AF_INET */ +-- > in_port_t sin_port; /* port in network byte order */ +-- > struct in_addr sin_addr; /* internet address */ +-- > }; +module Posix.Struct.SocketAddressInternet.Peek + ( family + , port + , address + ) where + +import Posix.Socket.Types (SocketAddressInternet,Family) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peekByteOff) +import Data.Word (Word16,Word32) +import System.ByteOrder (Fixed,ByteOrder(BigEndian)) + +-- | Get @sin_family@. +family :: Ptr SocketAddressInternet -> IO Family +family = #{peek struct sockaddr_in, sin_family} + +-- | Get @in_port_t@. +port :: Ptr SocketAddressInternet -> IO (Fixed 'BigEndian Word16) +port = #{peek struct sockaddr_in, sin_port} + +-- | Get @sin_addr.saddr@. This works on Linux because @struct in_addr@ has +-- a single 32-bit field. I do not know how to perform this in a portable way +-- with hsc2hs. +address :: Ptr SocketAddressInternet -> IO (Fixed 'BigEndian Word32) +address = #{peek struct sockaddr_in, sin_addr} diff --git a/src/Posix/Types.hsc b/src/Posix/Types.hsc --- a/src/Posix/Types.hsc +++ b/src/Posix/Types.hsc @@ -11,8 +11,14 @@ import Foreign.Storable (Storable) import Data.Bits (FiniteBits,Bits) +#if MIN_VERSION_base(4,14,0) +import System.Posix.Types (CNfds(..)) +#endif #include +-- This is a compatibility shim for older GHCs +#if !MIN_VERSION_base(4,14,0) newtype CNfds = CNfds #{type nfds_t} deriving newtype (Eq,Real,Integral,Enum,Num,Ord,Storable,FiniteBits,Bits) +#endif