diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## Version 3.0.1.1 + +* Fix blocking `if_nametoindex` errors on Windows + [#391](https://github.com/haskell/network/pull/391) + ## Version 3.0.1.0 * Added `getSocketType :: Socket -> IO SocketType`. @@ -28,7 +33,7 @@ new mkSocket :: CInt -> IO Socket ``` * Breaking change: the deprecated APIs are removed: send, sendTo, recv, recvFrom, recvLen, htonl, ntohl, inet_addr, int_ntoa, bindSocket, sClose, SocketStatus, isConnected, isBound, isListening, isReadable, isWritable, sIsConnected, sIsBound, sIsListening, sIsReadable, sIsWritable, aNY_PORT, iNADDR_ANY, iN6ADDR_ANY, sOMAXCONN, sOL_SOCKET, sCM_RIGHTS, packSocketType, getPeerCred. -* Breaking chage: SockAddrCan is removed from SockAddr. +* Breaking change: SockAddrCan is removed from SockAddr. * Socket addresses are extendable with Network.Socket.Address. * "socket" is now asynchronous-exception-safe. [#336](https://github.com/haskell/network/pull/336) diff --git a/Network/Socket/Fcntl.hs b/Network/Socket/Fcntl.hs --- a/Network/Socket/Fcntl.hs +++ b/Network/Socket/Fcntl.hs @@ -15,7 +15,7 @@ setNonBlockIfNeeded fd = System.Posix.Internals.setNonBlockingFD fd True --- | Set the nonblocking flag on Unix. +-- | Set the close_on_exec flag on Unix. -- On Windows, nothing is done. -- -- Since 2.7.0.0. @@ -45,7 +45,7 @@ return (ret /= 0) #endif --- | Get the close_on_exec flag. +-- | Get the nonblocking flag. -- On Windows, this function always returns 'False'. -- -- Since 2.7.0.0. 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.0.1.0 +version: 3.0.1.1 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Evan Borden @@ -95,8 +95,6 @@ Network.Socket.ByteString.IOVec Network.Socket.ByteString.Lazy.Posix Network.Socket.ByteString.MsgHdr - build-depends: - unix >= 2 c-sources: cbits/ancilData.c if os(solaris) @@ -106,7 +104,7 @@ other-modules: Network.Socket.ByteString.Lazy.Windows c-sources: cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c - extra-libraries: ws2_32 + extra-libraries: ws2_32, iphlpapi -- See https://github.com/haskell/network/pull/362 if impl(ghc >= 7.10) cpp-options: -D_WIN32_WINNT=0x0600 diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs --- a/tests/Network/SocketSpec.hs +++ b/tests/Network/SocketSpec.hs @@ -29,8 +29,25 @@ connect' (8080 :: Int) `shouldThrow` anyIOException it "successfully connects to a socket with no exception" $ do - tcpTestUsingClient return return $ readMVar >=> connect' + withPort $ \portVar -> test (tcp return portVar) + { clientSetup = readMVar portVar >>= connect' + } + describe "bind" $ do + let hints = defaultHints + { addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + it "successfully binds to an ipv6 socket" $ do + addr:_ <- getAddrInfo (Just hints) (Just serverAddr6) Nothing + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + bind sock $ addrAddress addr + + it "fails to bind to unknown ipv6 socket" $ do + addr:_ <- getAddrInfo (Just hints) (Just "::6") Nothing + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + bind sock (addrAddress addr) `shouldThrow` anyIOException + describe "UserTimeout" $ do it "can be set" $ do when (isSupportedSocketOption UserTimeout) $ do @@ -41,44 +58,6 @@ getSocketOption sock UserTimeout `shouldReturn` 2000 close sock - -- On various BSD systems the peer credentials are exchanged during - -- connect(), and this does not happen with `socketpair()`. Therefore, - -- we must actually set up a listener and connect, rather than use a - -- socketpair(). - -- - describe "getPeerCredential" $ do - it "can return something" $ do - when isUnixDomainSocketAvailable $ 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 client sock = do - (_, uid, _) <- getPeerCredential sock - uid `shouldNotBe` Nothing - server (sock, _) = do - (_, uid, _) <- getPeerCredential sock - uid `shouldNotBe` Nothing - unixTest client 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 - provided sock is an AF_UNIX socket. This will fixed some day, but - we should not fail on those systems in the mean-time. The upstream - C-library fix is to call getsockname() and check the address family - before calling `getpeereid()`. We could duplicate that in our own - code, and then this test would work on those platforms that have - `getpeereid()` and not the SO_PEERCRED socket option. - - it "return nothing for non-UNIX-domain socket" $ do - when isUnixDomainSocketAvailable $ do - s <- socket AF_INET Stream defaultProtocol - cred1 <- getPeerCredential s - cred1 `shouldBe` (Nothing,Nothing,Nothing) - -} - describe "getAddrInfo" $ do it "works for IPv4 address" $ do let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } @@ -100,11 +79,94 @@ let hints = defaultHints { addrFlags = [AI_NUMERICSERV] } void $ getAddrInfo (Just hints) (Just "localhost") Nothing - describe "unix sockets" $ do - it "basic unix sockets end-to-end" $ do - when isUnixDomainSocketAvailable $ do +#if defined(mingw32_HOST_OS) + let lpdevname = "loopback_0" +#else + let lpdevname = "lo" +#endif + + describe "ifNameToIndex" $ do + it "converts a name to an index" $ + ifNameToIndex lpdevname `shouldReturn` Just 1 + + describe "ifIndexToName" $ do + it "converts an index to a name" $ + ifIndexToName 1 `shouldReturn` Just lpdevname + + + 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 "") - unixTest client server + recv sock 1024 `shouldReturn` testMsg + addr `shouldBe` (SockAddrUnix "") + test . setClientAction client $ unixWithUnlink unixAddr server + +#ifdef linux_HOST_OS + it "can end-to-end with an abstract socket" $ do + let + abstractAddress = toEnum 0:"/haskell/network/abstract" + client sock = send sock testMsg + server (sock, addr) = do + recv sock 1024 `shouldReturn` testMsg + addr `shouldBe` (SockAddrUnix "") + test . setClientAction client $ + unix abstractAddress (const $ return ()) $ server +#endif + + describe "socketPair" $ do + it "can send and recieve bi-directionally" $ do + (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol + void $ send s1 testMsg + recv s2 1024 `shouldReturn` testMsg + void $ send s2 testMsg + recv s1 1024 `shouldReturn` testMsg + + describe "sendFd/recvFd" $ do + it "can send and recieve a file descriptor" $ do + (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol + (s3, s4) <- socketPair AF_UNIX Stream defaultProtocol + fd1 <- fdSocket s1 + void $ sendFd s3 fd1 + fd1' <- recvFd s4 + s1' <- mkSocket fd1' + void $ send s1' testMsg + recv s2 1024 `shouldReturn` testMsg + + -- On various BSD systems the peer credentials are exchanged during + -- connect(), and this does not happen with `socketpair()`. Therefore, + -- we must actually set up a listener and connect, rather than use a + -- socketpair(). + -- + 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 + {- 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 + provided sock is an AF_UNIX socket. This will fixed some day, but + we should not fail on those systems in the mean-time. The upstream + C-library fix is to call getsockname() and check the address family + before calling `getpeereid()`. We could duplicate that in our own + code, and then this test would work on those platforms that have + `getpeereid()` and not the SO_PEERCRED socket option. + + it "return nothing for non-UNIX-domain socket" $ do + when isUnixDomainSocketAvailable $ do + s <- socket AF_INET Stream defaultProtocol + cred1 <- getPeerCredential s + cred1 `shouldBe` (Nothing,Nothing,Nothing) + -} 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 @@ -3,13 +3,25 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.Test.Common - ( serverAddr - , testMsg - , lazyTestMsg + ( -- * Client server configuration + ClientServer(..) + , setClientAction + , setServerAction + , tcp + , unix + , unixWithUnlink + , udp + , withPort + -- * Run a ClientServer configuration + , test , tcpTest - , unixTest , udpTest - , tcpTestUsingClient + -- * Common constants + , serverAddr + , serverAddr6 + , unixAddr + , testMsg + , lazyTestMsg ) where import Control.Concurrent (ThreadId, forkIO, myThreadId) @@ -27,6 +39,9 @@ serverAddr :: String serverAddr = "127.0.0.1" +serverAddr6 :: String +serverAddr6 = "::1" + testMsg :: ByteString testMsg = "This is a test message." @@ -41,32 +56,37 @@ -- get passed a connected 'Socket', used for communicating between -- client and server. 'unixTest' makes sure that the 'Socket' is -- closed after the actions have run. -unixTest :: (Socket -> IO a) -> ((Socket, SockAddr) -> IO b) -> IO () -unixTest clientAct serverAct = - test clientSetup clientAct serverSetup server +unixWithUnlink :: String -> ((Socket, SockAddr) -> IO b) -> (ClientServer Socket b) +unixWithUnlink address = unix address unlink where - clientSetup = do + unlink file = do + exist <- doesFileExist file + when exist $ removeFile file + +unix + :: String -- ^ address + -> (String -> IO ()) -- ^ clean up action + -> ((Socket, SockAddr) -> IO b) -- ^ server action + -> (ClientServer Socket b) +unix address cleanupAct serverAct = defaultClientServer + { clientSetup = do sock <- socket AF_UNIX Stream defaultProtocol - connect sock (SockAddrUnix unixAddr) + connect sock (SockAddrUnix address) return sock - - serverSetup = do + , serverSetup = do sock <- socket AF_UNIX Stream defaultProtocol - unlink unixAddr -- just in case - bind sock (SockAddrUnix unixAddr) + cleanupAct address -- just in case + bind sock (SockAddrUnix address) listen sock 1 return sock - - server sock = E.bracket (accept sock) (killClientSock . fst) serverAct - - unlink file = do - exist <- doesFileExist file - when exist $ removeFile file - + , serverAction = \sock -> + E.bracket (accept sock) (killClientSock . fst) serverAct + } + where killClientSock sock = do shutdown sock ShutdownBoth close sock - unlink unixAddr + cleanupAct address -- | Establish a connection between client and server and then run -- 'clientAct' and 'serverAct', in different threads. Both actions @@ -74,10 +94,11 @@ -- client and server. 'tcpTest' makes sure that the 'Socket' is -- closed after the actions have run. tcpTest :: (Socket -> IO a) -> (Socket -> IO b) -> IO () -tcpTest clientAct serverAct = - tcpTestUsingClient serverAct clientAct clientSetup - where - clientSetup portVar = do +tcpTest client server = withPort $ test . setClientAction client . tcp server + +tcp :: (Socket -> IO b) -> MVar PortNumber -> ClientServer Socket () +tcp serverAct portVar = defaultClientServer + { clientSetup = do let hints = defaultHints { addrSocketType = Stream } serverPort <- readMVar portVar addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) @@ -89,18 +110,11 @@ #endif connect sock $ addrAddress addr return sock - -tcpTestUsingClient - :: (Socket -> IO a) -> (Socket -> IO b) -> (MVar PortNumber -> IO Socket) -> IO () -tcpTestUsingClient serverAct clientAct clientSetup = do - portVar <- newEmptyMVar - test (clientSetup portVar) clientAct (serverSetup portVar) server - where - serverSetup portVar = do + , serverSetup = do let hints = defaultHints { addrFlags = [AI_PASSIVE] - , addrSocketType = Stream - } + , addrSocketType = Stream + } addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) fd <- fdSocket sock @@ -118,8 +132,7 @@ serverPort <- socketPort sock putMVar portVar serverPort return sock - - server sock = do + , serverAction = \sock -> do (clientSock, _) <- accept sock #if !defined(mingw32_HOST_OS) fd <- fdSocket clientSock @@ -128,25 +141,28 @@ #endif _ <- serverAct clientSock close clientSock + } -- | Create an unconnected 'Socket' for sending UDP and receiving -- datagrams and then run 'clientAct' and 'serverAct'. udpTest :: (Socket -> PortNumber -> IO a) -> (Socket -> IO b) -> IO () -udpTest clientAct serverAct = do - portVar <- newEmptyMVar - test clientSetup (client portVar) (serverSetup portVar) serverAct - where - clientSetup = socket AF_INET Datagram defaultProtocol +udpTest client server = + withPort $ test . setServerAction server . udp client - client portVar sock = do +udp + :: (Socket -> PortNumber -> IO a) + -> MVar PortNumber + -> ClientServer a Socket +udp clientAct portVar = defaultClientServer + { clientSetup = socket AF_INET Datagram defaultProtocol + , clientAction = \sock -> do serverPort <- readMVar portVar clientAct sock serverPort - - serverSetup portVar = do + , serverSetup = do let hints = defaultHints { addrFlags = [AI_PASSIVE] - , addrSocketType = Datagram - } + , addrSocketType = Datagram + } addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) setSocketOption sock ReuseAddr 1 @@ -154,32 +170,64 @@ serverPort <- socketPort sock putMVar portVar serverPort return sock + } +data ClientServer a b + = ClientServer + { clientSetup :: IO Socket + , clientAction :: Socket -> IO a + , serverSetup :: IO Socket + , serverAction :: Socket -> IO b + } + +setClientAction + :: (Socket -> IO b) + -> ClientServer a c + -> ClientServer b c +setClientAction f c = c { clientAction = f } + +setServerAction + :: (Socket -> IO c) + -> ClientServer a b + -> ClientServer a c +setServerAction f c = c { serverAction = f } + +defaultClientServer :: ClientServer Socket Socket +defaultClientServer = ClientServer + { clientSetup = + E.throwIO $ userError "no client setup defined" + , clientAction = return + , serverSetup = E.throwIO $ userError "no server setup defined" + , serverAction = return + } + -- | Run a client/server pair and synchronize them so that the server -- is started before the client and the specified server action is -- finished before the client closes the 'Socket'. -test :: IO Socket -> (Socket -> IO b) -> IO Socket -> (Socket -> IO c) -> IO () -test clientSetup clientAct serverSetup serverAct = do +test :: ClientServer a b -> IO () +test conf = do tid <- myThreadId barrier <- newEmptyMVar - _ <- forkIO $ server barrier + _ <- forkIO $ server tid barrier client tid barrier where - server barrier = - E.bracket serverSetup close $ \sock -> do + server tid barrier = + bracketWithReraise tid (serverSetup conf) close $ \sock -> do serverReady - Just _ <- timeout 1000000 $ serverAct sock + Just _ <- timeout 1000000 $ (serverAction conf) sock putMVar barrier () where -- | Signal to the client that it can proceed. serverReady = putMVar barrier () - client tid barrier = do takeMVar barrier -- Transfer exceptions to the main thread. - bracketWithReraise tid clientSetup close $ \res -> do - Just _ <- timeout 1000000 $ clientAct res + bracketWithReraise tid (clientSetup conf) close $ \res -> do + Just _ <- timeout 1000000 $ (clientAction conf) res takeMVar barrier + +withPort :: (MVar PortNumber -> IO a) -> IO a +withPort f = f =<< newEmptyMVar -- | Like 'bracket' but catches and reraises the exception in another -- thread, specified by the first argument.