diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ -# Revision history for posix +# Changelog +All notable changes to this project will be documented in this file. -## 0.1.0.0 -- YYYY-mm-dd +The format is inspired by [Keep a Changelog](http://keepachangelog.com/en/1.0.0/). +This changelog deviates from the recommendation by not grouping changes into +added, changed, deprecated, etc. subsections. -* First version. Released on an unsuspecting world. +This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [0.1.0.0] - 2018-01-02 +- Initial release. +- Includes a ton of sockets API stuff. +- Includes the get working directory function. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,60 @@ +# posix-api + +## Objective + +This library provides minimal bindings to system calls for POSIX-compliant +operating systems. All functions follow these design decisions: + +* `String` is not used anywhere. `ByteArray` (from `primitive`) is used for + serialized data. It is also used in certain filesystem function variants + used in contexts where the paths are only ever handed over to other + filesystem functions. `Addr` (from `primitive`) is used for pointers to + data whose type is unknown. `Ptr` is used for pointers to data whose type + is known. +* Functions should not throw errors. This library uses `IO (Either Errno a)` + in places where some libraries would use `IO a`. +* The numeric types from `Foreign.C.Types` and `System.Posix.Types` are + used in the type signatures of functions so that a haskell function's + type signature matches its underlying POSIX equivalent exactly. +* Flags are newtypes over `CInt` (or whatever integral type matches the + posix specification) rather than enumerations. The data constructors + are exported, making the types extensible for operating system that + have additional flags. +* There is some platform-specific code in this library. POSIX-specified data + structures do not have the same in-memory representation on all platforms. + Consequently, some of the code to serialize data to its C-struct + representation must be written differently on different platforms. + This is seldom needed. A viable alternative would be using the FFI + to perform this serialization. However, the approach of using + per-platform haskell code lets the serialization code inline better. + +Pull requests that add bindings to POSIX APIs in a way that agrees +with these guidelines will be accepted. Unfortunately, there is some +grey area when it comes to what a "minimal binding" to a function +is. Discussion may sometimes be necessary to refine the guidelines. + +## Build Instructions + +This library relies on a currently-unreleased version of `hsc2hs` in +order to build. In order to try out this library, try: + +``` +~/dev $ git clone https://github.com/haskell/hsc2hs +~/dev $ cd hsc2hs +~/dev/hsc2hs $ cabal install +~/dev/hsc2hs $ cd .. +~/dev $ git clone https://github.com/andrewthad/posix-api +~/dev $ cd posix-api +~/dev/posix-api $ cabal new-build --with-hsc2hs=~/.cabal/bin/hsc2hs +``` + +This will build `posix-api` with the unreleased version of the `hsc2hs` +tool. + +## Infelicities + +This project currently includes some Linux-specific code. It in the +the `Linux.Socket`. The plan is to eventually move the `Linux.Socket` module +into its own library. Currently, a ton of POSIX APIs are missing. +These should be included. + diff --git a/include/custom.h b/include/custom.h new file mode 100644 --- /dev/null +++ b/include/custom.h @@ -0,0 +1,87 @@ +#include + +// This include file lets us use hsc2hs to generate code working +// with ByteArray (through Data.Primitive) instead of Ptr. + +// The macro FIELD_SIZEOF is defined in the linux kernel. +// It is written out here for portability. +#define INTERNAL_FIELD_SIZEOF(t, f) (sizeof(((t*)0)->f)) + +// This is a lot like peek except that it is designed to +// work with MutableByteArray instead of Ptr. GHC requires that all +// indexing into ByteArrays is aligned. So, we do some trickery +// based on the size of what the user is requesting. +#define hsc_read(t, f) \ + switch (INTERNAL_FIELD_SIZEOF(t,f)) { \ + case 1: \ + hsc_printf ("(\\hsc_arr -> readByteArray hsc_arr %ld)", (long) offsetof (t, f)); \ + break; \ + case 2: \ + if (offsetof (t, f) % 2 == 0) \ + hsc_printf ("(\\hsc_arr -> readByteArray hsc_arr %ld)", ((long) offsetof (t, f)) / 2); \ + else \ + hsc_printf ("BAD_READ_ALIGNMENT"); \ + break; \ + default: \ + hsc_printf ("(BAD_READ_SIZE_%ld)", (long) INTERNAL_FIELD_SIZEOF(t,f)); \ + break; \ + } + +// This is like peek except that it is designed to work with ByteArray +// instead of Ptr. See hsc_read. This function becomes indexByteArray. +#define hsc_index(t, f) \ + switch (INTERNAL_FIELD_SIZEOF(t,f)) { \ + case 1: \ + hsc_printf ("(\\hsc_arr -> indexByteArray hsc_arr %ld)", (long) offsetof (t, f)); \ + break; \ + case 2: \ + if (offsetof (t, f) % 2 == 0) \ + hsc_printf ("(\\hsc_arr -> indexByteArray hsc_arr %ld)", ((long) offsetof (t, f)) / 2); \ + else \ + hsc_printf ("BAD_INDEX_ALIGNMENT"); \ + break; \ + case 4: \ + if (offsetof (t, f) % 4 == 0) \ + hsc_printf ("(\\hsc_arr -> indexByteArray hsc_arr %ld)", ((long) offsetof (t, f)) / 4); \ + else \ + hsc_printf ("BAD_INDEX_ALIGNMENT"); \ + break; \ + default: \ + hsc_printf ("(BAD_INDEX_SIZE_%ld)", (long) INTERNAL_FIELD_SIZEOF(t,f)); \ + break; \ + } + +// This is a lot like poke except that it is designed to +// work with MutableByteArray instead of Ptr. See hsc_read. +#define hsc_write(t, f) \ + switch (INTERNAL_FIELD_SIZEOF(t,f)) { \ + case 1: \ + hsc_printf ("(\\hsc_arr -> writeByteArray hsc_arr %ld)", (long) offsetof (t, f)); \ + break; \ + case 2: \ + if (offsetof (t, f) % 2 == 0) \ + hsc_printf ("(\\hsc_arr -> writeByteArray hsc_arr %ld)", ((long) offsetof (t, f)) / 2); \ + else \ + hsc_printf ("BAD_WRITE_ALIGNMENT"); \ + break; \ + case 4: \ + if (offsetof (t, f) % 4 == 0) \ + hsc_printf ("(\\hsc_arr -> writeByteArray hsc_arr %ld)", ((long) offsetof (t, f)) / 4); \ + else \ + hsc_printf ("BAD_WRITE_ALIGNMENT"); \ + break; \ + default: \ + hsc_printf ("(BAD_WRITE_SIZE_%ld)", (long) INTERNAL_FIELD_SIZEOF(t,f)); \ + break; \ + } + +// Compute an element offset from a byte offset and the element size. +// This causes a compile-time failure if the element size does not +// divide evenly into the byte offset. This is commonly used as: +#define hsc_elementize(boff, sz) \ + if ((boff) % (sz) == 0) { \ + hsc_printf ("%ld", ((boff) / (sz))); \ + } else { \ + hsc_printf ("BAD_ELEMENT_OFFSET"); \ + } + 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.1.0.0 +version: 0.2.0.0 synopsis: posix bindings description: This library provides a very thin wrapper around POSIX APIs. It can be @@ -65,9 +65,11 @@ category: System build-type: Simple extra-source-files: + README.md CHANGELOG.md cbits/HaskellPosix.c include/HaskellPosix.h + include/custom.h library exposed-modules: diff --git a/src-linux/Posix/Socket/Platform.hsc b/src-linux/Posix/Socket/Platform.hsc --- a/src-linux/Posix/Socket/Platform.hsc +++ b/src-linux/Posix/Socket/Platform.hsc @@ -12,6 +12,7 @@ #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. @@ -19,48 +20,64 @@ ( -- * Encoding Socket Addresses encodeSocketAddressInternet , encodeSocketAddressUnix + -- * Decoding Socket Addresses + , decodeSocketAddressInternet + -- * Sizes + , sizeofSocketAddressInternet ) where -import Data.Primitive (ByteArray(..),Addr(..)) -import Data.Void (Void) +import Control.Monad (when) +import Data.Primitive (ByteArray(..),writeByteArray,indexByteArray) import Data.Word (Word8) -import Foreign.C.Types (CUShort) -import Foreign.Storable (pokeByteOff) -import GHC.Exts (ByteArray##,State##,RealWorld,Ptr(..),runRW##,touch##) -import GHC.IO (IO(..)) -import Posix.Socket.Types (SocketAddressInternet(..),SocketAddressUnix(..)) +import Foreign.C.Types (CUShort,CInt) +import GHC.Exts (ByteArray##,State##,RealWorld,runRW##) +import GHC.ST (ST(..)) import Posix.Socket.Types (SocketAddress(..)) -import Control.Monad (when) +import Posix.Socket.Types (SocketAddressInternet(..),SocketAddressUnix(..)) import qualified Data.Primitive as PM import qualified Foreign.Storable as FS +-- | The size of a serialized internet socket address. +sizeofSocketAddressInternet :: CInt +sizeofSocketAddressInternet = #{size struct sockaddr_in} + -- | Serialize a IPv4 socket address so that it may be passed to @bind@. -- This serialization is operating-system dependent. encodeSocketAddressInternet :: SocketAddressInternet -> SocketAddress encodeSocketAddressInternet (SocketAddressInternet {port, address}) = - SocketAddress $ runByteArrayIO $ unboxByteArrayIO $ do - bs <- PM.newPinnedByteArray #{size struct sockaddr_in} + SocketAddress $ runByteArrayST $ unboxByteArrayST $ do + bs <- PM.newByteArray #{size struct sockaddr_in} -- Initialize the bytearray by filling it with zeroes to ensure -- that the sin_zero padding that linux expects is properly zeroed. PM.setByteArray bs 0 #{size struct sockaddr_in} (0 :: Word8) - let !(Addr addr) = PM.mutableByteArrayContents bs - let !(ptr :: Ptr Void) = Ptr addr -- ATM: I cannot find a way to poke AF_INET into the socket address -- without hardcoding the expected length (CUShort). There may be -- a way to use hsc2hs to convert a size to a haskell type, but -- I am not sure of how to do this. At any rate, I do not expect -- that linux will ever change the bit size of sa_family_t, so I -- am not too concerned. - #{poke struct sockaddr_in, sin_family} ptr (#{const AF_INET} :: CUShort) + #{write struct sockaddr_in, sin_family} bs (#{const AF_INET} :: CUShort) -- The port and the address are already supposed to be in network -- byte order in the SocketAddressInternet data type. - #{poke struct sockaddr_in, sin_port} ptr port - #{poke struct sockaddr_in, sin_addr.s_addr} ptr address + #{write struct sockaddr_in, sin_port} bs port + #{write struct sockaddr_in, sin_addr.s_addr} bs address r <- PM.unsafeFreezeByteArray bs - touchByteArray r pure r +decodeSocketAddressInternet :: SocketAddress -> Maybe SocketAddressInternet +decodeSocketAddressInternet (SocketAddress arr) = + if PM.sizeofByteArray arr == (#{size struct sockaddr_in}) + -- We assume that AF_INET takes up 16 bits. See the comment in + -- encodeSocketAddressInternet for more detail. + then if (#{index struct sockaddr_in, sin_family} arr) == (#{const AF_INET} :: CUShort) + then Just $ SocketAddressInternet + { port = #{index struct sockaddr_in, sin_port} arr + , address = #{index struct sockaddr_in, sin_addr.s_addr} arr + } + else Nothing + else Nothing + -- | Serialize a unix domain socket address so that it may be passed to @bind@. -- This serialization is operating-system dependent. If the path provided by -- the argument equals or exceeds the size of @sun_path@ (typically in the range 92 @@ -69,7 +86,7 @@ -- error code. encodeSocketAddressUnix :: SocketAddressUnix -> SocketAddress encodeSocketAddressUnix (SocketAddressUnix !name) = - SocketAddress $ runByteArrayIO $ unboxByteArrayIO $ do + SocketAddress $ runByteArrayST $ unboxByteArrayST $ do -- On linux, sun_path always has exactly 108 bytes. It is a null-terminated -- string, so we initialize the byte array to zeroes to ensure this -- happens. @@ -77,7 +94,7 @@ -- Again, we hard-code the size of sa_family_t as the size of -- an unsigned short. let familySize = FS.sizeOf (undefined :: CUShort) - bs <- PM.newPinnedByteArray (pathSize + familySize) + bs <- PM.newByteArray (pathSize + familySize) PM.setByteArray bs familySize pathSize (0 :: Word8) PM.writeByteArray bs 0 (#{const AF_UNIX} :: CUShort) let sz = PM.sizeofByteArray name @@ -85,18 +102,12 @@ PM.copyByteArray bs familySize name 0 sz PM.unsafeFreezeByteArray bs -touchByteArray :: ByteArray -> IO () -touchByteArray (ByteArray x) = touchByteArray## x - -touchByteArray## :: ByteArray## -> IO () -touchByteArray## x = IO $ \s -> case touch## x s of s' -> (## s', () ##) - -unboxByteArrayIO :: IO ByteArray -> State## RealWorld -> (## State## RealWorld, ByteArray## ##) -unboxByteArrayIO (IO f) s = case f s of +unboxByteArrayST :: ST s ByteArray -> State## s -> (## State## s, ByteArray## ##) +unboxByteArrayST (ST f) s = case f s of (## s', ByteArray b ##) -> (## s', b ##) --- In a general setting, this function is unsafe, but it is used kind of like --- runST in this module. -runByteArrayIO :: (State## RealWorld -> (## State## RealWorld, ByteArray## ##)) -> ByteArray -runByteArrayIO st_rep = case runRW## st_rep of (## _, a ##) -> ByteArray a +-- This is a specialization of runST that avoids a needless +-- data constructor allocation. +runByteArrayST :: (State## RealWorld -> (## State## RealWorld, ByteArray## ##)) -> ByteArray +runByteArrayST st_rep = case runRW## st_rep of (## _, a ##) -> ByteArray a diff --git a/src/Linux/Socket.hs b/src/Linux/Socket.hs --- a/src/Linux/Socket.hs +++ b/src/Linux/Socket.hs @@ -1,6 +1,35 @@ module Linux.Socket - ( -- * Flags - LST.dontWait + ( -- * Types + SocketFlags(..) + -- * Message Flags + , LST.dontWait + , LST.truncate + -- * Socket Flags + , LST.closeOnExec + , LST.nonblocking + -- * Twiddle + , applySocketFlags ) where +import Prelude hiding (truncate) + +import Data.Bits ((.|.)) +import Linux.Socket.Types (SocketFlags(..)) +import Posix.Socket (Type(..)) + import qualified Linux.Socket.Types as LST + +-- | Linux extends the @type@ argument of +-- to accept +-- flags. It is advisable to set @SOCK_CLOEXEC@ on when opening a socket +-- on linux. For example, we may open a TCP Internet socket with: +-- +-- > uninterruptibleSocket internet (applySocketFlags closeOnExec stream) defaultProtocol +-- +-- To additionally open the socket in nonblocking mode +-- (e.g. with @SOCK_NONBLOCK@): +-- +-- > uninterruptibleSocket internet (applySocketFlags (closeOnExec <> nonblocking) stream) defaultProtocol +-- +applySocketFlags :: SocketFlags -> Type -> Type +applySocketFlags (SocketFlags s) (Type t) = Type (s .|. t) diff --git a/src/Linux/Socket/Types.hsc b/src/Linux/Socket/Types.hsc --- a/src/Linux/Socket/Types.hsc +++ b/src/Linux/Socket/Types.hsc @@ -1,14 +1,44 @@ +{-# language DerivingStrategies #-} +{-# language GeneralizedNewtypeDeriving #-} + #include -- | All of the data constructors provided by this module are unsafe. -- Only use them if you really know what you are doing. module Linux.Socket.Types - ( dontWait + ( SocketFlags(..) + , dontWait + , truncate + , closeOnExec + , nonblocking ) where -import Posix.Socket (Flags(..)) +import Prelude hiding (truncate) +import Data.Bits (Bits((.|.))) +import Foreign.C.Types (CInt) +import Posix.Socket (MessageFlags(..)) + +newtype SocketFlags = SocketFlags CInt + deriving stock (Eq) + deriving newtype (Bits) + +instance Semigroup SocketFlags where (<>) = (.|.) +instance Monoid SocketFlags where mempty = SocketFlags 0 + -- | The @MSG_DONTWAIT@ receive flag or send flag. -dontWait :: Flags m -dontWait = Flags #{const MSG_DONTWAIT} +dontWait :: MessageFlags m +dontWait = MessageFlags #{const MSG_DONTWAIT} + +-- | The @MSG_TRUNC@ receive flag. +truncate :: MessageFlags m +truncate = MessageFlags #{const MSG_DONTWAIT} + +-- | The @SOCK_CLOEXEC@ receive flag or send flag. +closeOnExec :: SocketFlags +closeOnExec = SocketFlags #{const SOCK_CLOEXEC} + +-- | The @SOCK_NONBLOCK@ receive flag or send flag. +nonblocking :: SocketFlags +nonblocking = SocketFlags #{const SOCK_NONBLOCK} diff --git a/src/Posix/Socket.hs b/src/Posix/Socket.hs --- a/src/Posix/Socket.hs +++ b/src/Posix/Socket.hs @@ -1,6 +1,5 @@ {-# language BangPatterns #-} {-# language DataKinds #-} -{-# language InterruptibleFFI #-} {-# language MagicHash #-} {-# language ScopedTypeVariables #-} {-# language UnboxedTuples #-} @@ -18,47 +17,70 @@ -- buffer type. They all call @send@ or @recv@ exactly once. They do not -- repeatedly make syscalls like some of the functions in @network@. -- Users who want that behavior need to build on top of this package. +-- * There are no requirements on the pinnedness of @ByteArray@ arguments +-- passed to any of these functions. If wrappers of the safe FFI are +-- passed unpinned @ByteArray@ arguments, they will copy the contents +-- into pinned memory before invoking the foreign function. module Posix.Socket ( -- * Functions -- ** Socket - socket + uninterruptibleSocket -- ** Socket Pair - , socketPair + , uninterruptibleSocketPair -- ** Bind - , bind + , uninterruptibleBind -- ** Connect , connect + , uninterruptibleConnect -- ** Listen - , listen + , uninterruptibleListen -- ** Accept , accept + , uninterruptibleAccept , accept_ + -- ** Get Socket Name + , uninterruptibleGetSocketName + -- ** Get Socket Option + , uninterruptibleGetSocketOption -- ** Close , close - , unsafeClose + , uninterruptibleClose + , uninterruptibleErrorlessClose + -- ** Shutdown + , uninterruptibleShutdown -- ** Send , send , sendByteArray , sendMutableByteArray - , unsafeSend - , unsafeSendByteArray - , unsafeSendMutableByteArray + , uninterruptibleSend + , uninterruptibleSendByteArray + , uninterruptibleSendMutableByteArray -- ** Send To - , unsafeSendToByteArray - , unsafeSendToMutableByteArray + , uninterruptibleSendToByteArray + , uninterruptibleSendToMutableByteArray -- ** Receive , receive , receiveByteArray - , unsafeReceive - , unsafeReceiveMutableByteArray + , uninterruptibleReceive + , uninterruptibleReceiveMutableByteArray -- ** Receive From - , unsafeReceiveFromMutableByteArray - , unsafeReceiveFromMutableByteArray_ + , uninterruptibleReceiveFromMutableByteArray + , uninterruptibleReceiveFromMutableByteArray_ + -- ** Byte-Order Conversion + -- $conversion + , hostToNetworkLong + , hostToNetworkShort + , networkToHostLong + , networkToHostShort -- * Types , Domain(..) , Type(..) , Protocol(..) - , Flags(..) + , OptionName(..) + , OptionValue(..) + , Level(..) + , MessageFlags(..) + , ShutdownType(..) -- * Socket Address -- ** Types , SocketAddress(..) @@ -67,11 +89,16 @@ -- ** Encoding , PSP.encodeSocketAddressInternet , PSP.encodeSocketAddressUnix + -- ** Decoding + , PSP.decodeSocketAddressInternet + -- ** Sizes + , PSP.sizeofSocketAddressInternet -- * Data Construction -- ** Socket Domains , PST.unix , PST.unspecified , PST.internet + , PST.internet6 -- ** Socket Types , PST.stream , PST.datagram @@ -89,21 +116,34 @@ , PST.peek , PST.outOfBand , PST.waitAll + -- ** Shutdown Types + , PST.read + , PST.write + , PST.readWrite + -- ** Socket Levels + , PST.levelSocket + -- ** Option Names + , PST.optionError ) where +import GHC.ByteOrder (ByteOrder(BigEndian,LittleEndian),targetByteOrder) import GHC.IO (IO(..)) import Data.Primitive (MutablePrimArray(..),MutableByteArray(..),Addr(..),ByteArray(..)) +import Data.Word (Word16,Word32,byteSwap16,byteSwap32) import Data.Void (Void) import Foreign.C.Error (Errno,getErrno) import Foreign.C.Types (CInt(..),CSize(..)) import Foreign.Ptr (nullPtr) -import GHC.Exts (Ptr,RealWorld,ByteArray#,MutableByteArray#,Addr#) +import GHC.Exts (Ptr,RealWorld,ByteArray#,MutableByteArray#,Addr#,Int(I#)) +import GHC.Exts (shrinkMutableByteArray#) import Posix.Socket.Types (Domain(..),Protocol(..),Type(..),SocketAddress(..)) -import Posix.Socket.Types (Flags(..),Message(..)) +import Posix.Socket.Types (MessageFlags(..),Message(..),ShutdownType(..)) +import Posix.Socket.Types (Level(..),OptionName(..),OptionValue(..)) import System.Posix.Types (Fd(..),CSsize(..)) import qualified Posix.Socket.Types as PST import qualified Data.Primitive as PM +import qualified Control.Monad.Primitive as PM -- This module include operating-system specific code used -- to serialize some of various kind of socket address types. @@ -118,12 +158,15 @@ foreign import ccall unsafe "sys/socket.h listen" c_listen :: Fd -> CInt -> IO CInt -foreign import ccall interruptible "unistd.h close" +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 + -- Per the spec, the type signature of bind is: -- int bind(int socket, const struct sockaddr *address, socklen_t address_len); -- However, here we choose to represent the third argument as @@ -141,19 +184,44 @@ -- note on c_bind for why we use CInt for socklen_t. Remember that the -- first bytearray argument is actually SocketAddress in the function that -- wraps this one. The second bytearray argument is a pointer to the size. -foreign import ccall interruptible "sys/socket.h accept" +foreign import ccall safe "sys/socket.h accept" c_safe_accept :: Fd -> MutableByteArray# RealWorld -- SocketAddress -> MutableByteArray# RealWorld -- Ptr CInt -> IO Fd -foreign import ccall interruptible "sys/socket.h accept" +foreign import ccall unsafe "sys/socket.h accept" + c_unsafe_accept :: Fd + -> MutableByteArray# RealWorld -- SocketAddress + -> MutableByteArray# RealWorld -- Ptr CInt + -> IO Fd +-- This variant of accept is used when we do not care about the +-- remote sockaddr. We pass null. +foreign import ccall safe "sys/socket.h accept" c_safe_ptr_accept :: Fd -> Ptr Void -> Ptr CInt -> IO Fd +foreign import ccall unsafe "sys/socket.h getsockname" + c_unsafe_getsockname :: Fd + -> MutableByteArray# RealWorld -- SocketAddress + -> MutableByteArray# RealWorld -- Addr length (Ptr CInt) + -> IO CInt + +foreign import ccall unsafe "sys/socket.h getsockopt" + c_unsafe_getsockopt :: Fd + -> Level + -> OptionName + -> MutableByteArray# RealWorld -- Option value + -> MutableByteArray# RealWorld -- Option len (Ptr CInt) + -> 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. -foreign import ccall interruptible "sys/socket.h connect" +foreign import ccall safe "sys/socket.h connect" c_safe_connect :: Fd -> ByteArray# -> CInt -> IO CInt +foreign import ccall safe "sys/socket.h connect" + c_safe_mutablebytearray_connect :: Fd -> MutableByteArray# RealWorld -> CInt -> IO CInt +foreign import ccall unsafe "sys/socket.h connect" + c_unsafe_connect :: Fd -> ByteArray# -> CInt -> IO CInt -- There are several options for wrapping send. Both safe and unsafe -- are useful. Additionally, in the unsafe category, we also @@ -162,65 +230,67 @@ -- while the FFI call is taking place. Safe FFI calls do not have -- this guarantee, so internally we must be careful when using these to only -- provide pinned byte arrays as arguments. -foreign import ccall interruptible "sys/socket.h send" - c_safe_addr_send :: Fd -> Addr# -> CSize -> Flags 'Send -> IO CSsize -foreign import ccall interruptible "sys/socket.h send_offset" - c_safe_bytearray_send :: Fd -> ByteArray# -> CInt -> CSize -> Flags 'Send -> IO CSsize -foreign import ccall interruptible "sys/socket.h send_offset" - c_safe_mutablebytearray_send :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> Flags 'Send -> IO CSsize -foreign import ccall interruptible "sys/socket.h send" - c_safe_mutablebytearray_no_offset_send :: Fd -> MutableByteArray# RealWorld -> CSize -> Flags 'Send -> IO CSsize +foreign import ccall safe "sys/socket.h send" + c_safe_addr_send :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall safe "sys/socket.h send_offset" + c_safe_bytearray_send :: Fd -> ByteArray# -> CInt -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall safe "sys/socket.h send_offset" + c_safe_mutablebytearray_send :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall safe "sys/socket.h send" + c_safe_mutablebytearray_no_offset_send :: Fd -> MutableByteArray# RealWorld -> CSize -> MessageFlags 'Send -> IO CSsize foreign import ccall unsafe "sys/socket.h send" - c_unsafe_addr_send :: Fd -> Addr# -> CSize -> Flags 'Send -> IO CSsize + c_unsafe_addr_send :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize foreign import ccall unsafe "sys/socket.h send_offset" - c_unsafe_bytearray_send :: Fd -> ByteArray# -> CInt -> CSize -> Flags 'Send -> IO CSsize + c_unsafe_bytearray_send :: Fd -> ByteArray# -> CInt -> CSize -> MessageFlags 'Send -> IO CSsize foreign import ccall unsafe "sys/socket.h send_offset" - c_unsafe_mutable_bytearray_send :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> Flags 'Send -> IO CSsize + c_unsafe_mutable_bytearray_send :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> MessageFlags 'Send -> IO CSsize -- The ByteArray# (second to last argument) is a SocketAddress. foreign import ccall unsafe "sys/socket.h sendto_offset" - c_unsafe_bytearray_sendto :: Fd -> ByteArray# -> CInt -> CSize -> Flags 'Send -> ByteArray# -> CInt -> IO CSsize + c_unsafe_bytearray_sendto :: Fd -> ByteArray# -> CInt -> CSize -> MessageFlags 'Send -> ByteArray# -> CInt -> IO CSsize -- The ByteArray# (second to last argument) is a SocketAddress. foreign import ccall unsafe "sys/socket.h sendto_offset" - c_unsafe_mutable_bytearray_sendto :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> Flags 'Send -> ByteArray# -> CInt -> IO CSsize + c_unsafe_mutable_bytearray_sendto :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> MessageFlags 'Send -> ByteArray# -> CInt -> IO CSsize -- There are several ways to wrap recv. -foreign import ccall interruptible "sys/socket.h recv" - c_safe_addr_recv :: Fd -> Addr# -> CSize -> Flags 'Receive -> IO CSsize +foreign import ccall safe "sys/socket.h recv" + c_safe_addr_recv :: Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize foreign import ccall unsafe "sys/socket.h recv" - c_unsafe_addr_recv :: Fd -> Addr# -> CSize -> Flags 'Receive -> IO CSsize + c_unsafe_addr_recv :: Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize foreign import ccall unsafe "sys/socket.h recv_offset" - c_unsafe_mutable_byte_array_recv :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> Flags 'Receive -> IO CSsize + c_unsafe_mutable_byte_array_recv :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> MessageFlags 'Receive -> IO CSsize -- The last two arguments are SocketAddress and Ptr CInt. foreign import ccall unsafe "sys/socket.h recvfrom_offset" - c_unsafe_mutable_byte_array_recvfrom :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> Flags 'Receive -> MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> IO CSsize + c_unsafe_mutable_byte_array_recvfrom :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> MessageFlags 'Receive -> MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> IO CSsize foreign import ccall unsafe "sys/socket.h recvfrom_offset" - c_unsafe_mutable_byte_array_ptr_recvfrom :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> Flags 'Receive -> Ptr Void -> Ptr CInt -> IO CSsize + c_unsafe_mutable_byte_array_ptr_recvfrom :: Fd -> MutableByteArray# RealWorld -> CInt -> CSize -> MessageFlags 'Receive -> Ptr Void -> Ptr CInt -> IO CSsize -- | Create an endpoint for communication, returning a file -- descriptor that refers to that endpoint. The -- --- includes more details. This is implemented as an unsafe FFI --- call since the author believes that it cannot block indefinitely. -socket :: +-- includes more details. No special preparation is required before calling +-- this function. The author believes that it cannot block for a prolonged +-- period of time. +uninterruptibleSocket :: Domain -- ^ Communications domain (e.g. 'internet', 'unix') - -> Type -- ^ Socket type (e.g. 'datagram', 'stream') + -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags -> Protocol -- ^ Protocol -> IO (Either Errno Fd) -socket dom typ prot = c_socket dom typ prot >>= errorsFromFd +uninterruptibleSocket dom typ prot = c_socket dom typ prot >>= errorsFromFd -- | Create an unbound pair of connected sockets in a specified domain, of -- a specified type, under the protocol optionally specified by the protocol -- argument. The --- includes more details. This is implemented as an unsafe FFI call --- since the author believes that it cannot block indefinitely. -socketPair :: +-- includes more details. No special preparation is required before calling +-- this function. The author believes that it cannot block for a prolonged +-- period of time. +uninterruptibleSocketPair :: Domain -- ^ Communications domain (probably 'unix') - -> Type -- ^ Socket type (e.g. 'datagram', 'stream') + -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags -> Protocol -- ^ Protocol -> IO (Either Errno (Fd,Fd)) -socketPair dom typ prot = do +uninterruptibleSocketPair dom typ prot = do -- If this ever switches to the safe FFI, we will need to use -- a pinned array here instead. (sockets@(MutablePrimArray sockets#) :: MutablePrimArray RealWorld Fd) <- PM.newPrimArray 2 @@ -237,38 +307,55 @@ -- -- includes more details. The 'SocketAddress' represents the @sockaddr@ pointer argument, together -- with its @socklen_t@ size, as a byte array. This allows @bind@ to --- be used with @sockaddr@ extensions on various platforms. This uses --- the unsafe FFI since the author believes it cannot block indefinitely. -bind :: +-- be used with @sockaddr@ extensions on various platforms. No special +-- preparation is required before calling this function. The author +-- believes that it cannot block for a prolonged period of time. +uninterruptibleBind :: Fd -- ^ Socket -> SocketAddress -- ^ Socket address, extensible tagged union -> IO (Either Errno ()) -bind fd (SocketAddress b@(ByteArray b#)) = +uninterruptibleBind fd (SocketAddress b@(ByteArray b#)) = c_bind fd b# (intToCInt (PM.sizeofByteArray b)) >>= errorsFromInt -- | Mark the socket as a passive socket, that is, as a socket that -- will be used to accept incoming connection requests using @accept@. -- The --- includes more details. Listen uses the unsafe FFI since it cannot block --- and always returns promptly. -listen :: +-- includes more details. No special preparation is required before +-- calling this function. The author believes that it cannot block +-- for a prolonged period of time. +uninterruptibleListen :: Fd -- ^ Socket -> CInt -- ^ Backlog -> IO (Either Errno ()) -listen fd backlog = c_listen fd backlog >>= errorsFromInt +uninterruptibleListen fd backlog = c_listen fd backlog >>= errorsFromInt -- | Connect the socket to the specified socket address. -- The --- includes more details. An @unsafeConnect@ using the unsafe FFI is --- not provided since there is no way to hook such a beast into the --- event manager. +-- includes more details. connect :: Fd -- ^ Fd -> SocketAddress -- ^ Socket address, extensible tagged union -> IO (Either Errno ()) connect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = - c_safe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt + case PM.isByteArrayPinned sockAddr of + True -> c_safe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt + False -> do + let len = PM.sizeofByteArray sockAddr + x@(MutableByteArray x#) <- PM.newPinnedByteArray len + PM.copyByteArray x 0 sockAddr 0 len + c_safe_mutablebytearray_connect fd x# (intToCInt len) >>= errorsFromInt +-- | Connect the socket to the specified socket address. +-- The +-- includes more details. The only sensible way to use this is to +-- give a nonblocking socket as the argument. +uninterruptibleConnect :: + Fd -- ^ Fd + -> SocketAddress -- ^ Socket address, extensible tagged union + -> IO (Either Errno ()) +uninterruptibleConnect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = + c_unsafe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt + -- | Extract the first connection on the queue of pending connections. The -- -- includes more details. This function\'s type differs slightly from @@ -297,8 +384,8 @@ accept :: Fd -- ^ Listening socket -> CInt -- ^ Maximum socket address size - -> IO (Either Errno (SocketAddress,Fd)) -- ^ Peer information and connected socket -accept sock maxSz = do + -> IO (Either Errno (CInt,SocketAddress,Fd)) -- ^ Peer information and connected socket +accept !sock !maxSz = do sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newPinnedByteArray (cintToInt maxSz) lenBuf@(MutableByteArray lenBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: CInt)) PM.writeByteArray lenBuf 0 maxSz @@ -306,10 +393,38 @@ if r > (-1) then do (sz :: CInt) <- PM.readByteArray lenBuf 0 - sockAddr <- PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray sockAddrBuf (cintToInt sz) - pure (Right (SocketAddress sockAddr,r)) + -- Why copy when we could just shrink? We want to always return + -- byte arrays that are not explicitly pinned. + let minSz = min sz maxSz + x <- PM.newByteArray (cintToInt minSz) + PM.copyMutableByteArray x 0 sockAddrBuf 0 (cintToInt minSz) + sockAddr <- PM.unsafeFreezeByteArray x + -- sockAddr <- PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray sockAddrBuf (cintToInt sz) + pure (Right (sz,SocketAddress sockAddr,r)) else fmap Left getErrno +-- | See 'accept'. This uses the unsafe FFI. Consequently, it does not +-- not need to allocate pinned memory. It only makes sense to call this +-- on a nonblocking socket. +uninterruptibleAccept :: + Fd -- ^ Listening socket + -> CInt -- ^ Maximum socket address size + -> IO (Either Errno (CInt,SocketAddress,Fd)) -- ^ Peer information and connected socket +uninterruptibleAccept !sock !maxSz = do + sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) + PM.writeByteArray lenBuf 0 maxSz + r <- c_unsafe_accept sock sockAddrBuf# lenBuf# + if r > (-1) + then do + (sz :: CInt) <- PM.readByteArray lenBuf 0 + if sz < maxSz + then shrinkMutableByteArray sockAddrBuf (cintToInt sz) + else pure () + sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf + pure (Right (sz,SocketAddress sockAddr,r)) + else fmap Left getErrno + -- | A variant of 'accept' that does not provide the user with a -- 'SocketAddress' detailing the peer. accept_ :: @@ -318,9 +433,57 @@ accept_ sock = c_safe_ptr_accept sock nullPtr nullPtr >>= errorsFromFd +-- | Retrieve the locally-bound name of the specified socket. The +-- +-- of @getsockname@ includes more details. +uninterruptibleGetSocketName :: + Fd -- ^ Socket + -> CInt -- ^ Maximum socket address size + -> IO (Either Errno (CInt,SocketAddress)) +uninterruptibleGetSocketName sock maxSz = do + sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) + PM.writeByteArray lenBuf 0 maxSz + r <- c_unsafe_getsockname sock sockAddrBuf# lenBuf# + if r == 0 + then do + (sz :: CInt) <- PM.readByteArray lenBuf 0 + if sz < maxSz + then shrinkMutableByteArray sockAddrBuf (cintToInt sz) + else pure () + sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf + pure (Right (sz,SocketAddress sockAddr)) + else fmap Left getErrno + +-- | Retrieve the value for the option specified by the 'Option' argument for +-- the socket specified by the 'Fd' argument. The +-- +-- of @getsockopt@ includes more details. +uninterruptibleGetSocketOption :: + Fd -- ^ Socket + -> Level -- ^ Socket level + -> OptionName -- Option name + -> CInt -- ^ Maximum option value size + -> IO (Either Errno (CInt,OptionValue)) +uninterruptibleGetSocketOption sock level optName maxSz = do + valueBuf@(MutableByteArray valueBuf#) <- PM.newByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) + PM.writeByteArray lenBuf 0 maxSz + r <- c_unsafe_getsockopt sock level optName valueBuf# lenBuf# + if r == 0 + then do + (sz :: CInt) <- PM.readByteArray lenBuf 0 + if sz < maxSz + then shrinkMutableByteArray valueBuf (cintToInt sz) + else pure () + value <- PM.unsafeFreezeByteArray valueBuf + pure (Right (sz,OptionValue value)) + else fmap Left getErrno + + -- | 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 interruptible +-- actually present in the array. Since this uses the safe -- FFI, it allocates a pinned copy of the bytearry if it was not -- already pinned. sendByteArray :: @@ -328,7 +491,7 @@ -> ByteArray -- ^ Source byte array -> CInt -- ^ Offset into source array -> CSize -- ^ Length in bytes - -> Flags 'Send -- ^ Flags + -> MessageFlags 'Send -- ^ Flags -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer sendByteArray fd b@(ByteArray b#) off len flags = if PM.isByteArrayPinned b then errorsFromSize =<< c_safe_bytearray_send fd b# off len flags @@ -339,7 +502,7 @@ -- | Send data from a mutable 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 interruptible +-- actually present in the array. Since this uses the safe -- FFI, it allocates a pinned copy of the bytearry if it was not -- already pinned. sendMutableByteArray :: @@ -347,7 +510,7 @@ -> MutableByteArray RealWorld -- ^ Source byte array -> CInt -- ^ Offset into source array -> CSize -- ^ Length in bytes - -> Flags 'Send -- ^ Flags + -> MessageFlags 'Send -- ^ Flags -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer sendMutableByteArray fd b@(MutableByteArray b#) off len flags = if PM.isMutableByteArrayPinned b then errorsFromSize =<< c_safe_mutablebytearray_send fd b# off len flags @@ -357,13 +520,13 @@ errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags -- | Send data from an address over a network socket. This is not guaranteed --- to send the entire length. This uses the safe interruptible FFI since +-- to send the entire length. This uses the safe FFI since -- it may block indefinitely. send :: Fd -- ^ Connected socket -> Addr -- ^ Source address -> CSize -- ^ Length in bytes - -> Flags 'Send -- ^ Flags + -> MessageFlags 'Send -- ^ Flags -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer send fd (Addr addr) len flags = c_safe_addr_send fd addr len flags >>= errorsFromSize @@ -373,41 +536,41 @@ -- from blocking. On Linux this is accomplished with @O_NONBLOCK@. It is -- often desirable to call 'threadWaitWrite' on a nonblocking socket before -- calling @unsafeSend@ on it. -unsafeSend :: +uninterruptibleSend :: Fd -- ^ Socket -> Addr -- ^ Source address -> CSize -- ^ Length in bytes - -> Flags 'Send -- ^ Flags + -> MessageFlags 'Send -- ^ Flags -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -unsafeSend fd (Addr addr) len flags = +uninterruptibleSend fd (Addr addr) len flags = c_unsafe_addr_send fd addr len flags >>= errorsFromSize -- | Send data from a byte array over a network socket. This uses the unsafe FFI; -- considerations pertaining to 'sendUnsafe' apply to this function as well. Users -- may specify a length to send fewer bytes than are actually present in the -- array. -unsafeSendByteArray :: +uninterruptibleSendByteArray :: Fd -- ^ Socket -> ByteArray -- ^ Source byte array -> CInt -- ^ Offset into source array -> CSize -- ^ Length in bytes - -> Flags 'Send -- ^ Flags + -> MessageFlags 'Send -- ^ Flags -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -unsafeSendByteArray fd (ByteArray b) off len flags = +uninterruptibleSendByteArray fd (ByteArray b) off len flags = c_unsafe_bytearray_send fd b off len flags >>= errorsFromSize -- | Send data from a mutable byte array over a network socket. This uses the unsafe FFI; -- considerations pertaining to 'sendUnsafe' apply to this function as well. Users -- specify an offset and a length to send fewer bytes than are actually present in the -- array. -unsafeSendMutableByteArray :: +uninterruptibleSendMutableByteArray :: Fd -- ^ Socket -> MutableByteArray RealWorld -- ^ Source mutable byte array -> CInt -- ^ Offset into source array -> CSize -- ^ Length in bytes - -> Flags 'Send -- ^ Flags + -> MessageFlags 'Send -- ^ Flags -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -unsafeSendMutableByteArray fd (MutableByteArray b) off len flags = +uninterruptibleSendMutableByteArray fd (MutableByteArray b) off len flags = c_unsafe_mutable_bytearray_send fd b off len flags >>= errorsFromSize -- | Send data from a byte array over an unconnected network socket. @@ -415,15 +578,15 @@ -- apply to this function as well. The offset and length arguments -- cause a slice of the byte array to be sent rather than the entire -- byte array. -unsafeSendToByteArray :: +uninterruptibleSendToByteArray :: Fd -- ^ Socket -> ByteArray -- ^ Source byte array -> CInt -- ^ Offset into source array -> CSize -- ^ Length in bytes - -> Flags 'Send -- ^ Flags + -> MessageFlags 'Send -- ^ Flags -> SocketAddress -- ^ Socket Address -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -unsafeSendToByteArray fd (ByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = +uninterruptibleSendToByteArray fd (ByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = c_unsafe_bytearray_sendto fd b off len flags a# (intToCInt (PM.sizeofByteArray a)) >>= errorsFromSize -- | Send data from a mutable byte array over an unconnected network socket. @@ -431,38 +594,38 @@ -- apply to this function as well. The offset and length arguments -- cause a slice of the mutable byte array to be sent rather than the entire -- byte array. -unsafeSendToMutableByteArray :: +uninterruptibleSendToMutableByteArray :: Fd -- ^ Socket -> MutableByteArray RealWorld -- ^ Source byte array -> CInt -- ^ Offset into source array -> CSize -- ^ Length in bytes - -> Flags 'Send -- ^ Flags + -> MessageFlags 'Send -- ^ Flags -> SocketAddress -- ^ Socket Address -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -unsafeSendToMutableByteArray fd (MutableByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = +uninterruptibleSendToMutableByteArray fd (MutableByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = c_unsafe_mutable_bytearray_sendto fd b off len flags a# (intToCInt (PM.sizeofByteArray a)) >>= errorsFromSize -- | Receive data into an address from a network socket. This wraps @recv@ using --- the safe interruptible FFI. When the returned size is zero, there are no +-- the safe FFI. When the returned size is zero, there are no -- additional bytes to receive and the peer has performed an orderly shutdown. receive :: Fd -- ^ Socket -> Addr -- ^ Source address -> CSize -- ^ Length in bytes - -> Flags 'Receive -- ^ Flags + -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno CSize) receive fd (Addr addr) len flags = c_safe_addr_recv fd addr len flags >>= errorsFromSize -- | Receive data into a byte array from a network socket. This wraps @recv@ using --- the safe interruptible FFI. When the returned size is zero, there are no +-- the safe FFI. When the returned size is zero, there are no -- additional bytes to receive and the peer has performed an orderly shutdown. receiveByteArray :: Fd -- ^ Socket -> CSize -- ^ Length in bytes - -> Flags 'Receive -- ^ Flags + -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno ByteArray) -receiveByteArray fd len flags = do +receiveByteArray !fd !len !flags = do m <- PM.newPinnedByteArray (csizeToInt len) let !(Addr addr) = PM.mutableByteArrayContents m r <- c_safe_addr_recv fd addr len flags @@ -483,66 +646,75 @@ -- the @MSG_DONTWAIT@ flag and handling the resulting @EAGAIN@ or -- @EWOULDBLOCK@. When the returned size is zero, there are no additional -- bytes to receive and the peer has performed an orderly shutdown. -unsafeReceive :: +uninterruptibleReceive :: Fd -- ^ Socket -> Addr -- ^ Source address -> CSize -- ^ Length in bytes - -> Flags 'Receive -- ^ Flags + -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno CSize) -unsafeReceive fd (Addr addr) len flags = +uninterruptibleReceive !fd (Addr !addr) !len !flags = c_unsafe_addr_recv fd addr len flags >>= errorsFromSize -- | Receive data into an address from a network socket. This uses the unsafe -- FFI; considerations pertaining to 'receiveUnsafe' apply to this function -- as well. Users may specify a length to receive fewer bytes than are -- actually present in the mutable byte array. -unsafeReceiveMutableByteArray :: +uninterruptibleReceiveMutableByteArray :: Fd -- ^ Socket -> MutableByteArray RealWorld -- ^ Destination byte array -> CInt -- ^ Destination offset -> CSize -- ^ Maximum bytes to receive - -> Flags 'Receive -- ^ Flags + -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno CSize) -- ^ Bytes received into array -unsafeReceiveMutableByteArray fd (MutableByteArray b) off len flags = +uninterruptibleReceiveMutableByteArray !fd (MutableByteArray !b) !off !len !flags = c_unsafe_mutable_byte_array_recv fd b off len flags >>= errorsFromSize --- | Receive data into an address from an unconnected network socket. This uses the unsafe --- FFI. Users may specify an offset into the destination byte array. -unsafeReceiveFromMutableByteArray :: +-- | Receive data into an address from an unconnected network socket. This +-- uses the unsafe FFI. Users may specify an offset into the destination +-- byte array. This function does not resize the buffer. +uninterruptibleReceiveFromMutableByteArray :: Fd -- ^ Socket -> MutableByteArray RealWorld -- ^ Destination byte array -> CInt -- ^ Destination offset -> CSize -- ^ Maximum bytes to receive - -> Flags 'Receive -- ^ Flags + -> MessageFlags 'Receive -- ^ Flags -> CInt -- ^ Maximum socket address size - -> IO (Either Errno (SocketAddress,CSize)) -- ^ Remote host, umber of bytes received into array -unsafeReceiveFromMutableByteArray fd (MutableByteArray b) off len flags maxSz = do - sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newPinnedByteArray (cintToInt maxSz) - lenBuf@(MutableByteArray lenBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: CInt)) + -> IO (Either Errno (CInt,SocketAddress,CSize)) + -- ^ Remote host, bytes received into array, bytes needed for @addrlen@. +{-# INLINE uninterruptibleReceiveFromMutableByteArray #-} +-- GHC does not inline this unless we give it the pragma. We really +-- want this to inline since inlining typically avoids the Left/Right +-- data constructor allocation. +uninterruptibleReceiveFromMutableByteArray !fd (MutableByteArray !b) !off !len !flags !maxSz = do + sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) PM.writeByteArray lenBuf 0 maxSz r <- c_unsafe_mutable_byte_array_recvfrom fd b off len flags sockAddrBuf# lenBuf# if r > (-1) then do (sz :: CInt) <- PM.readByteArray lenBuf 0 - sockAddr <- PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray sockAddrBuf (cintToInt sz) - pure (Right (SocketAddress sockAddr,cssizeToCSize r)) + if sz < maxSz + then shrinkMutableByteArray sockAddrBuf (cintToInt sz) + else pure () + sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf + pure (Right (sz,SocketAddress sockAddr,cssizeToCSize r)) else fmap Left getErrno -- | Receive data into an address from a network socket. This uses the unsafe -- FFI. This does not return the socket address of the remote host that -- sent the packet received. -unsafeReceiveFromMutableByteArray_ :: +uninterruptibleReceiveFromMutableByteArray_ :: Fd -- ^ Socket -> MutableByteArray RealWorld -- ^ Destination byte array -> CInt -- ^ Destination offset -> CSize -- ^ Maximum bytes to receive - -> Flags 'Receive -- ^ Flags + -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno CSize) -- ^ Number of bytes received into array -unsafeReceiveFromMutableByteArray_ fd (MutableByteArray b) off len flags = +uninterruptibleReceiveFromMutableByteArray_ !fd (MutableByteArray !b) !off !len !flags = c_unsafe_mutable_byte_array_ptr_recvfrom fd b off len flags nullPtr nullPtr >>= errorsFromSize -- | Close a socket. The --- includes more details. This uses the safe interruptible FFI. +-- includes more details. This uses the safe FFI. close :: Fd -- ^ Socket -> IO (Either Errno ()) @@ -555,11 +727,32 @@ -- 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." -unsafeClose :: +uninterruptibleClose :: Fd -- ^ Socket -> IO (Either Errno ()) -unsafeClose fd = c_unsafe_close fd >>= errorsFromInt +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 :: + Fd + -> ShutdownType + -> IO (Either Errno ()) +uninterruptibleShutdown fd typ = + c_unsafe_shutdown fd typ >>= errorsFromInt + errorsFromSize :: CSsize -> IO (Either Errno CSize) errorsFromSize r = if r > (-1) then pure (Right (cssizeToCSize r)) @@ -599,4 +792,40 @@ -- -- touchByteArray# :: ByteArray# -> IO () -- touchByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) + +shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () +shrinkMutableByteArray (MutableByteArray arr) (I# sz) = + PM.primitive_ (shrinkMutableByteArray# arr sz) + +-- | Convert a 16-bit word from host to network byte order (e.g. @htons@). +hostToNetworkShort :: Word16 -> Word16 +hostToNetworkShort = case targetByteOrder of + BigEndian -> id + LittleEndian -> byteSwap16 + +-- | Convert a 16-bit word from network to host byte order (e.g. @ntohs@). +networkToHostShort :: Word16 -> Word16 +networkToHostShort = case targetByteOrder of + BigEndian -> id + LittleEndian -> byteSwap16 + +-- | Convert a 32-bit word from host to network byte order (e.g. @htonl@). +hostToNetworkLong :: Word32 -> Word32 +hostToNetworkLong = case targetByteOrder of + BigEndian -> id + LittleEndian -> byteSwap32 + +-- | Convert a 32-bit word from network to host byte order (e.g. @ntohl@). +networkToHostLong :: Word32 -> Word32 +networkToHostLong = case targetByteOrder of + BigEndian -> id + LittleEndian -> byteSwap32 + +{- $conversion +These functions are used to convert IPv4 addresses and ports between network +byte order and host byte order. They are essential when working with +'SocketAddressInternet'. To avoid getting in the way of GHC compile-time +optimizations, these functions are not actually implemented with FFI +calls to @htonl@ and friends. Rather, they are reimplemented in haskell. +-} 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,10 @@ {-# language GeneralizedNewtypeDeriving #-} {-# language KindSignatures #-} +-- This is needed because hsc2hs does not currently handle ticked +-- promoted data constructors correctly. +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + #include #include @@ -14,16 +18,21 @@ ( Domain(..) , Type(..) , Protocol(..) + , Level(..) + , OptionName(..) + , OptionValue(..) , SocketAddress(..) , SocketAddressInternet(..) , SocketAddressInternet6(..) , SocketAddressUnix(..) - , Flags(..) + , MessageFlags(..) , Message(..) + , ShutdownType(..) -- * Socket Families , unix , unspecified , internet + , internet6 -- * Socket Types , stream , datagram @@ -41,12 +50,23 @@ , peek , outOfBand , waitAll + -- * Shutdown Types + , read + , write + , readWrite + -- * Socket Levels + , levelSocket + -- * Option Names + , optionError ) where -import Foreign.C.Types (CInt(..)) -import Data.Primitive (ByteArray) +import Prelude hiding (read) + import Data.Bits (Bits,(.|.)) +import Data.Primitive (ByteArray) import Data.Word (Word16,Word32,Word64) +import Foreign.C.Types (CInt(..)) + import qualified Data.Kind -- | A socket communications domain, sometimes referred to as a family. The spec @@ -60,29 +80,37 @@ newtype Protocol = Protocol CInt +newtype Level = Level CInt + +newtype OptionName = OptionName CInt + +-- | Which end of the socket to shutdown. +newtype ShutdownType = ShutdownType CInt + -- | The direction of a message. The data constructor are only used -- at the type level as phantom arguments. data Message = Send | Receive --- | Receive flags are given by @Flags Receive@ and send flags --- are given by @Flags Send@. This is done because there are +-- | Receive flags are given by @MessageFlags Receive@ and send flags +-- are given by @MessageFlags Send@. This is done because there are -- several flags that are applicable in either a receiving -- context or a sending context. -newtype Flags :: Message -> Data.Kind.Type where - Flags :: CInt -> Flags m +newtype MessageFlags :: Message -> Data.Kind.Type where + MessageFlags :: CInt -> MessageFlags m deriving stock (Eq) deriving newtype (Bits) -instance Semigroup (Flags m) where (<>) = (.|.) -instance Monoid (Flags m) where mempty = Flags 0 +instance Semigroup (MessageFlags m) where (<>) = (.|.) +instance Monoid (MessageFlags m) where mempty = MessageFlags 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 representing the socket address must be pinned --- since @bind@ uses a safe FFI call. +-- | 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. newtype SocketAddress = SocketAddress ByteArray +-- | The @option_value@ data. +newtype OptionValue = OptionValue ByteArray + -- | An address for an Internet socket over IPv4. The -- -- mandates three fields: @@ -161,17 +189,25 @@ internet :: Domain internet = Domain #{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} + -- | The @MSG_OOB@ receive flag or send flag. -outOfBand :: Flags m -outOfBand = Flags #{const MSG_OOB} +outOfBand :: MessageFlags m +outOfBand = MessageFlags #{const MSG_OOB} -- | The @MSG_PEEK@ receive flag. -peek :: Flags 'Receive -peek = Flags #{const MSG_PEEK} +peek :: MessageFlags Receive +peek = MessageFlags #{const MSG_PEEK} -- | The @MSG_WAITALL@ receive flag. -waitAll :: Flags 'Receive -waitAll = Flags #{const MSG_WAITALL} +waitAll :: MessageFlags Receive +waitAll = MessageFlags #{const MSG_WAITALL} -- | The default protocol for a socket type. defaultProtocol :: Protocol @@ -200,4 +236,24 @@ -- | The @IPPROTO_IPV6@ protocol. ipv6 :: Protocol ipv6 = Protocol #{const IPPROTO_IPV6} + +-- | Disable further receive operations (e.g. @SHUT_RD@) +read :: ShutdownType +read = ShutdownType #{const SHUT_RD} + +-- | Disable further send operations (e.g. @SHUT_WR@) +write :: ShutdownType +write = ShutdownType #{const SHUT_WR} + +-- | Disable further send operations (e.g. @SHUT_RDWR@) +readWrite :: ShutdownType +readWrite = ShutdownType #{const SHUT_RDWR} + +-- | Socket error status (e.g. @SOL_SOCKET@) +levelSocket :: Level +levelSocket = Level #{const SOL_SOCKET} + +-- | Socket error status (e.g. @SO_ERROR@) +optionError :: OptionName +optionError = OptionName #{const SO_ERROR}