{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.SocketSpec (main, spec) where import Control.Concurrent (threadDelay, forkIO) import Control.Concurrent.MVar (readMVar) import Control.Monad 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, isAlreadyInUseError) import System.IO.Temp (withSystemTempDirectory) import Foreign.C.Types () import Test.Hspec import Test.QuickCheck main :: IO () main = hspec spec 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, twice" $ do withSystemTempDirectory "haskell-network" $ \path -> do let sfile = path ++ "/socket-file" 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" Left e | not (isAlreadyInUseError e) -> ioError e _ -> return () close sock0 -- Unix systems tend to leave the file existing, which is -- why our `bind` does its workaround. however if any -- system in the future does fix this issue, we don't want -- this test to fail, since that would defeat the purpose -- of our workaround. but you can uncomment the below lines -- if you want to play with this on your own system. --import System.Directory (doesPathExist) --ex <- doesPathExist sfile --unless ex $ error "socket file was deleted unexpectedly" sock2 <- socket AF_UNIX Stream defaultProtocol bind sock2 addr 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 "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 #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 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 -- 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 describe "gracefulClose" $ do it "does not send TCP RST back" $ do let server sock = do void $ recv sock 1024 -- receiving "GOAWAY" gracefulClose sock 3000 client sock = do sendAll sock "GOAWAY" threadDelay 10000 sendAll sock "PING" threadDelay 10000 void $ recv sock 1024 tcpTest client server 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)" 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) -- 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 -- 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,OOBInline,TimeToLive ,MaxSegment,NoDelay,Cork,Linger,ReusePort ,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut ,UseLoopBack,UserTimeout,IPv6Only ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo ,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo] cmsgidPatterns :: [CmsgId] cmsgidPatterns = nub [ UnsupportedCmsgId , CmsgIdIPv4TTL , CmsgIdIPv6HopLimit , CmsgIdIPv4TOS , CmsgIdIPv6TClass , CmsgIdIPv4PktInfo , CmsgIdIPv6PktInfo , CmsgIdFd ]