diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +0.8.1.0 Lars Petersen 2018-08-13 + + * Issue 51: Add a `getAddress` operation for getting the local socket address. + * Marked `System.Socket.Type.Stream.receiveAll` as deprecated. + This is a preparation for a name reuse in upcoming 0.9.0.0. + * Removed dead code (`Message` type). + * Added error code `ePermissionDenied`. + 0.8.0.1 Lars Petersen 2017-02-25 * Issue 47: Fixed haddock documentation. diff --git a/CONTRIBUTORS.txt b/CONTRIBUTORS.txt --- a/CONTRIBUTORS.txt +++ b/CONTRIBUTORS.txt @@ -1,3 +1,4 @@ +Olivier Nicole (issue #15) Vyacheslav Hashov (issues #37, #38, #40, #41, #42) Alexander Vershilov (fixed bug in GHC upstream) Antom @SX91 (reported and helped with #27) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -40,7 +40,7 @@ The original [network](https://hackage.haskell.org/package/network) library suffers from this, too. For example, connection attempts are non-interruptible etc. The approach taken to circumvent this in this library is to poll the -non-blocking sockets with increasing delay. This guarantees non-interruptability +non-blocking sockets with increasing delay. This guarantees interruptibility and fairness between different threads. It allows for decent throughput while also keeping CPU consumption on a moderate level if a socket has not seen events for a longer period of time (maximum of 1 second delay after 20 diff --git a/platform/linux/cbits/hs_socket.c b/platform/linux/cbits/hs_socket.c --- a/platform/linux/cbits/hs_socket.c +++ b/platform/linux/cbits/hs_socket.c @@ -105,3 +105,9 @@ *err = errno; return i; } + +int hs_getsockname(int fd, struct sockaddr *addr, socklen_t *addrlen, int *err) { + int i = getsockname(fd, addr, addrlen); + *err = errno; + return i; +} 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 @@ -33,6 +33,7 @@ #define SEAGAIN EAGAIN #define SEWOULDBLOCK EWOULDBLOCK #define SEBADF EBADF +#define SEACCES EACCES #define SEINVAL EINVAL #define SEINPROGRESS EINPROGRESS #define SEPROTONOSUPPORT EPROTONOSUPPORT 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 @@ -11,7 +11,7 @@ ( 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 + c_setsockopt, c_getsockopt, c_getsockname) where import Control.Monad ( when, unless ) import Control.Concurrent.MVar @@ -114,3 +114,6 @@ foreign import ccall unsafe "gai_strerror" c_gai_strerror :: CInt -> IO CString + +foreign import ccall unsafe "hs_getsockname" + c_getsockname :: Fd -> Ptr a -> Ptr CInt -> Ptr CInt -> IO 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 @@ -189,3 +189,11 @@ freeaddrinfo(res); return; }; + +int hs_getsockname(int fd, struct sockaddr *addr, socklen_t *addrlen, int *err) { + int i = getsockname(fd, addr, addrlen); + if (i < 0) { + *err = WSAGetLastError(); + } + return i; +} 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 @@ -108,6 +108,7 @@ #define SEAGAIN WSATRY_AGAIN #define SEWOULDBLOCK WSAEWOULDBLOCK #define SEBADF WSAEBADF +#define SEACCES WSAEACCES #define SEINVAL WSAEINVAL #define SEINPROGRESS WSAEINPROGRESS #define SEPROTONOSUPPORT WSAEPROTONOSUPPORT 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 @@ -132,3 +132,6 @@ foreign import ccall safe "hs_getnameinfo" c_getnameinfo :: Ptr a -> CInt -> CString -> CInt -> CString -> CInt -> CInt -> IO CInt + +foreign import ccall unsafe "hs_getsockname" + c_getsockname :: Fd -> Ptr a -> Ptr CInt -> Ptr CInt -> IO CInt diff --git a/socket.cabal b/socket.cabal --- a/socket.cabal +++ b/socket.cabal @@ -1,5 +1,5 @@ name: socket -version: 0.8.0.1 +version: 0.8.1.0 synopsis: An extensible socket library. description: This library is a minimal cross-platform interface for @@ -14,8 +14,9 @@ cabal-version: >=1.10 homepage: https://github.com/lpeterse/haskell-socket bug-reports: https://github.com/lpeterse/haskell-socket/issues -tested-with: GHC==7.8.1, GHC==7.8.2, GHC==7.8.3, GHC==7.8.4, - GHC==7.10.1, GHC==7.10.2, GHC==7.10.3, GHC==8.0.1 +tested-with: GHC==7.8.1,GHC==7.8.2,GHC==7.8.3,GHC==7.8.4, + GHC==7.10.1, GHC==7.10.2, GHC==7.10.3, + GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 extra-source-files: README.md CHANGELOG.md CONTRIBUTORS.txt @@ -46,6 +47,10 @@ , System.Socket.Internal.Platform build-depends: base >= 4.7 && < 5 , bytestring < 0.11 + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + else + build-depends: fail == 4.9.*, semigroups == 0.18.* hs-source-dirs: src build-tools: hsc2hs default-language: Haskell2010 diff --git a/src/System/Socket.hsc b/src/System/Socket.hsc --- a/src/System/Socket.hsc +++ b/src/System/Socket.hsc @@ -74,6 +74,15 @@ , receive, receiveFrom -- ** close , close + -- * Name Resolution + -- ** getAddress + , getAddress + -- ** getAddressInfo + , AddressInfo (..) + , HasAddressInfo (..) + -- ** getNameInfo + , NameInfo (..) + , HasNameInfo (..) -- * Options , SocketOption (..) -- ** Error @@ -82,18 +91,11 @@ , ReuseAddress (..) -- ** KeepAlive , KeepAlive (..) - -- * Name Resolution - -- ** getAddressInfo - , AddressInfo (..) - , HasAddressInfo (..) - -- ** getNameInfo - , NameInfo (..) - , HasNameInfo (..) -- * Flags -- ** MessageFlags , MessageFlags (..) - , msgEndOfRecord , msgNoSignal + , msgEndOfRecord , msgOutOfBand , msgWaitAll -- ** AddressInfoFlags @@ -136,13 +138,13 @@ import Data.Function import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS -import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Internal as BS import GHC.Conc ( closeFdWith ) - -import Foreign.Storable -import Foreign.Marshal.Alloc +import Foreign.Storable +import Foreign.Marshal.Alloc + import System.Socket.Unsafe import System.Socket.Internal.Socket @@ -348,7 +350,7 @@ send :: Socket f t p -> BS.ByteString -> MessageFlags -> IO Int send s bs flags = do bytesSent <- BS.unsafeUseAsCStringLen bs $ \(bufPtr,bufSize)-> - unsafeSend s bufPtr (fromIntegral bufSize) flags + unsafeSend s bufPtr (fromIntegral bufSize) flags return (fromIntegral bytesSent) -- | Like `send`, but allows to specify a destination address. @@ -376,10 +378,10 @@ -- 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 = - BS.createUptoN bufSize $ \bufPtr-> - fromIntegral `fmap` unsafeReceive s bufPtr (fromIntegral bufSize) flags - +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) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f) receiveFrom = receiveFrom' @@ -388,11 +390,11 @@ receiveFrom' s bufSize flags = do alloca $ \addrPtr-> do alloca $ \addrSizePtr-> do - 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) + 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. -- @@ -431,3 +433,25 @@ -- When we arrive here, no exception has been thrown and the descriptor has been closed. -- We put an invalid file descriptor into the MVar. return (-1) + +-- | Get a socket's (local) address. +-- +-- > > (socket :: IO (Socket Inet Stream TCP)) >>= getAddress +-- > SocketAddressInet {inetAddress = InetAddress 0.0.0.0, inetPort = InetPort 0} +-- +-- - The operation throws `SocketException`s. Calling `getAddress` on a `close`d +-- socket throws `eBadFileDescriptor` even if the former file descriptor has +-- been reassigned. +-- - Behaviour of calling `getAddress` on a socket that is neither bound nor connected +-- is undefined. +getAddress :: (Family f) => Socket f t p -> IO (SocketAddress f) +getAddress = getAddress' + where + getAddress' :: forall f t p. (Family f) => Socket f t p -> IO (SocketAddress f) + getAddress' (Socket mfd) = alloca $ \addrPtr -> alloca $ \addrSizePtr -> alloca $ \errPtr -> do + poke addrSizePtr (fromIntegral $ sizeOf (undefined :: SocketAddress f)) + withMVar mfd $ \fd -> do + i <- c_getsockname fd addrPtr addrSizePtr errPtr + when (i /= 0) (SocketException <$> peek errPtr >>= throwIO) + addr <- peek addrPtr + return addr 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 @@ -89,7 +89,7 @@ deriving (Eq) newtype InetPort = InetPort Word16 - deriving (Eq, Ord, Show, Num) + deriving (Eq, Ord, Show, Num, Real, Enum, Integral) -- | Constructs a custom `InetAddress`. -- 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 @@ -94,13 +94,13 @@ deriving (Eq) newtype Inet6Port = Inet6Port Word16 - deriving (Eq, Ord, Show, Num) + deriving (Eq, Ord, Show, Num, Real, Enum, Integral) newtype Inet6FlowInfo = Inet6FlowInfo Word32 - deriving (Eq, Ord, Show, Num) + deriving (Eq, Ord, Show, Num, Real, Enum, Integral) newtype Inet6ScopeId = Inet6ScopeId Word32 - deriving (Eq, Ord, Show, Num) + deriving (Eq, Ord, Show, Num, Real, Enum, Integral) -- | Deconstructs an `Inet6Address`. inet6AddressToTuple :: Inet6Address -> (Word16,Word16,Word16,Word16,Word16,Word16,Word16,Word16) 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 @@ -45,6 +45,7 @@ import Data.Monoid import Data.Bits +import Data.Semigroup as Sem import Data.Typeable import qualified Data.ByteString as BS @@ -149,12 +150,14 @@ = AddressInfoFlags CInt deriving (Eq, Show, Bits) -instance Data.Monoid.Monoid AddressInfoFlags where - mempty - = AddressInfoFlags 0 - mappend (AddressInfoFlags a) (AddressInfoFlags b) +instance Sem.Semigroup AddressInfoFlags where + (AddressInfoFlags a) <> (AddressInfoFlags b) = AddressInfoFlags (a .|. b) +instance Data.Monoid.Monoid AddressInfoFlags where + mempty = AddressInfoFlags 0 + mappend = (Sem.<>) + -- | @AI_ADDRCONFIG@: aiAddressConfig :: AddressInfoFlags aiAddressConfig = AddressInfoFlags (#const AI_ADDRCONFIG) @@ -193,11 +196,13 @@ = NameInfoFlags CInt deriving (Eq, Show, Bits) -instance Monoid NameInfoFlags where - mempty - = NameInfoFlags 0 - mappend (NameInfoFlags a) (NameInfoFlags b) +instance Sem.Semigroup NameInfoFlags where + (NameInfoFlags a) <> (NameInfoFlags b) = NameInfoFlags (a .|. b) + +instance Monoid NameInfoFlags where + mempty = NameInfoFlags 0 + mappend = (Sem.<>) -- | @NI_NAMEREQD@: Throw an exception if the hostname cannot be determined. niNameRequired :: NameInfoFlags 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 @@ -13,6 +13,7 @@ , eOk , eInterrupted , eBadFileDescriptor + , ePermissionDenied , eInvalid , ePipe , eWouldBlock @@ -71,6 +72,7 @@ | e == eOk = "eOk" | e == eInterrupted = "eInterrupted" | e == eBadFileDescriptor = "eBadFileDescriptor" + | e == ePermissionDenied = "ePermissionDenied" | e == eInvalid = "eInvalid" | e == ePipe = "ePipe" | e == eWouldBlock = "eWouldBlock" @@ -106,155 +108,159 @@ | otherwise = let SocketException n = e in "SocketException " ++ show n --- | > SocketException "No error" +-- | No error. eOk :: SocketException eOk = SocketException (#const SEOK) --- | > SocketException "Interrupted system call" +-- | 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" +-- | Bad file descriptor. eBadFileDescriptor :: SocketException eBadFileDescriptor = SocketException (#const SEBADF) --- | > SocketException "Invalid argument" +-- | Permission denied. +ePermissionDenied :: SocketException +ePermissionDenied = SocketException (#const SEACCES) + +-- | Invalid argument. eInvalid :: SocketException eInvalid = SocketException (#const SEINVAL) --- | > SocketException "Broken pipe" +-- | Broken pipe. ePipe :: SocketException ePipe = SocketException (#const SEPIPE) --- | > SocketException "Resource temporarily unavailable" +-- | 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" +-- | Resource temporarily unavailable. eAgain :: SocketException eAgain = SocketException (#const SEAGAIN) --- | > SocketException "Socket operation on non-socket" +-- | 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" +-- | Destination address required. eDestinationAddressRequired :: SocketException eDestinationAddressRequired = SocketException (#const SEDESTADDRREQ) --- | > SocketException "Message too long" +-- | Message too long. eMessageSize :: SocketException eMessageSize = SocketException (#const SEMSGSIZE) --- | > SocketException "Protocol wrong type for socket" +-- | 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" +-- | Protocol not available. eNoProtocolOption :: SocketException eNoProtocolOption = SocketException (#const SENOPROTOOPT) --- | > SocketException "Protocol not supported" +-- | Protocol not supported. eProtocolNotSupported :: SocketException eProtocolNotSupported = SocketException (#const SEPROTONOSUPPORT) --- | > SocketException "Socket type not supported" +-- | Socket type not supported. eSocketTypeNotSupported :: SocketException eSocketTypeNotSupported = SocketException (#const SESOCKTNOSUPPORT) --- | > SocketException "Operation not supported" +-- | Operation not supported. eOperationNotSupported :: SocketException eOperationNotSupported = SocketException (#const SEOPNOTSUPP) --- | > SocketException "Protocol family not supported" +-- | Protocol family not supported. eProtocolFamilyNotSupported :: SocketException eProtocolFamilyNotSupported = SocketException (#const SEPFNOSUPPORT) --- | > SocketException "Address family not supported by protocol" +-- | Address family not supported by protocol. eAddressFamilyNotSupported :: SocketException eAddressFamilyNotSupported = SocketException (#const SEAFNOSUPPORT) --- | > SocketException "Address already in use" +-- | Address already in use. eAddressInUse :: SocketException eAddressInUse = SocketException (#const SEADDRINUSE) --- | > SocketException "Cannot assign requested address" +-- | Cannot assign requested address. eAddressNotAvailable :: SocketException eAddressNotAvailable = SocketException (#const SEADDRNOTAVAIL) --- | > SocketException "Network is down" +-- | Network is down. eNetworkDown :: SocketException eNetworkDown = SocketException (#const SENETDOWN) --- | > SocketException "Network is unreachable" +-- | Network is unreachable. eNetworkUnreachable :: SocketException eNetworkUnreachable = SocketException (#const SENETUNREACH) --- | > SocketException "Network dropped connection on reset" +-- | Network dropped connection on reset. eNetworkReset :: SocketException eNetworkReset = SocketException (#const SENETRESET) --- | > SocketException "Software caused connection abort" +-- | Software caused connection abort. eConnectionAborted :: SocketException eConnectionAborted = SocketException (#const SECONNABORTED) --- | > SocketException "Connection reset by peer" +-- | Connection reset by peer. eConnectionReset :: SocketException eConnectionReset = SocketException (#const SECONNRESET) --- | > SocketException "No buffer space available" +-- | No buffer space available. eNoBufferSpace :: SocketException eNoBufferSpace = SocketException (#const SENOBUFS) --- | > SocketException "Transport endpoint is already connected" +-- | Transport endpoint is already connected. eIsConnected :: SocketException eIsConnected = SocketException (#const SEISCONN) --- | > SocketException "Transport endpoint is not connected" +-- | Transport endpoint is not connected. eNotConnected :: SocketException eNotConnected = SocketException (#const SENOTCONN) --- | > SocketException "Cannot send after transport endpoint shutdown" +-- | Cannot send after transport endpoint shutdown. eShutdown :: SocketException eShutdown = SocketException (#const SESHUTDOWN) --- | > SocketException "Too many references: cannot splice" +-- | Too many references: cannot splice. eTooManyReferences :: SocketException eTooManyReferences = SocketException (#const SETOOMANYREFS) --- | > SocketException "Connection timed out" +-- | Connection timed out. eTimedOut :: SocketException eTimedOut = SocketException (#const SETIMEDOUT) --- | > SocketException "Connection refused" +-- | Connection refused. eConnectionRefused :: SocketException eConnectionRefused = SocketException (#const SECONNREFUSED) --- | > SocketException "Host is down" +-- | Host is down. eHostDown :: SocketException eHostDown = SocketException (#const SEHOSTDOWN) --- | > SocketException "No route to host" +-- | No route to host. eHostUnreachable :: SocketException eHostUnreachable = SocketException (#const SEHOSTUNREACH) --- | > SocketException "Operation already in progress" +-- | 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" +-- | 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 @@ -10,7 +10,6 @@ -------------------------------------------------------------------------------- module System.Socket.Internal.Message ( MessageFlags (..) - , Message , msgEndOfRecord , msgNoSignal , msgOutOfBand @@ -21,6 +20,7 @@ import Data.Monoid import Data.Maybe import Data.List (intersperse) +import Data.Semigroup as Sem import Foreign.C.Types import Foreign.Storable @@ -38,11 +38,12 @@ = MessageFlags CInt deriving (Eq, Bits, Storable) -data Message a t p +instance Sem.Semigroup MessageFlags where + (<>) = (.|.) instance Monoid MessageFlags where mempty = MessageFlags 0 - mappend = (.|.) + mappend = (Sem.<>) instance Show MessageFlags where show msg = "mconcat [" ++ y ++ "]" @@ -56,10 +57,6 @@ ] y = concat $ intersperse "," $ catMaybes x --- | @MSG_EOR@ -msgEndOfRecord :: MessageFlags -msgEndOfRecord = MessageFlags (#const MSG_EOR) - -- | @MSG_NOSIGNAL@ -- -- Suppresses the generation of @PIPE@ signals when writing to a socket @@ -83,13 +80,34 @@ -- ignores them if you don't hook them explicitly. The -- non-portable socket option `SO_NOSIGPIPE` may be used disable signals -- on a per-socket basis. +-- +-- __/It is safe and advised to always use this flag unless one wants to/__ +-- __/explictly hook and handle the @PIPE@ signal which is not very useful in todays/__ +-- __/multi-threaded environments anyway. Although GHC's RTS ignores the/__ +-- __/signal by default it causes an unnecessary interruption./__ msgNoSignal :: MessageFlags msgNoSignal = MessageFlags (#const MSG_NOSIGNAL) +-- | @MSG_EOR@ +-- +-- Used by `System.Socket.Type.SequentialPacket.SequentialPacket` to mark record boundaries. +-- Consult the POSIX standard for details. +msgEndOfRecord :: MessageFlags +msgEndOfRecord = MessageFlags (#const MSG_EOR) +{-# WARNING msgEndOfRecord "Untested: Use at your own risk!" #-} + -- | @MSG_OOB@ +-- +-- Used to send and receive out-of-band data. Consult the relevant standards +-- for details. msgOutOfBand :: MessageFlags msgOutOfBand = MessageFlags (#const MSG_OOB) +{-# WARNING msgOutOfBand "Untested: Use at your own risk!" #-} -- | @MSG_WAITALL@ +-- +-- A `System.Socket.receive` call shall not return unless the requested number of +-- bytes becomes available. msgWaitAll :: MessageFlags msgWaitAll = MessageFlags (#const MSG_WAITALL) +{-# WARNING msgWaitAll "Untested: Use at your own risk!" #-} 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 @@ -132,8 +132,8 @@ -- - The `Data.Int.Int64` parameter is a soft limit on how many bytes to receive. -- Collection is stopped if the limit has been exceeded. The result might -- be up to one internal buffer size longer than the given limit. --- If the returned `Data.ByteString.Lazy.ByteString`s length is lower or --- eqal than the limit, the data has not been truncated and the +-- If the returned `Data.ByteString.Lazy.ByteString`s length is lower than or +-- equal to the limit, the data has not been truncated and the -- transmission is complete. receiveAll :: Socket f Stream p -> Int64 -> MessageFlags -> IO LBS.ByteString receiveAll sock maxLen flags = collect 0 Data.Monoid.mempty @@ -150,3 +150,5 @@ $! (accum `Data.Monoid.mappend` BB.byteString bs) build accum = do return (BB.toLazyByteString accum) + +{-# DEPRECATED receiveAll "Semantics will change in the next major release. Don't use it anymore!" #-} diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,28 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (async, cancel, concurrently, poll, - race, wait) -import Control.Exception (bracket, catch, throwIO, try) -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) -import Prelude hiding (head) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async, cancel, concurrently, + poll, race, wait) +import Control.Exception (bracket, catch, throwIO, try) +import Control.Monad (unless, void, when) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int64) +import Data.Maybe (isJust) +import Data.Monoid (mappend, mempty) +import Prelude hiding (head) import System.Socket import System.Socket.Family.Inet import System.Socket.Family.Inet6 +import System.Socket.Protocol.Default import System.Socket.Protocol.TCP import System.Socket.Protocol.UDP import System.Socket.Type.Datagram import System.Socket.Type.Stream import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as QC +import Test.Tasty.QuickCheck as QC main :: IO () main = defaultMain $ testGroup "socket" @@ -33,6 +34,7 @@ , group03 , group07 , group80 + , group98 , group99 ] , testGroup "System.Socket.Inet" [ @@ -49,7 +51,7 @@ group00 :: TestTree group00 = testGroup "accept" - [ testGroup "Inet/Strem/TCP" + [ testGroup "Inet/Stream/TCP" [ testCase "cancel operation" $ -- | This is to test interruptability of (blocking) calls like -- accept. The implementation may either run the call "safe" @@ -430,6 +432,19 @@ ] ] +group98 :: TestTree +group98 = testGroup "getAddress" [ + + testCase "getAddress after bind" $ bracket + ( socket :: IO (Socket Inet Stream Default) ) close + ( \s -> do + let addr = SocketAddressInet (inetAddressFromTuple (127,0,0,1)) 8080 + bind s addr + addr' <- getAddress s + assertEqual "" addr' addr + ) + ] + group99 :: TestTree group99 = testGroup "getAddrInfo" [ @@ -448,7 +463,7 @@ , testCase "getAddrInfo \"\" \"\"" $ void (getAddressInfo Nothing Nothing mempty :: IO [AddressInfo Inet Stream TCP]) `catch` \e-> case e of _ | e == eaiNoName -> return () - _ -> assertFailure "expected eaiNoName" + _ -> assertFailure "expected eaiNoName" ]