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' (8080 :: 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