content: {-# 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
      ]
  