network-run-0.7.0: test/TCPSpec.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module TCPSpec (spec) where
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
import Data.ByteString (ByteString)
import Data.IORef
import Data.List (nub)
import qualified Data.List.NonEmpty as NE
import GHC.IO.Exception (IOErrorType (InvalidArgument), ioe_errno)
import Network.Socket
import Network.Socket.ByteString
import System.IO.Error (ioeGetErrorType)
import System.Info (os)
import System.Timeout (timeout)
import Test.Hspec
import Network.Run.Core (openServerSocket)
import Network.Run.TCP
import Helper
spec :: Spec
spec = do
describe "runTCPServer" $ do
it "serves a connection" $
limited $
withTCPServer defaultServerSettings echo $ \port ->
request port "hello" `shouldReturn` "hello"
it "resolves and binds the address itself" $ limited $ do
-- The port cannot be chosen in advance here, so an
-- ephemeral one is looked up first.
port <- freeTCPPort
withServerThread (runTCPServer (Just loopback) (show port) echo) $ do
threadDelay 200000
request port "hello" `shouldReturn` "hello"
it "keeps serving after a handler throws" $ limited $ do
(set, getReports) <- collecting
ref <- newIORef (0 :: Int)
withTCPServer set (failFirst ref) $ \port -> do
ignoreAny $ request port "hello"
request port "hello" `shouldReturn` "hello"
reports <- waitFor 1 getReports
length reports `shouldBe` 1
it "reports the peer of a failed handler" $ limited $ do
(set, getReports) <- collecting
withTCPServer set (\_ -> E.throwIO $ userError "boom") $ \port -> do
peer <- client port $ \sock -> do
sendAll sock "hello"
getSocketName sock
reports <- waitFor 1 getReports
map fst reports `shouldBe` [Just peer]
it "keeps serving when the exception hook itself throws" $ limited $ do
let set =
defaultServerSettings
{ settingsOnException = \_ _ -> E.throwIO $ userError "hook"
}
ref <- newIORef (0 :: Int)
withTCPServer set (failFirst ref) $ \port -> do
ignoreAny $ request port "hello"
request port "hello" `shouldReturn` "hello"
it "stops when the listening socket is closed" $ limited $ do
done <- newEmptyMVar
withListenSocket $ \lsock _ -> do
void $
forkFinally (runTCPServerWithSocket lsock echo) (putMVar done)
threadDelay 100000
close lsock
r <- timeout 2000000 $ takeMVar done
case r of
Just (Right _) -> return ()
Just (Left e) ->
expectationFailure $ "the accept loop threw: " ++ show e
Nothing -> expectationFailure "the accept loop did not stop"
it "stops when the shutdown handler is run" $ limited $ do
told <- newEmptyMVar
done <- newEmptyMVar
let set =
defaultServerSettings
{ settingsInstallShutdownHandler = putMVar told
}
withListenSocket $ \lsock _ -> do
void $
forkFinally
(runTCPServerWithSocketAndSettings set lsock echo)
(putMVar done)
stop <- takeMVar told
threadDelay 100000
stop
r <- timeout 2000000 $ takeMVar done
case r of
Just (Right _) -> return ()
Just (Left e) ->
expectationFailure $ "the accept loop threw: " ++ show e
Nothing -> expectationFailure "the accept loop did not stop"
it "listens on a single address family" $ limited $ do
port <- freeTCPPort
let hints =
defaultHints
{ addrSocketType = Stream
, addrFlags = [AI_PASSIVE]
}
addrs <- getAddrInfo (Just hints) (Just "localhost") (Just $ show port)
let families = NE.toList $ NE.map addrFamily addrs
if length (nub families) < 2
then pendingWith "localhost has a single address family here"
else do
-- Only the first address is used, so the other
-- family is not served at all.
let (served, unserved)
| addrFamily (NE.head addrs) == AF_INET6 =
("::1", "127.0.0.1")
| otherwise = ("127.0.0.1", "::1")
withServerThread (runTCPServer (Just "localhost") (show port) echo) $ do
threadDelay 200000
echoOn served port `shouldReturn` "hello"
echoOn unserved port `shouldThrow` anyIOException
it "drains a connection when the graceful close timeout is positive" $ limited $ do
-- The handler returns while the request it never read is
-- still queued. 'gracefulClose' sends FIN and drains it.
gate <- newEmptyMVar
let set = defaultServerSettings{settingsGracefulCloseTimeout = 500}
withTCPServer set (\_ -> takeMVar gate) $ \port ->
client port $ \sock -> do
sendAll sock "hello"
threadDelay 200000
putMVar gate ()
recv sock 1024 `shouldReturn` ""
it "resets a connection when the graceful close timeout is not positive" $ limited $ do
-- The same, with 'close' instead: unread data in the queue
-- makes the kernel answer with RST.
gate <- newEmptyMVar
let set = defaultServerSettings{settingsGracefulCloseTimeout = 0}
withTCPServer set (\_ -> takeMVar gate) $ \port ->
client port $ \sock -> do
sendAll sock "hello"
threadDelay 200000
putMVar gate ()
recv sock 1024 `shouldThrow` anyIOException
it "serves many connections concurrently" $
limited $
withTCPServer defaultServerSettings echo $ \port -> do
vars <- replicateM 50 newEmptyMVar
forM_ vars $ \var -> forkIO $ do
r <-
(Just <$> request port "hello")
`E.catch` \(_ :: E.SomeException) -> return Nothing
putMVar var r
rs <- mapM takeMVar vars
rs `shouldBe` replicate 50 (Just "hello")
describe "openTCPServerSocket" $ do
it "listens, unlike openServerSocket" $ limited $ do
addr <- resolve Stream (Just loopback) "0" [AI_PASSIVE] NE.head
-- Probing with 'connect' instead would be slow: BSD drops
-- the SYN sent to a socket which is bound but does not
-- listen, where Linux answers with RST.
E.bracket (openServerSocket addr) close $ \sock ->
accept sock `shouldThrow` invalidArgument
withTCPServer defaultServerSettings echo $ \port ->
request port "hello" `shouldReturn` "hello"
it "sets ReuseAddr" $ limited $ withListenSocket $ \lsock _ ->
getSocketOption lsock ReuseAddr `shouldNotReturn` 0
it "sets close-on-exec" $ limited $
if os == "mingw32"
then pendingWith "Windows has no close-on-exec"
else withListenSocket $ \lsock _ ->
withFdSocket lsock getCloseOnExec `shouldReturn` True
it "sets a composite option" $ limited $ do
addr <- resolve Stream (Just loopback) "0" [AI_PASSIVE] NE.head
let opts = [(Linger, SockOptValue $ StructLinger 1 0)]
E.bracket (openTCPServerSocketWithOpts opts addr) close $ \lsock -> do
StructLinger onoff _ <- getSockOpt lsock Linger
onoff `shouldBe` 1
it "makes an IPv6 socket IPv6 only" $ limited $ onIPv6 $ do
addr <- resolve Stream (Just "::") "0" [AI_PASSIVE] NE.head
E.bracket (openTCPServerSocket addr) close $ \lsock -> do
getSocketOption lsock IPv6Only `shouldNotReturn` 0
port <- portOf <$> getSocketName lsock
withServerThread (void $ runTCPServerWithSocket lsock echo) $ do
-- The IPv4 loopback must not reach it.
r <- E.try $ request port "hello"
case r :: Either E.IOException ByteString of
Left _ -> return ()
Right _ -> expectationFailure "IPv4 reached an IPv6 only socket"
it "can be asked for a dual stack socket" $
limited $
onIPv6 $
if os == "openbsd"
then pendingWith "OpenBSD always makes IPv6 sockets IPv6 only"
else do
addr <- resolve Stream (Just "::") "0" [AI_PASSIVE] NE.head
E.bracket
(openTCPServerSocketWithOptions [(IPv6Only, 0)] addr)
close
$ \lsock -> do
port <- portOf <$> getSocketName lsock
withServerThread
(void $ runTCPServerWithSocket lsock echo)
$ request port "hello" `shouldReturn` "hello"
describe "runTCPClient" $ do
it "opens the socket with settingsOpenClientSocket" $ limited $ do
ref <- newIORef (0 :: Int)
withTCPServer defaultServerSettings echo $ \port -> do
let set =
defaultSettings
{ settingsOpenClientSocket = \addr -> do
atomicModifyIORef' ref $ \n -> (n + 1, ())
openClientSocketWithOptions [(NoDelay, 1)] addr
}
r <- runTCPClientWithSettings set loopback (show port) $ \sock -> do
sendAll sock "hello"
recv sock 1024
r `shouldBe` "hello"
readIORef ref `shouldReturn` 1
it "connects to what settingsSelectAddrInfo chose" $
limited $
withTCPServer defaultServerSettings echo $ \port -> do
-- Resolving a port where nothing listens, and then
-- replacing the address with the real one. Only a
-- client which honours the selection can connect.
let real = SockAddrInet port $ tupleToHostAddress (127, 0, 0, 1)
set =
defaultSettings
{ settingsSelectAddrInfo = \ais ->
(NE.head ais){addrAddress = real}
}
wrong = show (port + 1)
r <- runTCPClientWithSettings set loopback wrong $ \sock -> do
sendAll sock "hello"
recv sock 1024
r `shouldBe` "hello"
it "closes the socket when the action throws" $ limited $ do
ref <- newIORef Nothing
withTCPServer defaultServerSettings echo $ \port -> do
let set =
defaultSettings
{ settingsOpenClientSocket = \addr -> do
sock <- openClientSocket addr
writeIORef ref $ Just sock
return sock
}
action = runTCPClientWithSettings set loopback (show port) $
\_ -> E.throwIO $ userError "boom"
(action :: IO ()) `shouldThrow` anyIOException
msock <- readIORef ref
case msock of
Nothing -> expectationFailure "the socket was never opened"
Just sock -> do
r <- E.try $ getSocketOption sock ReuseAddr
case r :: Either E.IOException Int of
Left _ -> return ()
Right _ -> expectationFailure "the client socket is still open"
describe "resolve" $ do
it "asks for a passive wildcard address" $ do
addr <- resolve Stream Nothing "0" [AI_PASSIVE] NE.head
addrSocketType addr `shouldBe` Stream
case addrAddress addr of
SockAddrInet _ ha -> ha `shouldBe` tupleToHostAddress (0, 0, 0, 0)
SockAddrInet6 _ _ ha _ ->
ha `shouldBe` tupleToHostAddress6 (0, 0, 0, 0, 0, 0, 0, 0)
sa -> expectationFailure $ "unexpected address: " ++ show sa
it "uses the given socket type" $ do
addr <- resolve Datagram (Just loopback) "0" [] NE.head
addrSocketType addr `shouldBe` Datagram
it "returns what the selector chose" $ do
let mark = SockAddrInet 1 $ tupleToHostAddress (1, 2, 3, 4)
addr <- resolve Stream (Just loopback) "0" [] $ \ais ->
(NE.head ais){addrAddress = mark}
addrAddress addr `shouldBe` mark
----------------------------------------------------------------
-- | 'accept' on a socket which is not listening fails with @EINVAL@.
--
-- Winsock numbers its errors apart from @errno@ and network reports them
-- all as 'GHC.IO.Exception.OtherError', so on Windows the code is what
-- there is to look at.
invalidArgument :: Selector E.IOException
invalidArgument e =
ioeGetErrorType e == InvalidArgument || ioe_errno e == Just wsaEINVAL
where
wsaEINVAL = 10022
-- | A handler which fails the first connection and echoes the rest.
failFirst :: IORef Int -> Socket -> IO ()
failFirst ref sock = do
n <- atomicModifyIORef' ref $ \n -> (n + 1, n)
if n == 0 then E.throwIO (userError "boom") else echo sock
-- | One request and one response to the given host.
echoOn :: HostName -> PortNumber -> IO ByteString
echoOn host port = runTCPClient host (show port) $ \sock -> do
sendAll sock "hello"
recv sock 1024
-- | A TCP port which is free at the time of the call.
freeTCPPort :: IO PortNumber
freeTCPPort = withListenSocket $ \_ port -> return port
onIPv6 :: IO () -> IO ()
onIPv6 action = do
ok <- hasIPv6
if ok then action else pendingWith "no IPv6 on this machine"