packages feed

socket 0.7.0.0 → 0.8.0.0

raw patch · 28 files changed

+873/−514 lines, 28 files

Files

CHANGELOG.md view
@@ -1,3 +1,44 @@+0.8.0.0 Lars Petersen <info@lars-petersen.net> 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 <info@lars-petersen.net> 2016-11-13   * Added function `sendAllLazy` and `sendAllBuilder`. Changed the signature and
CONTRIBUTORS.txt view
@@ -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
README.md view
@@ -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
platform/linux/include/hs_socket.h view
@@ -1,6 +1,7 @@ #define _GNU_SOURCE  #include <stdint.h>+#include <string.h> #include <unistd.h> #include <fcntl.h> #include <errno.h>@@ -9,6 +10,7 @@ #include "sys/socket.h" #include "sys/un.h" #include "netinet/in.h"+#include <netinet/tcp.h> #include "netdb.h"  int hs_socket  (int domain, int type, int protocol, int *err);
platform/linux/src/System/Socket/Internal/Platform.hsc view
@@ -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
platform/win32/cbits/hs_socket.c view
@@ -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) {
platform/win32/include/hs_socket.h view
@@ -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
platform/win32/src/System/Socket/Internal/Platform.hsc view
@@ -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
socket.cabal view
@@ -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
src/System/Socket.hsc view
@@ -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@
src/System/Socket/Family/Inet.hsc view
@@ -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. --
src/System/Socket/Family/Inet6.hsc view
@@ -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. --
src/System/Socket/Internal/AddressInfo.hsc view
@@ -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
src/System/Socket/Internal/Exception.hsc view
@@ -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)
src/System/Socket/Internal/Message.hsc view
@@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -------------------------------------------------------------------------------- -- |--- Module      :  System.Socket+-- Module      :  System.Socket.Internal.Message -- Copyright   :  (c) Lars Petersen 2015 -- License     :  MIT --
+ src/System/Socket/Internal/Socket.hs view
@@ -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
− src/System/Socket/Internal/Socket.hsc 
@@ -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)
+ src/System/Socket/Internal/SocketOption.hsc view
@@ -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)
+ src/System/Socket/Protocol/Default.hsc view
@@ -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
src/System/Socket/Protocol/TCP.hsc view
@@ -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)
src/System/Socket/Protocol/UDP.hsc view
@@ -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)
src/System/Socket/Type/Datagram.hsc view
@@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- |--- Module      :  System.Socket+-- Module      :  System.Socket.Type.Datagram -- Copyright   :  (c) Lars Petersen 2015 -- License     :  MIT --
src/System/Socket/Type/Raw.hsc view
@@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- |--- Module      :  System.Socket+-- Module      :  System.Socket.Type.Raw -- Copyright   :  (c) Lars Petersen 2015 -- License     :  MIT --
src/System/Socket/Type/SequentialPacket.hsc view
@@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- |--- Module      :  System.Socket+-- Module      :  System.Socket.Type.SequentialPacket -- Copyright   :  (c) Lars Petersen 2015 -- License     :  MIT --
src/System/Socket/Type/Stream.hsc view
@@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- |--- Module      :  System.Socket+-- Module      :  System.Socket.Type.Stream -- Copyright   :  (c) Lars Petersen 2015 -- License     :  MIT --
+ src/System/Socket/Unsafe.hs view
@@ -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+
− src/System/Socket/Unsafe.hsc 
@@ -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
test/test.hs view
@@ -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