SocketSpec.hs

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

        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

        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)
    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 ProtocolNumber" $ do
        it "works for pattern synonyms" $
            let proto = DefaultProtocol in
            show proto `shouldBe` "DefaultProtocol"

        it "works for unsupported" $
            let proto = GeneralProtocol (-1) in
            show proto `shouldBe` "-1"

        it "works for positive values" $
            let proto = GeneralProtocol 300 in
            show proto `shouldBe` "300"

        it "works for negative values" $
            let proto = GeneralProtocol (-300) in
            show proto `shouldBe` "-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 ProtocolNumber" $ forAll protoGen $
            \x -> (read . show $ x) == (x :: ProtocolNumber)

        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

protoGen :: Gen ProtocolNumber
protoGen = biasedGen (fmap GeneralProtocol) protoPatterns 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
    ]

protoPatterns :: [ProtocolNumber]
protoPatterns = nub
    [ DefaultProtocol
    , IPPROTO_IPV4
    , IPPROTO_IPV6
    , IPPROTO_UDP
    , IPPROTO_TCP
    , IPPROTO_ICMP
    , IPPROTO_ICMPV6
    , IPPROTO_RAW
    ]