diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for posix + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Andrew Martin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Martin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/HaskellPosix.c b/cbits/HaskellPosix.c new file mode 100644 --- /dev/null +++ b/cbits/HaskellPosix.c @@ -0,0 +1,21 @@ +#include +#include "HaskellPosix.h" + +// Generally, this library tries to avoid wrapping POSIX functions +// in an additional function. However, for some functions whose wrappers +// unsafe FFI wrappers use unpinned ByteArray instead of Addr, the only +// way to support providing an offset (without just copying the bytes +// into pinned memory) is to use a wrapper. + +ssize_t recv_offset(int socket, char *buffer, int offset, size_t length, int flags) { + recv(socket, (void*)(buffer + offset), length, flags); +} +ssize_t send_offset(int socket, const char *buffer, int offset, size_t length, int flags) { + send(socket, (const void*)(buffer + offset), length, flags); +} +ssize_t sendto_offset(int socket, const char *message, int offset, size_t length, int flags, const struct sockaddr *dest_addr, socklen_t dest_len){ + sendto(socket, (const void*)(message + offset), length, flags, dest_addr, dest_len); +} +ssize_t recvfrom_offset(int socket, char *restrict buffer, int offset, size_t length, int flags, struct sockaddr *restrict address, socklen_t *restrict address_len) { + recvfrom(socket, (void*)(buffer + offset), length, flags, address, address_len); +} diff --git a/include/HaskellPosix.h b/include/HaskellPosix.h new file mode 100644 --- /dev/null +++ b/include/HaskellPosix.h @@ -0,0 +1,11 @@ +#include +#include + +ssize_t recv_offset(int socket, char *buffer, int offset, size_t length, int flags); +ssize_t send_offset(int socket, const char *buffer, int offset, size_t length, int flags); + +ssize_t sendto_offset(int socket, const char *message, int offset, size_t length, int flags, const struct sockaddr *dest_addr, socklen_t dest_len); +ssize_t recvfrom_offset(int socket, char *restrict buffer, int offset, size_t length, int flags, struct sockaddr *restrict address, socklen_t *restrict address_len); + + + diff --git a/posix-api.cabal b/posix-api.cabal new file mode 100644 --- /dev/null +++ b/posix-api.cabal @@ -0,0 +1,106 @@ +cabal-version: 2.2 +name: posix-api +version: 0.1.0.0 +synopsis: posix bindings +description: + This library provides a very thin wrapper around POSIX APIs. It can be + compiled on any operating system that implements the standard as specified + in + faithfully. It has similar goals as the `unix` package, but its design + differs in several areas: + . + * `ByteArray` and `Addr` are used pervasively. There is no use of + `String` in this library. + . + * Functions do not throw errors. This library uses `IO (Either Errno a)` + in places where `unix` 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. + . + About a dozen other packages offers wrappers for some subset of the POSIX + specification are strewn across hackage. They include `regex-posix`, + `posix-paths`, `posix-timer`, `posix-socket`, `posix-filelock`, + `posix-acl`, etc. This library differs from all off these in various + ways. Here are some of the design guidelines followed here that distinguish + this package from some or all of these others: + . + * Scope. Although this library does not include all APIs specified by + POSIX, it welcomes as many of them as anyone is willing to implement. + . + * Monomorphization. Effectful functions in this library return their + results in `IO` rather than using a type that involves `MonadIO` + or `MonadBaseControl`. + . + * Typeclass avoidance. This library does not introduce new typeclasses. + Overloading is eschewed in favor of providing multiple functions + with distinct names. + . + * Minimality. Functions wrapping the POSIX APIs do little more than + wrap the underlying functions. The major deviation here is that, + when applicable, the wrappers allocate buffers are the underlying + functions fill. This eschews C's characteristic buffer-passing + in favor of the Haskell convention of allocating internally and returning. + A more minor deviation is that for safe FFI calls, this library + will perform additional work to ensure that only pinned byte arrays are + handed over. + . + Unlike `network`, this sockets API in this library does not integrate + sockets with GHC's event manager. This is geared + toward an audience that understands how to use `threadWaitRead` + and `threadWaitWrite` with unsafe FFI calls to avoid blocking + the runtime. +homepage: https://github.com/andrewthad/posix-api +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2018 Andrew Martin +category: System +build-type: Simple +extra-source-files: + CHANGELOG.md + cbits/HaskellPosix.c + include/HaskellPosix.h + +library + exposed-modules: + Linux.Socket + Posix.Directory + Posix.Socket + other-modules: + Linux.Socket.Types + Posix.Socket.Types + Posix.Socket.Platform + build-depends: + , base >=4.11.1 && <5 + , primitive >= 0.6.4 + hs-source-dirs: src + if os(linux) + hs-source-dirs: src-linux + default-language: Haskell2010 + ghc-options: -Wall -O2 + c-sources: cbits/HaskellPosix.c + include-dirs: include + includes: HaskellPosix.h + build-tools: hsc2hs + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , base + , posix-api + , tasty + , tasty-hunit + , primitive + ghc-options: -Wall -O2 -threaded + default-language: Haskell2010 + diff --git a/src-linux/Posix/Socket/Platform.hsc b/src-linux/Posix/Socket/Platform.hsc new file mode 100644 --- /dev/null +++ b/src-linux/Posix/Socket/Platform.hsc @@ -0,0 +1,102 @@ +{-# language BangPatterns #-} +{-# language DerivingStrategies #-} +{-# language DuplicateRecordFields #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language MagicHash #-} +{-# language NamedFieldPuns #-} +{-# language UnboxedTuples #-} +{-# language ScopedTypeVariables #-} + +#include +#include +#include +#include +#include + +-- | All of the data constructors provided by this module are unsafe. +-- Only use them if you really know what you are doing. +module Posix.Socket.Platform + ( -- * Encoding Socket Addresses + encodeSocketAddressInternet + , encodeSocketAddressUnix + ) where + +import Data.Primitive (ByteArray(..),Addr(..)) +import Data.Void (Void) +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 Posix.Socket.Types (SocketAddress(..)) +import Control.Monad (when) + +import qualified Data.Primitive as PM +import qualified Foreign.Storable as FS + +-- | 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} + -- 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) + -- 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 + r <- PM.unsafeFreezeByteArray bs + touchByteArray r + pure r + +-- | 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 +-- to 108 but varies by platform), the socket address will instead be given the +-- empty string as its path. This typically results in @bind@ returning an +-- error code. +encodeSocketAddressUnix :: SocketAddressUnix -> SocketAddress +encodeSocketAddressUnix (SocketAddressUnix !name) = + SocketAddress $ runByteArrayIO $ unboxByteArrayIO $ 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. + let pathSize = 108 :: Int + -- 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) + PM.setByteArray bs familySize pathSize (0 :: Word8) + PM.writeByteArray bs 0 (#{const AF_UNIX} :: CUShort) + let sz = PM.sizeofByteArray name + when (sz < pathSize) $ do + 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 + (## 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 + diff --git a/src/Linux/Socket.hs b/src/Linux/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Linux/Socket.hs @@ -0,0 +1,6 @@ +module Linux.Socket + ( -- * Flags + LST.dontWait + ) where + +import qualified Linux.Socket.Types as LST diff --git a/src/Linux/Socket/Types.hsc b/src/Linux/Socket/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Linux/Socket/Types.hsc @@ -0,0 +1,14 @@ +#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 + ) where + +import Posix.Socket (Flags(..)) + +-- | The @MSG_DONTWAIT@ receive flag or send flag. +dontWait :: Flags m +dontWait = Flags #{const MSG_DONTWAIT} + diff --git a/src/Posix/Directory.hs b/src/Posix/Directory.hs new file mode 100644 --- /dev/null +++ b/src/Posix/Directory.hs @@ -0,0 +1,68 @@ +{-# language BangPatterns #-} +{-# language MagicHash #-} +{-# language LambdaCase #-} +{-# language UnboxedTuples #-} + +module Posix.Directory + ( getCurrentWorkingDirectory + ) where + +import Data.Primitive (Addr(..),ByteArray) +import GHC.Exts (Ptr(..)) +import Foreign.Ptr (nullPtr) +import Foreign.C.Error (Errno,eRANGE,getErrno) +import Foreign.C.Types (CChar,CSize(..)) +import GHC.IO (IO(..)) + +import qualified Data.Primitive as PM +import qualified Foreign.Storable as FS + +foreign import ccall safe "getcwd" + c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) + +-- | Get the current working directory without using the system locale +-- to convert it to text. This is implemented with a safe FFI call +-- since it may block. +getCurrentWorkingDirectory :: IO (Either Errno ByteArray) +getCurrentWorkingDirectory = go (4096 - chunkOverhead) where + go !sz = do + -- It may be nice to add a variant of getCurrentWorkingDirectory that + -- allow the user to supply an initial pinned buffer. I'm not sure + -- how many other POSIX functions there are that could benefit + -- from this. Calls to getCurrentWorkingDirectory are extremely rare, + -- so there would be little benefit here, but there may be other + -- functions where these repeated 4KB allocations might trigger + -- GC very quickly. + marr <- PM.newPinnedByteArray sz + let !(Addr addr) = PM.mutableByteArrayContents marr + ptr <- c_getcwd (Ptr addr) (intToCSize sz) + -- We probably want to use touch# or with# here. + if ptr /= nullPtr + then do + strSize <- findNullByte ptr + dst <- PM.newByteArray strSize + PM.copyMutableByteArray dst 0 marr 0 strSize + dst' <- PM.unsafeFreezeByteArray dst + pure (Right dst') + else do + errno <- getErrno + if errno == eRANGE + then go (2 * sz) + else fmap Left getErrno + +chunkOverhead :: Int +chunkOverhead = 2 * PM.sizeOf (undefined :: Int) + +intToCSize :: Int -> CSize +intToCSize = fromIntegral + +-- There must be a null byte present or bad things will happen. +-- This will return a nonnegative number. +findNullByte :: Ptr CChar -> IO Int +findNullByte = go 0 where + go :: Int -> Ptr CChar -> IO Int + go !ix !ptr = do + FS.peekElemOff ptr ix >>= \case + 0 -> pure ix + _ -> go (ix + 1) ptr + diff --git a/src/Posix/Socket.hs b/src/Posix/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Posix/Socket.hs @@ -0,0 +1,602 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language InterruptibleFFI #-} +{-# language MagicHash #-} +{-# language ScopedTypeVariables #-} +{-# language UnboxedTuples #-} +{-# language UnliftedFFITypes #-} + +-- | Types and functions related to the POSIX sockets API. +-- Unusual characteristics: +-- +-- * Any time the standard calls for @socklen_t@, we use +-- @CInt@ instead. Linus Torvalds +-- that \"Any sane library must have @socklen_t@ be the same size as @int@. +-- Anything else breaks any BSD socket layer stuff.\" +-- * Send and receive each have several variants. They are distinguished by +-- the safe/unsafe FFI use and by the @Addr@/@ByteArray@/@MutableByteArray@ +-- 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. +module Posix.Socket + ( -- * Functions + -- ** Socket + socket + -- ** Socket Pair + , socketPair + -- ** Bind + , bind + -- ** Connect + , connect + -- ** Listen + , listen + -- ** Accept + , accept + , accept_ + -- ** Close + , close + , unsafeClose + -- ** Send + , send + , sendByteArray + , sendMutableByteArray + , unsafeSend + , unsafeSendByteArray + , unsafeSendMutableByteArray + -- ** Send To + , unsafeSendToByteArray + , unsafeSendToMutableByteArray + -- ** Receive + , receive + , receiveByteArray + , unsafeReceive + , unsafeReceiveMutableByteArray + -- ** Receive From + , unsafeReceiveFromMutableByteArray + , unsafeReceiveFromMutableByteArray_ + -- * Types + , Domain(..) + , Type(..) + , Protocol(..) + , Flags(..) + -- * Socket Address + -- ** Types + , SocketAddress(..) + , PST.SocketAddressInternet(..) + , PST.SocketAddressUnix(..) + -- ** Encoding + , PSP.encodeSocketAddressInternet + , PSP.encodeSocketAddressUnix + -- * Data Construction + -- ** Socket Domains + , PST.unix + , PST.unspecified + , PST.internet + -- ** Socket Types + , PST.stream + , PST.datagram + , PST.raw + , PST.sequencedPacket + -- ** Protocols + , PST.defaultProtocol + , PST.rawProtocol + , PST.icmp + , PST.tcp + , PST.udp + , PST.ip + , PST.ipv6 + -- ** Receive Flags + , PST.peek + , PST.outOfBand + , PST.waitAll + ) where + +import GHC.IO (IO(..)) +import Data.Primitive (MutablePrimArray(..),MutableByteArray(..),Addr(..),ByteArray(..)) +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 Posix.Socket.Types (Domain(..),Protocol(..),Type(..),SocketAddress(..)) +import Posix.Socket.Types (Flags(..),Message(..)) +import System.Posix.Types (Fd(..),CSsize(..)) + +import qualified Posix.Socket.Types as PST +import qualified Data.Primitive as PM + +-- This module include operating-system specific code used +-- to serialize some of various kind of socket address types. +import qualified Posix.Socket.Platform as PSP + +foreign import ccall unsafe "sys/socket.h socket" + c_socket :: Domain -> Type -> Protocol -> IO Fd + +foreign import ccall unsafe "sys/socket.h socketpair" + c_socketpair :: Domain -> Type -> Protocol -> MutableByteArray# RealWorld -> IO CInt + +foreign import ccall unsafe "sys/socket.h listen" + c_listen :: Fd -> CInt -> IO CInt + +foreign import ccall interruptible "unistd.h close" + c_safe_close :: Fd -> IO CInt + +foreign import ccall unsafe "unistd.h close" + c_unsafe_close :: Fd -> 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 +-- CInt rather than introducing a type corresponding to socklen_t. +-- According to Linus Torvalds, "Any sane library must have socklen_t +-- be the same size as int. Anything else breaks any BSD socket layer stuff." +-- (https://yarchive.net/comp/linux/socklen_t.html). If a platform +-- violates this assumption, this wrapper will be broken on that platform. +foreign import ccall unsafe "sys/socket.h bind" + c_bind :: Fd -> ByteArray# -> CInt -> IO CInt + +-- Per the spec, the type signature of accept is: +-- int accept(int socket, struct sockaddr *restrict address, socklen_t *restrict address_len); +-- The restrict keyword does not matter much for our purposes. See the +-- 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" + c_safe_accept :: Fd + -> MutableByteArray# RealWorld -- SocketAddress + -> MutableByteArray# RealWorld -- Ptr CInt + -> IO Fd +foreign import ccall interruptible "sys/socket.h accept" + c_safe_ptr_accept :: Fd -> Ptr Void -> Ptr CInt -> IO Fd + +-- 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" + c_safe_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 +-- have the option of writing to either an address or a byte array. +-- Unsafe FFI calls guarantee that byte arrays will not be relocated +-- 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 unsafe "sys/socket.h send" + c_unsafe_addr_send :: Fd -> Addr# -> CSize -> Flags 'Send -> IO CSsize +foreign import ccall unsafe "sys/socket.h send_offset" + c_unsafe_bytearray_send :: Fd -> ByteArray# -> CInt -> CSize -> Flags '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 + +-- 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 +-- 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 + +-- 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 unsafe "sys/socket.h recv" + c_unsafe_addr_recv :: Fd -> Addr# -> CSize -> Flags '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 + +-- 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 +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 + +-- | 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 :: + Domain -- ^ Communications domain (e.g. 'internet', 'unix') + -> Type -- ^ Socket type (e.g. 'datagram', 'stream') + -> Protocol -- ^ Protocol + -> IO (Either Errno Fd) +socket 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 :: + Domain -- ^ Communications domain (probably 'unix') + -> Type -- ^ Socket type (e.g. 'datagram', 'stream') + -> Protocol -- ^ Protocol + -> IO (Either Errno (Fd,Fd)) +socketPair 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 + r <- c_socketpair dom typ prot sockets# + if r == 0 + then do + fd1 <- PM.readPrimArray sockets 0 + fd2 <- PM.readPrimArray sockets 1 + pure (Right (fd1,fd2)) + else fmap Left getErrno + +-- | Assign a local socket address address to a socket identified by +-- descriptor socket that has no local socket address assigned. The +-- +-- 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 :: + Fd -- ^ Socket + -> SocketAddress -- ^ Socket address, extensible tagged union + -> IO (Either Errno ()) +bind 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 :: + Fd -- ^ Socket + -> CInt -- ^ Backlog + -> IO (Either Errno ()) +listen 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. +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 + +-- | Extract the first connection on the queue of pending connections. The +-- +-- includes more details. This function\'s type differs slightly from +-- the specification: +-- +-- > int accept(int socket, struct sockaddr *restrict address, socklen_t *restrict address_len); +-- +-- Instead of requiring the caller to prepare buffers through which +-- information is returned, this haskell binding to @accept@ prepares +-- those buffers internally. This eschews C\'s characteristic buffer-passing +-- in favor of the Haskell convention of allocating internally and returning. +-- +-- More specifically, this binding lacks an argument corresponding to the +-- @sockaddr@ buffer from the specification. That mutable buffer is allocated +-- internally, resized and frozen upon a success, and returned along with +-- the file descriptor of the accepted socket. The size of this buffer is +-- determined by the second argument (maximum socket address size). This +-- size argument is also writen to the @address_len@ buffer, which is also +-- allocated internally. The size returned through this pointer is used to +-- resize the @sockaddr@ buffer, which is then frozen so that an immutable +-- 'SocketAddress' is returned to the end user. +-- +-- For applications uninterested in the peer (described by @sockaddr@), +-- POSIX @accept@ allows the null pointer to be passed as both @address@ and +-- @address_len@. This behavior is provided by 'accept_'. +accept :: + Fd -- ^ Listening socket + -> CInt -- ^ Maximum socket address size + -> IO (Either Errno (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 + r <- c_safe_accept sock 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,r)) + else fmap Left getErrno + +-- | A variant of 'accept' that does not provide the user with a +-- 'SocketAddress' detailing the peer. +accept_ :: + Fd -- ^ Listening socket + -> IO (Either Errno Fd) -- ^ Connected socket +accept_ sock = + c_safe_ptr_accept sock nullPtr nullPtr >>= errorsFromFd + +-- | 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 +-- FFI, it allocates a pinned copy of the bytearry if it was not +-- already pinned. +sendByteArray :: + Fd -- ^ Socket + -> ByteArray -- ^ Source byte array + -> CInt -- ^ Offset into source array + -> CSize -- ^ Length in bytes + -> Flags '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 + else do + x@(MutableByteArray x#) <- PM.newPinnedByteArray (csizeToInt len) + PM.copyByteArray x (cintToInt off) b 0 (csizeToInt len) + errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags + +-- | 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 +-- FFI, it allocates a pinned copy of the bytearry if it was not +-- already pinned. +sendMutableByteArray :: + Fd -- ^ Socket + -> MutableByteArray RealWorld -- ^ Source byte array + -> CInt -- ^ Offset into source array + -> CSize -- ^ Length in bytes + -> Flags '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 + else do + x@(MutableByteArray x#) <- PM.newPinnedByteArray (csizeToInt len) + PM.copyMutableByteArray x (cintToInt off) b 0 (csizeToInt len) + 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 +-- it may block indefinitely. +send :: + Fd -- ^ Connected socket + -> Addr -- ^ Source address + -> CSize -- ^ Length in bytes + -> Flags '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 + +-- | Send data from an address over a network socket. This uses the unsafe FFI. +-- Users of this function should be sure to set flags that prohibit this +-- 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 :: + Fd -- ^ Socket + -> Addr -- ^ Source address + -> CSize -- ^ Length in bytes + -> Flags 'Send -- ^ Flags + -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer +unsafeSend 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 :: + Fd -- ^ Socket + -> ByteArray -- ^ Source byte array + -> CInt -- ^ Offset into source array + -> CSize -- ^ Length in bytes + -> Flags 'Send -- ^ Flags + -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer +unsafeSendByteArray 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 :: + Fd -- ^ Socket + -> MutableByteArray RealWorld -- ^ Source mutable byte array + -> CInt -- ^ Offset into source array + -> CSize -- ^ Length in bytes + -> Flags 'Send -- ^ Flags + -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer +unsafeSendMutableByteArray 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. +-- This uses the unsafe FFI; considerations pertaining to 'sendToUnsafe' +-- 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 :: + Fd -- ^ Socket + -> ByteArray -- ^ Source byte array + -> CInt -- ^ Offset into source array + -> CSize -- ^ Length in bytes + -> Flags '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#)) = + 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. +-- This uses the unsafe FFI; considerations pertaining to 'sendToUnsafe' +-- 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 :: + Fd -- ^ Socket + -> MutableByteArray RealWorld -- ^ Source byte array + -> CInt -- ^ Offset into source array + -> CSize -- ^ Length in bytes + -> Flags '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#)) = + 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 +-- 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 + -> 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 +-- additional bytes to receive and the peer has performed an orderly shutdown. +receiveByteArray :: + Fd -- ^ Socket + -> CSize -- ^ Length in bytes + -> Flags 'Receive -- ^ Flags + -> IO (Either Errno ByteArray) +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 + if r /= (-1) + then do + -- Why copy when we could just shrink? We want to always return + -- byte arrays that are not explicitly pinned. + let sz = cssizeToInt r + x <- PM.newByteArray sz + PM.copyMutableByteArray x 0 m 0 sz + a <- PM.unsafeFreezeByteArray x + pure (Right a) + else fmap Left getErrno + +-- | Receive data into an address from a network socket. This wraps @recv@ +-- using the unsafe FFI. Users of this function should be sure to set flags +-- that prohibit this from blocking. On Linux this is accomplished by setting +-- 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 :: + Fd -- ^ Socket + -> Addr -- ^ Source address + -> CSize -- ^ Length in bytes + -> Flags 'Receive -- ^ Flags + -> IO (Either Errno CSize) +unsafeReceive 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 :: + Fd -- ^ Socket + -> MutableByteArray RealWorld -- ^ Destination byte array + -> CInt -- ^ Destination offset + -> CSize -- ^ Maximum bytes to receive + -> Flags 'Receive -- ^ Flags + -> IO (Either Errno CSize) -- ^ Bytes received into array +unsafeReceiveMutableByteArray 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 :: + Fd -- ^ Socket + -> MutableByteArray RealWorld -- ^ Destination byte array + -> CInt -- ^ Destination offset + -> CSize -- ^ Maximum bytes to receive + -> Flags '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)) + 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)) + 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_ :: + Fd -- ^ Socket + -> MutableByteArray RealWorld -- ^ Destination byte array + -> CInt -- ^ Destination offset + -> CSize -- ^ Maximum bytes to receive + -> Flags 'Receive -- ^ Flags + -> IO (Either Errno CSize) -- ^ Number of bytes received into array +unsafeReceiveFromMutableByteArray_ 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. +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." +unsafeClose :: + Fd -- ^ Socket + -> IO (Either Errno ()) +unsafeClose fd = c_unsafe_close fd >>= errorsFromInt + +errorsFromSize :: CSsize -> IO (Either Errno CSize) +errorsFromSize r = if r > (-1) + 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 + +-- 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 + +intToCInt :: Int -> CInt +intToCInt = fromIntegral + +cintToInt :: CInt -> Int +cintToInt = fromIntegral + +csizeToInt :: CSize -> Int +csizeToInt = fromIntegral + +cssizeToInt :: CSsize -> Int +cssizeToInt = fromIntegral + +-- only call this when it is known that the argument is non-negative +cssizeToCSize :: CSsize -> CSize +cssizeToCSize = fromIntegral + +-- touchByteArray :: ByteArray -> IO () +-- touchByteArray (ByteArray x) = touchByteArray# x +-- +-- touchByteArray# :: ByteArray# -> IO () +-- touchByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) + diff --git a/src/Posix/Socket/Types.hsc b/src/Posix/Socket/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Posix/Socket/Types.hsc @@ -0,0 +1,203 @@ +{-# language DataKinds #-} +{-# language DerivingStrategies #-} +{-# language DuplicateRecordFields #-} +{-# language GADTSyntax #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language KindSignatures #-} + +#include +#include + +-- | All of the data constructors provided by this module are unsafe. +-- Only use them if you really know what you are doing. +module Posix.Socket.Types + ( Domain(..) + , Type(..) + , Protocol(..) + , SocketAddress(..) + , SocketAddressInternet(..) + , SocketAddressInternet6(..) + , SocketAddressUnix(..) + , Flags(..) + , Message(..) + -- * Socket Families + , unix + , unspecified + , internet + -- * Socket Types + , stream + , datagram + , raw + , sequencedPacket + -- * Protocols + , defaultProtocol + , rawProtocol + , icmp + , tcp + , udp + , ip + , ipv6 + -- * Receive Flags + , peek + , outOfBand + , waitAll + ) where + +import Foreign.C.Types (CInt(..)) +import Data.Primitive (ByteArray) +import Data.Bits (Bits,(.|.)) +import Data.Word (Word16,Word32,Word64) +import qualified Data.Kind + +-- | A socket communications domain, sometimes referred to as a family. The spec +-- mandates @AF_UNIX@, @AF_UNSPEC@, and @AF_INET@. +newtype Domain = Domain CInt + +-- | A socket type. The spec mandates @SOCK_STREAM@, @SOCK_DGRAM@, +-- and @SOCK_SEQPACKET@. Other types may be available on a per-platform +-- basis. +newtype Type = Type CInt + +newtype Protocol = Protocol 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 +-- 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 + deriving stock (Eq) + deriving newtype (Bits) + +instance Semigroup (Flags m) where (<>) = (.|.) +instance Monoid (Flags m) where mempty = Flags 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. +newtype SocketAddress = SocketAddress ByteArray + +-- | An address for an Internet socket over IPv4. The +-- +-- mandates three fields: +-- +-- > sa_family_t sin_family AF_INET +-- > in_port_t sin_port Port number +-- > struct in_addr sin_addr IP address +-- +-- This type omits the first field since is a constant that +-- is only relevant for serialization purposes. The spec also +-- mandates that @sin_port@ and @sin_addr@ be in network +-- byte order, so keep in mind that these values are not +-- immidiately useable. +data SocketAddressInternet = SocketAddressInternet + { port :: !Word16 + , address :: !Word32 + } + +-- Revisit this. We really need a standard Word128 type somewhere. +data SocketAddressInternet6 = SocketAddressInternet6 + { port :: !Word16 + , flowInfo :: !Word32 + , addressA :: !Word64 + , addressB :: !Word64 + , scopeId :: !Word32 + } + +-- | An address for a UNIX domain socket. The +-- +-- mandates two fields: +-- +-- > sa_family_t sun_family Address family. +-- > char sun_path[] Socket pathname. +-- +-- However, the first field is omitted since it is always @AF_UNIX@. +-- It is adding during serialization. Although @sun_path@ is a +-- null-terminated string, @SocketAddressUnix@ should not have +-- a trailing null byte. The conversion function @encodeSocketAddressUnix@ +-- adds the null terminator. The size of path should not equal +-- or exceed the platform-dependent size of @sun_path@. +newtype SocketAddressUnix = SocketAddressUnix + { path :: ByteArray + } + +-- | The @SOCK_STREAM@ socket type. +stream :: Type +stream = Type #{const SOCK_STREAM} + +-- | The @SOCK_DGRAM@ socket type. +datagram :: Type +datagram = Type #{const SOCK_DGRAM} + +-- | The @SOCK_RAW@ socket type. 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. Keep in mind that even though raw sockets may exist +-- on all POSIX-compliant operating systems, they may differ in +-- their behavior. +raw :: Type +raw = Type #{const SOCK_RAW} + +-- | The @SOCK_SEQPACKET@ socket type. +sequencedPacket :: Type +sequencedPacket = Type #{const SOCK_SEQPACKET} + +-- | The @AF_UNIX@ communications domain. +unix :: Domain +unix = Domain #{const AF_UNIX} + +-- | The @AF_UNSPEC@ communications domain. +unspecified :: Domain +unspecified = Domain #{const AF_UNSPEC} + +-- | The @AF_INET@ communications domain. +internet :: Domain +internet = Domain #{const AF_INET} + +-- | The @MSG_OOB@ receive flag or send flag. +outOfBand :: Flags m +outOfBand = Flags #{const MSG_OOB} + +-- | The @MSG_PEEK@ receive flag. +peek :: Flags 'Receive +peek = Flags #{const MSG_PEEK} + +-- | The @MSG_WAITALL@ receive flag. +waitAll :: Flags 'Receive +waitAll = Flags #{const MSG_WAITALL} + +-- | The default protocol for a socket type. +defaultProtocol :: Protocol +defaultProtocol = Protocol 0 + +-- | The @IPPROTO_RAW@ protocol. +rawProtocol :: Protocol +rawProtocol = Protocol #{const IPPROTO_RAW} + +-- | The @IPPROTO_ICMP@ protocol. +icmp :: Protocol +icmp = Protocol #{const IPPROTO_ICMP} + +-- | The @IPPROTO_TCP@ protocol. +tcp :: Protocol +tcp = Protocol #{const IPPROTO_TCP} + +-- | The @IPPROTO_UDP@ protocol. +udp :: Protocol +udp = Protocol #{const IPPROTO_UDP} + +-- | The @IPPROTO_IP@ protocol. +ip :: Protocol +ip = Protocol #{const IPPROTO_IP} + +-- | The @IPPROTO_IPV6@ protocol. +ipv6 :: Protocol +ipv6 = Protocol #{const IPPROTO_IPV6} + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,98 @@ +{-# language BangPatterns #-} +{-# language ScopedTypeVariables #-} + +import Test.Tasty +import Test.Tasty.HUnit +import Foreign.C.Error (Errno,errnoToIOError) +import Data.Primitive (ByteArray) +import Control.Concurrent (forkIO) +import Control.Monad (when) +import Foreign.C.Types (CInt,CSize) +import Control.Concurrent (threadWaitRead) + +import qualified GHC.Exts as E +import qualified Data.Primitive as PM +import qualified Data.Primitive.MVar as PM +import qualified Posix.Socket as S + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" + [ testGroup "sockets" + [ testCase "A" testSocketsA + , testCase "B" testSocketsB + , testCase "C" testSocketsC + , testCase "D" testSocketsD + ] + ] + +testSocketsA :: Assertion +testSocketsA = do + (a,b) <- demand =<< S.socketPair S.unix S.datagram S.defaultProtocol + m <- PM.newEmptyMVar + _ <- forkIO $ S.receiveByteArray b 5 mempty >>= PM.putMVar m + bytesSent <- demand =<< S.sendByteArray a sample 0 5 mempty + when (bytesSent /= 5) (fail "testSocketsA: bytesSent was wrong") + actual <- demand =<< PM.takeMVar m + sample @=? actual + +testSocketsB :: Assertion +testSocketsB = do + let limit = 10 + wordSz = PM.sizeOf (undefined :: Int) + cwordSz = fromIntegral wordSz :: CSize + (a,b) <- demand =<< S.socketPair S.unix S.datagram S.defaultProtocol + lock <- PM.newEmptyMVar + let go1 !(ix :: Int) !(n :: Int) = if (ix < limit) + then do + y <- PM.newByteArray wordSz + PM.writeByteArray y 0 (1 + n) + z <- PM.unsafeFreezeByteArray y + oneWord =<< demand =<< S.sendByteArray b z 0 cwordSz mempty + x <- demand =<< S.receiveByteArray b cwordSz mempty + go1 (ix + 1) (PM.indexByteArray x 0) + else pure n + go2 !(ix :: Int) = if (ix < limit) + then do + x <- demand =<< S.receiveByteArray a cwordSz mempty + y <- PM.newByteArray wordSz + PM.writeByteArray y 0 (1 + PM.indexByteArray x 0 :: Int) + z <- PM.unsafeFreezeByteArray y + oneWord =<< demand =<< S.sendByteArray a z 0 cwordSz mempty + go2 (ix + 1) + else PM.putMVar lock () + _ <- forkIO (go2 0) + r <- go1 0 0 + PM.takeMVar lock + 20 @=? r + +testSocketsC :: Assertion +testSocketsC = do + (a,b) <- demand =<< S.socketPair S.unix S.datagram S.defaultProtocol + m <- PM.newEmptyMVar + _ <- forkIO $ S.receiveByteArray a 5 mempty >>= PM.putMVar m + bytesSent <- demand =<< S.sendByteArray b sample 0 5 mempty + when (bytesSent /= 5) (fail "testSocketsC: bytesSent was wrong") + actual <- demand =<< PM.takeMVar m + sample @=? actual + +testSocketsD :: Assertion +testSocketsD = do + (a,b) <- demand =<< S.socketPair S.unix S.datagram S.defaultProtocol + _ <- forkIO $ do + bytesSent <- demand =<< S.sendByteArray b sample 0 5 mempty + when (bytesSent /= 5) (fail "testSocketsD: bytesSent was wrong") + actual <- demand =<< S.receiveByteArray a 5 mempty + sample @=? actual + +sample :: ByteArray +sample = E.fromList [1,2,3,4,5] + +demand :: Either Errno a -> IO a +demand = either (\e -> ioError (errnoToIOError "test" e Nothing Nothing)) pure + +oneWord :: CSize -> IO () +oneWord x = if x == fromIntegral (PM.sizeOf (undefined :: Int)) then pure () else fail "expected one machine word" +