1{-# LANGUAGE CPP #-} 2{-# LANGUAGE OverloadedStrings #-} 3 4module Network.SocketSpec (main, spec) where 5 6import Control.Concurrent (threadDelay, forkIO) 7import Control.Concurrent.MVar (readMVar) 8import Control.Monad 9import Data.Maybe (fromJust) 10import Data.List (nub) 11import Network.Socket 12import Network.Socket.ByteString 13import Network.Test.Common 14import System.Mem (performGC) 15import System.IO.Error (tryIOError, isAlreadyInUseError) 16import System.IO.Temp (withSystemTempDirectory) 17import Foreign.C.Types () 18 19import Test.Hspec 20import Test.QuickCheck 21 22main :: IO () 23main = hspec spec 24 25spec :: Spec 26spec = do 27 describe "connect" $ do 28 let 29 hints = defaultHints { addrSocketType = Stream } 30 connect' serverPort = do 31 addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) 32 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 33 connect sock (addrAddress addr) 34 return sock 35 36 it "fails to connect and throws an IOException" $ do 37 connect' (8003 :: Int) `shouldThrow` anyIOException 38 39 it "successfully connects to a socket with no exception" $ do 40 withPort $ \portVar -> test (tcp serverAddr return portVar) 41 { clientSetup = readMVar portVar >>= connect' 42 } 43 44 describe "bind" $ do 45 let hints = defaultHints 46 { addrFlags = [AI_PASSIVE] 47 , addrSocketType = Stream 48 } 49 it "successfully binds to an ipv4 socket" $ do 50 addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing 51 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 52 bind sock $ addrAddress addr 53 54{- This does not work on Windows and Linux. 55 it "fails to bind to unknown ipv4 socket" $ do 56 addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.3") Nothing 57 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 58 bind sock (addrAddress addr) `shouldThrow` anyIOException 59-} 60 61#ifdef DEVELOPMENT 62 it "successfully binds to an ipv6 socket" $ do 63 addr:_ <- getAddrInfo (Just hints) (Just serverAddr6) Nothing 64 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 65 bind sock $ addrAddress addr 66 67 it "fails to bind to unknown ipv6 socket" $ do 68 addr:_ <- getAddrInfo (Just hints) (Just "::6") Nothing 69 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 70 bind sock (addrAddress addr) `shouldThrow` anyIOException 71#endif 72 73 it "successfully binds to a unix socket, twice" $ do 74 withSystemTempDirectory "haskell-network" $ \path -> do 75 let sfile = path ++ "/socket-file" 76 let addr = SockAddrUnix sfile 77 when (isSupportedSockAddr addr) $ do 78 sock0 <- socket AF_UNIX Stream defaultProtocol 79 bind sock0 addr 80 listen sock0 1 81 82 sock1 <- socket AF_UNIX Stream defaultProtocol 83 tryIOError (bind sock1 addr) >>= \o -> case o of 84 Right () -> error "bind should have failed but succeeded" 85 Left e | not (isAlreadyInUseError e) -> ioError e 86 _ -> return () 87 88 close sock0 89 90 -- Unix systems tend to leave the file existing, which is 91 -- why our `bind` does its workaround. however if any 92 -- system in the future does fix this issue, we don't want 93 -- this test to fail, since that would defeat the purpose 94 -- of our workaround. but you can uncomment the below lines 95 -- if you want to play with this on your own system. 96 --import System.Directory (doesPathExist) 97 --ex <- doesPathExist sfile 98 --unless ex $ error "socket file was deleted unexpectedly" 99 100 sock2 <- socket AF_UNIX Stream defaultProtocol 101 bind sock2 addr 102 103 describe "UserTimeout" $ do 104 it "can be set" $ do 105 when (isSupportedSocketOption UserTimeout) $ do 106 sock <- socket AF_INET Stream defaultProtocol 107 setSocketOption sock UserTimeout 1000 108 getSocketOption sock UserTimeout `shouldReturn` 1000 109 setSocketOption sock UserTimeout 2000 110 getSocketOption sock UserTimeout `shouldReturn` 2000 111 close sock 112 113 describe "getAddrInfo" $ do 114 it "works for IPv4 address" $ do 115 let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } 116 AddrInfo{addrAddress = (SockAddrInet _ hostAddr)}:_ <- 117 getAddrInfo (Just hints) (Just "127.128.129.130") Nothing 118 hostAddressToTuple hostAddr `shouldBe` (0x7f, 0x80, 0x81, 0x82) 119 120 it "works for IPv6 address" $ do 121 let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } 122 host = "2001:0db8:85a3:0000:0000:8a2e:0370:7334" 123 AddrInfo{addrAddress = (SockAddrInet6 _ _ hostAddr _)}:_ <- 124 getAddrInfo (Just hints) (Just host) Nothing 125 hostAddress6ToTuple hostAddr 126 `shouldBe` (0x2001, 0x0db8, 0x85a3, 0x0000, 0x0000, 0x8a2e, 0x0370, 0x7334) 127 128 it "does not cause segfault on macOS 10.8.2 due to AI_NUMERICSERV" $ do 129 let hints = defaultHints { addrFlags = [AI_NUMERICSERV] } 130 void $ getAddrInfo (Just hints) (Just "localhost") Nothing 131 132#if defined(mingw32_HOST_OS) 133 let lpdevname = "loopback_0" 134#elif defined(darwin_HOST_OS) || defined(freebsd_HOST_OS) 135 let lpdevname = "lo0" 136#else 137 let lpdevname = "lo" 138#endif 139 140 describe "ifNameToIndex and ifIndexToName" $ do 141 it "convert a name to an index and back" $ 142 do 143 n <- ifNameToIndex lpdevname 144 n `shouldNotBe` Nothing 145 ifIndexToName (fromJust n) `shouldReturn` Just lpdevname 146 147 describe "socket" $ do 148 let gc = do 149 threadDelay 100000 150 performGC 151 connect' = do 152 threadDelay 200000 153 sock <- socket AF_INET Stream defaultProtocol 154 connect sock $ SockAddrInet 6000 $ tupleToHostAddress (127, 0, 0, 1) 155 it "should not be GCed while blocking" $ do 156 sock <- socket AF_INET Stream defaultProtocol 157 setSocketOption sock ReuseAddr 1 158 bind sock $ SockAddrInet 6000 $ tupleToHostAddress (127, 0, 0, 1) 159 listen sock 1 160 _ <- forkIO gc 161 _ <- forkIO connect' 162 (_sock', addr) <- accept sock 163 -- check if an exception is not thrown. 164 isSupportedSockAddr addr `shouldBe` True 165 166#if !defined(mingw32_HOST_OS) 167 when isUnixDomainSocketAvailable $ do 168 context "unix sockets" $ do 169 it "basic unix sockets end-to-end" $ do 170 let client sock = send sock testMsg 171 server (sock, addr) = do 172 recv sock 1024 `shouldReturn` testMsg 173 addr `shouldBe` (SockAddrUnix "") 174 test . setClientAction client $ unixWithUnlink unixAddr server 175#endif 176 177#ifdef linux_HOST_OS 178 it "can end-to-end with an abstract socket" $ do 179 let 180 abstractAddress = toEnum 0:"/haskell/network/abstract" 181 client sock = send sock testMsg 182 server (sock, addr) = do 183 recv sock 1024 `shouldReturn` testMsg 184 addr `shouldBe` (SockAddrUnix "") 185 test . setClientAction client $ 186 unix abstractAddress (const $ return ()) $ server 187 it "safely throws an exception" $ do 188 when isUnixDomainSocketAvailable $ do 189 let abstractAddress = toEnum 0:"/haskell/network/abstract-longlonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglong" 190 sock <- socket AF_UNIX Stream defaultProtocol 191 bind sock (SockAddrUnix abstractAddress) `shouldThrow` anyErrorCall 192#endif 193 194#if !defined(mingw32_HOST_OS) 195 describe "socketPair" $ do 196 it "can send and recieve bi-directionally" $ do 197 (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol 198 void $ send s1 testMsg 199 recv s2 1024 `shouldReturn` testMsg 200 void $ send s2 testMsg 201 recv s1 1024 `shouldReturn` testMsg 202 203 describe "sendFd/recvFd" $ do 204 it "can send and recieve a file descriptor" $ do 205 (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol 206 (s3, s4) <- socketPair AF_UNIX Stream defaultProtocol 207 withFdSocket s1 $ \fd1 -> void $ sendFd s3 fd1 208 fd1' <- recvFd s4 209 s1' <- mkSocket fd1' 210 void $ send s1' testMsg 211 recv s2 1024 `shouldReturn` testMsg 212 213 -- On various BSD systems the peer credentials are exchanged during 214 -- connect(), and this does not happen with `socketpair()`. Therefore, 215 -- we must actually set up a listener and connect, rather than use a 216 -- socketpair(). 217 -- 218 describe "getPeerCredential" $ do 219 it "can return something" $ do 220 -- It would be useful to check that we did not get garbage 221 -- back, but rather the actual uid of the test program. For 222 -- that we'd need System.Posix.User, but that is not available 223 -- under Windows. For now, accept the risk that we did not get 224 -- the right answer. 225 -- 226 let server (sock, _) = do 227 (_, uid, _) <- getPeerCredential sock 228 uid `shouldNotBe` Nothing 229 client sock = do 230 (_, uid, _) <- getPeerCredential sock 231 uid `shouldNotBe` Nothing 232 test . setClientAction client $ unixWithUnlink unixAddr server 233 {- The below test fails on many *BSD systems, because the getsockopt() 234 call that underlies getpeereid() does not have the same meaning for 235 all address families, but the C-library was not checking that the 236 provided sock is an AF_UNIX socket. This will fixed some day, but 237 we should not fail on those systems in the mean-time. The upstream 238 C-library fix is to call getsockname() and check the address family 239 before calling `getpeereid()`. We could duplicate that in our own 240 code, and then this test would work on those platforms that have 241 `getpeereid()` and not the SO_PEERCRED socket option. 242 243 it "return nothing for non-UNIX-domain socket" $ do 244 when isUnixDomainSocketAvailable $ do 245 s <- socket AF_INET Stream defaultProtocol 246 cred1 <- getPeerCredential s 247 cred1 `shouldBe` (Nothing,Nothing,Nothing) 248 -} 249#endif 250 251 describe "gracefulClose" $ do 252 it "does not send TCP RST back" $ do 253 let server sock = do 254 void $ recv sock 1024 -- receiving "GOAWAY" 255 gracefulClose sock 3000 256 client sock = do 257 sendAll sock "GOAWAY" 258 threadDelay 10000 259 sendAll sock "PING" 260 threadDelay 10000 261 void $ recv sock 1024 262 tcpTest client server 263 264 describe "socketToFd" $ do 265 it "socketToFd can send using fd" $ do 266 let server sock = do 267 void $ recv sock 1024 268 client sock = do 269 fd <- socketToFd sock 270 s <- mkSocket fd 271 sendAll s "HELLO WORLD" 272 tcpTest client server 273 274 describe "getNameInfo" $ do 275 it "works for IPv4 address" $ do 276 let addr = SockAddrInet 80 (tupleToHostAddress (127, 0, 0, 1)) 277 (hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr 278 279 hn_m `shouldBe` (Just "127.0.0.1") 280 sn_m `shouldBe` (Just "80") 281 282 it "works for IPv6 address" $ do 283 let addr = SockAddrInet6 80 0 284 (tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0 285 (hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr 286 hn_m `shouldBe`(Just "2001:db8:2:3:4:5:6:7") 287 sn_m `shouldBe` (Just "80") 288 289 it "works for IPv6 address" $ do 290 let addr = SockAddrInet6 80 0 291 (tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0 292 (hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr 293 hn_m `shouldBe`(Just "2001:db8:2:3:4:5:6:7") 294 sn_m `shouldBe` (Just "80") 295 296 it "works for global multicast IPv6 address" $ do 297 let addr = SockAddrInet6 80 0 298 (tupleToHostAddress6 (0xfe01, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0 299 (hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr 300 hn_m `shouldBe`(Just "fe01:db8:2:3:4:5:6:7") 301 sn_m `shouldBe` (Just "80") 302 303 describe "show SocketAddr" $ do 304 it "works for IPv4 address" $ 305 let addr = SockAddrInet 80 (tupleToHostAddress (127, 0, 0, 1)) in 306 show addr `shouldBe` "127.0.0.1:80" 307 308 it "works for IPv6 address" $ 309 let addr = SockAddrInet6 80 0 310 (tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0 in 311 show addr `shouldBe` "[2001:db8:2:3:4:5:6:7]:80" 312 313 it "works for IPv6 address with zeros" $ 314 let addr = SockAddrInet6 80 0 315 (tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x0, 0x0, 0x0, 0x7)) 0 in 316 show addr `shouldBe` "[2001:db8:2:3::7]:80" 317 318 it "works for multicast IPv6 address with reserved scope" $ do 319 let addr = SockAddrInet6 80 0 320 (tupleToHostAddress6 (0xff01, 0x1234, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0 321 show addr `shouldBe` "[ff01:1234:2:3:4:5:6:7]:80" 322 323 describe "show Family" $ do 324 it "works for pattern synonyms" $ 325 let fam = AF_UNSPEC in 326 show fam `shouldBe` "AF_UNSPEC" 327 328 it "works for unsupported" $ 329 let fam = GeneralFamily (-1) in 330 show fam `shouldBe` "UnsupportedFamily" 331 332 it "works for positive values" $ 333 let fam = GeneralFamily 300 in 334 show fam `shouldBe` "GeneralFamily 300" 335 336 it "works for negative values" $ 337 let fam = GeneralFamily (-300) in 338 show fam `shouldBe` "GeneralFamily (-300)" 339 340 describe "show SocketType" $ do 341 it "works for pattern synonyms" $ 342 let socktype = NoSocketType in 343 show socktype `shouldBe` "NoSocketType" 344 345 it "works for unsupported" $ 346 let socktype = GeneralSocketType (-1) in 347 show socktype `shouldBe` "UnsupportedSocketType" 348 349 it "works for positive values" $ 350 let socktype = GeneralSocketType 300 in 351 show socktype `shouldBe` "GeneralSocketType 300" 352 353 it "works for negative values" $ 354 let socktype = GeneralSocketType (-300) in 355 show socktype `shouldBe` "GeneralSocketType (-300)" 356 357 describe "show SocketOptions" $ do 358 it "works for pattern synonyms" $ 359 let opt = ReuseAddr in 360 show opt `shouldBe` "ReuseAddr" 361 362 it "works for unsupported" $ 363 let opt = SockOpt (-1) (-1) in 364 show opt `shouldBe` "UnsupportedSocketOption" 365 366 it "works for positive values" $ 367 let opt = SockOpt 300 300 in 368 show opt `shouldBe` "SockOpt 300 300" 369 370 it "works for negative values" $ 371 let opt = SockOpt (-300) (-300) in 372 show opt `shouldBe` "SockOpt (-300) (-300)" 373 374 describe "show CmsgId" $ do 375 it "works for pattern synonyms" $ 376 let msgid = CmsgIdIPv6HopLimit in 377 show msgid `shouldBe` "CmsgIdIPv6HopLimit" 378 379 it "works for unsupported" $ 380 let msgid = CmsgId (-1) (-1) in 381 show msgid `shouldBe` "UnsupportedCmsgId" 382 383 it "works for positive values" $ 384 let msgid = CmsgId 300 300 in 385 show msgid `shouldBe` "CmsgId 300 300" 386 387 it "works for negative values" $ 388 let msgid = CmsgId (-300) (-300) in 389 show msgid `shouldBe` "CmsgId (-300) (-300)" 390 391 describe "bijective read-show roundtrip equality" $ do 392 it "holds for Family" $ forAll familyGen $ 393 \x -> (read . show $ x) == (x :: Family) 394 395 it "holds for SocketType" $ forAll socktypeGen $ 396 \x -> (read . show $ x) == (x :: SocketType) 397 398 it "holds for SocketOption" $ forAll sockoptGen $ 399 \x -> (read . show $ x) == (x :: SocketOption) 400 401 it "holds for CmsgId" $ forAll cmsgidGen $ 402 \x -> (read . show $ x) == (x :: CmsgId) 403 404 405-- Type-specific generators with strong bias towards pattern synonyms 406 407-- Generator combinator that biases elements of a given list and otherwise 408-- applies a function to a given generator 409biasedGen :: (Gen a -> Gen b) -> [b] -> Gen a -> Gen b 410biasedGen f xs g = do 411 useBias <- (arbitrary :: Gen Bool) 412 if useBias 413 then elements xs 414 else f g 415 416familyGen :: Gen Family 417familyGen = biasedGen (fmap GeneralFamily) familyPatterns arbitrary 418 419socktypeGen :: Gen SocketType 420socktypeGen = biasedGen (fmap GeneralSocketType) socktypePatterns arbitrary 421 422sockoptGen :: Gen SocketOption 423sockoptGen = biasedGen (\g -> SockOpt <$> g <*> g) sockoptPatterns arbitrary 424 425cmsgidGen :: Gen CmsgId 426cmsgidGen = biasedGen (\g -> CmsgId <$> g <*> g) cmsgidPatterns arbitrary 427 428-- pruned lists of pattern synonym values for each type to generate values from 429 430familyPatterns :: [Family] 431familyPatterns = nub 432 [UnsupportedFamily 433 ,AF_UNSPEC,AF_UNIX,AF_INET,AF_INET6,AF_IMPLINK,AF_PUP,AF_CHAOS 434 ,AF_NS,AF_NBS,AF_ECMA,AF_DATAKIT,AF_CCITT,AF_SNA,AF_DECnet 435 ,AF_DLI,AF_LAT,AF_HYLINK,AF_APPLETALK,AF_ROUTE,AF_NETBIOS 436 ,AF_NIT,AF_802,AF_ISO,AF_OSI,AF_NETMAN,AF_X25,AF_AX25,AF_OSINET 437 ,AF_GOSSIP,AF_IPX,Pseudo_AF_XTP,AF_CTF,AF_WAN,AF_SDL,AF_NETWARE 438 ,AF_NDD,AF_INTF,AF_COIP,AF_CNT,Pseudo_AF_RTIP,Pseudo_AF_PIP 439 ,AF_SIP,AF_ISDN,Pseudo_AF_KEY,AF_NATM,AF_ARP,Pseudo_AF_HDRCMPLT 440 ,AF_ENCAP,AF_LINK,AF_RAW,AF_RIF,AF_NETROM,AF_BRIDGE,AF_ATMPVC 441 ,AF_ROSE,AF_NETBEUI,AF_SECURITY,AF_PACKET,AF_ASH,AF_ECONET 442 ,AF_ATMSVC,AF_IRDA,AF_PPPOX,AF_WANPIPE,AF_BLUETOOTH,AF_CAN] 443 444socktypePatterns :: [SocketType] 445socktypePatterns = nub 446 [ UnsupportedSocketType 447 , NoSocketType 448 , Stream 449 , Datagram 450 , Raw 451 , RDM 452 , SeqPacket 453 ] 454 455sockoptPatterns :: [SocketOption] 456sockoptPatterns = nub 457 [UnsupportedSocketOption 458 ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute 459 ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline,TimeToLive 460 ,MaxSegment,NoDelay,Cork,Linger,ReusePort 461 ,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut 462 ,UseLoopBack,UserTimeout,IPv6Only 463 ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo 464 ,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo] 465 466cmsgidPatterns :: [CmsgId] 467cmsgidPatterns = nub 468 [ UnsupportedCmsgId 469 , CmsgIdIPv4TTL 470 , CmsgIdIPv6HopLimit 471 , CmsgIdIPv4TOS 472 , CmsgIdIPv6TClass 473 , CmsgIdIPv4PktInfo 474 , CmsgIdIPv6PktInfo 475 , CmsgIdFd 476 ] 477