network-3.2.10.0: tests/Network/SocketSpec.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.SocketSpec (main, spec) where
import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar, takeMVar)
import Control.Exception (bracket)
import Control.Concurrent.STM
import Control.Monad
import Data.ByteString (ByteString)
import Data.Maybe (fromJust)
import Data.List (nub)
import Network.Socket
import Network.Socket.ByteString
import Network.Test.Common
import System.Mem (performGC)
import System.IO.Error (tryIOError)
import System.IO.Temp (withSystemTempDirectory)
import System.Posix.Types (Fd(..))
import Foreign.C.Types ()
import Test.Hspec
import Test.QuickCheck
main :: IO ()
main = hspec spec
-- Send through the given action to a port nobody has bound, then receive
-- on the same socket. 'Nothing' if the receive heard nothing in time.
bounce :: (Socket -> SockAddr -> IO ()) -> IO (Maybe ByteString)
bounce send' = do
dead <- deadPort
sock <- socket AF_INET Datagram defaultProtocol
bind sock $ SockAddrInet 0 localhost
send' sock dead
-- Long enough for the unreachable to come back before the receive.
waitFor 300000
late <- registerDelay 300000
r <- recvFromWith sock 2048 $ check =<< readTVar late
close sock
return $ either (const Nothing) (Just . fst) r
where
localhost = tupleToHostAddress (127, 0, 0, 1)
waitFor us = do
late <- registerDelay us
atomically $ check =<< readTVar late
-- Bind a port, read it, and let it go again.
deadPort = do
s <- socket AF_INET Datagram defaultProtocol
bind s $ SockAddrInet 0 localhost
sa <- getSocketName s
close s
return sa
spec :: Spec
spec = do
describe "connect" $ do
let
hints = defaultHints { addrSocketType = Stream }
connect' serverPort = do
addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
connect sock (addrAddress addr)
return sock
it "fails to connect and throws an IOException" $ do
connect' (8003 :: Int) `shouldThrow` anyIOException
it "successfully connects to a socket with no exception" $ do
withPort $ \portVar -> test (tcp serverAddr return portVar)
{ clientSetup = readMVar portVar >>= connect'
}
describe "bind" $ do
let hints = defaultHints
{ addrFlags = [AI_PASSIVE]
, addrSocketType = Stream
}
it "successfully binds to an ipv4 socket" $ do
addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
bind sock $ addrAddress addr
{- This does not work on Windows and Linux.
it "fails to bind to unknown ipv4 socket" $ do
addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.3") Nothing
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
bind sock (addrAddress addr) `shouldThrow` anyIOException
-}
#ifdef DEVELOPMENT
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
#endif
it "successfully binds to a unix socket" $ do
withSystemTempDirectory "haskell-network" $ \path -> do
let sfile = path ++ "/socket-file"
-- exist <- doesFileExist sfile
-- when exist $ removeFile sfile
-- removeFile sfile
let addr = SockAddrUnix sfile
when (isSupportedSockAddr addr) $ do
sock0 <- socket AF_UNIX Stream defaultProtocol
bind sock0 addr
listen sock0 1
sock1 <- socket AF_UNIX Stream defaultProtocol
tryIOError (bind sock1 addr) >>= \o -> case o of
Right () -> error "bind should have failed but succeeded"
_ -> return ()
close sock0
close sock1
describe "UserTimeout" $ do
it "can be set" $ do
when (isSupportedSocketOption UserTimeout) $ do
sock <- socket AF_INET Stream defaultProtocol
setSocketOption sock UserTimeout 1000
getSocketOption sock UserTimeout `shouldReturn` 1000
setSocketOption sock UserTimeout 2000
getSocketOption sock UserTimeout `shouldReturn` 2000
close sock
describe "DontFragment" $ do
it "can be set" $ do
sock <- socket AF_INET Stream defaultProtocol
when (isSupportedSocketOption DontFragment) $
setSocketOption sock DontFragment 1
close sock
describe "getAddrInfo" $ do
it "works for IPv4 address" $ do
let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] }
AddrInfo{addrAddress = (SockAddrInet _ hostAddr)}:_ <-
getAddrInfo (Just hints) (Just "127.128.129.130") Nothing
hostAddressToTuple hostAddr `shouldBe` (0x7f, 0x80, 0x81, 0x82)
it "works for IPv6 address" $ do
let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] }
host = "2001:0db8:85a3:0000:0000:8a2e:0370:7334"
AddrInfo{addrAddress = (SockAddrInet6 _ _ hostAddr _)}:_ <-
getAddrInfo (Just hints) (Just host) Nothing
hostAddress6ToTuple hostAddr
`shouldBe` (0x2001, 0x0db8, 0x85a3, 0x0000, 0x0000, 0x8a2e, 0x0370, 0x7334)
it "does not cause segfault on macOS 10.8.2 due to AI_NUMERICSERV" $ do
let hints = defaultHints { addrFlags = [AI_NUMERICSERV] }
void (getAddrInfo (Just hints) (Just "localhost") Nothing :: IO [AddrInfo])
#if defined(mingw32_HOST_OS)
let lpdevname = "loopback_0"
#elif defined(darwin_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS)
let lpdevname = "lo0"
#else
let lpdevname = "lo"
#endif
describe "ifNameToIndex and ifIndexToName" $ do
it "convert a name to an index and back" $
do
n <- ifNameToIndex lpdevname
n `shouldNotBe` Nothing
ifIndexToName (fromJust n) `shouldReturn` Just lpdevname
describe "socket" $ do
let gc = do
threadDelay 100000
performGC
connect' = do
threadDelay 200000
sock <- socket AF_INET Stream defaultProtocol
connect sock $ SockAddrInet 6000 $ tupleToHostAddress (127, 0, 0, 1)
it "should not be GCed while blocking" $ do
sock <- socket AF_INET Stream defaultProtocol
setSocketOption sock ReuseAddr 1
bind sock $ SockAddrInet 6000 $ tupleToHostAddress (127, 0, 0, 1)
listen sock 1
_ <- forkIO gc
_ <- forkIO connect'
(_sock', addr) <- accept sock
-- check if an exception is not thrown.
isSupportedSockAddr addr `shouldBe` True
#if !defined(mingw32_HOST_OS)
when isUnixDomainSocketAvailable $ do
context "unix sockets" $ do
it "basic unix sockets end-to-end" $ do
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
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
it "safely throws an exception" $ do
when isUnixDomainSocketAvailable $ do
let abstractAddress = toEnum 0:"/haskell/network/abstract-longlonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglong"
sock <- socket AF_UNIX Stream defaultProtocol
bind sock (SockAddrUnix abstractAddress) `shouldThrow` anyErrorCall
#endif
#if !defined(mingw32_HOST_OS)
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
withFdSocket s1 $ \fd1 -> 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
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
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)
-}
#endif
-- A send to a port nobody has bound brings an ICMP unreachable back.
-- POSIX hands it to the sender only once the socket is connected, and
-- Winsock hands it to every datagram socket; a reply bouncing off a
-- client which has gone would then end a server's receive loop.
describe "an ICMP unreachable from a send of one's own" $ do
it "is not heard by a socket which was never connected" $
bounce (\sock dead -> void $ sendTo sock "bounce" dead)
`shouldReturn` Nothing
it "is heard by a connected one" $
bounce (\sock dead -> connect sock dead >> void (send sock "bounce"))
`shouldThrow` anyIOException
describe "gracefulClose" $ do
it "does not send TCP RST back" $ do
let server sock = do
void $ recv sock 1024 -- receiving "GOAWAY"
gracefulClose sock 300
client sock = do
sendAll sock "GOAWAY"
threadDelay 10000
sendAll sock "PING"
threadDelay 10000
void $ recv sock 1024
tcpTest client server
describe "giving up" $ do
it "ends a receive which is told to stop, leaving the socket usable" $ do
let server sock = do
stop <- newTVarIO False
done <- newEmptyMVar
void $ forkIO $ do
r <- recvWith sock 1024 (check =<< readTVar stop)
putMVar done r
threadDelay 100000
atomically $ writeTVar stop True
takeMVar done `shouldReturn` Left ()
-- Nothing was closed, so the socket is still the
-- caller's to read.
recv sock 1024 `shouldReturn` testMsg
client sock = do
threadDelay 300000
void $ send sock testMsg
tcpTest client server
-- A tie goes to the data: answering Left would leave bytes
-- already received unread, which for a stream loses them.
it "takes what is there even once the caller has given up" $ do
let server sock = do
threadDelay 100000
gone <- newTVarIO True
recvWith sock 1024 (check =<< readTVar gone)
`shouldReturn` Right testMsg
client sock = void $ send sock testMsg
tcpTest client server
it "ends an accept which is told to stop, leaving the socket usable" $
withListener $ \sock port -> do
stop <- newTVarIO False
done <- newEmptyMVar
void $ forkIO $ do
r <- acceptWith sock (check =<< readTVar stop)
putMVar done $
either (const True) (const False)
(r :: Either () (Socket, SockAddr))
threadDelay 100000
atomically $ writeTVar stop True
takeMVar done `shouldReturn` True
-- The listening socket was not closed to end that
-- accept, so it still accepts.
bracket (socket AF_INET Stream defaultProtocol) close $ \cli -> do
connect cli $ SockAddrInet port $ tupleToHostAddress (127, 0, 0, 1)
bracket (fst <$> accept sock) close $ \_ -> return ()
it "tells a socket closed under an accept from other errors" $ do
sock <- socket AF_INET Stream defaultProtocol
bind sock $ SockAddrInet 0 $ tupleToHostAddress (127, 0, 0, 1)
listen sock 1
close sock
r <- tryIOError $ accept sock
either isClosedSocketError (const False) r `shouldBe` True
describe "socketToFd" $ do
it "socketToFd can send using fd" $ do
let server sock = do
void $ recv sock 1024
client sock = do
fd <- socketToFd sock
s <- mkSocket fd
sendAll s "HELLO WORLD"
tcpTest client server
describe "getNameInfo" $ do
it "works for IPv4 address" $ do
let addr = SockAddrInet 80 (tupleToHostAddress (127, 0, 0, 1))
(hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr
hn_m `shouldBe` (Just "127.0.0.1")
sn_m `shouldBe` (Just "80")
it "works for IPv6 address" $ do
let addr = SockAddrInet6 80 0
(tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0
(hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr
hn_m `shouldBe`(Just "2001:db8:2:3:4:5:6:7")
sn_m `shouldBe` (Just "80")
it "works for IPv6 address" $ do
let addr = SockAddrInet6 80 0
(tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0
(hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr
hn_m `shouldBe`(Just "2001:db8:2:3:4:5:6:7")
sn_m `shouldBe` (Just "80")
it "works for global multicast IPv6 address" $ do
let addr = SockAddrInet6 80 0
(tupleToHostAddress6 (0xfe01, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0
(hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr
hn_m `shouldBe`(Just "fe01:db8:2:3:4:5:6:7")
sn_m `shouldBe` (Just "80")
describe "show SocketAddr" $ do
it "works for IPv4 address" $
let addr = SockAddrInet 80 (tupleToHostAddress (127, 0, 0, 1)) in
show addr `shouldBe` "127.0.0.1:80"
it "works for IPv6 address" $
let addr = SockAddrInet6 80 0
(tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0 in
show addr `shouldBe` "[2001:db8:2:3:4:5:6:7]:80"
it "works for IPv6 address with zeros" $
let addr = SockAddrInet6 80 0
(tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x0, 0x0, 0x0, 0x7)) 0 in
show addr `shouldBe` "[2001:db8:2:3::7]:80"
it "works for multicast IPv6 address with reserved scope" $ do
let addr = SockAddrInet6 80 0
(tupleToHostAddress6 (0xff01, 0x1234, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0
show addr `shouldBe` "[ff01:1234:2:3:4:5:6:7]:80"
describe "show Family" $ do
it "works for pattern synonyms" $
let fam = AF_UNSPEC in
show fam `shouldBe` "AF_UNSPEC"
it "works for unsupported" $
let fam = GeneralFamily (-1) in
show fam `shouldBe` "UnsupportedFamily"
it "works for positive values" $
let fam = GeneralFamily 300 in
show fam `shouldBe` "GeneralFamily 300"
it "works for negative values" $
let fam = GeneralFamily (-300) in
show fam `shouldBe` "GeneralFamily (-300)"
describe "show SocketType" $ do
it "works for pattern synonyms" $
let socktype = NoSocketType in
show socktype `shouldBe` "NoSocketType"
it "works for unsupported" $
let socktype = GeneralSocketType (-1) in
show socktype `shouldBe` "UnsupportedSocketType"
it "works for positive values" $
let socktype = GeneralSocketType 300 in
show socktype `shouldBe` "GeneralSocketType 300"
it "works for negative values" $
let socktype = GeneralSocketType (-300) in
show socktype `shouldBe` "GeneralSocketType (-300)"
describe "show SocketOptions" $ do
it "works for pattern synonyms" $
let opt = ReuseAddr in
show opt `shouldBe` "ReuseAddr"
it "works for unsupported" $
let opt = SockOpt (-1) (-1) in
show opt `shouldBe` "UnsupportedSocketOption"
it "works for positive values" $
let opt = SockOpt 300 300 in
show opt `shouldBe` "SockOpt 300 300"
it "works for negative values" $
let opt = SockOpt (-300) (-300) in
show opt `shouldBe` "SockOpt (-300) (-300)"
describe "show CmsgId" $ do
it "works for pattern synonyms" $
let msgid = CmsgIdIPv6HopLimit in
show msgid `shouldBe` "CmsgIdIPv6HopLimit"
it "works for unsupported" $
let msgid = CmsgId (-1) (-1) in
show msgid `shouldBe` "UnsupportedCmsgId"
it "works for positive values" $
let msgid = CmsgId 300 300 in
show msgid `shouldBe` "CmsgId 300 300"
it "works for negative values" $
let msgid = CmsgId (-300) (-300) in
show msgid `shouldBe` "CmsgId (-300) (-300)"
#if !defined(_WIN32)
describe "bijective encodeCmsg-decodeCmsg roundtrip equality" $ do
it "holds for [Fd]" $ forAll genFds $
\x -> (decodeCmsg . encodeCmsg $ x) == Just (x :: [Fd])
#endif
describe "bijective read-show roundtrip equality" $ do
it "holds for Family" $ forAll familyGen $
\x -> (read . show $ x) == (x :: Family)
it "holds for SocketType" $ forAll socktypeGen $
\x -> (read . show $ x) == (x :: SocketType)
it "holds for SocketOption" $ forAll sockoptGen $
\x -> (read . show $ x) == (x :: SocketOption)
it "holds for CmsgId" $ forAll cmsgidGen $
\x -> (read . show $ x) == (x :: CmsgId)
describe "hostname" $ do
it "is not empty" $ do
hostname <- getHostName
hostname `shouldSatisfy` (not . null)
-- Type-specific generators with strong bias towards pattern synonyms
-- Generator combinator that biases elements of a given list and otherwise
-- applies a function to a given generator
biasedGen :: (Gen a -> Gen b) -> [b] -> Gen a -> Gen b
biasedGen f xs g = do
useBias <- (arbitrary :: Gen Bool)
if useBias
then elements xs
else f g
familyGen :: Gen Family
familyGen = biasedGen (fmap GeneralFamily) familyPatterns arbitrary
socktypeGen :: Gen SocketType
socktypeGen = biasedGen (fmap GeneralSocketType) socktypePatterns arbitrary
sockoptGen :: Gen SocketOption
sockoptGen = biasedGen (\g -> SockOpt <$> g <*> g) sockoptPatterns arbitrary
cmsgidGen :: Gen CmsgId
cmsgidGen = biasedGen (\g -> CmsgId <$> g <*> g) cmsgidPatterns arbitrary
genFds :: Gen [Fd]
genFds = listOf (Fd <$> arbitrary)
-- pruned lists of pattern synonym values for each type to generate values from
familyPatterns :: [Family]
familyPatterns = nub
[UnsupportedFamily
,AF_UNSPEC,AF_UNIX,AF_INET,AF_INET6,AF_IMPLINK,AF_PUP,AF_CHAOS
,AF_NS,AF_NBS,AF_ECMA,AF_DATAKIT,AF_CCITT,AF_SNA,AF_DECnet
,AF_DLI,AF_LAT,AF_HYLINK,AF_APPLETALK,AF_ROUTE,AF_NETBIOS
,AF_NIT,AF_802,AF_ISO,AF_OSI,AF_NETMAN,AF_X25,AF_AX25,AF_OSINET
,AF_GOSSIP,AF_IPX,Pseudo_AF_XTP,AF_CTF,AF_WAN,AF_SDL,AF_NETWARE
,AF_NDD,AF_INTF,AF_COIP,AF_CNT,Pseudo_AF_RTIP,Pseudo_AF_PIP
,AF_SIP,AF_ISDN,Pseudo_AF_KEY,AF_NATM,AF_ARP,Pseudo_AF_HDRCMPLT
,AF_ENCAP,AF_LINK,AF_RAW,AF_RIF,AF_NETROM,AF_BRIDGE,AF_ATMPVC
,AF_ROSE,AF_NETBEUI,AF_SECURITY,AF_PACKET,AF_ASH,AF_ECONET
,AF_ATMSVC,AF_IRDA,AF_PPPOX,AF_WANPIPE,AF_BLUETOOTH,AF_CAN]
socktypePatterns :: [SocketType]
socktypePatterns = nub
[ UnsupportedSocketType
, NoSocketType
, Stream
, Datagram
, Raw
, RDM
, SeqPacket
]
sockoptPatterns :: [SocketOption]
sockoptPatterns = nub
[UnsupportedSocketOption
,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute
,Broadcast,SendBuffer,RecvBuffer,KeepAlive,KeepInit,OOBInline
,TimeToLive,MaxSegment,NoDelay,Cork,Linger,ReusePort
,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut
,UseLoopBack,UserTimeout,IPv6Only
,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo,DontFragment
,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo]
cmsgidPatterns :: [CmsgId]
cmsgidPatterns = nub
[ UnsupportedCmsgId
, CmsgIdIPv4TTL
, CmsgIdIPv6HopLimit
, CmsgIdIPv4TOS
, CmsgIdIPv6TClass
, CmsgIdIPv4PktInfo
, CmsgIdIPv6PktInfo
, CmsgIdFds
]
-- A listening socket on the loopback, and the port it got.
withListener :: (Socket -> PortNumber -> IO a) -> IO a
withListener action =
bracket (socket AF_INET Stream defaultProtocol) close $ \sock -> do
setSocketOption sock ReuseAddr 1
bind sock $ SockAddrInet 0 $ tupleToHostAddress (127, 0, 0, 1)
listen sock 1
port <- socketPort sock
action sock port