diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,44 @@ +0.8.0.0 Lars Petersen 2017-02-25 + + * Issue 26: Show instances for `SocketException` and `AddressInfoException` + no longer use `strerror()` and `gai_strerror()`, but simply show the name + of the error code. Linking to `gai_strerror()` was problematic on Windows + and `strerror()` was not thread-safe on Linux. + + * Issue 38: Added SO_KEEPALIVE as `System.Socket.KeepAlive`. + + * Issue 37: Added TCP_NODELAY as `System.Socket.Protocol.TCP.NoDelay`. + + * Issue 40: Changed allocation function to malloPlainForeignPtr. + This mechanism used in the ByteString library is heavily optimised and + 2 - 2.5 times faster than the previous implementation. + See https://github.com/lpeterse/haskell-socket/pull/40 for details. + + * Issue 31: Added a `Default` protocol type. + + * Issue 27: Fixed a memory leak that manifested when interrupting threads + waiting on socket events. + + * Issue 25: The `awaitEvent: invalid argument` was caused by the forked-off + thread in `threadWaitRead`. The new code introduced by the changes caused + by issue 27 catches and swallows this exception in a sane way. + + * Renamed `unsafeSocketWaitRead/Write/Connected` to `waitRead/Write/Connected` + as these operations are not really unsafe, just internal. The operation + signatures changed due to issue 27. Also, documented Windows specific + implementation details. + + * The `connect` operation does no longer hold the lock on the socket while + waiting for connection establishment. + + * Refactored and adapted the `accept` operation for changes caused by issue 27. + Operation semantics shouldn't have changed. + + * Made `SocketAddress` an associated data family and added a + `Storable (SocketAddress f)` constraint to the `Family` class. This allows + omitting the `Storable` in socket operations (`Family` suffices now). It + should be compatible with all existing code and not require any changes. + 0.7.0.0 Lars Petersen 2016-11-13 * Added function `sendAllLazy` and `sendAllBuilder`. Changed the signature and diff --git a/CONTRIBUTORS.txt b/CONTRIBUTORS.txt --- a/CONTRIBUTORS.txt +++ b/CONTRIBUTORS.txt @@ -1,3 +1,7 @@ +Vyacheslav Hashov (issues #37, #38, #40, #41, #42) +Alexander Vershilov (fixed bug in GHC upstream) +Antom @SX91 (reported and helped with #27) +Lukas Epple (small fix in documentation) Erik Rantapaa (issue #19) Mathieu Boespflug (issue #15) Ben Gamari (issue #10) @@ -5,3 +9,4 @@ Michael Fox (reported issue #7) Bryan O'Sullivan (legitimately criticised the bizarre naming) Alex Högy (reported the MSG_NOSIGNAL issue on OSX) +Lars Petersen diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,11 +4,12 @@ [![Available on Hackage][badge-hackage]][hackage] [![License MIT][badge-license]][license] [![Build Status][badge-travis]][travis] +[![AppVeyor][badge-appveyor]][appveyor] ### Motivation -This library aims to expose a minimal and cross platform interface for -POSIX compliant networking code. +This library aims to expose a minimal and cross-platform interface for +BSD style networking code. ### Implementation Philosophy @@ -51,8 +52,9 @@ This workaround may be removed if someone is willing to sacrifice to improve the IO manager on Windows. -Each release is manually tested on a Windows 10 virtual machine with the -latest Haskell Platform (64bit). +Each commit and release is automatically tested with +[AppVeyor](https://ci.appveyor.com/project/lpeterse/haskell-socket) continuous +integration. #### MacOS @@ -69,20 +71,15 @@ The project uses [tasty](http://documentup.com/feuerbach/tasty) for testing. -There are two test suites: `default` and `threaded` which are using the same -code. Only difference is that one is compiled against GHC's single threaded RTS -and the other against the multi-threaded one. Run `cabal test` to run both -in sequence. - -In order to see details and colored output you may also want to try - -```bash -ghc --make test/test.hs && ./test/test -``` +There are two test suites: `default` and `threaded` which share the same +code. The only difference is that one is compiled against GHC's single threaded +RTS and the other against the multi-threaded one. Run `cabal test` or `stack test` +to execute both in sequence. [badge-travis]: https://img.shields.io/travis/lpeterse/haskell-socket.svg [travis]: https://travis-ci.org/lpeterse/haskell-socket [badge-hackage]: https://img.shields.io/hackage/v/socket.svg?dummy +[badge-appveyor]: https://ci.appveyor.com/api/projects/status/i2il3a616s9yy48k/branch/master?svg=true [hackage]: https://hackage.haskell.org/package/socket [badge-license]: https://img.shields.io/badge/license-MIT-green.svg?dummy [license]: https://github.com/lpeterse/haskell-socket/blob/master/LICENSE diff --git a/platform/linux/include/hs_socket.h b/platform/linux/include/hs_socket.h --- a/platform/linux/include/hs_socket.h +++ b/platform/linux/include/hs_socket.h @@ -1,6 +1,7 @@ #define _GNU_SOURCE #include +#include #include #include #include @@ -9,6 +10,7 @@ #include "sys/socket.h" #include "sys/un.h" #include "netinet/in.h" +#include #include "netdb.h" int hs_socket (int domain, int type, int protocol, int *err); diff --git a/platform/linux/src/System/Socket/Internal/Platform.hsc b/platform/linux/src/System/Socket/Internal/Platform.hsc --- a/platform/linux/src/System/Socket/Internal/Platform.hsc +++ b/platform/linux/src/System/Socket/Internal/Platform.hsc @@ -1,36 +1,65 @@ -module System.Socket.Internal.Platform where +-------------------------------------------------------------------------------- +-- | +-- Module : System.Socket.Internal.Platform +-- Copyright : (c) Lars Petersen 2015 +-- License : MIT +-- +-- Maintainer : info@lars-petersen.net +-- Stability : experimental +-------------------------------------------------------------------------------- +module System.Socket.Internal.Platform + ( waitRead, waitWrite, waitConnected, c_socket, c_close, c_connect, + c_accept, c_bind, c_listen, c_recv, c_recvfrom, c_send, c_sendto, + c_freeaddrinfo, c_getaddrinfo, c_getnameinfo, c_memset, c_gai_strerror, + c_setsockopt, c_getsockopt) where -import Control.Monad (join) +import Control.Monad ( when, unless ) +import Control.Concurrent.MVar +import Control.Concurrent ( threadWaitRead, threadWaitWrite, + threadWaitReadSTM, threadWaitWriteSTM, + forkIO, rtsSupportsBoundThreads, killThread ) +import Control.Exception ( bracketOnError, mapException, throwIO, + catch, SomeException(..) ) import Foreign.Ptr import Foreign.C.Types import Foreign.C.String -import GHC.Conc (threadWaitReadSTM, threadWaitWriteSTM, atomically) +import GHC.Conc.Sync ( STM, atomically ) import System.Posix.Types ( Fd(..) ) +import System.Socket.Internal.Socket import System.Socket.Internal.Message +import System.Socket.Internal.Exception #include "hs_socket.h" -unsafeSocketWaitWrite :: Fd -> Int -> IO (IO ()) -unsafeSocketWaitWrite fd _ = do - threadWaitWriteSTM fd >>= return . atomically . fst +waitRead :: Socket f t p -> Int -> IO () +waitRead s _ = wait s threadWaitRead threadWaitReadSTM --- | Blocks until a socket should be tried for reading. --- --- > safeSocketWaitRead = do --- > wait <- withMVar msock $ \sock-> do --- > -- Register while holding a lock on the socket descriptor. --- > unsafeSocketWaitRead sock 0 --- > -- Do the waiting without keeping the socket descriptor locked. --- > wait -unsafeSocketWaitRead :: Fd -- ^ Socket descriptor - -> Int -- ^ How many times has it been tried unsuccessfully so far? (currently only relevant on Windows) - -> IO (IO ()) -- ^ The outer action registers the waiting, the inner does the actual wait. -unsafeSocketWaitRead fd _ = do - threadWaitReadSTM fd >>= return . atomically . fst +waitWrite :: Socket f t p -> Int -> IO () +waitWrite s _ = wait s threadWaitWrite threadWaitWriteSTM -unsafeSocketWaitConnected :: Fd -> IO () -unsafeSocketWaitConnected fd = do - join $ unsafeSocketWaitWrite fd 0 +waitConnected :: Socket f t p -> IO () +waitConnected = flip waitWrite 0 + +wait :: Socket f t p -> (Fd -> IO ()) -> (Fd -> IO (STM (), IO ())) -> IO () +wait (Socket mfd) threadWait threadWaitSTM + | rtsSupportsBoundThreads = mapException + ( const eBadFileDescriptor :: IOError -> SocketException ) + ( bracketOnError + ( withMVar mfd $ \fd -> do + when (fd < 0) (throwIO eBadFileDescriptor) + threadWaitSTM fd + ) snd ( atomically . fst ) + ) + | otherwise = do + m <- newEmptyMVar + bracketOnError + ( withMVar mfd $ \fd-> do + when (fd < 0) (throwIO eBadFileDescriptor) + forkIO $ catch + ( threadWait fd >> putMVar m True ) + ( \(SomeException _)-> putMVar m False ) + ) killThread + ( const $ takeMVar m >>= flip unless (throwIO eBadFileDescriptor) ) type CSSize = CInt diff --git a/platform/win32/cbits/hs_socket.c b/platform/win32/cbits/hs_socket.c --- a/platform/win32/cbits/hs_socket.c +++ b/platform/win32/cbits/hs_socket.c @@ -167,10 +167,6 @@ return i; }; -const char *hs_gai_strerror(int errcode) { - return gai_strerror(errcode); -}; - int hs_getaddrinfo(const char *node, const char *service, const struct addrinfo *hints, struct addrinfo **res) { diff --git a/platform/win32/include/hs_socket.h b/platform/win32/include/hs_socket.h --- a/platform/win32/include/hs_socket.h +++ b/platform/win32/include/hs_socket.h @@ -103,8 +103,6 @@ void hs_freeaddrinfo(struct addrinfo *res); -const char *hs_gai_strerror(int errcode); - #define SEOK 0 #define SEINTR WSAEINTR #define SEAGAIN WSATRY_AGAIN diff --git a/platform/win32/src/System/Socket/Internal/Platform.hsc b/platform/win32/src/System/Socket/Internal/Platform.hsc --- a/platform/win32/src/System/Socket/Internal/Platform.hsc +++ b/platform/win32/src/System/Socket/Internal/Platform.hsc @@ -1,45 +1,83 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.Socket.Internal.Platform +-- Copyright : (c) Lars Petersen 2015 +-- License : MIT +-- +-- Maintainer : info@lars-petersen.net +-- Stability : experimental +-------------------------------------------------------------------------------- module System.Socket.Internal.Platform where import Control.Concurrent ( threadDelay ) -import Control.Concurrent.MVar ( MVar, withMVar ) +import Control.Concurrent.MVar ( withMVar ) import Control.Exception ( throwIO ) import Control.Monad ( when ) - import Data.Bits - import Foreign.Ptr import Foreign.C.Types import Foreign.C.String import Foreign.Storable import Foreign.Marshal - import System.Posix.Types ( Fd(..) ) - +import System.Socket.Internal.Socket import System.Socket.Internal.Message import System.Socket.Internal.Exception -unsafeSocketWaitWrite :: Fd -> Int -> IO (IO ()) -unsafeSocketWaitWrite _ iteration = do - return (threadDelay $ 1 `shiftL` min iteration 20) +-- | Wait until the socket becomes readable (Windows specific version). +-- +-- This operation does not actually do anything with the socket. It just +-- calls `threadDelay` with a delay exponentially increasing in the second +-- parameter (0 => 1μs, 20 or greater => 1s). When the operation returns, +-- the socket shall be tried to read from - it does not imply that there is +-- actually data to read and it might be necessary to wait again! +-- +-- On Windows, socket descriptors don't behave like file +-- descriptors, but require a specific select mechanism. Unfortunately, +-- this is not (yet) implemented in GHC's RTS and it cannot be called from here +-- as it would block. +-- +-- In practice, this means that your application may suffer from reduced +-- responsibility (up to 1s in case the socket has not seen events for 20 +-- cycles). Usually, this is only the case for the first of several sequential +-- reads from a socket. Subsequent reads will be executed without delay until +-- there is no more data to read, so it is still possible to achieve high +-- throughput. The central achievement of this approach is that all socket +-- operations offered by the library are interruptable and no special +-- considerations (apart the from one above) apply when running socket code on +-- Windows. +waitRead :: Socket f t p -> Int -> IO () +waitRead _ iteration = + threadDelay $ 1 `shiftL` min iteration 20 -unsafeSocketWaitRead :: Fd -> Int -> IO (IO ()) -unsafeSocketWaitRead _ iteration = do - return (threadDelay $ 1 `shiftL` min iteration 20) +-- | Wait until the socket becomes writable (Windows specific version). +-- +-- See `waitRead` for technical details. +waitWrite :: Socket f t p -> Int -> IO () +waitWrite _ iteration = + threadDelay $ 1 `shiftL` min iteration 20 -unsafeSocketWaitConnected :: Fd -> IO () -unsafeSocketWaitConnected fd = +-- | Wait until the socket is confirmed to be connected (Windows specific version). +-- +-- This operation uses an exponential-backoff algorithm as described in +-- `waitRead`. On each iteration `select` is called with a minmal timeout +-- to poll the connection status. This approach keeps the operation interruptable. +waitConnected :: Socket f t p -> IO () +waitConnected (Socket mfd) = alloca $ \errPtr-> loop errPtr 0 where loop errPtr iteration = do - i <- c_connect_status fd errPtr - when (i /= 0) $ case i of - 1 -> do - -- Wait with exponential backoff. - threadDelay $ 1 `shiftL` min iteration 20 - -- Try again. - loop errPtr $! iteration + 1 - _ -> do - SocketException <$> peek errPtr >>= throwIO + i <- withMVar mfd $ \fd-> do + when (fd < 0) (throwIO eBadFileDescriptor) + c_connect_status fd errPtr + case i of + 0 -> return () + 1 -> do + -- Wait with exponential backoff. + threadDelay $ 1 `shiftL` min iteration 20 + -- Try again. + loop errPtr $! iteration + 1 + _ -> SocketException <$> peek errPtr >>= throwIO type CSSize = CInt @@ -94,6 +132,3 @@ foreign import ccall safe "hs_getnameinfo" c_getnameinfo :: Ptr a -> CInt -> CString -> CInt -> CString -> CInt -> CInt -> IO CInt - -foreign import ccall unsafe "hs_gai_strerror" - c_gai_strerror :: CInt -> IO CString diff --git a/socket.cabal b/socket.cabal --- a/socket.cabal +++ b/socket.cabal @@ -1,5 +1,5 @@ name: socket -version: 0.7.0.0 +version: 0.8.0.0 synopsis: An extensible socket library. description: This library is a minimal cross-platform interface for @@ -36,8 +36,10 @@ , System.Socket.Type.SequentialPacket , System.Socket.Protocol.UDP , System.Socket.Protocol.TCP + , System.Socket.Protocol.Default , System.Socket.Unsafe other-modules: System.Socket.Internal.Socket + , System.Socket.Internal.SocketOption , System.Socket.Internal.Exception , System.Socket.Internal.Message , System.Socket.Internal.AddressInfo diff --git a/src/System/Socket.hsc b/src/System/Socket.hsc --- a/src/System/Socket.hsc +++ b/src/System/Socket.hsc @@ -124,24 +124,25 @@ , eaiSystem ) where +import Control.Applicative ( (<$>) ) import Control.Exception import Control.Monad -import Control.Applicative import Control.Concurrent import Data.Function import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS - -import GHC.Conc (closeFdWith) +import qualified Data.ByteString.Internal as BS -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Alloc +import GHC.Conc ( closeFdWith ) + +import Foreign.Storable +import Foreign.Marshal.Alloc import System.Socket.Unsafe import System.Socket.Internal.Socket +import System.Socket.Internal.SocketOption import System.Socket.Internal.Exception import System.Socket.Internal.Message import System.Socket.Internal.AddressInfo @@ -153,13 +154,15 @@ -- -- Whereas the underlying POSIX socket operation takes 3 parameters, this library -- encodes this information in the type variables. This rules out several --- kinds of errors and escpecially simplifies the handling of addresses (by using --- associated type families). Examples: +-- kinds of errors and especially simplifies the handling of addresses (by using +-- associated data families). Examples: -- --- > -- create a IPv4-UDP-datagram socket +-- > -- create an IPv4-UDP-datagram socket -- > sock <- socket :: IO (Socket Inet Datagram UDP) --- > -- create a IPv6-TCP-streaming socket +-- > -- create an IPv6-TCP-streaming socket -- > sock6 <- socket :: IO (Socket Inet6 Stream TCP) +-- > -- create an IPv6-streaming socket with default protocol (usually TCP) +-- > sock6 <- socket :: IO (Socket Inet6 Strem Default) -- -- - This operation sets up a finalizer that automatically closes the socket -- when the garbage collection decides to collect it. This is just a @@ -174,13 +177,12 @@ -- > somethingWith sock -- your computation here -- > return somethingelse -- --- -- - This operation configures the socket non-blocking to work seamlessly -- with the runtime system's event notification mechanism. -- - This operation can safely deal with asynchronous exceptions without -- leaking file descriptors. --- - This operation throws `SocketException`s. Consult your @man@ page for --- details and specific @errno@s. +-- - This operation throws `SocketException`s. Consult your @man socket@ for +-- details and specific errors. socket :: (Family f, Type t, Protocol p) => IO (Socket f t p) socket = socket' where @@ -206,37 +208,41 @@ -- - This operation returns as soon as a connection has been established (as -- if the socket were blocking). The connection attempt has either failed or -- succeeded after this operation threw an exception or returned. --- - The socket is locked throughout the whole operation. -- - The operation throws `SocketException`s. Calling `connect` on a `close`d -- socket throws `eBadFileDescriptor` even if the former file descriptor has -- been reassigned. -connect :: (Family f, Storable (SocketAddress f)) => Socket f t p -> SocketAddress f -> IO () -connect (Socket mfd) addr = - withMVar mfd $ \fd-> do - when (fd < 0) (throwIO eBadFileDescriptor) - alloca $ \addrPtr-> alloca $ \errPtr-> do - poke addrPtr addr - let addrLen = fromIntegral (sizeOf addr) - -- The actual connection attempt. - i <- c_connect fd addrPtr addrLen errPtr - -- On non-blocking sockets we expect to get EINPROGRESS or EWOULDBLOCK. - when (i /= 0) $ do - err <- SocketException <$> peek errPtr - if err == eInProgress || err == eWouldBlock - then do - -- The manpage says that in this case the connection - -- shall be established asynchronously and one is - -- supposed to wait. - unsafeSocketWaitConnected fd - -- At least on Linux a second connect after signaled writeability - -- will not fail (the next one would). - i' <- c_connect fd addrPtr addrLen errPtr - when (i' /= 0) $ do - err' <- SocketException <$> peek errPtr - -- On Windows, the second connect fails with `eIsConnected`. - -- In our case this is not an error condition - other errors are. - when (err' /= eIsConnected) (throwIO err') - else throwIO err +connect :: (Family f) => Socket f t p -> SocketAddress f -> IO () +connect s@(Socket mfd) addr = + alloca $ \addrPtr-> alloca $ \errPtr-> do + poke addrPtr addr + let addrLen = fromIntegral (sizeOf addr) + -- The actual connection attempt. + i <- withMVar mfd $ \fd-> do + when (fd < 0) (throwIO eBadFileDescriptor) + c_connect fd addrPtr addrLen errPtr + -- On non-blocking sockets we expect to get EINPROGRESS or EWOULDBLOCK. + when (i /= 0) $ do + err <- SocketException <$> peek errPtr + if err == eInProgress || err == eWouldBlock + then do + -- The manpage says that in this case the connection + -- shall be established asynchronously and one is + -- supposed to wait. + waitConnected s + -- We need to issue a second connect call to get the correct error + -- code in case the connection has been refused etc. + -- At least on Linux a second connect after signaled writeability + -- will not fail in case the connection has been established + -- sucessfully (the next one would). + i' <- withMVar mfd $ \fd-> do + when (fd < 0) (throwIO eBadFileDescriptor) + c_connect fd addrPtr addrLen errPtr + when (i' /= 0) $ do + err' <- SocketException <$> peek errPtr + -- On Windows, the second connect fails with `eIsConnected`. + -- In our case this is not an error condition - other errors are. + when (err' /= eIsConnected) (throwIO err') + else throwIO err -- | Bind a socket to an address. -- @@ -248,7 +254,7 @@ -- [argued here](http://stackoverflow.com/a/14485305). -- - This operation throws `SocketException`s. Consult your @man@ page for -- details and specific @errno@s. -bind :: (Family f, Storable (SocketAddress f)) => Socket f t p -> SocketAddress f -> IO () +bind :: (Family f) => Socket f t p -> SocketAddress f -> IO () bind (Socket mfd) addr = alloca $ \addrPtr-> alloca $ \errPtr-> do poke addrPtr addr @@ -257,15 +263,15 @@ when (i /= 0) (SocketException <$> peek errPtr >>= throwIO) -- | Starts listening and queueing connection requests on a connection-mode --- socket. +-- socket. The second parameter determines the backlog size. -- --- - Calling `listen` on a `close`d socket throws `eBadFileDescriptor` even if the former --- file descriptor has been reassigned. +-- - Calling `listen` on a `close`d socket throws `eBadFileDescriptor` even +-- if the former file descriptor has been reassigned. -- - The second parameter is called /backlog/ and sets a limit on how many --- unaccepted connections the socket implementation shall queue. A value +-- unaccepted connections the transport implementation shall queue. A value -- of @0@ leaves the decision to the implementation. --- - This operation throws `SocketException`s. Consult your @man@ page for --- details and specific @errno@s. +-- - This operation throws `SocketException`s. Consult your @man listen@ for +-- details and specific errors. listen :: Socket f t p -> Int -> IO () listen (Socket ms) backlog = withMVar ms $ \s-> alloca $ \errPtr-> do @@ -274,75 +280,75 @@ -- | Accept a new connection. -- --- - Calling `accept` on a `close`d socket throws `eBadFileDescriptor` even if the former --- file descriptor has been reassigned. --- - This operation configures the new socket non-blocking (TODO: use `accept4` if available). +-- - Calling `accept` on a `close`d socket throws `eBadFileDescriptor` even +-- if the former file descriptor has been reassigned. +-- - This operation configures the new socket non-blocking. It uses `accept4` +-- (when available) in order to accept and set the socket non-blocking with +-- a single system call. -- - This operation sets up a finalizer for the new socket that automatically -- closes the new socket when the garbage collection decides to collect it. -- This is just a fail-safe. You might still run out of file descriptors as -- there's no guarantee about when the finalizer is run. You're advised to -- manually `close` the socket when it's no longer needed. --- - This operation throws `SocketException`s. Consult your @man@ page for --- details and specific @errno@s. --- - This operation catches `eAgain`, `eWouldBlock` and `eInterrupted` internally --- and retries automatically. -accept :: (Family f, Storable (SocketAddress f)) => Socket f t p -> IO (Socket f t p, SocketAddress f) +-- - This operation throws `SocketException`s. +-- - This operation catches `eAgain`, `eWouldBlock` and `eInterrupted` +-- internally and retries automatically. +accept :: (Family f) => Socket f t p -> IO (Socket f t p, SocketAddress f) accept s@(Socket mfd) = accept' where - accept' :: forall f t p. (Family f, Storable (SocketAddress f)) => IO (Socket f t p, SocketAddress f) + accept' :: forall f t p. (Family f) => IO (Socket f t p, SocketAddress f) accept' = do -- Allocate local (!) memory for the address. - alloca $ \addrPtr-> do - alloca $ \addrPtrLen-> alloca $ \errPtr-> do - poke addrPtrLen (fromIntegral $ sizeOf (undefined :: SocketAddress f)) - ( fix $ \again iteration-> do - -- We mask asynchronous exceptions during this critical section. - ews <- withMVar mfd $ \fd-> do - when (fd < 0) (throwIO eBadFileDescriptor) - bracketOnError - ( c_accept fd addrPtr addrPtrLen errPtr ) - ( \ft-> when (ft >= 0) $ alloca $ void . c_close ft ) - ( \ft-> if ft < 0 - then do - err <- SocketException <$> peek errPtr - unless (err == eWouldBlock || err == eAgain) (throwIO err) - wait <- unsafeSocketWaitRead fd iteration - return $ Left wait - else do - addr <- peek addrPtr :: IO (SocketAddress f) - -- newMVar is guaranteed to be not interruptible. - mft <- newMVar ft - -- Register a finalizer on the new socket. - _ <- mkWeakMVar mft (close (Socket mft `asTypeOf` s)) - return $ Right (Socket mft, addr) - ) - -- If ews is Left we got EAGAIN or EWOULDBLOCK and retry after the next event. - case ews of - Left wait -> wait >> (again $! iteration + 1) - Right sock -> return sock - ) 0 -- This is the initial iteration value. + alloca $ \addrPtr-> alloca $ \addrPtrLen-> alloca $ \errPtr-> do + poke addrPtrLen (fromIntegral $ sizeOf (undefined :: SocketAddress f)) + ( fix $ \again iteration-> do + msa <- withMVar mfd $ \fd-> do + when (fd < 0) (throwIO eBadFileDescriptor) + bracketOnError + ( c_accept fd addrPtr addrPtrLen errPtr ) + ( \ft-> when (ft >= 0) $ alloca $ void . c_close ft ) + ( \ft-> if ft < 0 + then do + err <- SocketException <$> peek errPtr + -- EWOULDBLOCK and EAGAIN are valid in case there a no + -- queued connections at the moment and we are supposed to + -- wait. All other errors are unexpected and we throw them. + unless (err == eWouldBlock || err == eAgain) (throwIO err) + return Nothing + else do + addr <- peek addrPtr :: IO (SocketAddress f) + s'@(Socket mft) <- Socket <$> newMVar ft + -- Register a finalizer on the new socket. + _ <- mkWeakMVar mft (close s') + return $ Just (s', addr) + ) + -- If ews is Left we got EAGAIN or EWOULDBLOCK and retry after the next event. + case msa of + Just sa -> return sa + Nothing -> waitRead s iteration >> (again $! iteration + 1) + ) 0 -- This is the initial iteration value. --- | Send a message on a connected socket. +-- | Send data. -- -- - Calling `send` on a `close`d socket throws `eBadFileDescriptor` even if the former -- file descriptor has been reassigned. --- - The operation returns the number of bytes sent. On `Datagram` and --- `SequentialPacket` sockets certain assurances on atomicity exist and `eAgain` or --- `eWouldBlock` are returned until the whole message would fit --- into the send buffer. --- - This operation throws `SocketException`s. Consult @man 3p send@ for --- details and specific @errno@s. +-- - The operation returns the number of bytes sent. On `System.Socket.Type.Datagram` +-- and `System.Socket.Type.SequentialPacket` sockets certain assurances on +-- atomicity exist and `eAgain` or `eWouldBlock` are thrown until the +-- whole message would fit into the send buffer. +-- - This operation throws `SocketException`s. Consult @man send@ for +-- details and specific errors. -- - `eAgain`, `eWouldBlock` and `eInterrupted` and handled internally and won't -- be thrown. For performance reasons the operation first tries a write -- on the socket and then waits when it got `eAgain` or `eWouldBlock`. send :: Socket f t p -> BS.ByteString -> MessageFlags -> IO Int send s bs flags = do bytesSent <- BS.unsafeUseAsCStringLen bs $ \(bufPtr,bufSize)-> - unsafeSend s (castPtr bufPtr) (fromIntegral bufSize) flags + unsafeSend s bufPtr (fromIntegral bufSize) flags return (fromIntegral bytesSent) -- | Like `send`, but allows to specify a destination address. -sendTo ::(Family f, Storable (SocketAddress f)) => Socket f t p -> BS.ByteString -> MessageFlags -> SocketAddress f -> IO Int +sendTo ::(Family f) => Socket f t p -> BS.ByteString -> MessageFlags -> SocketAddress f -> IO Int sendTo s bs flags addr = do bytesSent <- alloca $ \addrPtr-> do poke addrPtr addr @@ -350,44 +356,39 @@ unsafeSendTo s bufPtr (fromIntegral bufSize) flags addrPtr (fromIntegral $ sizeOf addr) return (fromIntegral bytesSent) --- | Receive a message on a connected socket. +-- | Receive data. -- --- - Calling `receive` on a `close`d socket throws `eBadFileDescriptor` even if the former file descriptor has been reassigned. -- - The operation takes a buffer size in bytes a first parameter which -- limits the maximum length of the returned `Data.ByteString.ByteString`. --- - This operation throws `SocketException`s. Consult @man 3p receive@ for --- details and specific @errno@s. +-- - When an empty `Data.ByteString.ByteString` is returned this usally +-- (protocol specific) means that the peer gracefully closed the connection. +-- The user is advised to check for and handle this case. +-- - Calling `receive` on a `close`d socket throws `eBadFileDescriptor` even +-- if the former file descriptor has been reassigned. +-- - This operation throws `SocketException`s. Consult @man recv@ for +-- details and specific errors. -- - `eAgain`, `eWouldBlock` and `eInterrupted` and handled internally and won't be thrown. -- For performance reasons the operation first tries a read --- on the socket and then waits when it got `eAgain` or `eWouldBlock`. +-- on the socket and then waits when it got `eAgain` or `eWouldBlock` until +-- the socket is signaled to be readable. receive :: Socket f t p -> Int -> MessageFlags -> IO BS.ByteString -receive s bufSize flags = - bracketOnError - ( mallocBytes bufSize ) - (\bufPtr-> free bufPtr ) - (\bufPtr-> do - bytesReceived <- unsafeReceive s bufPtr (fromIntegral bufSize) flags - BS.unsafePackMallocCStringLen (bufPtr, fromIntegral bytesReceived) - ) - +receive s bufSize flags = + BS.createUptoN bufSize $ \bufPtr-> + fromIntegral `fmap` unsafeReceive s bufPtr (fromIntegral bufSize) flags + -- | Like `receive`, but additionally yields the peer address. -receiveFrom :: (Family f, Storable (SocketAddress f)) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f) +receiveFrom :: (Family f) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f) receiveFrom = receiveFrom' where - receiveFrom' :: forall f t p. (Family f, Storable (SocketAddress f)) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f) + receiveFrom' :: forall f t p. (Family f) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f) receiveFrom' s bufSize flags = do alloca $ \addrPtr-> do alloca $ \addrSizePtr-> do - poke addrSizePtr (fromIntegral $ sizeOf (undefined :: SocketAddress f)) - bracketOnError - ( mallocBytes bufSize ) - (\bufPtr-> free bufPtr ) - (\bufPtr-> do - bytesReceived <- unsafeReceiveFrom s bufPtr (fromIntegral bufSize) flags addrPtr addrSizePtr - addr <- peek addrPtr - bs <- BS.unsafePackMallocCStringLen (bufPtr, fromIntegral bytesReceived) - return (bs, addr) - ) + poke addrSizePtr (fromIntegral $ sizeOf (undefined :: SocketAddress f)) + bs <- BS.createUptoN bufSize $ \bufPtr-> + fromIntegral `fmap` unsafeReceiveFrom s bufPtr (fromIntegral bufSize) flags addrPtr addrSizePtr + addr <- peek addrPtr + return (bs, addr) -- | Closes a socket. -- @@ -395,7 +396,7 @@ -- If it throws an exception it is presumably a not recoverable situation and the process should exit. -- - This operation does not block. -- - This operation wakes up all threads that are currently blocking on this --- socket. All other threads are guaranteed not to block on operations on this socket in the future. +-- socket. All other threads are guaranteed to not block on operations on this socket in the future. -- Threads that perform operations other than `close` on this socket will fail with `eBadFileDescriptor` -- after the socket has been closed (`close` replaces the -- `System.Posix.Types.Fd` in the `Control.Concurrent.MVar.MVar` with @-1@ diff --git a/src/System/Socket/Family/Inet.hsc b/src/System/Socket/Family/Inet.hsc --- a/src/System/Socket/Family/Inet.hsc +++ b/src/System/Socket/Family/Inet.hsc @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving #-} -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Family.Inet -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- @@ -59,18 +59,17 @@ instance Family Inet where familyNumber _ = (#const AF_INET) - --- | An [IPv4](https://en.wikipedia.org/wiki/IPv4) socket address. --- --- The socket address contains a port number that may be used by transport --- protocols like [TCP](https://en.wikipedia.org/wiki/Transmission_Control_Protocol). --- --- > SocketAddressInet inetLoopback 8080 -data instance SocketAddress Inet - = SocketAddressInet - { inetAddress :: InetAddress - , inetPort :: InetPort - } deriving (Eq, Show) + -- | An [IPv4](https://en.wikipedia.org/wiki/IPv4) socket address. + -- + -- The socket address contains a port number that may be used by transport + -- protocols like [TCP](https://en.wikipedia.org/wiki/Transmission_Control_Protocol). + -- + -- > SocketAddressInet inetLoopback 8080 + data SocketAddress Inet + = SocketAddressInet + { inetAddress :: InetAddress + , inetPort :: InetPort + } deriving (Eq, Show) -- | To avoid errors with endianess it was decided to keep this type abstract. -- diff --git a/src/System/Socket/Family/Inet6.hsc b/src/System/Socket/Family/Inet6.hsc --- a/src/System/Socket/Family/Inet6.hsc +++ b/src/System/Socket/Family/Inet6.hsc @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving #-} -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Family.Inet6 -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- @@ -46,6 +46,7 @@ import Foreign.Storable import System.Socket.Internal.Socket +import System.Socket.Internal.SocketOption import System.Socket.Internal.Platform #include "hs_socket.h" @@ -54,25 +55,24 @@ #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) #endif --- | The [Internet Protocol version 4](https://en.wikipedia.org/wiki/IPv4). +-- | The [Internet Protocol version 6](https://en.wikipedia.org/wiki/IPv6). data Inet6 instance Family Inet6 where familyNumber _ = (#const AF_INET6) - --- | An [IPv6](https://en.wikipedia.org/wiki/IPv6) socket address. --- --- The socket address contains a port number that may be used by transport --- protocols like [TCP](https://en.wikipedia.org/wiki/Transmission_Control_Protocol). --- --- > SocketAddressInet6 inet6Loopback 8080 0 0 -data instance SocketAddress Inet6 - = SocketAddressInet6 - { inet6Address :: Inet6Address - , inet6Port :: Inet6Port - , inet6FlowInfo :: Inet6FlowInfo - , inet6ScopeId :: Inet6ScopeId - } deriving (Eq, Show) + -- | An [IPv6](https://en.wikipedia.org/wiki/IPv6) socket address. + -- + -- The socket address contains a port number that may be used by transport + -- protocols like [TCP](https://en.wikipedia.org/wiki/Transmission_Control_Protocol). + -- + -- > SocketAddressInet6 inet6Loopback 8080 0 0 + data SocketAddress Inet6 + = SocketAddressInet6 + { inet6Address :: Inet6Address + , inet6Port :: Inet6Port + , inet6FlowInfo :: Inet6FlowInfo + , inet6ScopeId :: Inet6ScopeId + } deriving (Eq, Show) -- | To avoid errors with endianess it was decided to keep this type abstract. -- diff --git a/src/System/Socket/Internal/AddressInfo.hsc b/src/System/Socket/Internal/AddressInfo.hsc --- a/src/System/Socket/Internal/AddressInfo.hsc +++ b/src/System/Socket/Internal/AddressInfo.hsc @@ -2,7 +2,7 @@ FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving #-} -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Internal.AddressInfo -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- @@ -54,8 +54,6 @@ import Foreign.C.String import Foreign.Marshal.Alloc -import System.IO.Unsafe - import System.Socket.Family.Inet import System.Socket.Family.Inet6 import System.Socket.Internal.Socket @@ -67,10 +65,6 @@ #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) #endif -------------------------------------------------------------------------------- --- AddressInfo -------------------------------------------------------------------------------- - data AddressInfo f t p = AddressInfo { addressInfoFlags :: AddressInfoFlags @@ -85,24 +79,33 @@ -- AddressInfoException ------------------------------------------------------------------------------- --- | Contains the error code that can be matched against. Use `show` --- to get a human readable explanation of the error. +-- | Contains the error code that can be matched against. +-- +-- Hint: Use guards or @MultiWayIf@ to match against specific exceptions: +-- +-- > if | e == eaiFail -> ... +-- > | e == eaiNoName -> ... +-- > | otherwise -> ... newtype AddressInfoException = AddressInfoException CInt deriving (Eq, Typeable) instance Show AddressInfoException where - show e = "AddressInfoException \"" ++ gaiStrerror e ++ "\"" + show e + | e == eaiAgain = "eaiAgain" + | e == eaiBadFlags = "eaiBadFlags" + | e == eaiFail = "eaiFail" + | e == eaiFamily = "eaiFamily" + | e == eaiMemory = "eaiMemory" + | e == eaiNoName = "eaiNoName" + | e == eaiService = "eaiService" + | e == eaiSocketType = "eaiSocketType" + | e == eaiSystem = "eaiSystem" + | otherwise = let AddressInfoException n = e + in "AddressInfoException " ++ show n instance Exception AddressInfoException --- | A wrapper around @gai_strerror@. -gaiStrerror :: AddressInfoException -> String -gaiStrerror (AddressInfoException e) = - unsafePerformIO $ do - msgPtr <- c_gai_strerror e - peekCString msgPtr - -- | > AddressInfoException "Temporary failure in name resolution" eaiAgain :: AddressInfoException eaiAgain = AddressInfoException (#const EAI_AGAIN) @@ -156,9 +159,9 @@ aiAddressConfig :: AddressInfoFlags aiAddressConfig = AddressInfoFlags (#const AI_ADDRCONFIG) --- | @AI_ALL@: Return both IPv4 (as mapped `SocketAddressInet6`) and IPv6 addresses when --- `aiV4Mapped` is set independent of whether IPv6 addresses exist for this --- name. +-- | @AI_ALL@: Return both IPv4 (as v4-mapped IPv6 address) and IPv6 addresses +-- when `aiV4Mapped` is set independent of whether IPv6 addresses exist for +-- this name. aiAll :: AddressInfoFlags aiAll = AddressInfoFlags (#const AI_ALL) @@ -216,8 +219,9 @@ niNumericService :: NameInfoFlags niNumericService = NameInfoFlags (#const NI_NUMERICSERV) +-- | This class is for address families that support name resolution. class (Family f) => HasAddressInfo f where - -- | Maps names to addresses (i.e. by DNS lookup). +-- | Maps names to addresses (i.e. by DNS lookup). -- -- The operation throws `AddressInfoException`s. -- @@ -312,13 +316,14 @@ , serviceName :: BS.ByteString } deriving (Eq, Show) --- | Maps addresses to readable host- and service names. --- --- The operation throws `AddressInfoException`s. --- --- > > getNameInfo (SocketAddressInet inetLoopback 80) mempty --- > NameInfo {hostName = "localhost.localdomain", serviceName = "http"} +-- | This class is for address families that support reverse name resolution. class (Family f) => HasNameInfo f where + -- | (Reverse-)map an address back to a human-readable host- and service name. + -- + -- The operation throws `AddressInfoException`s. + -- + -- > > getNameInfo (SocketAddressInet inetLoopback 80) mempty + -- > NameInfo {hostName = "localhost.localdomain", serviceName = "http"} getNameInfo :: SocketAddress f -> NameInfoFlags -> IO NameInfo instance HasNameInfo Inet where diff --git a/src/System/Socket/Internal/Exception.hsc b/src/System/Socket/Internal/Exception.hsc --- a/src/System/Socket/Internal/Exception.hsc +++ b/src/System/Socket/Internal/Exception.hsc @@ -1,14 +1,51 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Internal.Exception -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- -- Maintainer : info@lars-petersen.net -- Stability : experimental -------------------------------------------------------------------------------- -module System.Socket.Internal.Exception where +module System.Socket.Internal.Exception + ( SocketException (..) + , eOk + , eInterrupted + , eBadFileDescriptor + , eInvalid + , ePipe + , eWouldBlock + , eAgain + , eNotSocket + , eDestinationAddressRequired + , eMessageSize + , eProtocolType + , eNoProtocolOption + , eProtocolNotSupported + , eSocketTypeNotSupported + , eOperationNotSupported + , eProtocolFamilyNotSupported + , eAddressFamilyNotSupported + , eAddressInUse + , eAddressNotAvailable + , eNetworkDown + , eNetworkUnreachable + , eNetworkReset + , eConnectionAborted + , eConnectionReset + , eNoBufferSpace + , eIsConnected + , eNotConnected + , eShutdown + , eTooManyReferences + , eTimedOut + , eConnectionRefused + , eHostDown + , eHostUnreachable + , eAlready + , eInProgress + ) where import Control.Exception import Data.Typeable @@ -16,6 +53,13 @@ #include "hs_socket.h" +-- | Contains the error code that can be matched against. +-- +-- Hint: Use guards or @MultiWayIf@ to match against specific exceptions: +-- +-- > if | e == eAddressInUse -> ... +-- > | e == eAddressNotAvailable -> ... +-- > | otherwise -> ... newtype SocketException = SocketException CInt deriving (Typeable, Eq, Ord) @@ -23,145 +67,194 @@ instance Exception SocketException instance Show SocketException where - show e@(SocketException i) - | e == eOk = "eOk" - | e == eInterrupted = "eInterrupted" - | e == eBadFileDescriptor = "eBadFileDescriptor" - | e == eInvalid = "eInvalid" - | e == ePipe = "ePipe" - | e == eWouldBlock = "eWouldBlock" - | e == eAgain = "eAgain" - | e == eNotSocket = "eNotSocket" - | e == eDestinationAddressRequired = "eDestinationAddressRequired" - | e == eMessageSize = "eMessageSize" - | e == eProtocolType = "eProtocolType" - | e == eNoProtocolOption = "eNoProtocolOption" - | e == eProtocolNotSupported = "eProtocolNotSupported" - | e == eSocketTypeNotSupported = "eSocketTypeNotSupported" - | e == eOperationNotSupported = "eOperationNotSupported" - | e == eProtocolFamilyNotSupported = "eProtocolFamilyNotSupported" - | e == eAddressFamilyNotSupported = "eAddressFamilyNotSupported" - | e == eAddressInUse = "eAddressInUse" - | e == eAddressNotAvailable = "eAddressNotAvailable" - | e == eNetworkDown = "eNetworkDown" - | e == eNetworkUnreachable = "eNetworkUnreachable" - | e == eNetworkReset = "eNetworkReset" - | e == eConnectionAborted = "eConnectionAborted" - | e == eConnectionReset = "eConnectionReset" - | e == eNoBufferSpace = "eNoBufferSpace" - | e == eIsConnected = "eIsConnected" - | e == eNotConnected = "eNotConnected" - | e == eShutdown = "eShutdown" - | e == eTooManyReferences = "eTooManyReferences" - | e == eTimedOut = "eTimedOut" - | e == eConnectionRefused = "eConnectionRefused" - | e == eHostDown = "eHostDown" - | e == eHostUnreachable = "eHostUnreachable" - | e == eAlready = "eAlready" - | e == eInProgress = "eInProgress" - | otherwise = "SocketException " ++ show i + show e + | e == eOk = "eOk" + | e == eInterrupted = "eInterrupted" + | e == eBadFileDescriptor = "eBadFileDescriptor" + | e == eInvalid = "eInvalid" + | e == ePipe = "ePipe" + | e == eWouldBlock = "eWouldBlock" + | e == eAgain = "eAgain" + | e == eNotSocket = "eNotSocket" + | e == eDestinationAddressRequired = "eDestinationAddressRequired" + | e == eMessageSize = "eMessageSize" + | e == eProtocolType = "eProtocolType" + | e == eNoProtocolOption = "eNoProtocolOption" + | e == eProtocolNotSupported = "eProtocolNotSupported" + | e == eSocketTypeNotSupported = "eSocketTypeNotSupported" + | e == eOperationNotSupported = "eOperationNotSupported" + | e == eProtocolFamilyNotSupported = "eProtocolFamilyNotSupported" + | e == eAddressFamilyNotSupported = "eAddressFamilyNotSupported" + | e == eAddressInUse = "eAddressInUse" + | e == eAddressNotAvailable = "eAddressNotAvailable" + | e == eNetworkDown = "eNetworkDown" + | e == eNetworkUnreachable = "eNetworkUnreachable" + | e == eNetworkReset = "eNetworkReset" + | e == eConnectionAborted = "eConnectionAborted" + | e == eConnectionReset = "eConnectionReset" + | e == eNoBufferSpace = "eNoBufferSpace" + | e == eIsConnected = "eIsConnected" + | e == eNotConnected = "eNotConnected" + | e == eShutdown = "eShutdown" + | e == eTooManyReferences = "eTooManyReferences" + | e == eTimedOut = "eTimedOut" + | e == eConnectionRefused = "eConnectionRefused" + | e == eHostDown = "eHostDown" + | e == eHostUnreachable = "eHostUnreachable" + | e == eAlready = "eAlready" + | e == eInProgress = "eInProgress" + | otherwise = let SocketException n = e + in "SocketException " ++ show n +-- | > SocketException "No error" eOk :: SocketException eOk = SocketException (#const SEOK) +-- | > SocketException "Interrupted system call" +-- +-- NOTE: This exception shall not be thrown by any public operation in this +-- library, but is handled internally. eInterrupted :: SocketException eInterrupted = SocketException (#const SEINTR) +-- | > SocketException "Bad file descriptor" eBadFileDescriptor :: SocketException eBadFileDescriptor = SocketException (#const SEBADF) +-- | > SocketException "Invalid argument" eInvalid :: SocketException eInvalid = SocketException (#const SEINVAL) +-- | > SocketException "Broken pipe" ePipe :: SocketException ePipe = SocketException (#const SEPIPE) +-- | > SocketException "Resource temporarily unavailable" +-- +-- NOTE: This exception shall not be thrown by any public operation in this +-- library, but is handled internally. eWouldBlock :: SocketException eWouldBlock = SocketException (#const SEWOULDBLOCK) +-- | > SocketException "Resource temporarily unavailable" eAgain :: SocketException eAgain = SocketException (#const SEAGAIN) +-- | > SocketException "Socket operation on non-socket" +-- +-- NOTE: This should be ruled out by the type system. eNotSocket :: SocketException eNotSocket = SocketException (#const SENOTSOCK) +-- | > SocketException "Destination address required" eDestinationAddressRequired :: SocketException eDestinationAddressRequired = SocketException (#const SEDESTADDRREQ) +-- | > SocketException "Message too long" eMessageSize :: SocketException eMessageSize = SocketException (#const SEMSGSIZE) +-- | > SocketException "Protocol wrong type for socket" + +-- NOTE: This should be ruled out by the type system. eProtocolType :: SocketException eProtocolType = SocketException (#const SEPROTOTYPE) +-- | > SocketException "Protocol not available" eNoProtocolOption :: SocketException eNoProtocolOption = SocketException (#const SENOPROTOOPT) +-- | > SocketException "Protocol not supported" eProtocolNotSupported :: SocketException eProtocolNotSupported = SocketException (#const SEPROTONOSUPPORT) +-- | > SocketException "Socket type not supported" eSocketTypeNotSupported :: SocketException eSocketTypeNotSupported = SocketException (#const SESOCKTNOSUPPORT) +-- | > SocketException "Operation not supported" eOperationNotSupported :: SocketException eOperationNotSupported = SocketException (#const SEOPNOTSUPP) +-- | > SocketException "Protocol family not supported" eProtocolFamilyNotSupported :: SocketException eProtocolFamilyNotSupported = SocketException (#const SEPFNOSUPPORT) +-- | > SocketException "Address family not supported by protocol" eAddressFamilyNotSupported :: SocketException eAddressFamilyNotSupported = SocketException (#const SEAFNOSUPPORT) +-- | > SocketException "Address already in use" eAddressInUse :: SocketException eAddressInUse = SocketException (#const SEADDRINUSE) +-- | > SocketException "Cannot assign requested address" eAddressNotAvailable :: SocketException eAddressNotAvailable = SocketException (#const SEADDRNOTAVAIL) +-- | > SocketException "Network is down" eNetworkDown :: SocketException eNetworkDown = SocketException (#const SENETDOWN) +-- | > SocketException "Network is unreachable" eNetworkUnreachable :: SocketException eNetworkUnreachable = SocketException (#const SENETUNREACH) +-- | > SocketException "Network dropped connection on reset" eNetworkReset :: SocketException eNetworkReset = SocketException (#const SENETRESET) +-- | > SocketException "Software caused connection abort" eConnectionAborted :: SocketException eConnectionAborted = SocketException (#const SECONNABORTED) +-- | > SocketException "Connection reset by peer" eConnectionReset :: SocketException eConnectionReset = SocketException (#const SECONNRESET) +-- | > SocketException "No buffer space available" eNoBufferSpace :: SocketException eNoBufferSpace = SocketException (#const SENOBUFS) +-- | > SocketException "Transport endpoint is already connected" eIsConnected :: SocketException eIsConnected = SocketException (#const SEISCONN) +-- | > SocketException "Transport endpoint is not connected" eNotConnected :: SocketException eNotConnected = SocketException (#const SENOTCONN) +-- | > SocketException "Cannot send after transport endpoint shutdown" eShutdown :: SocketException eShutdown = SocketException (#const SESHUTDOWN) +-- | > SocketException "Too many references: cannot splice" eTooManyReferences :: SocketException eTooManyReferences = SocketException (#const SETOOMANYREFS) +-- | > SocketException "Connection timed out" eTimedOut :: SocketException eTimedOut = SocketException (#const SETIMEDOUT) +-- | > SocketException "Connection refused" eConnectionRefused :: SocketException eConnectionRefused = SocketException (#const SECONNREFUSED) +-- | > SocketException "Host is down" eHostDown :: SocketException eHostDown = SocketException (#const SEHOSTDOWN) +-- | > SocketException "No route to host" eHostUnreachable :: SocketException eHostUnreachable = SocketException (#const SEHOSTUNREACH) +-- | > SocketException "Operation already in progress" +-- +-- NOTE: This exception shall not be thrown by any public operation in this +-- library, but is handled internally. eAlready :: SocketException eAlready = SocketException (#const SEALREADY) +-- | > SocketException "Operation now in progress" eInProgress :: SocketException eInProgress = SocketException (#const SEINPROGRESS) diff --git a/src/System/Socket/Internal/Message.hsc b/src/System/Socket/Internal/Message.hsc --- a/src/System/Socket/Internal/Message.hsc +++ b/src/System/Socket/Internal/Message.hsc @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Internal.Message -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- diff --git a/src/System/Socket/Internal/Socket.hs b/src/System/Socket/Internal/Socket.hs new file mode 100644 --- /dev/null +++ b/src/System/Socket/Internal/Socket.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +-------------------------------------------------------------------------------- +-- | +-- Module : System.Socket.Internal.Socket +-- Copyright : (c) Lars Petersen 2015 +-- License : MIT +-- +-- Maintainer : info@lars-petersen.net +-- Stability : experimental +-------------------------------------------------------------------------------- +module System.Socket.Internal.Socket ( + Socket (..) + , Family (..) + , Type (..) + , Protocol (..) + ) where + +import Control.Concurrent.MVar +import Foreign.C.Types +import Foreign.Storable +import System.Posix.Types + +-- | A generic socket type. Use `System.Socket.socket` to create a new socket. +-- +-- The socket is just an `Control.Concurrent.MVar.MVar`-wrapped file descriptor. +-- The `System.Socket.Unsafe.Socket` constructor is exported trough the unsafe +-- module in order to make this library easily extensible, but it is usually +-- not necessary nor advised to work directly on the file descriptor. +-- If you do, the following rules must be obeyed: +-- +-- - Make sure not to deadlock. Use `Control.Concurrent.MVar.withMVar` or similar. +-- - The lock __must not__ be held during a blocking call. This would make it impossible +-- to send and receive simultaneously or to close the socket. +-- - The lock __must__ be held when calling operations that use the file descriptor. +-- Otherwise the socket might get closed or even reused by another +-- thread/capability which might result in reading from or writing on a +-- totally different socket. This is a security nightmare! +-- - The socket is non-blocking and all the code relies on that assumption. +-- You need to use GHC's eventing mechanism primitives to block until +-- something happens. The former rules forbid to use `GHC.Conc.threadWaitRead` as it +-- does not separate between registering the file descriptor (for which +-- the lock __must__ be held) and the actual waiting (for which you must +-- __not__ hold the lock). +-- Also see [this](https://mail.haskell.org/pipermail/haskell-cafe/2014-September/115823.html) +-- thread and read the library code to see how the problem is currently circumvented. +newtype Socket f t p + = Socket (MVar Fd) + +-- | The address `Family` determines the network protocol to use. +-- +-- The most common address families are `System.Socket.Family.Inet` (IPv4) +-- and `System.Socket.Family.Inet6` (IPv6). +class Storable (SocketAddress f) => Family f where + -- | The number designating this `Family` on the specific platform. This + -- method is only exported for implementing extension libraries. + -- + -- This function shall yield the values of constants like `AF_INET`, `AF_INET6` etc. + familyNumber :: f -> CInt + -- | The `SocketAddress` type is a [data family](https://wiki.haskell.org/GHC/Type_families#Detailed_definition_of_data_families). + -- This allows to provide different data constructors depending on the socket + -- family without knowing all of them in advance or the need to extend this + -- core library. + -- + -- > SocketAddressInet inetLoopback 8080 :: SocketAddress Inet + -- > SocketAddressInet6 inet6Loopback 8080 0 0 :: SocketAddress Inet6 + data SocketAddress f + +-- | The `Type` determines properties of the transport layer and the semantics +-- of basic socket operations. +-- +-- The instances supplied by this library are `System.Socket.Type.Raw` +-- (no transport layer), `System.Socket.Type.Stream` +-- (for unframed binary streams, e.g. `System.Socket.Protocol.TCP`), +-- `System.Socket.Type.Datagram` (for datagrams +-- of limited length, e.g. `System.Socket.Protocol.UDP`) and +-- `System.Socket.Type.SequentialPacket` (for framed messages of arbitrary +-- length, e.g. `System.Socket.Protocol.SCTP`). +class Type t where + -- | This number designates this `Type` on the specific platform. This + -- method is only exported for implementing extension libraries. + -- + -- The function shall yield the values of constants like `SOCK_STREAM`, + -- `SOCK_DGRAM` etc. + typeNumber :: t -> CInt + +-- | The `Protocol` determines the transport protocol to use. +-- +-- Use `System.Socket.Protocol.Default` to let the operating system choose +-- a transport protocol compatible with the socket's `Type`. +class Protocol p where + -- | This number designates this `Protocol` on the specific platform. This + -- method is only exported for implementing extension libraries. + -- + -- The function shall yield the values of constants like `IPPROTO_TCP`, + -- `IPPROTO_UDP` etc. + protocolNumber :: p -> CInt diff --git a/src/System/Socket/Internal/Socket.hsc b/src/System/Socket/Internal/Socket.hsc deleted file mode 100644 --- a/src/System/Socket/Internal/Socket.hsc +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} --------------------------------------------------------------------------------- --- | --- Module : System.Socket --- Copyright : (c) Lars Petersen 2015 --- License : MIT --- --- Maintainer : info@lars-petersen.net --- Stability : experimental --------------------------------------------------------------------------------- -module System.Socket.Internal.Socket ( - Socket (..) - , SocketAddress - , Family (..) - , Type (..) - , Protocol (..) - , SocketOption (..) - , unsafeGetSocketOption - , unsafeSetSocketOption - , Error (..) - , ReuseAddress (..) - ) where - -import Control.Concurrent.MVar -import Control.Exception -import Control.Monad -import Control.Applicative ((<$>)) - -import Foreign.Ptr -import Foreign.Storable -import Foreign.C.Types -import Foreign.Marshal.Alloc -import System.Posix.Types - -import System.Socket.Internal.Platform -import System.Socket.Internal.Exception - -#include "hs_socket.h" - --- | A generic socket type. Use `System.Socket.socket` to create a new socket. --- --- The socket is just an `Control.Concurrent.MVar.MVar`-wrapped file descriptor. --- The `System.Socket.Unsafe.Socket` constructor is exported trough the unsafe --- module in order to make this library easily extensible, but it is usually --- not necessary nor advised to work directly on the file descriptor. --- If you do, the following rules must be obeyed: --- --- - Make sure not to deadlock. Use `Control.Concurrent.MVar.withMVar` or similar. --- - The lock __must not__ be held during a blocking call. This would make it impossible --- to send and receive simultaneously or to close the socket. --- - The lock __must__ be held when calling operations that use the file descriptor. --- Otherwise the socket might get closed or even reused by another --- thread/capability which might result in reading from or writing --- totally different connection. This is a security nightmare! --- - The socket is non-blocking and all the code relies on that assumption. --- You need to use GHC's eventing mechanism primitives to block until --- something happens. The former rules forbid to use `GHC.Conc.threadWaitRead` as it --- does not separate between registering the file descriptor (for which --- the lock __must__ be held) and the actual waiting (for which you must --- __not__ hold the lock). --- Also see [this](https://mail.haskell.org/pipermail/haskell-cafe/2014-September/115823.html) --- thread and read the library code to see how the problem is currently circumvented. -newtype Socket f t p - = Socket (MVar Fd) - --- | The `SocketAddress` type is a [data family](https://wiki.haskell.org/GHC/Type_families#Detailed_definition_of_data_families). --- This allows to provide different data constructors depending on the socket --- family wihtout knowing all of them in advance or the need to patch this --- core library. --- --- > SocketAddressInet inetLoopback 8080 :: SocketAddress Inet --- > SocketAddressInet6 inet6Loopback 8080 0 0 :: SocketAddress Inet6 -data family SocketAddress f - -class Family f where - familyNumber :: f -> CInt - -class Type t where - typeNumber :: t -> CInt - -class Protocol p where - protocolNumber :: p -> CInt - -class SocketOption o where - getSocketOption :: Socket f t p -> IO o - setSocketOption :: Socket f t p -> o -> IO () - --- | @SO_ERROR@ -data Error - = Error SocketException - deriving (Eq, Ord, Show) - -instance SocketOption Error where - getSocketOption s = - Error . SocketException Control.Applicative.<$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_ERROR) - setSocketOption _ _ = throwIO eInvalid - --- | @SO_REUSEADDR@ -data ReuseAddress - = ReuseAddress Bool - deriving (Eq, Ord, Show) - -instance SocketOption ReuseAddress where - getSocketOption s = - ReuseAddress . ((/=0) :: CInt -> Bool) <$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_REUSEADDR) - setSocketOption s (ReuseAddress o) = - unsafeSetSocketOption s (#const SOL_SOCKET) (#const SO_REUSEADDR) (if o then 1 else 0 :: CInt) - -------------------------------------------------------------------------------- --- Unsafe helpers -------------------------------------------------------------------------------- - -unsafeSetSocketOption :: Storable a => Socket f t p -> CInt -> CInt -> a -> IO () -unsafeSetSocketOption (Socket mfd) level name value = - withMVar mfd $ \fd-> alloca $ \vPtr-> alloca $ \errPtr-> do - poke vPtr value - i <- c_setsockopt fd level name vPtr (fromIntegral $ sizeOf value) errPtr - when (i < 0) (SocketException <$> peek errPtr >>= throwIO) - -unsafeGetSocketOption :: Storable a => Socket f t p -> CInt -> CInt -> IO a -unsafeGetSocketOption (Socket mfd) level name = - withMVar mfd $ \fd-> alloca $ \vPtr-> alloca $ \lPtr-> alloca $ \errPtr-> do - u <- return undefined - poke lPtr (fromIntegral $ sizeOf u) - i <- c_getsockopt fd level name vPtr (lPtr :: Ptr CInt) errPtr - when (i < 0) (SocketException <$> peek errPtr >>= throwIO) - x <- peek vPtr - return (x `asTypeOf` u) diff --git a/src/System/Socket/Internal/SocketOption.hsc b/src/System/Socket/Internal/SocketOption.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Internal/SocketOption.hsc @@ -0,0 +1,115 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.Socket.Internal.SocketOption +-- Copyright : (c) Lars Petersen 2016 +-- License : MIT +-- +-- Maintainer : info@lars-petersen.net +-- Stability : experimental +-------------------------------------------------------------------------------- +module System.Socket.Internal.SocketOption ( + SocketOption (..) + , unsafeGetSocketOption + , unsafeSetSocketOption + , Error (..) + , ReuseAddress (..) + , KeepAlive(..) + ) where + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Control.Applicative ((<$>)) + +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Types +import Foreign.Marshal.Alloc + +import System.Socket.Internal.Socket +import System.Socket.Internal.Platform +import System.Socket.Internal.Exception + +#include "hs_socket.h" + +-- | `SocketOption`s allow to read and write certain properties of a socket. +-- +-- - Each option shall have a corresponding data type that models the data +-- associated with the socket option. +-- - Use `System.Socket.Unsafe.unsafeGetSocketOption` and +-- `System.Socket.Unsafe.unsafeSetSocketOption` in order to implement custom socket +-- options. +class SocketOption o where + -- | Get a specific `SocketOption`. + -- + -- - This operation throws `SocketException`s. Consult @man getsockopt@ for + -- details and specific errors. + getSocketOption :: Socket f t p -> IO o + -- | Set a specific `SocketOption`. + -- + -- - This operation throws `SocketException`s. Consult @man setsockopt@ for + -- details and specific errors. + setSocketOption :: Socket f t p -> o -> IO () + +-- | Reports the last error that occured on the socket. +-- +-- - Also known as @SO_ERROR@. +-- - The operation `setSocketOption` always throws `eInvalid` for this option. +-- - Use with care in the presence of concurrency! +data Error + = Error SocketException + deriving (Eq, Ord, Show) + +instance SocketOption Error where + getSocketOption s = + Error . SocketException Control.Applicative.<$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_ERROR) + setSocketOption _ _ = throwIO eInvalid + +-- | Allows or disallows the reuse of a local address in a `System.Socket.bind` call. +-- +-- - Also known as @SO_REUSEADDR@. +-- - This is particularly useful when experiencing `eAddressInUse` exceptions. +data ReuseAddress + = ReuseAddress Bool + deriving (Eq, Ord, Show) + +instance SocketOption ReuseAddress where + getSocketOption s = + ReuseAddress . ((/=0) :: CInt -> Bool) <$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_REUSEADDR) + setSocketOption s (ReuseAddress o) = + unsafeSetSocketOption s (#const SOL_SOCKET) (#const SO_REUSEADDR) (if o then 1 else 0 :: CInt) + +-- | When enabled the protocol checks in a protocol-specific manner +-- if the other end is still alive. +-- +-- - Also known as @SO_KEEPALIVE@. +data KeepAlive + = KeepAlive Bool + deriving (Eq, Ord, Show) + +instance SocketOption KeepAlive where + getSocketOption s = + KeepAlive . ((/=0) :: CInt -> Bool) <$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_KEEPALIVE) + setSocketOption s (KeepAlive o) = + unsafeSetSocketOption s (#const SOL_SOCKET) (#const SO_KEEPALIVE) (if o then 1 else 0 :: CInt) + +------------------------------------------------------------------------------- +-- Unsafe helpers +------------------------------------------------------------------------------- + +unsafeSetSocketOption :: Storable a => Socket f t p -> CInt -> CInt -> a -> IO () +unsafeSetSocketOption (Socket mfd) level name value = + withMVar mfd $ \fd-> alloca $ \vPtr-> alloca $ \errPtr-> do + poke vPtr value + i <- c_setsockopt fd level name vPtr (fromIntegral $ sizeOf value) errPtr + when (i < 0) (SocketException <$> peek errPtr >>= throwIO) + +unsafeGetSocketOption :: Storable a => Socket f t p -> CInt -> CInt -> IO a +unsafeGetSocketOption (Socket mfd) level name = + withMVar mfd $ \fd-> alloca $ \vPtr-> alloca $ \lPtr-> alloca $ \errPtr-> do + u <- return undefined + poke lPtr (fromIntegral $ sizeOf u) + i <- c_getsockopt fd level name vPtr (lPtr :: Ptr CInt) errPtr + when (i < 0) (SocketException <$> peek errPtr >>= throwIO) + x <- peek vPtr + return (x `asTypeOf` u) diff --git a/src/System/Socket/Protocol/Default.hsc b/src/System/Socket/Protocol/Default.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Protocol/Default.hsc @@ -0,0 +1,19 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.Socket.Protocol.Default +-- Copyright : (c) Lars Petersen 2015 +-- License : MIT +-- +-- Maintainer : info@lars-petersen.net +-- Stability : experimental +-------------------------------------------------------------------------------- +module System.Socket.Protocol.Default where + +import System.Socket.Internal.Socket + +#include "hs_socket.h" + +data Default + +instance Protocol Default where + protocolNumber _ = 0 diff --git a/src/System/Socket/Protocol/TCP.hsc b/src/System/Socket/Protocol/TCP.hsc --- a/src/System/Socket/Protocol/TCP.hsc +++ b/src/System/Socket/Protocol/TCP.hsc @@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Protocol.TCP -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- @@ -9,11 +9,27 @@ -------------------------------------------------------------------------------- module System.Socket.Protocol.TCP where +import Foreign.C.Types + import System.Socket.Internal.Socket +import System.Socket.Internal.SocketOption #include "hs_socket.h" data TCP -instance Protocol TCP where +instance Protocol TCP where protocolNumber _ = (#const IPPROTO_TCP) + +-- | If set to True, disable the Nagle's algorithm. +-- +-- - Also know as @TCP_NODELAY@. +data NoDelay + = NoDelay Bool + deriving (Eq, Ord, Show) + +instance SocketOption NoDelay where + getSocketOption s = + (NoDelay . (/=0) :: CInt -> NoDelay) `fmap` unsafeGetSocketOption s (#const IPPROTO_TCP) (#const TCP_NODELAY) + setSocketOption s (NoDelay o) = + unsafeSetSocketOption s (#const IPPROTO_TCP) (#const TCP_NODELAY) (if o then 1 else 0 :: CInt) diff --git a/src/System/Socket/Protocol/UDP.hsc b/src/System/Socket/Protocol/UDP.hsc --- a/src/System/Socket/Protocol/UDP.hsc +++ b/src/System/Socket/Protocol/UDP.hsc @@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Protocol.UDP -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- @@ -15,5 +15,5 @@ data UDP -instance Protocol UDP where +instance Protocol UDP where protocolNumber _ = (#const IPPROTO_UDP) diff --git a/src/System/Socket/Type/Datagram.hsc b/src/System/Socket/Type/Datagram.hsc --- a/src/System/Socket/Type/Datagram.hsc +++ b/src/System/Socket/Type/Datagram.hsc @@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Type.Datagram -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- diff --git a/src/System/Socket/Type/Raw.hsc b/src/System/Socket/Type/Raw.hsc --- a/src/System/Socket/Type/Raw.hsc +++ b/src/System/Socket/Type/Raw.hsc @@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Type.Raw -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- diff --git a/src/System/Socket/Type/SequentialPacket.hsc b/src/System/Socket/Type/SequentialPacket.hsc --- a/src/System/Socket/Type/SequentialPacket.hsc +++ b/src/System/Socket/Type/SequentialPacket.hsc @@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Type.SequentialPacket -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- diff --git a/src/System/Socket/Type/Stream.hsc b/src/System/Socket/Type/Stream.hsc --- a/src/System/Socket/Type/Stream.hsc +++ b/src/System/Socket/Type/Stream.hsc @@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- | --- Module : System.Socket +-- Module : System.Socket.Type.Stream -- Copyright : (c) Lars Petersen 2015 -- License : MIT -- diff --git a/src/System/Socket/Unsafe.hs b/src/System/Socket/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/System/Socket/Unsafe.hs @@ -0,0 +1,103 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.Socket.Unsafe +-- Copyright : (c) Lars Petersen 2015 +-- License : MIT +-- +-- Maintainer : info@lars-petersen.net +-- Stability : experimental +-------------------------------------------------------------------------------- +module System.Socket.Unsafe ( + Socket (..) + -- * Unsafe operations + -- ** unsafeSend + , unsafeSend + -- ** unsafeSendTo + , unsafeSendTo + -- ** unsafeReceive + , unsafeReceive + -- ** unsafeReceiveFrom + , unsafeReceiveFrom + -- ** unsafeGetSocketOption + , unsafeGetSocketOption + -- ** unsafeSetSocketOption + , unsafeSetSocketOption + -- * Waiting for events + -- ** waitRead + , waitRead + -- ** waitWrite + , waitWrite + -- ** waitConnected + , waitConnected + -- ** tryWaitRetryLoop + , tryWaitRetryLoop + ) where + +import Control.Applicative ( (<$>) ) +import Control.Concurrent.MVar +import Control.Exception ( throwIO ) +import Control.Monad +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import System.Posix.Types ( Fd(..) ) +import System.Socket.Internal.Socket +import System.Socket.Internal.SocketOption +import System.Socket.Internal.Platform +import System.Socket.Internal.Exception +import System.Socket.Internal.Message + +-- | Like `System.Socket.send`, but using `Ptr` and length instead of a `ByteString`. +-- +-- This function is /unsafe/. @bufPtr@ must refer to a buffer which size is at least @bufSize@ bytes. +unsafeSend :: Socket a t p -> Ptr b -> CSize -> MessageFlags -> IO CInt +unsafeSend s bufPtr bufSize flags = + tryWaitRetryLoop s waitWrite (\fd-> c_send fd bufPtr bufSize flags ) + +-- | Like `System.Socket.sendTo`, but using `Ptr` and length instead of a `ByteString`. +-- +-- This function is /unsafe/. @bufPtr@ must refer to a buffer which size is at least @bufSize@ bytes. +unsafeSendTo :: Socket f t p -> Ptr b -> CSize -> MessageFlags -> Ptr (SocketAddress f) -> CInt -> IO CInt +unsafeSendTo s bufPtr bufSize flags addrPtr addrSize = + tryWaitRetryLoop s waitWrite (\fd-> c_sendto fd bufPtr (fromIntegral bufSize) flags addrPtr addrSize) + +-- | Like `System.Socket.receive`, but using `Ptr` and length instead of a `ByteString`. +-- +-- This function is /unsafe/. @bufPtr@ must refer to a buffer which size is at least @bufSize@ bytes. +unsafeReceive :: Socket a t p -> Ptr b -> CSize -> MessageFlags -> IO CInt +unsafeReceive s bufPtr bufSize flags = + tryWaitRetryLoop s waitRead (\fd-> c_recv fd bufPtr bufSize flags) + +-- | Like `System.Socket.receiveFrom`, but using `Ptr` and length instead of a `ByteString`. +-- +-- This function is /unsafe/. @bufPtr@ must refer to a buffer which size is at least @bufSize@ bytes. +unsafeReceiveFrom :: Socket f t p -> Ptr b -> CSize -> MessageFlags -> Ptr (SocketAddress f) -> Ptr CInt -> IO CInt +unsafeReceiveFrom s bufPtr bufSize flags addrPtr addrSizePtr = + tryWaitRetryLoop s waitRead (\fd-> c_recvfrom fd bufPtr bufSize flags addrPtr addrSizePtr) + +tryWaitRetryLoop :: Socket f t p -> (Socket f t p -> Int -> IO ()) -> (Fd -> Ptr CInt -> IO CInt) -> IO CInt +tryWaitRetryLoop s@(Socket mfd) wait action = loop 0 + where + loop iteration = do + -- acquire lock on socket + mi <- withMVar mfd $ \fd-> alloca $ \errPtr-> do + when (fd < 0) (throwIO eBadFileDescriptor) + i <- action fd errPtr + if i < 0 then do + err <- SocketException <$> peek errPtr + unless (err == eWouldBlock || err == eAgain || err == eInterrupted) + (throwIO err) + return Nothing + else + -- The following is quite interesting for debugging: + -- when (iteration /= 0) (print iteration) + return (Just i) + -- lock on socket is release here + case mi of + Just i -> + return i + Nothing -> do + wait s iteration -- this call is (eventually) blocking + loop $! iteration + 1 -- tail recursion + diff --git a/src/System/Socket/Unsafe.hsc b/src/System/Socket/Unsafe.hsc deleted file mode 100644 --- a/src/System/Socket/Unsafe.hsc +++ /dev/null @@ -1,92 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : System.Socket --- Copyright : (c) Lars Petersen 2015 --- License : MIT --- --- Maintainer : info@lars-petersen.net --- Stability : experimental --------------------------------------------------------------------------------- -module System.Socket.Unsafe ( - -- * Socket Constructor - Socket (..) - -- * Socket Operations - -- ** unsafeSend - , unsafeSend - -- ** unsafeSendTo - , unsafeSendTo - -- ** unsafeReceive - , unsafeReceive - -- ** unsafeReceiveFrom - , unsafeReceiveFrom - -- * Socket Options - -- ** unsafeGetSocketOption - , unsafeGetSocketOption - -- ** unsafeSetSocketOption - , unsafeSetSocketOption - -- * Waiting For Events - -- ** unsafeSocketWaitRead - , unsafeSocketWaitRead - -- ** unsafeSocketWaitWrite - , unsafeSocketWaitWrite - -- * Other Helpers - -- ** tryWaitRetryLoop - , tryWaitRetryLoop - ) where - -import Control.Applicative ((<$>)) -import Control.Monad -import Control.Exception -import Control.Concurrent.MVar - -import Foreign.C.Types -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Alloc - -import System.Socket.Internal.Socket -import System.Socket.Internal.Platform -import System.Socket.Internal.Exception -import System.Socket.Internal.Message - -import System.Posix.Types (Fd) - -#include "hs_socket.h" - -unsafeSend :: Socket a t p -> Ptr b -> CSize -> MessageFlags -> IO CInt -unsafeSend s bufPtr bufSize flags = do - tryWaitRetryLoop s unsafeSocketWaitWrite (\fd-> c_send fd bufPtr bufSize flags ) - -unsafeSendTo :: Socket f t p -> Ptr b -> CSize -> MessageFlags -> Ptr (SocketAddress f) -> CInt -> IO CInt -unsafeSendTo s bufPtr bufSize flags addrPtr addrSize = do - tryWaitRetryLoop s unsafeSocketWaitWrite (\fd-> c_sendto fd bufPtr (fromIntegral bufSize) flags addrPtr addrSize) - -unsafeReceive :: Socket a t p -> Ptr b -> CSize -> MessageFlags -> IO CInt -unsafeReceive s bufPtr bufSize flags = - tryWaitRetryLoop s unsafeSocketWaitRead (\fd-> c_recv fd bufPtr bufSize flags) - -unsafeReceiveFrom :: Socket f t p -> Ptr b -> CSize -> MessageFlags -> Ptr (SocketAddress f) -> Ptr CInt -> IO CInt -unsafeReceiveFrom s bufPtr bufSize flags addrPtr addrSizePtr = do - tryWaitRetryLoop s unsafeSocketWaitRead (\fd-> c_recvfrom fd bufPtr bufSize flags addrPtr addrSizePtr) - -tryWaitRetryLoop :: Socket f t p -> (Fd -> Int-> IO (IO ())) -> (Fd -> Ptr CInt -> IO CInt) -> IO CInt -tryWaitRetryLoop (Socket mfd) getWaitAction action = loop 0 - where - loop iteration = do - ewr <- withMVar mfd $ \fd-> alloca $ \errPtr-> do - when (fd < 0) (throwIO eBadFileDescriptor) - i <- action fd errPtr - if (i < 0) then do - err <- SocketException <$> peek errPtr - unless (err == eWouldBlock || err == eAgain) (throwIO err) - Left <$> getWaitAction fd iteration - else - -- The following is quite interesting for debugging: - -- when (iteration /= 0) (print iteration) - return (Right i) - case ewr of - Left wait -> do - wait - loop $! iteration + 1 - Right result -> do - return result diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -8,6 +8,7 @@ import Control.Monad (unless, void, when) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS import Data.Int (Int64) import Data.Maybe (isJust) import Data.Monoid (mempty, mappend) @@ -202,6 +203,32 @@ send client helloWorld mempty msg <- wait serverRecv when (msg /= helloWorld) (assertFailure "Received message was bogus.") + ) + , testCase "recv empty bytestring when peer disconnected gracefully" $ bracket + ( socket :: IO (Socket Inet Stream TCP) ) close + (\server-> do + let addr = SocketAddressInet inetLoopback port + let msg = "msg" + setSocketOption server (ReuseAddress True) + bind server addr + listen server 5 + (peer,msg') <- bracket ( socket :: IO (Socket Inet Stream TCP) ) close + (\client-> do + connect client addr + (peer, _) <- accept server + _ <- send client msg mempty + msg' <- receive peer 4096 mempty + return (peer,msg') + ) + -- The client is disconnected after here. + when (msg' /= msg) $ + assertFailure "Received message does not match." + msg'' <- receive peer 4096 mempty + unless (BS.null msg'') $ + assertFailure "Expected subsequent receives to return empty bytestring." + msg''' <- receive peer 4096 mempty + unless (BS.null msg''') $ + assertFailure "Expected subsequent receives to return empty bytestring." ) , testCase "trigger ePipe exception" $ bracket ( do