diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # CHANGELOG for network +## Version 3.2.9.0 + +* Exporting recvBufNoWait. + ## Version 3.2.8.0 * sockopt: add IP_DONTFRAG/IP_MTU_DISCOVER option. diff --git a/Network/Socket.hs b/Network/Socket.hs --- a/Network/Socket.hs +++ b/Network/Socket.hs @@ -344,6 +344,7 @@ -- ** Sending and receiving data sendBuf, recvBuf, + recvBufNoWait, sendBufTo, recvBufFrom, diff --git a/Network/Socket/Buffer.hsc b/Network/Socket/Buffer.hsc --- a/Network/Socket/Buffer.hsc +++ b/Network/Socket/Buffer.hsc @@ -159,6 +159,8 @@ -- involved. The length of data is returned if received. -- -1 is returned in the case of EAGAIN or EWOULDBLOCK. -- -2 is returned in other error cases. +-- +-- @since 3.2.9.0 recvBufNoWait :: Socket -> Ptr Word8 -> Int -> IO Int recvBufNoWait s ptr nbytes = withFdSocket s $ \fd -> do #if defined(mingw32_HOST_OS) diff --git a/Network/Socket/Info.hsc b/Network/Socket/Info.hsc --- a/Network/Socket/Info.hsc +++ b/Network/Socket/Info.hsc @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} #include "HsNet.h" ##include "HsNetDef.h" @@ -446,68 +445,6 @@ unpackBits ((k,v):xs) r | r .&. v /= 0 = k : unpackBits xs (r .&. complement v) | otherwise = unpackBits xs r - ------------------------------------------------------------------------------ --- SockAddr - --- | --- --- >>> SockAddrInet6 80 0 (0,0,0xffff,0x01020304) 0 --- [::ffff:1.2.3.4]:80 -instance Show SockAddr where - showsPrec _ (SockAddrUnix str) = showString str - showsPrec _ (SockAddrInet port ha) - = showHostAddress ha - . showString ":" - . shows port - showsPrec _ (SockAddrInet6 port _ ha6 _) - = showChar '[' - . showHostAddress6 ha6 - . showString "]:" - . shows port - - --- Taken from on the implementation of showIPv4 in Data.IP.Addr -showHostAddress :: HostAddress -> ShowS -showHostAddress ip = - let (u3, u2, u1, u0) = hostAddressToTuple ip in - foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0] - -showHostAddress' :: HostAddress -> ShowS -showHostAddress' ip = - let (u3, u2, u1, u0) = hostAddressToTuple' ip in - foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0] - --- Taken from showIPv6 in Data.IP.Addr. - --- | Show an IPv6 address in the most appropriate notation, based on recommended --- representation proposed by . --- --- /The implementation is completely compatible with the current implementation --- of the `inet_ntop` function in glibc./ -showHostAddress6 :: HostAddress6 -> ShowS -showHostAddress6 ha6@(a1, a2, a3, a4) - -- IPv4-Mapped IPv6 Address - | a1 == 0 && a2 == 0 && a3 == 0xffff = - showString "::ffff:" . showHostAddress' a4 - -- IPv4-Compatible IPv6 Address (exclude IPRange ::/112) - | a1 == 0 && a2 == 0 && a3 == 0 && a4 >= 0x10000 = - showString "::" . showHostAddress' a4 - -- length of longest run > 1, replace it with "::" - | end - begin > 1 = - showFields prefix . showString "::" . showFields suffix - | otherwise = - showFields fields - where - fields = - let (u7, u6, u5, u4, u3, u2, u1, u0) = hostAddress6ToTuple ha6 in - [u7, u6, u5, u4, u3, u2, u1, u0] - showFields = foldr (.) id . intersperse (showChar ':') . map showHex - prefix = take begin fields -- fields before "::" - suffix = drop end fields -- fields after "::" - begin = end + diff -- the longest run of zeros - (diff, end) = minimum $ - scanl (\c i -> if i == 0 then c - 1 else 0) 0 fields `zip` [0..] ----------------------------------------------------------------------------- diff --git a/Network/Socket/Internal.hs b/Network/Socket/Internal.hs --- a/Network/Socket/Internal.hs +++ b/Network/Socket/Internal.hs @@ -84,11 +84,26 @@ -- | Throw an 'IOError' corresponding to the current socket error. throwSocketError :: String -- ^ textual description of the error location -> IO a +#if defined(mingw32_HOST_OS) +throwSocketError name = + c_getLastError >>= throwSocketErrorCode name +#else +throwSocketError = throwErrno +#endif -- | Like 'throwSocketError', but the error code is supplied as an argument. -- -- On Windows, do not use errno. Use a system error code instead. throwSocketErrorCode :: String -> CInt -> IO a +#if defined(mingw32_HOST_OS) +throwSocketErrorCode name rc = do + pstr <- c_getWSError rc + str <- peekCString pstr + ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str) +#else +throwSocketErrorCode loc errno = + ioError (errnoToIOError loc (Errno errno) Nothing Nothing) +#endif -- | Throw an 'IOError' corresponding to the current socket error if -- the IO action returns a result of @-1@. Discards the result of the @@ -98,6 +113,13 @@ => String -- ^ textual description of the location -> IO a -- ^ the 'IO' operation to be executed -> IO () +#if defined(mingw32_HOST_OS) +throwSocketErrorIfMinus1_ name act = do + _ <- throwSocketErrorIfMinus1Retry name act + return () +#else +throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry +#endif {-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-} @@ -109,6 +131,12 @@ => String -- ^ textual description of the location -> IO a -- ^ the 'IO' operation to be executed -> IO a +#if defined(mingw32_HOST_OS) +throwSocketErrorIfMinus1Retry + = throwSocketErrorIfMinus1ButRetry (const False) +#else +throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_ +#endif {-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-} @@ -136,6 +164,13 @@ -- immediate retry would block -> IO a -- ^ the 'IO' operation to be executed -> IO a +#if defined(mingw32_HOST_OS) +throwSocketErrorIfMinus1RetryMayBlock name _ act + = throwSocketErrorIfMinus1Retry name act +#else +throwSocketErrorIfMinus1RetryMayBlock name on_block act = + throwErrnoIfMinus1RetryMayBlock name act on_block +#endif {-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock :: String -> IO b -> IO CInt -> IO CInt #-} @@ -154,22 +189,20 @@ -- immediate retry would block -> IO a -- ^ the 'IO' operation to be executed -> IO a - -{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock - :: String -> IO b -> IO CInt -> IO CInt #-} - #if defined(mingw32_HOST_OS) - -throwSocketErrorIfMinus1RetryMayBlock name _ act - = throwSocketErrorIfMinus1Retry name act - throwSocketErrorIfMinus1RetryMayBlockBut exempt name _ act = throwSocketErrorIfMinus1ButRetry exempt name act +#else +throwSocketErrorIfMinus1RetryMayBlockBut _exempt name on_block act = + throwErrnoIfMinus1RetryMayBlock name act on_block +#endif -throwSocketErrorIfMinus1_ name act = do - _ <- throwSocketErrorIfMinus1Retry name act - return () +{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock + :: String -> IO b -> IO CInt -> IO CInt #-} +-- --------------------------------------------------------------------- + +#if defined(mingw32_HOST_OS) throwSocketErrorIfMinus1ButRetry :: (Eq a, Num a) => (CInt -> Bool) -> String -> IO a -> IO a throwSocketErrorIfMinus1ButRetry exempt name act = do @@ -189,41 +222,14 @@ else throwSocketError name else return r -throwSocketErrorIfMinus1Retry - = throwSocketErrorIfMinus1ButRetry (const False) - -throwSocketErrorCode name rc = do - pstr <- c_getWSError rc - str <- peekCString pstr - ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str) - -throwSocketError name = - c_getLastError >>= throwSocketErrorCode name - foreign import CALLCONV unsafe "WSAGetLastError" c_getLastError :: IO CInt foreign import ccall unsafe "getWSErrorDescr" c_getWSError :: CInt -> IO (Ptr CChar) - -#else - -throwSocketErrorIfMinus1RetryMayBlock name on_block act = - throwErrnoIfMinus1RetryMayBlock name act on_block - -throwSocketErrorIfMinus1RetryMayBlockBut _exempt name on_block act = - throwErrnoIfMinus1RetryMayBlock name act on_block - -throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry - -throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_ - -throwSocketError = throwErrno - -throwSocketErrorCode loc errno = - ioError (errnoToIOError loc (Errno errno) Nothing Nothing) - #endif + +-- --------------------------------------------------------------------- -- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with -- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready, diff --git a/Network/Socket/SockAddr.hs b/Network/Socket/SockAddr.hs --- a/Network/Socket/SockAddr.hs +++ b/Network/Socket/SockAddr.hs @@ -46,25 +46,25 @@ -- 'defaultPort' is passed then the system assigns the next available -- use port. bind :: Socket -> SockAddr -> IO () -bind s a = case a of +bind s sa = case sa of SockAddrUnix p -> do -- gracefully handle the fact that UNIX systems don't clean up closed UNIX -- domain sockets, inspired by https://stackoverflow.com/a/13719866 - res <- try (G.bind s a) + res <- try (G.bind s sa) case res of Right () -> return () Left e | not (isAlreadyInUseError e) -> throwIO (e :: IOException) Left e | otherwise -> do -- socket might be in use, try to connect - res2 <- try (G.connect s a) + res2 <- try (G.connect s sa) case res2 of Right () -> close s >> throwIO e Left e2 | not (isDoesNotExistError e2) -> throwIO (e2 :: IOException) _ -> do -- socket not actually in use, remove it and retry bind void (try $ removeFile p :: IO (Either IOError ())) - G.bind s a - _ -> G.bind s a + G.bind s sa + _ -> G.bind s sa -- | Accept a connection. The socket must be bound to an address and -- listening for connections. The return value is a pair @(conn, diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -1084,6 +1084,65 @@ rnf (SockAddrInet6 _ _ _ _) = () rnf (SockAddrUnix str) = rnf str +-- | +-- +-- >>> SockAddrInet6 80 0 (0,0,0xffff,0x01020304) 0 +-- [::ffff:1.2.3.4]:80 +instance Show SockAddr where + showsPrec _ (SockAddrUnix str) = showString str + showsPrec _ (SockAddrInet port ha) + = showHostAddress ha + . showString ":" + . shows port + showsPrec _ (SockAddrInet6 port _ ha6 _) + = showChar '[' + . showHostAddress6 ha6 + . showString "]:" + . shows port + + +-- Taken from on the implementation of showIPv4 in Data.IP.Addr +showHostAddress :: HostAddress -> ShowS +showHostAddress ip = + let (u3, u2, u1, u0) = hostAddressToTuple ip in + foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0] + +showHostAddress' :: HostAddress -> ShowS +showHostAddress' ip = + let (u3, u2, u1, u0) = hostAddressToTuple' ip in + foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0] + +-- Taken from showIPv6 in Data.IP.Addr. + +-- | Show an IPv6 address in the most appropriate notation, based on recommended +-- representation proposed by . +-- +-- /The implementation is completely compatible with the current implementation +-- of the `inet_ntop` function in glibc./ +showHostAddress6 :: HostAddress6 -> ShowS +showHostAddress6 ha6@(a1, a2, a3, a4) + -- IPv4-Mapped IPv6 Address + | a1 == 0 && a2 == 0 && a3 == 0xffff = + showString "::ffff:" . showHostAddress' a4 + -- IPv4-Compatible IPv6 Address (exclude IPRange ::/112) + | a1 == 0 && a2 == 0 && a3 == 0 && a4 >= 0x10000 = + showString "::" . showHostAddress' a4 + -- length of longest run > 1, replace it with "::" + | end - begin > 1 = + showFields prefix . showString "::" . showFields suffix + | otherwise = + showFields fields + where + fields = + let (u7, u6, u5, u4, u3, u2, u1, u0) = hostAddress6ToTuple ha6 in + [u7, u6, u5, u4, u3, u2, u1, u0] + showFields = foldr (.) id . intersperse (showChar ':') . map showHex + prefix = take begin fields -- fields before "::" + suffix = drop end fields -- fields after "::" + begin = end + diff -- the longest run of zeros + (diff, end) = minimum $ + scanl (\c i -> if i == 0 then c - 1 else 0) 0 fields `zip` [0..] + -- | Is the socket address type supported on this system? isSupportedSockAddr :: SockAddr -> Bool isSupportedSockAddr addr = case addr of diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: network -version: 3.2.8.0 +version: 3.2.9.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Tamar Christina diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs --- a/tests/Network/SocketSpec.hs +++ b/tests/Network/SocketSpec.hs @@ -158,11 +158,13 @@ when isUnixDomainSocketAvailable $ do context "unix sockets" $ do it "basic unix sockets end-to-end" $ do - let client sock = send sock testMsg - server (sock, addr) = do - recv sock 1024 `shouldReturn` testMsg - addr `shouldBe` (SockAddrUnix "") - test . setClientAction client $ unixWithUnlink unixAddr server + withSystemTempDirectory "haskell-network" $ \path -> do + let unixAddr = path ++ "/socket-file" + let client sock = send sock testMsg + server (sock, addr) = do + recv sock 1024 `shouldReturn` testMsg + addr `shouldBe` (SockAddrUnix "") + test . setClientAction client $ unixWithUnlink unixAddr server #endif #ifdef linux_HOST_OS @@ -208,19 +210,21 @@ -- describe "getPeerCredential" $ do it "can return something" $ do - -- It would be useful to check that we did not get garbage - -- back, but rather the actual uid of the test program. For - -- that we'd need System.Posix.User, but that is not available - -- under Windows. For now, accept the risk that we did not get - -- the right answer. - -- - let server (sock, _) = do - (_, uid, _) <- getPeerCredential sock - uid `shouldNotBe` Nothing - client sock = do - (_, uid, _) <- getPeerCredential sock - uid `shouldNotBe` Nothing - test . setClientAction client $ unixWithUnlink unixAddr server + withSystemTempDirectory "haskell-network" $ \path -> do + let unixAddr = path ++ "/socket-file" + -- It would be useful to check that we did not get garbage + -- back, but rather the actual uid of the test program. For + -- that we'd need System.Posix.User, but that is not available + -- under Windows. For now, accept the risk that we did not get + -- the right answer. + -- + let server (sock, _) = do + (_, uid, _) <- getPeerCredential sock + uid `shouldNotBe` Nothing + client sock = do + (_, uid, _) <- getPeerCredential sock + uid `shouldNotBe` Nothing + test . setClientAction client $ unixWithUnlink unixAddr server {- The below test fails on many *BSD systems, because the getsockopt() call that underlies getpeereid() does not have the same meaning for all address families, but the C-library was not checking that the diff --git a/tests/Network/Test/Common.hs b/tests/Network/Test/Common.hs --- a/tests/Network/Test/Common.hs +++ b/tests/Network/Test/Common.hs @@ -21,7 +21,6 @@ -- * Common constants , serverAddr , serverAddr6 - , unixAddr , testMsg , lazyTestMsg ) where @@ -52,9 +51,6 @@ lazyTestMsg :: L.ByteString lazyTestMsg = L.fromStrict "This is a test message." - -unixAddr :: String -unixAddr = "/tmp/network-test" -- | Establish a connection between client and server and then run -- 'clientAct' and 'serverAct', in different threads. Both actions