PageRenderTime 2290ms CodeModel.GetById 102ms app.highlight 14ms RepoModel.GetById 2ms app.codeStats 2162ms

/Network/Socket.hsc

https://github.com/hf6440/network
Unknown | 1673 lines | 1473 code | 200 blank | 0 comment | 0 complexity | d77799559c5a2ac36d3568829dc4138c MD5 | raw file
   1{-# LANGUAGE CPP, ScopedTypeVariables #-}
   2{-# OPTIONS_GHC -fno-warn-orphans #-}
   3-----------------------------------------------------------------------------
   4-- |
   5-- Module      :  Network.Socket
   6-- Copyright   :  (c) The University of Glasgow 2001
   7-- License     :  BSD-style (see the file libraries/network/LICENSE)
   8--
   9-- Maintainer  :  libraries@haskell.org
  10-- Stability   :  provisional
  11-- Portability :  portable
  12--
  13-- The "Network.Socket" module is for when you want full control over
  14-- sockets.  Essentially the entire C socket API is exposed through
  15-- this module; in general the operations follow the behaviour of the C
  16-- functions of the same name (consult your favourite Unix networking book).
  17--
  18-- A higher level interface to networking operations is provided
  19-- through the module "Network".
  20--
  21-----------------------------------------------------------------------------
  22
  23#include "HsNet.h"
  24
  25-- NOTE: ##, we want this interpreted when compiling the .hs, not by hsc2hs.
  26##include "Typeable.h"
  27
  28-- In order to process this file, you need to have CALLCONV defined.
  29
  30module Network.Socket
  31    (
  32    -- * Types
  33      Socket(..)
  34    , Family(..)
  35    , isSupportedFamily
  36    , SocketType(..)
  37    , isSupportedSocketType
  38    , SockAddr(..)
  39    , SocketStatus(..)
  40    , HostAddress
  41#if defined(IPV6_SOCKET_SUPPORT)
  42    , HostAddress6
  43    , FlowInfo
  44    , ScopeID
  45#endif
  46    , ShutdownCmd(..)
  47    , ProtocolNumber
  48    , defaultProtocol
  49    , PortNumber(..)
  50    -- PortNumber is used non-abstractly in Network.BSD.  ToDo: remove
  51    -- this use and make the type abstract.
  52
  53    -- * Address operations
  54
  55    , HostName
  56    , ServiceName
  57
  58#if defined(IPV6_SOCKET_SUPPORT)
  59    , AddrInfo(..)
  60
  61    , AddrInfoFlag(..)
  62    , addrInfoFlagImplemented
  63
  64    , defaultHints
  65
  66    , getAddrInfo
  67
  68    , NameInfoFlag(..)
  69
  70    , getNameInfo
  71#endif
  72
  73    -- * Socket operations
  74    , socket
  75#if defined(DOMAIN_SOCKET_SUPPORT)
  76    , socketPair
  77#endif
  78    , connect
  79    , bind
  80    , listen
  81    , accept
  82    , getPeerName
  83    , getSocketName
  84
  85#ifdef HAVE_STRUCT_UCRED
  86    -- get the credentials of our domain socket peer.
  87    , getPeerCred
  88#endif
  89
  90    , socketPort
  91
  92    , socketToHandle
  93
  94    -- ** Sending and receiving data
  95    -- $sendrecv
  96    , sendTo
  97    , sendBufTo
  98
  99    , recvFrom
 100    , recvBufFrom
 101
 102    , send
 103    , recv
 104    , recvLen
 105    , sendBuf
 106    , recvBuf
 107
 108    , inet_addr
 109    , inet_ntoa
 110
 111    , shutdown
 112    , close
 113
 114    -- ** Predicates on sockets
 115    , isConnected
 116    , isBound
 117    , isListening
 118    , isReadable
 119    , isWritable
 120
 121    -- * Socket options
 122    , SocketOption(..)
 123    , isSupportedSocketOption
 124    , getSocketOption
 125    , setSocketOption
 126
 127    -- * File descriptor transmission
 128#ifdef DOMAIN_SOCKET_SUPPORT
 129    , sendFd
 130    , recvFd
 131
 132#endif
 133
 134    -- * Special constants
 135    , aNY_PORT
 136    , iNADDR_ANY
 137#if defined(IPV6_SOCKET_SUPPORT)
 138    , iN6ADDR_ANY
 139#endif
 140    , sOMAXCONN
 141    , sOL_SOCKET
 142#ifdef SCM_RIGHTS
 143    , sCM_RIGHTS
 144#endif
 145    , maxListenQueue
 146
 147    -- * Initialisation
 148    , withSocketsDo
 149
 150    -- * Very low level operations
 151    -- in case you ever want to get at the underlying file descriptor..
 152    , fdSocket
 153    , mkSocket
 154
 155    -- * Deprecated aliases
 156    -- $deprecated-aliases
 157    , bindSocket
 158    , sClose
 159    , sIsConnected
 160    , sIsBound
 161    , sIsListening
 162    , sIsReadable
 163    , sIsWritable
 164
 165    -- * Internal
 166
 167    -- | The following are exported ONLY for use in the BSD module and
 168    -- should not be used anywhere else.
 169
 170    , packFamily
 171    , unpackFamily
 172    , packSocketType
 173    ) where
 174
 175import Data.Bits
 176import Data.List (delete, foldl')
 177import Data.Maybe (fromMaybe, isJust)
 178import Data.Word (Word8, Word16, Word32)
 179import Foreign.Ptr (Ptr, castPtr, nullPtr)
 180import Foreign.Storable (Storable(..))
 181import Foreign.C.Error
 182import Foreign.C.String (CString, withCString, peekCString, peekCStringLen)
 183import Foreign.C.Types (CUInt, CChar)
 184#if __GLASGOW_HASKELL__ >= 703
 185import Foreign.C.Types (CInt(..), CSize(..))
 186#else
 187import Foreign.C.Types (CInt, CSize)
 188#endif
 189import Foreign.Marshal.Alloc ( alloca, allocaBytes )
 190import Foreign.Marshal.Array ( peekArray )
 191import Foreign.Marshal.Utils ( maybeWith, with )
 192
 193import System.IO
 194import Control.Monad (liftM, when)
 195import Data.Ratio ((%))
 196
 197import qualified Control.Exception as E
 198import Control.Concurrent.MVar
 199import Data.Typeable
 200import System.IO.Error
 201
 202import GHC.Conc (threadWaitRead, threadWaitWrite)
 203##if MIN_VERSION_base(4,3,1)
 204import GHC.Conc (closeFdWith)
 205##endif
 206# if defined(mingw32_HOST_OS)
 207import GHC.Conc (asyncDoProc)
 208import Foreign (FunPtr)
 209# endif
 210# if __GLASGOW_HASKELL__ >= 611
 211import qualified GHC.IO.Device
 212import GHC.IO.Handle.FD
 213import GHC.IO.Exception
 214import GHC.IO
 215# else
 216import GHC.IOBase
 217import GHC.Handle
 218# endif
 219import qualified System.Posix.Internals
 220
 221# if __GLASGOW_HASKELL__ >= 611
 222import GHC.IO.FD
 223#endif
 224
 225import Network.Socket.Internal
 226import Network.Socket.Types
 227
 228-- | Either a host name e.g., @\"haskell.org\"@ or a numeric host
 229-- address string consisting of a dotted decimal IPv4 address or an
 230-- IPv6 address e.g., @\"192.168.0.1\"@.
 231type HostName       = String
 232type ServiceName    = String
 233
 234-- ----------------------------------------------------------------------------
 235-- On Windows, our sockets are not put in non-blocking mode (non-blocking
 236-- is not supported for regular file descriptors on Windows, and it would
 237-- be a pain to support it only for sockets).  So there are two cases:
 238--
 239--  - the threaded RTS uses safe calls for socket operations to get
 240--    non-blocking I/O, just like the rest of the I/O library
 241--
 242--  - with the non-threaded RTS, only some operations on sockets will be
 243--    non-blocking.  Reads and writes go through the normal async I/O
 244--    system.  accept() uses asyncDoProc so is non-blocking.  A handful
 245--    of others (recvFrom, sendFd, recvFd) will block all threads - if this
 246--    is a problem, -threaded is the workaround.
 247--
 248##if defined(mingw32_HOST_OS)
 249##define SAFE_ON_WIN safe
 250##else
 251##define SAFE_ON_WIN unsafe
 252##endif
 253
 254-----------------------------------------------------------------------------
 255-- Socket types
 256
 257#if __GLASGOW_HASKELL__ >= 611 && defined(mingw32_HOST_OS)
 258socket2FD  (MkSocket fd _ _ _ _) =
 259  -- HACK, 1 means True
 260  FD{fdFD = fd,fdIsSocket_ = 1}
 261#endif
 262
 263mkSocket :: CInt
 264         -> Family
 265         -> SocketType
 266         -> ProtocolNumber
 267         -> SocketStatus
 268         -> IO Socket
 269mkSocket fd fam sType pNum stat = do
 270   mStat <- newMVar stat
 271   return (MkSocket fd fam sType pNum mStat)
 272
 273
 274fdSocket :: Socket -> CInt
 275fdSocket (MkSocket fd _ _ _ _) = fd
 276
 277-- | This is the default protocol for a given service.
 278defaultProtocol :: ProtocolNumber
 279defaultProtocol = 0
 280
 281-----------------------------------------------------------------------------
 282-- SockAddr
 283
 284instance Show SockAddr where
 285#if defined(DOMAIN_SOCKET_SUPPORT)
 286  showsPrec _ (SockAddrUnix str) = showString str
 287#endif
 288  showsPrec _ (SockAddrInet port ha)
 289   = showString (unsafePerformIO (inet_ntoa ha))
 290   . showString ":"
 291   . shows port
 292#if defined(IPV6_SOCKET_SUPPORT)
 293  showsPrec _ addr@(SockAddrInet6 port _ _ _)
 294   = showChar '['
 295   . showString (unsafePerformIO $
 296                 fst `liftM` getNameInfo [NI_NUMERICHOST] True False addr >>=
 297                 maybe (fail "showsPrec: impossible internal error") return)
 298   . showString "]:"
 299   . shows port
 300#endif
 301
 302-----------------------------------------------------------------------------
 303-- Connection Functions
 304
 305-- In the following connection and binding primitives.  The names of
 306-- the equivalent C functions have been preserved where possible. It
 307-- should be noted that some of these names used in the C library,
 308-- \tr{bind} in particular, have a different meaning to many Haskell
 309-- programmers and have thus been renamed by appending the prefix
 310-- Socket.
 311
 312-- | Create a new socket using the given address family, socket type
 313-- and protocol number.  The address family is usually 'AF_INET',
 314-- 'AF_INET6', or 'AF_UNIX'.  The socket type is usually 'Stream' or
 315-- 'Datagram'.  The protocol number is usually 'defaultProtocol'.
 316-- If 'AF_INET6' is used, the 'IPv6Only' socket option is set to 0
 317-- so that both IPv4 and IPv6 can be handled with one socket.
 318socket :: Family         -- Family Name (usually AF_INET)
 319       -> SocketType     -- Socket Type (usually Stream)
 320       -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
 321       -> IO Socket      -- Unconnected Socket
 322socket family stype protocol = do
 323    c_stype <- packSocketTypeOrThrow "socket" stype
 324    fd <- throwSocketErrorIfMinus1Retry "socket" $
 325                c_socket (packFamily family) c_stype protocol
 326    setNonBlockIfNeeded fd
 327    socket_status <- newMVar NotConnected
 328    let sock = MkSocket fd family stype protocol socket_status
 329#if HAVE_DECL_IPV6_V6ONLY
 330# if defined(mingw32_HOST_OS)
 331    -- the IPv6Only option is only supported on Windows Vista and later,
 332    -- so trying to change it might throw an error
 333    when (family == AF_INET6) $
 334            E.catch (setSocketOption sock IPv6Only 0) $ (\(_ :: E.IOException) -> return ())
 335# else
 336    when (family == AF_INET6) $ setSocketOption sock IPv6Only 0
 337# endif
 338#endif
 339    return sock
 340
 341-- | Build a pair of connected socket objects using the given address
 342-- family, socket type, and protocol number.  Address family, socket
 343-- type, and protocol number are as for the 'socket' function above.
 344-- Availability: Unix.
 345#if defined(DOMAIN_SOCKET_SUPPORT)
 346socketPair :: Family              -- Family Name (usually AF_INET or AF_INET6)
 347           -> SocketType          -- Socket Type (usually Stream)
 348           -> ProtocolNumber      -- Protocol Number
 349           -> IO (Socket, Socket) -- unnamed and connected.
 350socketPair family stype protocol = do
 351    allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do
 352    c_stype <- packSocketTypeOrThrow "socketPair" stype
 353    _rc <- throwSocketErrorIfMinus1Retry "socketpair" $
 354                c_socketpair (packFamily family) c_stype protocol fdArr
 355    [fd1,fd2] <- peekArray 2 fdArr
 356    s1 <- mkNonBlockingSocket fd1
 357    s2 <- mkNonBlockingSocket fd2
 358    return (s1,s2)
 359  where
 360    mkNonBlockingSocket fd = do
 361       setNonBlockIfNeeded fd
 362       stat <- newMVar Connected
 363       return (MkSocket fd family stype protocol stat)
 364
 365foreign import ccall unsafe "socketpair"
 366  c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt
 367#endif
 368
 369-- | Set the socket to nonblocking, if applicable to this platform.
 370setNonBlockIfNeeded :: CInt -> IO ()
 371setNonBlockIfNeeded fd =
 372#if __GLASGOW_HASKELL__ < 611
 373    System.Posix.Internals.setNonBlockingFD fd
 374#else
 375    System.Posix.Internals.setNonBlockingFD fd True
 376#endif
 377
 378-----------------------------------------------------------------------------
 379-- Binding a socket
 380
 381-- | Bind the socket to an address. The socket must not already be
 382-- bound.  The 'Family' passed to @bind@ must be the
 383-- same as that passed to 'socket'.  If the special port number
 384-- 'aNY_PORT' is passed then the system assigns the next available
 385-- use port.
 386bind :: Socket    -- Unconnected Socket
 387           -> SockAddr  -- Address to Bind to
 388           -> IO ()
 389bind (MkSocket s _family _stype _protocol socketStatus) addr = do
 390 modifyMVar_ socketStatus $ \ status -> do
 391 if status /= NotConnected
 392  then
 393   ioError (userError ("bind: can't peform bind on socket in status " ++
 394         show status))
 395  else do
 396   withSockAddr addr $ \p_addr sz -> do
 397   _status <- throwSocketErrorIfMinus1Retry "bind" $ c_bind s p_addr (fromIntegral sz)
 398   return Bound
 399
 400-----------------------------------------------------------------------------
 401-- Connecting a socket
 402
 403-- | Connect to a remote socket at address.
 404connect :: Socket    -- Unconnected Socket
 405        -> SockAddr  -- Socket address stuff
 406        -> IO ()
 407connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = do
 408 modifyMVar_ socketStatus $ \currentStatus -> do
 409 if currentStatus /= NotConnected && currentStatus /= Bound
 410  then
 411    ioError (userError ("connect: can't peform connect on socket in status " ++
 412        show currentStatus))
 413  else do
 414    withSockAddr addr $ \p_addr sz -> do
 415
 416    let connectLoop = do
 417           r <- c_connect s p_addr (fromIntegral sz)
 418           if r == -1
 419               then do
 420#if !(defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS))
 421                   err <- getErrno
 422                   case () of
 423                     _ | err == eINTR       -> connectLoop
 424                     _ | err == eINPROGRESS -> connectBlocked
 425--                   _ | err == eAGAIN      -> connectBlocked
 426                     _otherwise             -> throwSocketError "connect"
 427#else
 428                   rc <- c_getLastError
 429                   case rc of
 430                     #{const WSANOTINITIALISED} -> do
 431                       withSocketsDo (return ())
 432                       r <- c_connect s p_addr (fromIntegral sz)
 433                       if r == -1
 434                         then throwSocketError "connect"
 435                         else return r
 436                     _ -> throwSocketError "connect"
 437#endif
 438               else return r
 439
 440        connectBlocked = do
 441           threadWaitWrite (fromIntegral s)
 442           err <- getSocketOption sock SoError
 443           if (err == 0)
 444                then return 0
 445                else throwSocketErrorCode "connect" (fromIntegral err)
 446
 447    connectLoop
 448    return Connected
 449
 450-----------------------------------------------------------------------------
 451-- Listen
 452
 453-- | Listen for connections made to the socket.  The second argument
 454-- specifies the maximum number of queued connections and should be at
 455-- least 1; the maximum value is system-dependent (usually 5).
 456listen :: Socket  -- Connected & Bound Socket
 457       -> Int     -- Queue Length
 458       -> IO ()
 459listen (MkSocket s _family _stype _protocol socketStatus) backlog = do
 460 modifyMVar_ socketStatus $ \ status -> do
 461 if status /= Bound
 462   then
 463     ioError (userError ("listen: can't peform listen on socket in status " ++
 464         show status))
 465   else do
 466     throwSocketErrorIfMinus1Retry "listen" (c_listen s (fromIntegral backlog))
 467     return Listening
 468
 469-----------------------------------------------------------------------------
 470-- Accept
 471--
 472-- A call to `accept' only returns when data is available on the given
 473-- socket, unless the socket has been set to non-blocking.  It will
 474-- return a new socket which should be used to read the incoming data and
 475-- should then be closed. Using the socket returned by `accept' allows
 476-- incoming requests to be queued on the original socket.
 477
 478-- | Accept a connection.  The socket must be bound to an address and
 479-- listening for connections.  The return value is a pair @(conn,
 480-- address)@ where @conn@ is a new socket object usable to send and
 481-- receive data on the connection, and @address@ is the address bound
 482-- to the socket on the other end of the connection.
 483accept :: Socket                        -- Queue Socket
 484       -> IO (Socket,                   -- Readable Socket
 485              SockAddr)                 -- Peer details
 486
 487accept sock@(MkSocket s family stype protocol status) = do
 488 currentStatus <- readMVar status
 489 okay <- isAcceptable sock
 490 if not okay
 491   then
 492     ioError (userError ("accept: can't perform accept on socket (" ++ (show (family,stype,protocol)) ++") in status " ++
 493         show currentStatus))
 494   else do
 495     let sz = sizeOfSockAddrByFamily family
 496     allocaBytes sz $ \ sockaddr -> do
 497#if defined(mingw32_HOST_OS)
 498     new_sock <-
 499        if threaded
 500           then with (fromIntegral sz) $ \ ptr_len ->
 501                  throwSocketErrorIfMinus1Retry "Network.Socket.accept" $
 502                    c_accept_safe s sockaddr ptr_len
 503           else do
 504                paramData <- c_newAcceptParams s (fromIntegral sz) sockaddr
 505                rc        <- asyncDoProc c_acceptDoProc paramData
 506                new_sock  <- c_acceptNewSock    paramData
 507                c_free paramData
 508                when (rc /= 0) $
 509                     throwSocketErrorCode "Network.Socket.accept" (fromIntegral rc)
 510                return new_sock
 511#else
 512     with (fromIntegral sz) $ \ ptr_len -> do
 513     new_sock <-
 514# ifdef HAVE_ACCEPT4
 515                 throwSocketErrorIfMinus1RetryMayBlock "accept"
 516                        (threadWaitRead (fromIntegral s))
 517                        (c_accept4 s sockaddr ptr_len (#const SOCK_NONBLOCK))
 518# else
 519                 throwSocketErrorWaitRead sock "accept"
 520                        (c_accept s sockaddr ptr_len)
 521# endif /* HAVE_ACCEPT4 */
 522#endif
 523     setNonBlockIfNeeded new_sock
 524     addr <- peekSockAddr sockaddr
 525     new_status <- newMVar Connected
 526     return ((MkSocket new_sock family stype protocol new_status), addr)
 527
 528#if defined(mingw32_HOST_OS)
 529foreign import ccall unsafe "HsNet.h acceptNewSock"
 530  c_acceptNewSock :: Ptr () -> IO CInt
 531foreign import ccall unsafe "HsNet.h newAcceptParams"
 532  c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ())
 533foreign import ccall unsafe "HsNet.h &acceptDoProc"
 534  c_acceptDoProc :: FunPtr (Ptr () -> IO Int)
 535foreign import ccall unsafe "free"
 536  c_free:: Ptr a -> IO ()
 537#endif
 538
 539-----------------------------------------------------------------------------
 540-- ** Sending and reciving data
 541
 542-- $sendrecv
 543--
 544-- Do not use the @send@ and @recv@ functions defined in this module
 545-- in new code, as they incorrectly represent binary data as a Unicode
 546-- string.  As a result, these functions are inefficient and may lead
 547-- to bugs in the program.  Instead use the @send@ and @recv@
 548-- functions defined in the 'Network.Socket.ByteString' module.
 549
 550-----------------------------------------------------------------------------
 551-- sendTo & recvFrom
 552
 553-- | Send data to the socket.  The recipient can be specified
 554-- explicitly, so the socket need not be in a connected state.
 555-- Returns the number of bytes sent.  Applications are responsible for
 556-- ensuring that all data has been sent.
 557--
 558-- NOTE: blocking on Windows unless you compile with -threaded (see
 559-- GHC ticket #1129)
 560sendTo :: Socket        -- (possibly) bound/connected Socket
 561       -> String        -- Data to send
 562       -> SockAddr
 563       -> IO Int        -- Number of Bytes sent
 564sendTo sock xs addr = do
 565 withCString xs $ \str -> do
 566   sendBufTo sock str (length xs) addr
 567
 568-- | Send data to the socket.  The recipient can be specified
 569-- explicitly, so the socket need not be in a connected state.
 570-- Returns the number of bytes sent.  Applications are responsible for
 571-- ensuring that all data has been sent.
 572sendBufTo :: Socket            -- (possibly) bound/connected Socket
 573          -> Ptr a -> Int  -- Data to send
 574          -> SockAddr
 575          -> IO Int            -- Number of Bytes sent
 576sendBufTo sock@(MkSocket s _family _stype _protocol _status) ptr nbytes addr = do
 577 withSockAddr addr $ \p_addr sz -> do
 578   liftM fromIntegral $
 579     throwSocketErrorWaitWrite sock "sendTo" $
 580        c_sendto s ptr (fromIntegral $ nbytes) 0{-flags-}
 581                        p_addr (fromIntegral sz)
 582
 583-- | Receive data from the socket. The socket need not be in a
 584-- connected state. Returns @(bytes, nbytes, address)@ where @bytes@
 585-- is a @String@ of length @nbytes@ representing the data received and
 586-- @address@ is a 'SockAddr' representing the address of the sending
 587-- socket.
 588--
 589-- NOTE: blocking on Windows unless you compile with -threaded (see
 590-- GHC ticket #1129)
 591recvFrom :: Socket -> Int -> IO (String, Int, SockAddr)
 592recvFrom sock nbytes =
 593  allocaBytes nbytes $ \ptr -> do
 594    (len, sockaddr) <- recvBufFrom sock ptr nbytes
 595    str <- peekCStringLen (ptr, len)
 596    return (str, len, sockaddr)
 597
 598-- | Receive data from the socket, writing it into buffer instead of
 599-- creating a new string.  The socket need not be in a connected
 600-- state. Returns @(nbytes, address)@ where @nbytes@ is the number of
 601-- bytes received and @address@ is a 'SockAddr' representing the
 602-- address of the sending socket.
 603--
 604-- NOTE: blocking on Windows unless you compile with -threaded (see
 605-- GHC ticket #1129)
 606recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr)
 607recvBufFrom sock@(MkSocket s family _stype _protocol _status) ptr nbytes
 608 | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvFrom")
 609 | otherwise   =
 610    withNewSockAddr family $ \ptr_addr sz -> do
 611      alloca $ \ptr_len -> do
 612        poke ptr_len (fromIntegral sz)
 613        len <- throwSocketErrorWaitRead sock "recvFrom" $
 614                   c_recvfrom s ptr (fromIntegral nbytes) 0{-flags-}
 615                                ptr_addr ptr_len
 616        let len' = fromIntegral len
 617        if len' == 0
 618         then ioError (mkEOFError "Network.Socket.recvFrom")
 619         else do
 620           flg <- isConnected sock
 621             -- For at least one implementation (WinSock 2), recvfrom() ignores
 622             -- filling in the sockaddr for connected TCP sockets. Cope with
 623             -- this by using getPeerName instead.
 624           sockaddr <-
 625                if flg then
 626                   getPeerName sock
 627                else
 628                   peekSockAddr ptr_addr
 629           return (len', sockaddr)
 630
 631-----------------------------------------------------------------------------
 632-- send & recv
 633
 634-- | Send data to the socket. The socket must be connected to a remote
 635-- socket. Returns the number of bytes sent.  Applications are
 636-- responsible for ensuring that all data has been sent.
 637send :: Socket  -- Bound/Connected Socket
 638     -> String  -- Data to send
 639     -> IO Int  -- Number of Bytes sent
 640send sock@(MkSocket s _family _stype _protocol _status) xs = do
 641 let len = length xs
 642 withCString xs $ \str -> do
 643   liftM fromIntegral $
 644#if defined(mingw32_HOST_OS)
 645# if __GLASGOW_HASKELL__ >= 611
 646    writeRawBufferPtr
 647      "Network.Socket.send"
 648      (socket2FD sock)
 649      (castPtr str)
 650      0
 651      (fromIntegral len)
 652#else
 653      writeRawBufferPtr
 654        "Network.Socket.send"
 655        (fromIntegral s)
 656        True
 657        str
 658        0
 659       (fromIntegral len)
 660#endif
 661
 662#else
 663     throwSocketErrorWaitWrite sock "send" $
 664        c_send s str (fromIntegral len) 0{-flags-}
 665#endif
 666
 667-- | Send data to the socket. The socket must be connected to a remote
 668-- socket. Returns the number of bytes sent.  Applications are
 669-- responsible for ensuring that all data has been sent.
 670sendBuf :: Socket     -- Bound/Connected Socket
 671        -> Ptr Word8  -- Pointer to the data to send
 672        -> Int        -- Length of the buffer
 673        -> IO Int     -- Number of Bytes sent
 674sendBuf sock@(MkSocket s _family _stype _protocol _status) str len = do
 675   liftM fromIntegral $
 676#if defined(mingw32_HOST_OS)
 677# if __GLASGOW_HASKELL__ >= 611
 678    writeRawBufferPtr
 679      "Network.Socket.sendBuf"
 680      (socket2FD sock)
 681      (castPtr str)
 682      0
 683      (fromIntegral len)
 684# else
 685      writeRawBufferPtr
 686        "Network.Socket.sendBuf"
 687        (fromIntegral s)
 688        True
 689        str
 690        0
 691       (fromIntegral len)
 692# endif
 693#else
 694     throwSocketErrorWaitWrite sock "sendBuf" $
 695        c_send s str (fromIntegral len) 0{-flags-}
 696#endif
 697
 698
 699-- | Receive data from the socket.  The socket must be in a connected
 700-- state. This function may return fewer bytes than specified.  If the
 701-- message is longer than the specified length, it may be discarded
 702-- depending on the type of socket.  This function may block until a
 703-- message arrives.
 704--
 705-- Considering hardware and network realities, the maximum number of
 706-- bytes to receive should be a small power of 2, e.g., 4096.
 707--
 708-- For TCP sockets, a zero length return value means the peer has
 709-- closed its half side of the connection.
 710recv :: Socket -> Int -> IO String
 711recv sock l = recvLen sock l >>= \ (s,_) -> return s
 712
 713recvLen :: Socket -> Int -> IO (String, Int)
 714recvLen sock@(MkSocket s _family _stype _protocol _status) nbytes
 715 | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recv")
 716 | otherwise   = do
 717     allocaBytes nbytes $ \ptr -> do
 718        len <-
 719#if defined(mingw32_HOST_OS)
 720# if __GLASGOW_HASKELL__ >= 611
 721          readRawBufferPtr "Network.Socket.recvLen" (socket2FD sock) ptr 0
 722                 (fromIntegral nbytes)
 723#else
 724          readRawBufferPtr "Network.Socket.recvLen" (fromIntegral s) True ptr 0
 725                 (fromIntegral nbytes)
 726#endif
 727#else
 728               throwSocketErrorWaitRead sock "recv" $
 729                   c_recv s ptr (fromIntegral nbytes) 0{-flags-}
 730#endif
 731        let len' = fromIntegral len
 732        if len' == 0
 733         then ioError (mkEOFError "Network.Socket.recv")
 734         else do
 735           s' <- peekCStringLen (castPtr ptr,len')
 736           return (s', len')
 737
 738-- | Receive data from the socket.  The socket must be in a connected
 739-- state. This function may return fewer bytes than specified.  If the
 740-- message is longer than the specified length, it may be discarded
 741-- depending on the type of socket.  This function may block until a
 742-- message arrives.
 743--
 744-- Considering hardware and network realities, the maximum number of
 745-- bytes to receive should be a small power of 2, e.g., 4096.
 746--
 747-- For TCP sockets, a zero length return value means the peer has
 748-- closed its half side of the connection.
 749recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int
 750recvBuf sock p l = recvLenBuf sock p l
 751
 752recvLenBuf :: Socket -> Ptr Word8 -> Int -> IO Int
 753recvLenBuf sock@(MkSocket s _family _stype _protocol _status) ptr nbytes
 754 | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf")
 755 | otherwise   = do
 756        len <-
 757#if defined(mingw32_HOST_OS)
 758# if __GLASGOW_HASKELL__ >= 611
 759          readRawBufferPtr "Network.Socket.recvLenBuf" (socket2FD sock) ptr 0
 760                 (fromIntegral nbytes)
 761#else
 762          readRawBufferPtr "Network.Socket.recvLenBuf" (fromIntegral s) True ptr 0
 763                 (fromIntegral nbytes)
 764#endif
 765#else
 766               throwSocketErrorWaitRead sock "recvBuf" $
 767                   c_recv s (castPtr ptr) (fromIntegral nbytes) 0{-flags-}
 768#endif
 769        let len' = fromIntegral len
 770        if len' == 0
 771         then ioError (mkEOFError "Network.Socket.recvBuf")
 772         else return len'
 773
 774
 775-- ---------------------------------------------------------------------------
 776-- socketPort
 777--
 778-- The port number the given socket is currently connected to can be
 779-- determined by calling $port$, is generally only useful when bind
 780-- was given $aNY\_PORT$.
 781
 782socketPort :: Socket            -- Connected & Bound Socket
 783           -> IO PortNumber     -- Port Number of Socket
 784socketPort sock@(MkSocket _ AF_INET _ _ _) = do
 785    (SockAddrInet port _) <- getSocketName sock
 786    return port
 787#if defined(IPV6_SOCKET_SUPPORT)
 788socketPort sock@(MkSocket _ AF_INET6 _ _ _) = do
 789    (SockAddrInet6 port _ _ _) <- getSocketName sock
 790    return port
 791#endif
 792socketPort (MkSocket _ family _ _ _) =
 793    ioError (userError ("socketPort: not supported for Family " ++ show family))
 794
 795
 796-- ---------------------------------------------------------------------------
 797-- getPeerName
 798
 799-- Calling $getPeerName$ returns the address details of the machine,
 800-- other than the local one, which is connected to the socket. This is
 801-- used in programs such as FTP to determine where to send the
 802-- returning data.  The corresponding call to get the details of the
 803-- local machine is $getSocketName$.
 804
 805getPeerName   :: Socket -> IO SockAddr
 806getPeerName (MkSocket s family _ _ _) = do
 807 withNewSockAddr family $ \ptr sz -> do
 808   with (fromIntegral sz) $ \int_star -> do
 809   throwSocketErrorIfMinus1Retry "getPeerName" $ c_getpeername s ptr int_star
 810   _sz <- peek int_star
 811   peekSockAddr ptr
 812
 813getSocketName :: Socket -> IO SockAddr
 814getSocketName (MkSocket s family _ _ _) = do
 815 withNewSockAddr family $ \ptr sz -> do
 816   with (fromIntegral sz) $ \int_star -> do
 817   throwSocketErrorIfMinus1Retry "getSocketName" $ c_getsockname s ptr int_star
 818   peekSockAddr ptr
 819
 820-----------------------------------------------------------------------------
 821-- Socket Properties
 822
 823-- | Socket options for use with 'setSocketOption' and 'getSocketOption'.
 824--
 825-- The existence of a constructor does not imply that the relevant option
 826-- is supported on your system: see 'isSupportedSocketOption'
 827data SocketOption
 828    = Debug         -- ^ SO_DEBUG
 829    | ReuseAddr     -- ^ SO_REUSEADDR
 830    | Type          -- ^ SO_TYPE
 831    | SoError       -- ^ SO_ERROR
 832    | DontRoute     -- ^ SO_DONTROUTE
 833    | Broadcast     -- ^ SO_BROADCAST
 834    | SendBuffer    -- ^ SO_SNDBUF
 835    | RecvBuffer    -- ^ SO_RCVBUF
 836    | KeepAlive     -- ^ SO_KEEPALIVE
 837    | OOBInline     -- ^ SO_OOBINLINE
 838    | TimeToLive    -- ^ IP_TTL
 839    | MaxSegment    -- ^ TCP_MAXSEG
 840    | NoDelay       -- ^ TCP_NODELAY
 841    | Cork          -- ^ TCP_CORK
 842    | Linger        -- ^ SO_LINGER
 843    | ReusePort     -- ^ SO_REUSEPORT
 844    | RecvLowWater  -- ^ SO_RCVLOWAT
 845    | SendLowWater  -- ^ SO_SNDLOWAT
 846    | RecvTimeOut   -- ^ SO_RCVTIMEO
 847    | SendTimeOut   -- ^ SO_SNDTIMEO
 848    | UseLoopBack   -- ^ SO_USELOOPBACK
 849    | IPv6Only      -- ^ IPV6_V6ONLY
 850    deriving (Show, Typeable)
 851
 852-- | Does the 'SocketOption' exist on this system?
 853isSupportedSocketOption :: SocketOption -> Bool
 854isSupportedSocketOption = isJust . packSocketOption
 855
 856-- | For a socket option, return Just (level, value) where level is the
 857-- corresponding C option level constant (e.g. SOL_SOCKET) and value is
 858-- the option constant itself (e.g. SO_DEBUG)
 859-- If either constant does not exist, return Nothing.
 860packSocketOption :: SocketOption -> Maybe (CInt, CInt)
 861packSocketOption so =
 862  -- The Just here is a hack to disable GHC's overlapping pattern detection:
 863  -- the problem is if all constants are present, the fallback pattern is
 864  -- redundant, but if they aren't then it isn't. Hence we introduce an
 865  -- extra pattern (Nothing) that can't possibly happen, so that the
 866  -- fallback is always (in principle) necessary.
 867  -- I feel a little bad for including this, but such are the sacrifices we
 868  -- make while working with CPP - excluding the fallback pattern correctly
 869  -- would be a serious nuisance.
 870  -- (NB: comments elsewhere in this file refer to this one)
 871  case Just so of
 872#ifdef SOL_SOCKET
 873#ifdef SO_DEBUG
 874    Just Debug         -> Just ((#const SOL_SOCKET), (#const SO_DEBUG))
 875#endif
 876#ifdef SO_REUSEADDR
 877    Just ReuseAddr     -> Just ((#const SOL_SOCKET), (#const SO_REUSEADDR))
 878#endif
 879#ifdef SO_TYPE
 880    Just Type          -> Just ((#const SOL_SOCKET), (#const SO_TYPE))
 881#endif
 882#ifdef SO_ERROR
 883    Just SoError       -> Just ((#const SOL_SOCKET), (#const SO_ERROR))
 884#endif
 885#ifdef SO_DONTROUTE
 886    Just DontRoute     -> Just ((#const SOL_SOCKET), (#const SO_DONTROUTE))
 887#endif
 888#ifdef SO_BROADCAST
 889    Just Broadcast     -> Just ((#const SOL_SOCKET), (#const SO_BROADCAST))
 890#endif
 891#ifdef SO_SNDBUF
 892    Just SendBuffer    -> Just ((#const SOL_SOCKET), (#const SO_SNDBUF))
 893#endif
 894#ifdef SO_RCVBUF
 895    Just RecvBuffer    -> Just ((#const SOL_SOCKET), (#const SO_RCVBUF))
 896#endif
 897#ifdef SO_KEEPALIVE
 898    Just KeepAlive     -> Just ((#const SOL_SOCKET), (#const SO_KEEPALIVE))
 899#endif
 900#ifdef SO_OOBINLINE
 901    Just OOBInline     -> Just ((#const SOL_SOCKET), (#const SO_OOBINLINE))
 902#endif
 903#ifdef SO_LINGER
 904    Just Linger        -> Just ((#const SOL_SOCKET), (#const SO_LINGER))
 905#endif
 906#ifdef SO_REUSEPORT
 907    Just ReusePort     -> Just ((#const SOL_SOCKET), (#const SO_REUSEPORT))
 908#endif
 909#ifdef SO_RCVLOWAT
 910    Just RecvLowWater  -> Just ((#const SOL_SOCKET), (#const SO_RCVLOWAT))
 911#endif
 912#ifdef SO_SNDLOWAT
 913    Just SendLowWater  -> Just ((#const SOL_SOCKET), (#const SO_SNDLOWAT))
 914#endif
 915#ifdef SO_RCVTIMEO
 916    Just RecvTimeOut   -> Just ((#const SOL_SOCKET), (#const SO_RCVTIMEO))
 917#endif
 918#ifdef SO_SNDTIMEO
 919    Just SendTimeOut   -> Just ((#const SOL_SOCKET), (#const SO_SNDTIMEO))
 920#endif
 921#ifdef SO_USELOOPBACK
 922    Just UseLoopBack   -> Just ((#const SOL_SOCKET), (#const SO_USELOOPBACK))
 923#endif
 924#endif // SOL_SOCKET
 925#ifdef IPPROTO_IP
 926#ifdef IP_TTL
 927    Just TimeToLive    -> Just ((#const IPPROTO_IP), (#const IP_TTL))
 928#endif
 929#endif // IPPROTO_IP
 930#ifdef IPPROTO_TCP
 931#ifdef TCP_MAXSEG
 932    Just MaxSegment    -> Just ((#const IPPROTO_TCP), (#const TCP_MAXSEG))
 933#endif
 934#ifdef TCP_NODELAY
 935    Just NoDelay       -> Just ((#const IPPROTO_TCP), (#const TCP_NODELAY))
 936#endif
 937#ifdef TCP_CORK
 938    Just Cork          -> Just ((#const IPPROTO_TCP), (#const TCP_CORK))
 939#endif
 940#endif // IPPROTO_TCP
 941#ifdef IPPROTO_IPV6
 942#if HAVE_DECL_IPV6_V6ONLY
 943    Just IPv6Only      -> Just ((#const IPPROTO_IPV6), (#const IPV6_V6ONLY))
 944#endif
 945#endif // IPPROTO_IPV6
 946    _             -> Nothing
 947
 948-- | Return the option level and option value if they exist,
 949-- otherwise throw an error that begins "Network.Socket." ++ the String
 950-- parameter
 951packSocketOption' :: String -> SocketOption -> IO (CInt, CInt)
 952packSocketOption' caller so = maybe err return (packSocketOption so)
 953 where
 954  err = ioError . userError . concat $ ["Network.Socket.", caller,
 955    ": socket option ", show so, " unsupported on this system"]
 956
 957-- | Set a socket option that expects an Int value.
 958-- There is currently no API to set e.g. the timeval socket options
 959setSocketOption :: Socket
 960                -> SocketOption -- Option Name
 961                -> Int          -- Option Value
 962                -> IO ()
 963setSocketOption (MkSocket s _ _ _ _) so v = do
 964   (level, opt) <- packSocketOption' "setSocketOption" so
 965   with (fromIntegral v) $ \ptr_v -> do
 966   throwSocketErrorIfMinus1_ "setSocketOption" $
 967       c_setsockopt s level opt ptr_v
 968          (fromIntegral (sizeOf (undefined :: CInt)))
 969   return ()
 970
 971
 972-- | Get a socket option that gives an Int value.
 973-- There is currently no API to get e.g. the timeval socket options
 974getSocketOption :: Socket
 975                -> SocketOption  -- Option Name
 976                -> IO Int        -- Option Value
 977getSocketOption (MkSocket s _ _ _ _) so = do
 978   (level, opt) <- packSocketOption' "getSocketOption" so
 979   alloca $ \ptr_v ->
 980     with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do
 981       throwSocketErrorIfMinus1Retry "getSocketOption" $
 982         c_getsockopt s level opt ptr_v ptr_sz
 983       fromIntegral `liftM` peek ptr_v
 984
 985
 986#ifdef HAVE_STRUCT_UCRED
 987-- | Returns the processID, userID and groupID of the socket's peer.
 988--
 989-- Only available on platforms that support SO_PEERCRED on domain sockets.
 990getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt)
 991getPeerCred sock = do
 992  let fd = fdSocket sock
 993  let sz = (fromIntegral (#const sizeof(struct ucred)))
 994  with sz $ \ ptr_cr ->
 995   alloca       $ \ ptr_sz -> do
 996     poke ptr_sz sz
 997     throwSocketErrorIfMinus1Retry "getPeerCred" $
 998       c_getsockopt fd (#const SOL_SOCKET) (#const SO_PEERCRED) ptr_cr ptr_sz
 999     pid <- (#peek struct ucred, pid) ptr_cr
1000     uid <- (#peek struct ucred, uid) ptr_cr
1001     gid <- (#peek struct ucred, gid) ptr_cr
1002     return (pid, uid, gid)
1003#endif
1004
1005##if !(MIN_VERSION_base(4,3,1))
1006closeFdWith closer fd = closer fd
1007##endif
1008
1009#if defined(DOMAIN_SOCKET_SUPPORT)
1010-- sending/receiving ancillary socket data; low-level mechanism
1011-- for transmitting file descriptors, mainly.
1012sendFd :: Socket -> CInt -> IO ()
1013sendFd sock outfd = do
1014  throwSocketErrorWaitWrite sock "sendFd" $
1015     c_sendFd (fdSocket sock) outfd
1016   -- Note: If Winsock supported FD-passing, thi would have been
1017   -- incorrect (since socket FDs need to be closed via closesocket().)
1018  closeFd outfd
1019
1020recvFd :: Socket -> IO CInt
1021recvFd sock = do
1022  theFd <- throwSocketErrorWaitRead sock "recvFd" $
1023               c_recvFd (fdSocket sock)
1024  return theFd
1025
1026foreign import ccall SAFE_ON_WIN "sendFd" c_sendFd :: CInt -> CInt -> IO CInt
1027foreign import ccall SAFE_ON_WIN "recvFd" c_recvFd :: CInt -> IO CInt
1028
1029#endif
1030
1031-- ---------------------------------------------------------------------------
1032-- Utility Functions
1033
1034aNY_PORT :: PortNumber
1035aNY_PORT = 0
1036
1037-- | The IPv4 wild card address.
1038
1039iNADDR_ANY :: HostAddress
1040iNADDR_ANY = htonl (#const INADDR_ANY)
1041
1042foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32
1043
1044#if defined(IPV6_SOCKET_SUPPORT)
1045-- | The IPv6 wild card address.
1046
1047iN6ADDR_ANY :: HostAddress6
1048iN6ADDR_ANY = (0, 0, 0, 0)
1049#endif
1050
1051sOMAXCONN :: Int
1052sOMAXCONN = #const SOMAXCONN
1053
1054sOL_SOCKET :: Int
1055sOL_SOCKET = #const SOL_SOCKET
1056
1057#ifdef SCM_RIGHTS
1058sCM_RIGHTS :: Int
1059sCM_RIGHTS = #const SCM_RIGHTS
1060#endif
1061
1062-- | This is the value of SOMAXCONN, typically 128.
1063-- 128 is good enough for normal network servers but
1064-- is too small for high performance servers.
1065maxListenQueue :: Int
1066maxListenQueue = sOMAXCONN
1067
1068-- -----------------------------------------------------------------------------
1069
1070data ShutdownCmd
1071 = ShutdownReceive
1072 | ShutdownSend
1073 | ShutdownBoth
1074 deriving Typeable
1075
1076sdownCmdToInt :: ShutdownCmd -> CInt
1077sdownCmdToInt ShutdownReceive = 0
1078sdownCmdToInt ShutdownSend    = 1
1079sdownCmdToInt ShutdownBoth    = 2
1080
1081-- | Shut down one or both halves of the connection, depending on the
1082-- second argument to the function.  If the second argument is
1083-- 'ShutdownReceive', further receives are disallowed.  If it is
1084-- 'ShutdownSend', further sends are disallowed.  If it is
1085-- 'ShutdownBoth', further sends and receives are disallowed.
1086shutdown :: Socket -> ShutdownCmd -> IO ()
1087shutdown (MkSocket s _ _ _ _) stype = do
1088  throwSocketErrorIfMinus1Retry "shutdown" (c_shutdown s (sdownCmdToInt stype))
1089  return ()
1090
1091-- -----------------------------------------------------------------------------
1092
1093-- | Close the socket.  All future operations on the socket object
1094-- will fail.  The remote end will receive no more data (after queued
1095-- data is flushed).
1096close :: Socket -> IO ()
1097close (MkSocket s _ _ _ socketStatus) = do
1098 modifyMVar_ socketStatus $ \ status ->
1099   case status of
1100     ConvertedToHandle ->
1101         ioError (userError ("close: converted to a Handle, use hClose instead"))
1102     Closed ->
1103         return status
1104     _ -> closeFdWith (closeFd . fromIntegral) (fromIntegral s) >> return Closed
1105
1106-- -----------------------------------------------------------------------------
1107
1108isConnected :: Socket -> IO Bool
1109isConnected (MkSocket _ _ _ _ status) = do
1110    value <- readMVar status
1111    return (value == Connected)
1112
1113-- -----------------------------------------------------------------------------
1114-- Socket Predicates
1115
1116isBound :: Socket -> IO Bool
1117isBound (MkSocket _ _ _ _ status) = do
1118    value <- readMVar status
1119    return (value == Bound)
1120
1121isListening :: Socket -> IO Bool
1122isListening (MkSocket _ _ _  _ status) = do
1123    value <- readMVar status
1124    return (value == Listening)
1125
1126isReadable  :: Socket -> IO Bool
1127isReadable (MkSocket _ _ _ _ status) = do
1128    value <- readMVar status
1129    return (value == Listening || value == Connected)
1130
1131isWritable  :: Socket -> IO Bool
1132isWritable = isReadable -- sort of.
1133
1134isAcceptable :: Socket -> IO Bool
1135#if defined(DOMAIN_SOCKET_SUPPORT)
1136isAcceptable (MkSocket _ AF_UNIX x _ status)
1137    | x == Stream || x == SeqPacket = do
1138        value <- readMVar status
1139        return (value == Connected || value == Bound || value == Listening)
1140isAcceptable (MkSocket _ AF_UNIX _ _ _) = return False
1141#endif
1142isAcceptable (MkSocket _ _ _ _ status) = do
1143    value <- readMVar status
1144    return (value == Connected || value == Listening)
1145
1146-- -----------------------------------------------------------------------------
1147-- Internet address manipulation routines:
1148
1149inet_addr :: String -> IO HostAddress
1150inet_addr ipstr = do
1151   withCString ipstr $ \str -> do
1152   had <- c_inet_addr str
1153   if had == -1
1154    then ioError (userError ("inet_addr: Malformed address: " ++ ipstr))
1155    else return had  -- network byte order
1156
1157inet_ntoa :: HostAddress -> IO String
1158inet_ntoa haddr = do
1159  pstr <- c_inet_ntoa haddr
1160  peekCString pstr
1161
1162-- | Turns a Socket into an 'Handle'. By default, the new handle is
1163-- unbuffered. Use 'System.IO.hSetBuffering' to change the buffering.
1164--
1165-- Note that since a 'Handle' is automatically closed by a finalizer
1166-- when it is no longer referenced, you should avoid doing any more
1167-- operations on the 'Socket' after calling 'socketToHandle'.  To
1168-- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose'
1169-- on the 'Handle'.
1170
1171#ifndef __PARALLEL_HASKELL__
1172socketToHandle :: Socket -> IOMode -> IO Handle
1173socketToHandle s@(MkSocket fd _ _ _ socketStatus) mode = do
1174 modifyMVar socketStatus $ \ status ->
1175    if status == ConvertedToHandle
1176        then ioError (userError ("socketToHandle: already a Handle"))
1177        else do
1178# if __GLASGOW_HASKELL__ >= 611
1179    h <- fdToHandle' (fromIntegral fd) (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-}
1180# elif __GLASGOW_HASKELL__ >= 608
1181    h <- fdToHandle' (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-}
1182# elif __GLASGOW_HASKELL__ < 608
1183    h <- openFd (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-}
1184# endif
1185    hSetBuffering h NoBuffering
1186    return (ConvertedToHandle, h)
1187#else
1188socketToHandle (MkSocket s family stype protocol status) m =
1189  error "socketToHandle not implemented in a parallel setup"
1190#endif
1191
1192-- | Pack a list of values into a bitmask.  The possible mappings from
1193-- value to bit-to-set are given as the first argument.  We assume
1194-- that each value can cause exactly one bit to be set; unpackBits will
1195-- break if this property is not true.
1196
1197packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b
1198
1199packBits mapping xs = foldl' pack 0 mapping
1200    where pack acc (k, v) | k `elem` xs = acc .|. v
1201                          | otherwise   = acc
1202
1203-- | Unpack a bitmask into a list of values.
1204
1205unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a]
1206
1207-- Be permissive and ignore unknown bit values. At least on OS X,
1208-- getaddrinfo returns an ai_flags field with bits set that have no
1209-- entry in <netdb.h>.
1210unpackBits [] _    = []
1211unpackBits ((k,v):xs) r
1212    | r .&. v /= 0 = k : unpackBits xs (r .&. complement v)
1213    | otherwise    = unpackBits xs r
1214
1215-----------------------------------------------------------------------------
1216-- Address and service lookups
1217
1218#if defined(IPV6_SOCKET_SUPPORT)
1219
1220-- | Flags that control the querying behaviour of 'getAddrInfo'.
1221data AddrInfoFlag
1222    = AI_ADDRCONFIG
1223    | AI_ALL
1224    | AI_CANONNAME
1225    | AI_NUMERICHOST
1226    | AI_NUMERICSERV
1227    | AI_PASSIVE
1228    | AI_V4MAPPED
1229    deriving (Eq, Read, Show, Typeable)
1230
1231aiFlagMapping :: [(AddrInfoFlag, CInt)]
1232
1233aiFlagMapping =
1234    [
1235#if HAVE_DECL_AI_ADDRCONFIG
1236     (AI_ADDRCONFIG, #const AI_ADDRCONFIG),
1237#else
1238     (AI_ADDRCONFIG, 0),
1239#endif
1240#if HAVE_DECL_AI_ALL
1241     (AI_ALL, #const AI_ALL),
1242#else
1243     (AI_ALL, 0),
1244#endif
1245     (AI_CANONNAME, #const AI_CANONNAME),
1246     (AI_NUMERICHOST, #const AI_NUMERICHOST),
1247#if HAVE_DECL_AI_NUMERICSERV
1248     (AI_NUMERICSERV, #const AI_NUMERICSERV),
1249#else
1250     (AI_NUMERICSERV, 0),
1251#endif
1252     (AI_PASSIVE, #const AI_PASSIVE),
1253#if HAVE_DECL_AI_V4MAPPED
1254     (AI_V4MAPPED, #const AI_V4MAPPED)
1255#else
1256     (AI_V4MAPPED, 0)
1257#endif
1258    ]
1259
1260-- | Indicate whether the given 'AddrInfoFlag' will have any effect on
1261-- this system.
1262addrInfoFlagImplemented :: AddrInfoFlag -> Bool
1263addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0
1264
1265data AddrInfo =
1266    AddrInfo {
1267        addrFlags :: [AddrInfoFlag],
1268        addrFamily :: Family,
1269        addrSocketType :: SocketType,
1270        addrProtocol :: ProtocolNumber,
1271        addrAddress :: SockAddr,
1272        addrCanonName :: Maybe String
1273        }
1274    deriving (Eq, Show, Typeable)
1275
1276instance Storable AddrInfo where
1277    sizeOf    _ = #const sizeof(struct addrinfo)
1278    alignment _ = alignment (undefined :: CInt)
1279
1280    peek p = do
1281        ai_flags <- (#peek struct addrinfo, ai_flags) p
1282        ai_family <- (#peek struct addrinfo, ai_family) p
1283        ai_socktype <- (#peek struct addrinfo, ai_socktype) p
1284        ai_protocol <- (#peek struct addrinfo, ai_protocol) p
1285        ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr
1286        ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p
1287
1288        ai_canonname <- if ai_canonname_ptr == nullPtr
1289                        then return Nothing
1290                        else liftM Just $ peekCString ai_canonname_ptr
1291
1292        socktype <- unpackSocketType' "AddrInfo.peek" ai_socktype
1293        return (AddrInfo
1294                {
1295                 addrFlags = unpackBits aiFlagMapping ai_flags,
1296                 addrFamily = unpackFamily ai_family,
1297                 addrSocketType = socktype,
1298                 addrProtocol = ai_protocol,
1299                 addrAddress = ai_addr,
1300                 addrCanonName = ai_canonname
1301                })
1302
1303    poke p (AddrInfo flags family socketType protocol _ _) = do
1304        c_stype <- packSocketTypeOrThrow "AddrInfo.poke" socketType
1305
1306        (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags)
1307        (#poke struct addrinfo, ai_family) p (packFamily family)
1308        (#poke struct addrinfo, ai_socktype) p c_stype
1309        (#poke struct addrinfo, ai_protocol) p protocol
1310
1311        -- stuff below is probably not needed, but let's zero it for safety
1312
1313        (#poke struct addrinfo, ai_addrlen) p (0::CSize)
1314        (#poke struct addrinfo, ai_addr) p nullPtr
1315        (#poke struct addrinfo, ai_canonname) p nullPtr
1316        (#poke struct addrinfo, ai_next) p nullPtr
1317
1318data NameInfoFlag
1319    = NI_DGRAM
1320    | NI_NAMEREQD
1321    | NI_NOFQDN
1322    | NI_NUMERICHOST
1323    | NI_NUMERICSERV
1324    deriving (Eq, Read, Show, Typeable)
1325
1326niFlagMapping :: [(NameInfoFlag, CInt)]
1327
1328niFlagMapping = [(NI_DGRAM, #const NI_DGRAM),
1329                 (NI_NAMEREQD, #const NI_NAMEREQD),
1330                 (NI_NOFQDN, #const NI_NOFQDN),
1331                 (NI_NUMERICHOST, #const NI_NUMERICHOST),
1332                 (NI_NUMERICSERV, #const NI_NUMERICSERV)]
1333
1334-- | Default hints for address lookup with 'getAddrInfo'.  The values
1335-- of the 'addrAddress' and 'addrCanonName' fields are 'undefined',
1336-- and are never inspected by 'getAddrInfo'.
1337
1338defaultHints :: AddrInfo
1339
1340defaultHints = AddrInfo {
1341                         addrFlags = [],
1342                         addrFamily = AF_UNSPEC,
1343                         addrSocketType = NoSocketType,
1344                         addrProtocol = defaultProtocol,
1345                         addrAddress = undefined,
1346                         addrCanonName = undefined
1347                        }
1348
1349-- | Resolve a host or service name to one or more addresses.
1350-- The 'AddrInfo' values that this function returns contain 'SockAddr'
1351-- values that you can pass directly to 'connect' or
1352-- 'bind'.
1353--
1354-- This function is protocol independent.  It can return both IPv4 and
1355-- IPv6 address information.
1356--
1357-- The 'AddrInfo' argument specifies the preferred query behaviour,
1358-- socket options, or protocol.  You can override these conveniently
1359-- using Haskell's record update syntax on 'defaultHints', for example
1360-- as follows:
1361--
1362-- @
1363--   myHints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }
1364-- @
1365--
1366-- Values for 'addrFlags' control query behaviour.  The supported
1367-- flags are as follows:
1368--
1369--   [@AI_PASSIVE@] If no 'HostName' value is provided, the network
1370--     address in each 'SockAddr'
1371--     will be left as a "wild card", i.e. as either 'iNADDR_ANY'
1372--     or 'iN6ADDR_ANY'.  This is useful for server applications that
1373--     will accept connections from any client.
1374--
1375--   [@AI_CANONNAME@] The 'addrCanonName' field of the first returned
1376--     'AddrInfo' will contain the "canonical name" of the host.
1377--
1378--   [@AI_NUMERICHOST@] The 'HostName' argument /must/ be a numeric
1379--     address in string form, and network name lookups will not be
1380--     attempted.
1381--
1382-- /Note/: Although the following flags are required by RFC 3493, they
1383-- may not have an effect on all platforms, because the underlying
1384-- network stack may not support them.  To see whether a flag from the
1385-- list below will have any effect, call 'addrInfoFlagImplemented'.
1386--
1387--   [@AI_NUMERICSERV@] The 'ServiceName' argument /must/ be a port
1388--     number in string form, and service name lookups will not be
1389--     attempted.
1390--
1391--   [@AI_ADDRCONFIG@] The list of returned 'AddrInfo' values will
1392--     only contain IPv4 addresses if the local system has at least
1393--     one IPv4 interface configured, and likewise for IPv6.
1394--
1395--   [@AI_V4MAPPED@] If an IPv6 lookup is performed, and no IPv6
1396--     addresses are found, IPv6-mapped IPv4 addresses will be
1397--     returned.
1398--
1399--   [@AI_ALL@] If 'AI_ALL' is specified, return all matching IPv6 and
1400--     IPv4 addresses.  Otherwise, this flag has no effect.
1401--
1402-- You must provide a 'Just' value for at least one of the 'HostName'
1403-- or 'ServiceName' arguments.  'HostName' can be either a numeric
1404-- network address (dotted quad for IPv4, colon-separated hex for
1405-- IPv6) or a hostname.  In the latter case, its addresses will be
1406-- looked up unless 'AI_NUMERICHOST' is specified as a hint.  If you
1407-- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as
1408-- a hint, network addresses in the result will contain the address of
1409-- the loopback interface.
1410--
1411-- If the query fails, this function throws an IO exception instead of
1412-- returning an empty list.  Otherwise, it returns a non-empty list
1413-- of 'AddrInfo' values.
1414--
1415-- There are several reasons why a query might result in several
1416-- values.  For example, the queried-for host could be multihomed, or
1417-- the service might be available via several protocols.
1418--
1419-- Note: the order of arguments is slightly different to that defined
1420-- for @getaddrinfo@ in RFC 2553.  The 'AddrInfo' parameter comes first
1421-- to make partial application easier.
1422--
1423-- Example:
1424-- @
1425--   let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }
1426--   addrs <- getAddrInfo (Just hints) (Just "www.haskell.org") (Just "http")
1427--   let addr = head addrs
1428--   sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1429--   connect sock (addrAddress addr)
1430-- @
1431
1432getAddrInfo :: Maybe AddrInfo -- ^ preferred socket type or protocol
1433            -> Maybe HostName -- ^ host name to look up
1434            -> Maybe ServiceName -- ^ service name to look up
1435            -> IO [AddrInfo] -- ^ resolved addresses, with "best" first
1436
1437getAddrInfo hints node service =
1438  maybeWith withCString node $ \c_node ->
1439    maybeWith withCString service $ \c_service ->
1440      maybeWith with filteredHints $ \c_hints ->
1441        alloca $ \ptr_ptr_addrs -> do
1442          ret <- c_getaddrinfo c_node c_service c_hints ptr_ptr_addrs
1443          case ret of
1444            0 -> do ptr_addrs <- peek ptr_ptr_addrs
1445                    ais <- followAddrInfo ptr_addrs
1446                    c_freeaddrinfo ptr_addrs
1447                    return ais
1448            _ -> do err <- gai_strerror ret
1449                    ioError (ioeSetErrorString
1450                             (mkIOError NoSuchThing "getAddrInfo" Nothing
1451                              Nothing) err)
1452    -- Leaving out the service and using AI_NUMERICSERV causes a
1453    -- segfault on OS X 10.8.2. This code removes AI_NUMERICSERV
1454    -- (which has no effect) in that case.
1455  where
1456#if defined(darwin_HOST_OS)
1457    filteredHints = case service of
1458        Nothing -> fmap (\ h -> h { addrFlags = delete AI_NUMERICSERV (addrFlags h) }) hints
1459        _       -> hints
1460#else
1461    filteredHints = hints
1462#endif
1463
1464followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo]
1465
1466followAddrInfo ptr_ai | ptr_ai == nullPtr = return []
1467                      | otherwise = do
1468    a <- peek ptr_ai
1469    as <- (#peek struct addrinfo, ai_next) ptr_ai >>= followAddrInfo
1470    return (a:as)
1471
1472foreign import ccall safe "hsnet_getaddrinfo"
1473    c_getaddrinfo :: CString -> CString -> Ptr AddrInfo -> Ptr (Ptr AddrInfo)
1474                  -> IO CInt
1475
1476foreign import ccall safe "hsnet_freeaddrinfo"
1477    c_freeaddrinfo :: Ptr AddrInfo -> IO ()
1478
1479gai_strerror :: CInt -> IO String
1480
1481#ifdef HAVE_GAI_STRERROR
1482gai_strerror n = c_gai_strerror n >>= peekCString
1483
1484foreign import ccall safe "gai_strerror"
1485    c_gai_strerror :: CInt -> IO CString
1486#else
1487gai_strerror n = return ("error " ++ show n)
1488#endif
1489
1490withCStringIf :: Bool -> Int -> (CSize -> CString -> IO a) -> IO a
1491withCStringIf False _ f = f 0 nullPtr
1492withCStringIf True n f = allocaBytes n (f (fromIntegral n))
1493
1494-- | Resolve an address to a host or service name.
1495-- This function is protocol independent.
1496--
1497-- The list of 'NameInfoFlag' values controls query behaviour.  The
1498-- supported flags are as follows:
1499--
1500--   [@NI_NOFQDN@] If a host is local, return only the
1501--     hostname part of the FQDN.
1502--
1503--   [@NI_NUMERICHOST@] The name of the host is not
1504--     looked up.  Instead, a numeric representation of the host's
1505--     address is returned.  For an IPv4 address, this will be a
1506--     dotted-quad string.  For IPv6, it will be colon-separated
1507--     hexadecimal.
1508--
1509--   [@NI_NUMERICSERV@] The name of the service is not
1510--     looked up.  Instead, a numeric representation of the
1511--     service is returned.
1512--
1513--   [@NI_NAMEREQD@] If the hostname cannot be looked up, an IO error
1514--     is thrown.
1515--
1516--   [@NI_DGRAM@] Resolve a datagram-based service name.  This is
1517--     required only for the few protocols that have different port
1518--     numbers for their datagram-based versions than for their
1519--     stream-based versions.
1520--
1521-- Hostname and service name lookups can be expensive.  You can
1522-- specify which lookups to perform via the two 'Bool' arguments.  If
1523-- one of these is 'False', the corresponding value in the returned
1524-- tuple will be 'Nothing', and no lookup will be performed.
1525--
1526-- If a host or service's name cannot be looked up, then the numeric
1527-- form of the address or service will be returned.
1528--
1529-- If the query fails, this function throws an IO exception.
1530--
1531-- Example:
1532-- @
1533--   (hostName, _) <- getNameInfo [] True False myAddress
1534-- @
1535
1536getNameInfo :: [NameInfoFlag] -- ^ flags to control lookup behaviour
1537            -> Bool -- ^ whether to look up a hostname
1538            -> Bool -- ^ whether to look up a service name
1539            -> SockAddr -- ^ the address to look up
1540            -> IO (Maybe HostName, Maybe ServiceName)
1541
1542getNameInfo flags doHost doService addr =
1543  withCStringIf doHost (#const NI_MAXHOST) $ \c_hostlen c_host ->
1544    withCStringIf doService (#const NI_MAXSERV) $ \c_servlen c_serv -> do
1545      withSockAddr addr $ \ptr_addr sz -> do
1546        ret <- c_getnameinfo ptr_addr (fromIntegral sz) c_host c_hostlen
1547                             c_serv c_servlen (packBits niFlagMapping flags)
1548        case ret of
1549          0 -> do
1550            let peekIf doIf c_val = if doIf
1551                                     then liftM Just $ peekCString c_val
1552                                     else return Nothing
1553            host <- peekIf doHost c_host
1554            serv <- peekIf doService c_serv
1555            return (host, serv)
1556          _ -> do err <- gai_strerror ret
1557                  ioError (ioeSetErrorString
1558                           (mkIOError NoSuchThing "getNameInfo" Nothing
1559                            Nothing) err)
1560
1561foreign import ccall safe "hsnet_getnameinfo"
1562    c_getnameinfo :: Ptr SockAddr -> CInt{-CSockLen???-} -> CString -> CSize -> CString
1563                  -> CSize -> CInt -> IO CInt
1564#endif
1565
1566mkInvalidRecvArgError :: String -> IOError
1567mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError
1568                                    InvalidArgument
1569                                    loc Nothing Nothing) "non-positive length"
1570
1571mkEOFError :: String -> IOError
1572mkEOFError loc = ioeSetErrorString (mkIOError EOF loc Nothing Nothing) "end of file"
1573
1574-- ---------------------------------------------------------------------------
1575-- foreign imports from the C library
1576
1577foreign import ccall unsafe "my_inet_ntoa"
1578  c_inet_ntoa :: HostAddress -> IO (Ptr CChar)
1579
1580foreign import CALLCONV unsafe "inet_addr"
1581  c_inet_addr :: Ptr CChar -> IO HostAddress
1582
1583foreign import CALLCONV unsafe "shutdown"
1584  c_shutdown :: CInt -> CInt -> IO CInt
1585
1586closeFd :: CInt -> IO ()
1587closeFd fd = throwSocketErrorIfMinus1_ "Network.Socket.close" $ c_close fd
1588
1589#if !defined(WITH_WINSOCK)
1590foreign import ccall unsafe "close"
1591  c_close :: CInt -> IO CInt
1592#else
1593foreign import stdcall unsafe "closesocket"
1594  c_close :: CInt -> IO CInt
1595#endif
1596
1597foreign import CALLCONV unsafe "socket"
1598  c_socket :: CInt -> CInt -> CInt -> IO CInt
1599foreign import CALLCONV unsafe "bind"
1600  c_bind :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt
1601foreign import CALLCONV SAFE_ON_WIN "connect"
1602  c_connect :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt
1603foreign import CALLCONV unsafe "accept"
1604  c_accept :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt
1605#ifdef HAVE_ACCEPT4
1606foreign import CALLCONV unsafe "accept4"
1607  c_accept4 :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> CInt -> IO CInt
1608#endif
1609foreign import CALLCONV unsafe "listen"
1610  c_listen :: CInt -> CInt -> IO CInt
1611
1612#if defined(mingw32_HOST_OS)
1613foreign import CALLCONV safe "accept"
1614  c_accept_safe :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt
1615
1616foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
1617#endif
1618
1619foreign import CALLCONV unsafe "send"
1620  c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt
1621foreign import CALLCONV SAFE_ON_WIN "sendto"
1622  c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr SockAddr -> CInt -> IO CInt
1623foreign import CALLCONV unsafe "recv"
1624  c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
1625foreign import CALLCONV SAFE_ON_WIN "recvfrom"
1626  c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt
1627foreign import CALLCONV unsafe "getpeername"
1628  c_getpeername :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt
1629foreign import CALLCONV unsafe "getsockname"
1630  c_getsockname :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt
1631
1632foreign import CALLCONV unsafe "getsockopt"
1633  c_getsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt
1634foreign import CALLCONV unsafe "setsockopt"
1635  c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
1636
1637-- ---------------------------------------------------------------------------
1638-- * Deprecated aliases
1639
1640-- $deprecated-aliases
1641--
1642-- These aliases are deprecated and should not be used in new code.
1643-- They will be removed in some future version of the package.
1644
1645-- | Deprecated alias for 'bind'.
1646bindSocket :: Socket    -- Unconnected Socket
1647           -> SockAddr  -- Address to Bind to
1648           -> IO ()
1649bindSocket = bind
1650
1651-- | Deprecated alias for 'close'.
1652sClose :: Socket -> IO ()
1653sClose = close
1654
1655-- | Deprecated alias for 'isConnected'.
1656sIsConnected :: Socket -> IO Bool
1657sIsConnected = isConnected
1658
1659-- | Deprecated alias for 'isBound'.
1660sIsBound :: Socket -> IO Bool
1661sIsBound = isBound
1662
1663-- | Deprecated alias for 'isListening'.
1664sIsListening :: Socket -> IO Bool
1665sIsListening = isListening
1666
1667-- | Deprecated alias for 'isReadable'.
1668sIsReadable  :: Socket -> IO Bool
1669sIsReadable = isReadable
1670
1671-- | Deprecated alias for 'isWritable'.
1672sIsWritable  :: Socket -> IO Bool
1673sIsWritable = isWritable