PageRenderTime 32ms CodeModel.GetById 3ms app.highlight 13ms RepoModel.GetById 1ms app.codeStats 0ms

/Network/Socket.hsc

https://github.com/singpolyma/network
Unknown | 1670 lines | 1470 code | 200 blank | 0 comment | 0 complexity | e8ea0bf263cf080ee3694f2a4d185539 MD5 | raw file

Large files files are truncated, but you can click here to view the full 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 (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
 202#ifdef __GLASGOW_HASKELL__
 203import GHC.Conc (threadWaitRead, threadWaitWrite)
 204##if MIN_VERSION_base(4,3,1)
 205import GHC.Conc (closeFdWith)
 206##endif
 207# if defined(mingw32_HOST_OS)
 208import GHC.Conc (asyncDoProc)
 209import Foreign (FunPtr)
 210# endif
 211# if __GLASGOW_HASKELL__ >= 611
 212import qualified GHC.IO.Device
 213import GHC.IO.Handle.FD
 214import GHC.IO.Exception
 215import GHC.IO
 216# else
 217import GHC.IOBase
 218import GHC.Handle
 219# endif
 220import qualified System.Posix.Internals
 221#else
 222import System.IO.Unsafe (unsafePerformIO)
 223#endif
 224
 225# if __GLASGOW_HASKELL__ >= 611
 226import GHC.IO.FD
 227#endif
 228
 229import Network.Socket.Internal
 230import Network.Socket.Types
 231
 232-- | Either a host name e.g., @\"haskell.org\"@ or a numeric host
 233-- address string consisting of a dotted decimal IPv4 address or an
 234-- IPv6 address e.g., @\"192.168.0.1\"@.
 235type HostName       = String
 236type ServiceName    = String
 237
 238-- ----------------------------------------------------------------------------
 239-- On Windows, our sockets are not put in non-blocking mode (non-blocking
 240-- is not supported for regular file descriptors on Windows, and it would
 241-- be a pain to support it only for sockets).  So there are two cases:
 242--
 243--  - the threaded RTS uses safe calls for socket operations to get
 244--    non-blocking I/O, just like the rest of the I/O library
 245--
 246--  - with the non-threaded RTS, only some operations on sockets will be
 247--    non-blocking.  Reads and writes go through the normal async I/O
 248--    system.  accept() uses asyncDoProc so is non-blocking.  A handful
 249--    of others (recvFrom, sendFd, recvFd) will block all threads - if this
 250--    is a problem, -threaded is the workaround.
 251--
 252##if defined(mingw32_HOST_OS)
 253##define SAFE_ON_WIN safe
 254##else
 255##define SAFE_ON_WIN unsafe
 256##endif
 257
 258-----------------------------------------------------------------------------
 259-- Socket types
 260
 261#if __GLASGOW_HASKELL__ >= 611 && defined(mingw32_HOST_OS)
 262socket2FD  (MkSocket fd _ _ _ _) =
 263  -- HACK, 1 means True
 264  FD{fdFD = fd,fdIsSocket_ = 1}
 265#endif
 266
 267mkSocket :: CInt
 268         -> Family
 269         -> SocketType
 270         -> ProtocolNumber
 271         -> SocketStatus
 272         -> IO Socket
 273mkSocket fd fam sType pNum stat = do
 274   mStat <- newMVar stat
 275   return (MkSocket fd fam sType pNum mStat)
 276
 277
 278fdSocket :: Socket -> CInt
 279fdSocket (MkSocket fd _ _ _ _) = fd
 280
 281-- | This is the default protocol for a given service.
 282defaultProtocol :: ProtocolNumber
 283defaultProtocol = 0
 284
 285-----------------------------------------------------------------------------
 286-- SockAddr
 287
 288instance Show SockAddr where
 289#if defined(DOMAIN_SOCKET_SUPPORT)
 290  showsPrec _ (SockAddrUnix str) = showString str
 291#endif
 292  showsPrec _ (SockAddrInet port ha)
 293   = showString (unsafePerformIO (inet_ntoa ha))
 294   . showString ":"
 295   . shows port
 296#if defined(IPV6_SOCKET_SUPPORT)
 297  showsPrec _ addr@(SockAddrInet6 port _ _ _)
 298   = showChar '['
 299   . showString (unsafePerformIO $
 300                 fst `liftM` getNameInfo [NI_NUMERICHOST] True False addr >>=
 301                 maybe (fail "showsPrec: impossible internal error") return)
 302   . showString "]:"
 303   . shows port
 304#endif
 305
 306-----------------------------------------------------------------------------
 307-- Connection Functions
 308
 309-- In the following connection and binding primitives.  The names of
 310-- the equivalent C functions have been preserved where possible. It
 311-- should be noted that some of these names used in the C library,
 312-- \tr{bind} in particular, have a different meaning to many Haskell
 313-- programmers and have thus been renamed by appending the prefix
 314-- Socket.
 315
 316-- | Create a new socket using the given address family, socket type
 317-- and protocol number.  The address family is usually 'AF_INET',
 318-- 'AF_INET6', or 'AF_UNIX'.  The socket type is usually 'Stream' or
 319-- 'Datagram'.  The protocol number is usually 'defaultProtocol'.
 320-- If 'AF_INET6' is used, the 'IPv6Only' socket option is set to 0
 321-- so that both IPv4 and IPv6 can be handled with one socket.
 322socket :: Family         -- Family Name (usually AF_INET)
 323       -> SocketType     -- Socket Type (usually Stream)
 324       -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
 325       -> IO Socket      -- Unconnected Socket
 326socket family stype protocol = do
 327    c_stype <- packSocketTypeOrThrow "socket" stype
 328    fd <- throwSocketErrorIfMinus1Retry "socket" $
 329                c_socket (packFamily family) c_stype protocol
 330    setNonBlockIfNeeded fd
 331    socket_status <- newMVar NotConnected
 332    let sock = MkSocket fd family stype protocol socket_status
 333#if HAVE_DECL_IPV6_V6ONLY
 334# if defined(mingw32_HOST_OS)
 335    -- the IPv6Only option is only supported on Windows Vista and later,
 336    -- so trying to change it might throw an error
 337    when (family == AF_INET6) $
 338            E.catch (setSocketOption sock IPv6Only 0) $ (\(_ :: E.IOException) -> return ())
 339# else
 340    when (family == AF_INET6) $ setSocketOption sock IPv6Only 0
 341# endif
 342#endif
 343    return sock
 344
 345-- | Build a pair of connected socket objects using the given address
 346-- family, socket type, and protocol number.  Address family, socket
 347-- type, and protocol number are as for the 'socket' function above.
 348-- Availability: Unix.
 349#if defined(DOMAIN_SOCKET_SUPPORT)
 350socketPair :: Family              -- Family Name (usually AF_INET or AF_INET6)
 351           -> SocketType          -- Socket Type (usually Stream)
 352           -> ProtocolNumber      -- Protocol Number
 353           -> IO (Socket, Socket) -- unnamed and connected.
 354socketPair family stype protocol = do
 355    allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do
 356    c_stype <- packSocketTypeOrThrow "socketPair" stype
 357    _rc <- throwSocketErrorIfMinus1Retry "socketpair" $
 358                c_socketpair (packFamily family) c_stype protocol fdArr
 359    [fd1,fd2] <- peekArray 2 fdArr
 360    s1 <- mkNonBlockingSocket fd1
 361    s2 <- mkNonBlockingSocket fd2
 362    return (s1,s2)
 363  where
 364    mkNonBlockingSocket fd = do
 365       setNonBlockIfNeeded fd
 366       stat <- newMVar Connected
 367       return (MkSocket fd family stype protocol stat)
 368
 369foreign import ccall unsafe "socketpair"
 370  c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt
 371#endif
 372
 373-- | Set the socket to nonblocking, if applicable to this platform.
 374setNonBlockIfNeeded :: CInt -> IO ()
 375setNonBlockIfNeeded fd =
 376#if __GLASGOW_HASKELL__ < 611
 377    System.Posix.Internals.setNonBlockingFD fd
 378#else
 379    System.Posix.Internals.setNonBlockingFD fd True
 380#endif
 381
 382-----------------------------------------------------------------------------
 383-- Binding a socket
 384
 385-- | Bind the socket to an address. The socket must not already be
 386-- bound.  The 'Family' passed to @bind@ must be the
 387-- same as that passed to 'socket'.  If the special port number
 388-- 'aNY_PORT' is passed then the system assigns the next available
 389-- use port.
 390bind :: Socket    -- Unconnected Socket
 391           -> SockAddr  -- Address to Bind to
 392           -> IO ()
 393bind (MkSocket s _family _stype _protocol socketStatus) addr = do
 394 modifyMVar_ socketStatus $ \ status -> do
 395 if status /= NotConnected
 396  then
 397   ioError (userError ("bind: can't peform bind on socket in status " ++
 398         show status))
 399  else do
 400   withSockAddr addr $ \p_addr sz -> do
 401   _status <- throwSocketErrorIfMinus1Retry "bind" $ c_bind s p_addr (fromIntegral sz)
 402   return Bound
 403
 404-----------------------------------------------------------------------------
 405-- Connecting a socket
 406
 407-- | Connect to a remote socket at address.
 408connect :: Socket    -- Unconnected Socket
 409        -> SockAddr  -- Socket address stuff
 410        -> IO ()
 411connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = do
 412 modifyMVar_ socketStatus $ \currentStatus -> do
 413 if currentStatus /= NotConnected && currentStatus /= Bound
 414  then
 415    ioError (userError ("connect: can't peform connect on socket in status " ++
 416        show currentStatus))
 417  else do
 418    withSockAddr addr $ \p_addr sz -> do
 419
 420    let connectLoop = do
 421           r <- c_connect s p_addr (fromIntegral sz)
 422           if r == -1
 423               then do
 424#if !(defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS))
 425                   err <- getErrno
 426                   case () of
 427                     _ | err == eINTR       -> connectLoop
 428                     _ | err == eINPROGRESS -> connectBlocked
 429--                   _ | err == eAGAIN      -> connectBlocked
 430                     _otherwise             -> throwSocketError "connect"
 431#else
 432                   rc <- c_getLastError
 433                   case rc of
 434                     #{const WSANOTINITIALISED} -> do
 435                       withSocketsDo (return ())
 436                       r <- c_connect s p_addr (fromIntegral sz)
 437                       if r == -1
 438                         then throwSocketError "connect"
 439                         else return r
 440                     _ -> throwSocketError "connect"
 441#endif
 442               else return r
 443
 444        connectBlocked = do
 445           threadWaitWrite (fromIntegral s)
 446           err <- getSocketOption sock SoError
 447           if (err == 0)
 448                then return 0
 449                else throwSocketErrorCode "connect" (fromIntegral err)
 450
 451    connectLoop
 452    return Connected
 453
 454-----------------------------------------------------------------------------
 455-- Listen
 456
 457-- | Listen for connections made to the socket.  The second argument
 458-- specifies the maximum number of queued connections and should be at
 459-- least 1; the maximum value is system-dependent (usually 5).
 460listen :: Socket  -- Connected & Bound Socket
 461       -> Int     -- Queue Length
 462       -> IO ()
 463listen (MkSocket s _family _stype _protocol socketStatus) backlog = do
 464 modifyMVar_ socketStatus $ \ status -> do
 465 if status /= Bound
 466   then
 467     ioError (userError ("listen: can't peform listen on socket in status " ++
 468         show status))
 469   else do
 470     throwSocketErrorIfMinus1Retry "listen" (c_listen s (fromIntegral backlog))
 471     return Listening
 472
 473-----------------------------------------------------------------------------
 474-- Accept
 475--
 476-- A call to `accept' only returns when data is available on the given
 477-- socket, unless the socket has been set to non-blocking.  It will
 478-- return a new socket which should be used to read the incoming data and
 479-- should then be closed. Using the socket returned by `accept' allows
 480-- incoming requests to be queued on the original socket.
 481
 482-- | Accept a connection.  The socket must be bound to an address and
 483-- listening for connections.  The return value is a pair @(conn,
 484-- address)@ where @conn@ is a new socket object usable to send and
 485-- receive data on the connection, and @address@ is the address bound
 486-- to the socket on the other end of the connection.
 487accept :: Socket                        -- Queue Socket
 488       -> IO (Socket,                   -- Readable Socket
 489              SockAddr)                 -- Peer details
 490
 491accept sock@(MkSocket s family stype protocol status) = do
 492 currentStatus <- readMVar status
 493 okay <- isAcceptable sock
 494 if not okay
 495   then
 496     ioError (userError ("accept: can't perform accept on socket (" ++ (show (family,stype,protocol)) ++") in status " ++
 497         show currentStatus))
 498   else do
 499     let sz = sizeOfSockAddrByFamily family
 500     allocaBytes sz $ \ sockaddr -> do
 501#if defined(mingw32_HOST_OS) && defined(__GLASGOW_HASKELL__)
 502     new_sock <-
 503        if threaded
 504           then with (fromIntegral sz) $ \ ptr_len ->
 505                  throwSocketErrorIfMinus1Retry "Network.Socket.accept" $
 506                    c_accept_safe s sockaddr ptr_len
 507           else do
 508                paramData <- c_newAcceptParams s (fromIntegral sz) sockaddr
 509                rc        <- asyncDoProc c_acceptDoProc paramData
 510                new_sock  <- c_acceptNewSock    paramData
 511                c_free paramData
 512                when (rc /= 0) $
 513                     throwSocketErrorCode "Network.Socket.accept" (fromIntegral rc)
 514                return new_sock
 515#else
 516     with (fromIntegral sz) $ \ ptr_len -> do
 517     new_sock <-
 518# ifdef HAVE_ACCEPT4
 519                 throwSocketErrorIfMinus1RetryMayBlock "accept"
 520                        (threadWaitRead (fromIntegral s))
 521                        (c_accept4 s sockaddr ptr_len (#const SOCK_NONBLOCK))
 522# else
 523                 throwSocketErrorWaitRead sock "accept"
 524                        (c_accept s sockaddr ptr_len)
 525# endif /* HAVE_ACCEPT4 */
 526#endif
 527     setNonBlockIfNeeded new_sock
 528     addr <- peekSockAddr sockaddr
 529     new_status <- newMVar Connected
 530     return ((MkSocket new_sock family stype protocol new_status), addr)
 531
 532#if defined(mingw32_HOST_OS)
 533foreign import ccall unsafe "HsNet.h acceptNewSock"
 534  c_acceptNewSock :: Ptr () -> IO CInt
 535foreign import ccall unsafe "HsNet.h newAcceptParams"
 536  c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ())
 537foreign import ccall unsafe "HsNet.h &acceptDoProc"
 538  c_acceptDoProc :: FunPtr (Ptr () -> IO Int)
 539foreign import ccall unsafe "free"
 540  c_free:: Ptr a -> IO ()
 541#endif
 542
 543-----------------------------------------------------------------------------
 544-- ** Sending and reciving data
 545
 546-- $sendrecv
 547--
 548-- Do not use the @send@ and @recv@ functions defined in this module
 549-- in new code, as they incorrectly represent binary data as a Unicode
 550-- string.  As a result, these functions are inefficient and may lead
 551-- to bugs in the program.  Instead use the @send@ and @recv@
 552-- functions defined in the 'Network.Socket.ByteString' module.
 553
 554-----------------------------------------------------------------------------
 555-- sendTo & recvFrom
 556
 557-- | Send data to the socket.  The recipient can be specified
 558-- explicitly, so the socket need not be in a connected state.
 559-- Returns the number of bytes sent.  Applications are responsible for
 560-- ensuring that all data has been sent.
 561--
 562-- NOTE: blocking on Windows unless you compile with -threaded (see
 563-- GHC ticket #1129)
 564sendTo :: Socket        -- (possibly) bound/connected Socket
 565       -> String        -- Data to send
 566       -> SockAddr
 567       -> IO Int        -- Number of Bytes sent
 568sendTo sock xs addr = do
 569 withCString xs $ \str -> do
 570   sendBufTo sock str (length xs) addr
 571
 572-- | Send data to the socket.  The recipient can be specified
 573-- explicitly, so the socket need not be in a connected state.
 574-- Returns the number of bytes sent.  Applications are responsible for
 575-- ensuring that all data has been sent.
 576sendBufTo :: Socket            -- (possibly) bound/connected Socket
 577          -> Ptr a -> Int  -- Data to send
 578          -> SockAddr
 579          -> IO Int            -- Number of Bytes sent
 580sendBufTo sock@(MkSocket s _family _stype _protocol _status) ptr nbytes addr = do
 581 withSockAddr addr $ \p_addr sz -> do
 582   liftM fromIntegral $
 583     throwSocketErrorWaitWrite sock "sendTo" $
 584        c_sendto s ptr (fromIntegral $ nbytes) 0{-flags-}
 585                        p_addr (fromIntegral sz)
 586
 587-- | Receive data from the socket. The socket need not be in a
 588-- connected state. Returns @(bytes, nbytes, address)@ where @bytes@
 589-- is a @String@ of length @nbytes@ representing the data received and
 590-- @address@ is a 'SockAddr' representing the address of the sending
 591-- socket.
 592--
 593-- NOTE: blocking on Windows unless you compile with -threaded (see
 594-- GHC ticket #1129)
 595recvFrom :: Socket -> Int -> IO (String, Int, SockAddr)
 596recvFrom sock nbytes =
 597  allocaBytes nbytes $ \ptr -> do
 598    (len, sockaddr) <- recvBufFrom sock ptr nbytes
 599    str <- peekCStringLen (ptr, len)
 600    return (str, len, sockaddr)
 601
 602-- | Receive data from the socket, writing it into buffer instead of
 603-- creating a new string.  The socket need not be in a connected
 604-- state. Returns @(nbytes, address)@ where @nbytes@ is the number of
 605-- bytes received and @address@ is a 'SockAddr' representing the
 606-- address of the sending socket.
 607--
 608-- NOTE: blocking on Windows unless you compile with -threaded (see
 609-- GHC ticket #1129)
 610recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr)
 611recvBufFrom sock@(MkSocket s family _stype _protocol _status) ptr nbytes
 612 | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvFrom")
 613 | otherwise   =
 614    withNewSockAddr family $ \ptr_addr sz -> do
 615      alloca $ \ptr_len -> do
 616        poke ptr_len (fromIntegral sz)
 617        len <- throwSocketErrorWaitRead sock "recvFrom" $
 618                   c_recvfrom s ptr (fromIntegral nbytes) 0{-flags-}
 619                                ptr_addr ptr_len
 620        let len' = fromIntegral len
 621        if len' == 0
 622         then ioError (mkEOFError "Network.Socket.recvFrom")
 623         else do
 624           flg <- isConnected sock
 625             -- For at least one implementation (WinSock 2), recvfrom() ignores
 626             -- filling in the sockaddr for connected TCP sockets. Cope with
 627             -- this by using getPeerName instead.
 628           sockaddr <-
 629                if flg then
 630                   getPeerName sock
 631                else
 632                   peekSockAddr ptr_addr
 633           return (len', sockaddr)
 634
 635-----------------------------------------------------------------------------
 636-- send & recv
 637
 638-- | Send data to the socket. The socket must be connected to a remote
 639-- socket. Returns the number of bytes sent.  Applications are
 640-- responsible for ensuring that all data has been sent.
 641send :: Socket  -- Bound/Connected Socket
 642     -> String  -- Data to send
 643     -> IO Int  -- Number of Bytes sent
 644send sock@(MkSocket s _family _stype _protocol _status) xs = do
 645 let len = length xs
 646 withCString xs $ \str -> do
 647   liftM fromIntegral $
 648#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)
 649# if __GLASGOW_HASKELL__ >= 611
 650    writeRawBufferPtr
 651      "Network.Socket.send"
 652      (socket2FD sock)
 653      (castPtr str)
 654      0
 655      (fromIntegral len)
 656#else
 657      writeRawBufferPtr
 658        "Network.Socket.send"
 659        (fromIntegral s)
 660        True
 661        str
 662        0
 663       (fromIntegral len)
 664#endif
 665
 666#else
 667     throwSocketErrorWaitWrite sock "send" $
 668        c_send s str (fromIntegral len) 0{-flags-}
 669#endif
 670
 671-- | Send data to the socket. The socket must be connected to a remote
 672-- socket. Returns the number of bytes sent.  Applications are
 673-- responsible for ensuring that all data has been sent.
 674sendBuf :: Socket     -- Bound/Connected Socket
 675        -> Ptr Word8  -- Pointer to the data to send
 676        -> Int        -- Length of the buffer
 677        -> IO Int     -- Number of Bytes sent
 678sendBuf sock@(MkSocket s _family _stype _protocol _status) str len = do
 679   liftM fromIntegral $
 680#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)
 681# if __GLASGOW_HASKELL__ >= 611
 682    writeRawBufferPtr
 683      "Network.Socket.sendBuf"
 684      (socket2FD sock)
 685      (castPtr str)
 686      0
 687      (fromIntegral len)
 688# else
 689      writeRawBufferPtr
 690        "Network.Socket.sendBuf"
 691        (fromIntegral s)
 692        True
 693        str
 694        0
 695       (fromIntegral len)
 696# endif
 697#else
 698     throwSocketErrorWaitWrite sock "sendBuf" $
 699        c_send s str (fromIntegral len) 0{-flags-}
 700#endif
 701
 702
 703-- | Receive data from the socket.  The socket must be in a connected
 704-- state. This function may return fewer bytes than specified.  If the
 705-- message is longer than the specified length, it may be discarded
 706-- depending on the type of socket.  This function may block until a
 707-- message arrives.
 708--
 709-- Considering hardware and network realities, the maximum number of
 710-- bytes to receive should be a small power of 2, e.g., 4096.
 711--
 712-- For TCP sockets, a zero length return value means the peer has
 713-- closed its half side of the connection.
 714recv :: Socket -> Int -> IO String
 715recv sock l = recvLen sock l >>= \ (s,_) -> return s
 716
 717recvLen :: Socket -> Int -> IO (String, Int)
 718recvLen sock@(MkSocket s _family _stype _protocol _status) nbytes
 719 | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recv")
 720 | otherwise   = do
 721     allocaBytes nbytes $ \ptr -> do
 722        len <-
 723#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)
 724# if __GLASGOW_HASKELL__ >= 611
 725          readRawBufferPtr "Network.Socket.recvLen" (socket2FD sock) ptr 0
 726                 (fromIntegral nbytes)
 727#else
 728          readRawBufferPtr "Network.Socket.recvLen" (fromIntegral s) True ptr 0
 729                 (fromIntegral nbytes)
 730#endif
 731#else
 732               throwSocketErrorWaitRead sock "recv" $
 733                   c_recv s ptr (fromIntegral nbytes) 0{-flags-}
 734#endif
 735        let len' = fromIntegral len
 736        if len' == 0
 737         then ioError (mkEOFError "Network.Socket.recv")
 738         else do
 739           s' <- peekCStringLen (castPtr ptr,len')
 740           return (s', len')
 741
 742-- | Receive data from the socket.  The socket must be in a connected
 743-- state. This function may return fewer bytes than specified.  If the
 744-- message is longer than the specified length, it may be discarded
 745-- depending on the type of socket.  This function may block until a
 746-- message arrives.
 747--
 748-- Considering hardware and network realities, the maximum number of
 749-- bytes to receive should be a small power of 2, e.g., 4096.
 750--
 751-- For TCP sockets, a zero length return value means the peer has
 752-- closed its half side of the connection.
 753recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int
 754recvBuf sock p l = recvLenBuf sock p l
 755
 756recvLenBuf :: Socket -> Ptr Word8 -> Int -> IO Int
 757recvLenBuf sock@(MkSocket s _family _stype _protocol _status) ptr nbytes
 758 | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf")
 759 | otherwise   = do
 760        len <-
 761#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)
 762# if __GLASGOW_HASKELL__ >= 611
 763          readRawBufferPtr "Network.Socket.recvLenBuf" (socket2FD sock) ptr 0
 764                 (fromIntegral nbytes)
 765#else
 766          readRawBufferPtr "Network.Socket.recvLenBuf" (fromIntegral s) True ptr 0
 767                 (fromIntegral nbytes)
 768#endif
 769#else
 770               throwSocketErrorWaitRead sock "recvBuf" $
 771                   c_recv s (castPtr ptr) (fromIntegral nbytes) 0{-flags-}
 772#endif
 773        let len' = fromIntegral len
 774        if len' == 0
 775         then ioError (mkEOFError "Network.Socket.recvBuf")
 776         else return len'
 777
 778
 779-- ---------------------------------------------------------------------------
 780-- socketPort
 781--
 782-- The port number the given socket is currently connected to can be
 783-- determined by calling $port$, is generally only useful when bind
 784-- was given $aNY\_PORT$.
 785
 786socketPort :: Socket            -- Connected & Bound Socket
 787           -> IO PortNumber     -- Port Number of Socket
 788socketPort sock@(MkSocket _ AF_INET _ _ _) = do
 789    (SockAddrInet port _) <- getSocketName sock
 790    return port
 791#if defined(IPV6_SOCKET_SUPPORT)
 792socketPort sock@(MkSocket _ AF_INET6 _ _ _) = do
 793    (SockAddrInet6 port _ _ _) <- getSocketName sock
 794    return port
 795#endif
 796socketPort (MkSocket _ family _ _ _) =
 797    ioError (userError ("socketPort: not supported for Family " ++ show family))
 798
 799
 800-- ---------------------------------------------------------------------------
 801-- getPeerName
 802
 803-- Calling $getPeerName$ returns the address details of the machine,
 804-- other than the local one, which is connected to the socket. This is
 805-- used in programs such as FTP to determine where to send the
 806-- returning data.  The corresponding call to get the details of the
 807-- local machine is $getSocketName$.
 808
 809getPeerName   :: Socket -> IO SockAddr
 810getPeerName (MkSocket s family _ _ _) = do
 811 withNewSockAddr family $ \ptr sz -> do
 812   with (fromIntegral sz) $ \int_star -> do
 813   throwSocketErrorIfMinus1Retry "getPeerName" $ c_getpeername s ptr int_star
 814   _sz <- peek int_star
 815   peekSockAddr ptr
 816
 817getSocketName :: Socket -> IO SockAddr
 818getSocketName (MkSocket s family _ _ _) = do
 819 withNewSockAddr family $ \ptr sz -> do
 820   with (fromIntegral sz) $ \int_star -> do
 821   throwSocketErrorIfMinus1Retry "getSocketName" $ c_getsockname s ptr int_star
 822   peekSockAddr ptr
 823
 824-----------------------------------------------------------------------------
 825-- Socket Properties
 826
 827-- | Socket options for use with 'setSocketOption' and 'getSocketOption'.
 828--
 829-- The existence of a constructor does not imply that the relevant option
 830-- is supported on your system: see 'isSupportedSocketOption'
 831data SocketOption
 832    = Debug         -- ^ SO_DEBUG
 833    | ReuseAddr     -- ^ SO_REUSEADDR
 834    | Type          -- ^ SO_TYPE
 835    | SoError       -- ^ SO_ERROR
 836    | DontRoute     -- ^ SO_DONTROUTE
 837    | Broadcast     -- ^ SO_BROADCAST
 838    | SendBuffer    -- ^ SO_SNDBUF
 839    | RecvBuffer    -- ^ SO_RCVBUF
 840    | KeepAlive     -- ^ SO_KEEPALIVE
 841    | OOBInline     -- ^ SO_OOBINLINE
 842    | TimeToLive    -- ^ IP_TTL
 843    | MaxSegment    -- ^ TCP_MAXSEG
 844    | NoDelay       -- ^ TCP_NODELAY
 845    | Cork          -- ^ TCP_CORK
 846    | Linger        -- ^ SO_LINGER
 847    | ReusePort     -- ^ SO_REUSEPORT
 848    | RecvLowWater  -- ^ SO_RCVLOWAT
 849    | SendLowWater  -- ^ SO_SNDLOWAT
 850    | RecvTimeOut   -- ^ SO_RCVTIMEO
 851    | SendTimeOut   -- ^ SO_SNDTIMEO
 852    | UseLoopBack   -- ^ SO_USELOOPBACK
 853    | IPv6Only      -- ^ IPV6_V6ONLY
 854    deriving (Show, Typeable)
 855
 856-- | Does the 'SocketOption' exist on this system?
 857isSupportedSocketOption :: SocketOption -> Bool
 858isSupportedSocketOption = isJust . packSocketOption
 859
 860-- | For a socket option, return Just (level, value) where level is the
 861-- corresponding C option level constant (e.g. SOL_SOCKET) and value is
 862-- the option constant itself (e.g. SO_DEBUG)
 863-- If either constant does not exist, return Nothing.
 864packSocketOption :: SocketOption -> Maybe (CInt, CInt)
 865packSocketOption so =
 866  -- The Just here is a hack to disable GHC's overlapping pattern detection:
 867  -- the problem is if all constants are present, the fallback pattern is
 868  -- redundant, but if they aren't then it isn't. Hence we introduce an
 869  -- extra pattern (Nothing) that can't possibly happen, so that the
 870  -- fallback is always (in principle) necessary.
 871  -- I feel a little bad for including this, but such are the sacrifices we
 872  -- make while working with CPP - excluding the fallback pattern correctly
 873  -- would be a serious nuisance.
 874  -- (NB: comments elsewhere in this file refer to this one)
 875  case Just so of
 876#ifdef SOL_SOCKET
 877#ifdef SO_DEBUG
 878    Just Debug         -> Just ((#const SOL_SOCKET), (#const SO_DEBUG))
 879#endif
 880#ifdef SO_REUSEADDR
 881    Just ReuseAddr     -> Just ((#const SOL_SOCKET), (#const SO_REUSEADDR))
 882#endif
 883#ifdef SO_TYPE
 884    Just Type          -> Just ((#const SOL_SOCKET), (#const SO_TYPE))
 885#endif
 886#ifdef SO_ERROR
 887    Just SoError       -> Just ((#const SOL_SOCKET), (#const SO_ERROR))
 888#endif
 889#ifdef SO_DONTROUTE
 890    Just DontRoute     -> Just ((#const SOL_SOCKET), (#const SO_DONTROUTE))
 891#endif
 892#ifdef SO_BROADCAST
 893    Just Broadcast     -> Just ((#const SOL_SOCKET), (#const SO_BROADCAST))
 894#endif
 895#ifdef SO_SNDBUF
 896    Just SendBuffer    -> Just ((#const SOL_SOCKET), (#const SO_SNDBUF))
 897#endif
 898#ifdef SO_RCVBUF
 899    Just RecvBuffer    -> Just ((#const SOL_SOCKET), (#const SO_RCVBUF))
 900#endif
 901#ifdef SO_KEEPALIVE
 902    Just KeepAlive     -> Just ((#const SOL_SOCKET), (#const SO_KEEPALIVE))
 903#endif
 904#ifdef SO_OOBINLINE
 905    Just OOBInline     -> Just ((#const SOL_SOCKET), (#const SO_OOBINLINE))
 906#endif
 907#ifdef SO_LINGER
 908    Just Linger        -> Just ((#const SOL_SOCKET), (#const SO_LINGER))
 909#endif
 910#ifdef SO_REUSEPORT
 911    Just ReusePort     -> Just ((#const SOL_SOCKET), (#const SO_REUSEPORT))
 912#endif
 913#ifdef SO_RCVLOWAT
 914    Just RecvLowWater  -> Just ((#const SOL_SOCKET), (#const SO_RCVLOWAT))
 915#endif
 916#ifdef SO_SNDLOWAT
 917    Just SendLowWater  -> Just ((#const SOL_SOCKET), (#const SO_SNDLOWAT))
 918#endif
 919#ifdef SO_RCVTIMEO
 920    Just RecvTimeOut   -> Just ((#const SOL_SOCKET), (#const SO_RCVTIMEO))
 921#endif
 922#ifdef SO_SNDTIMEO
 923    Just SendTimeOut   -> Just ((#const SOL_SOCKET), (#const SO_SNDTIMEO))
 924#endif
 925#ifdef SO_USELOOPBACK
 926    Just UseLoopBack   -> Just ((#const SOL_SOCKET), (#const SO_USELOOPBACK))
 927#endif
 928#endif // SOL_SOCKET
 929#ifdef IPPROTO_IP
 930#ifdef IP_TTL
 931    Just TimeToLive    -> Just ((#const IPPROTO_IP), (#const IP_TTL))
 932#endif
 933#endif // IPPROTO_IP
 934#ifdef IPPROTO_TCP
 935#ifdef TCP_MAXSEG
 936    Just MaxSegment    -> Just ((#const IPPROTO_TCP), (#const TCP_MAXSEG))
 937#endif
 938#ifdef TCP_NODELAY
 939    Just NoDelay       -> Just ((#const IPPROTO_TCP), (#const TCP_NODELAY))
 940#endif
 941#ifdef TCP_CORK
 942    Just Cork          -> Just ((#const IPPROTO_TCP), (#const TCP_CORK))
 943#endif
 944#endif // IPPROTO_TCP
 945#ifdef IPPROTO_IPV6
 946#if HAVE_DECL_IPV6_V6ONLY
 947    Just IPv6Only      -> Just ((#const IPPROTO_IPV6), (#const IPV6_V6ONLY))
 948#endif
 949#endif // IPPROTO_IPV6
 950    _             -> Nothing
 951
 952-- | Return the option level and option value if they exist,
 953-- otherwise throw an error that begins "Network.Socket." ++ the String
 954-- parameter
 955packSocketOption' :: String -> SocketOption -> IO (CInt, CInt)
 956packSocketOption' caller so = maybe err return (packSocketOption so)
 957 where
 958  err = ioError . userError . concat $ ["Network.Socket.", caller,
 959    ": socket option ", show so, " unsupported on this system"]
 960
 961-- | Set a socket option that expects an Int value.
 962-- There is currently no API to set e.g. the timeval socket options
 963setSocketOption :: Socket
 964                -> SocketOption -- Option Name
 965                -> Int          -- Option Value
 966                -> IO ()
 967setSocketOption (MkSocket s _ _ _ _) so v = do
 968   (level, opt) <- packSocketOption' "setSocketOption" so
 969   with (fromIntegral v) $ \ptr_v -> do
 970   throwSocketErrorIfMinus1_ "setSocketOption" $
 971       c_setsockopt s level opt ptr_v
 972          (fromIntegral (sizeOf (undefined :: CInt)))
 973   return ()
 974
 975
 976-- | Get a socket option that gives an Int value.
 977-- There is currently no API to get e.g. the timeval socket options
 978getSocketOption :: Socket
 979                -> SocketOption  -- Option Name
 980                -> IO Int        -- Option Value
 981getSocketOption (MkSocket s _ _ _ _) so = do
 982   (level, opt) <- packSocketOption' "getSocketOption" so
 983   alloca $ \ptr_v ->
 984     with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do
 985       throwSocketErrorIfMinus1Retry "getSocketOption" $
 986         c_getsockopt s level opt ptr_v ptr_sz
 987       fromIntegral `liftM` peek ptr_v
 988
 989
 990#ifdef HAVE_STRUCT_UCRED
 991-- | Returns the processID, userID and groupID of the socket's peer.
 992--
 993-- Only available on platforms that support SO_PEERCRED on domain sockets.
 994getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt)
 995getPeerCred sock = do
 996  let fd = fdSocket sock
 997  let sz = (fromIntegral (#const sizeof(struct ucred)))
 998  with sz $ \ ptr_cr ->
 999   alloca       $ \ ptr_sz -> do
1000     poke ptr_sz sz
1001     throwSocketErrorIfMinus1Retry "getPeerCred" $
1002       c_getsockopt fd (#const SOL_SOCKET) (#const SO_PEERCRED) ptr_cr ptr_sz
1003     pid <- (#peek struct ucred, pid) ptr_cr
1004     uid <- (#peek struct ucred, uid) ptr_cr
1005     gid <- (#peek struct ucred, gid) ptr_cr
1006     return (pid, uid, gid)
1007#endif
1008
1009##if !(MIN_VERSION_base(4,3,1))
1010closeFdWith closer fd = closer fd
1011##endif
1012
1013#if defined(DOMAIN_SOCKET_SUPPORT)
1014-- sending/receiving ancillary socket data; low-level mechanism
1015-- for transmitting file descriptors, mainly.
1016sendFd :: Socket -> CInt -> IO ()
1017sendFd sock outfd = do
1018  throwSocketErrorWaitWrite sock "sendFd" $
1019     c_sendFd (fdSocket sock) outfd
1020   -- Note: If Winsock supported FD-passing, thi would have been
1021   -- incorrect (since socket FDs need to be closed via closesocket().)
1022  closeFd outfd
1023
1024recvFd :: Socket -> IO CInt
1025recvFd sock = do
1026  theFd <- throwSocketErrorWaitRead sock "recvFd" $
1027               c_recvFd (fdSocket sock)
1028  return theFd
1029
1030foreign import ccall SAFE_ON_WIN "sendFd" c_sendFd :: CInt -> CInt -> IO CInt
1031foreign import ccall SAFE_ON_WIN "recvFd" c_recvFd :: CInt -> IO CInt
1032
1033#endif
1034
1035-- ---------------------------------------------------------------------------
1036-- Utility Functions
1037
1038aNY_PORT :: PortNumber
1039aNY_PORT = 0
1040
1041-- | The IPv4 wild card address.
1042
1043iNADDR_ANY :: HostAddress
1044iNADDR_ANY = htonl (#const INADDR_ANY)
1045
1046foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32
1047
1048#if defined(IPV6_SOCKET_SUPPORT)
1049-- | The IPv6 wild card address.
1050
1051iN6ADDR_ANY :: HostAddress6
1052iN6ADDR_ANY = (0, 0, 0, 0)
1053#endif
1054
1055sOMAXCONN :: Int
1056sOMAXCONN = #const SOMAXCONN
1057
1058sOL_SOCKET :: Int
1059sOL_SOCKET = #const SOL_SOCKET
1060
1061#ifdef SCM_RIGHTS
1062sCM_RIGHTS :: Int
1063sCM_RIGHTS = #const SCM_RIGHTS
1064#endif
1065
1066-- | This is the value of SOMAXCONN, typically 128.
1067-- 128 is good enough for normal network servers but
1068-- is too small for high performance servers.
1069maxListenQueue :: Int
1070maxListenQueue = sOMAXCONN
1071
1072-- -----------------------------------------------------------------------------
1073
1074data ShutdownCmd
1075 = ShutdownReceive
1076 | ShutdownSend
1077 | ShutdownBoth
1078 deriving Typeable
1079
1080sdownCmdToInt :: ShutdownCmd -> CInt
1081sdownCmdToInt ShutdownReceive = 0
1082sdownCmdToInt ShutdownSend    = 1
1083sdownCmdToInt ShutdownBoth    = 2
1084
1085-- | Shut down one or both halves of the connection, depending on the
1086-- second argument to the function.  If the second argument is
1087-- 'ShutdownReceive', further receives are disallowed.  If it is
1088-- 'ShutdownSend', further sends are disallowed.  If it is
1089-- 'ShutdownBoth', further sends and receives are disallowed.
1090shutdown :: Socket -> ShutdownCmd -> IO ()
1091shutdown (MkSocket s _ _ _ _) stype = do
1092  throwSocketErrorIfMinus1Retry "shutdown" (c_shutdown s (sdownCmdToInt stype))
1093  return ()
1094
1095-- -----------------------------------------------------------------------------
1096
1097-- | Close the socket.  All future operations on the socket object
1098-- will fail.  The remote end will receive no more data (after queued
1099-- data is flushed).
1100close :: Socket -> IO ()
1101close (MkSocket s _ _ _ socketStatus) = do
1102 modifyMVar_ socketStatus $ \ status ->
1103   case status of
1104     ConvertedToHandle ->
1105         ioError (userError ("close: converted to a Handle, use hClose instead"))
1106     Closed ->
1107         return status
1108     _ -> closeFdWith (closeFd . fromIntegral) (fromIntegral s) >> return Closed
1109
1110-- -----------------------------------------------------------------------------
1111
1112isConnected :: Socket -> IO Bool
1113isConnected (MkSocket _ _ _ _ status) = do
1114    value <- readMVar status
1115    return (value == Connected)
1116
1117-- -----------------------------------------------------------------------------
1118-- Socket Predicates
1119
1120isBound :: Socket -> IO Bool
1121isBound (MkSocket _ _ _ _ status) = do
1122    value <- readMVar status
1123    return (value == Bound)
1124
1125isListening :: Socket -> IO Bool
1126isListening (MkSocket _ _ _  _ status) = do
1127    value <- readMVar status
1128    return (value == Listening)
1129
1130isReadable  :: Socket -> IO Bool
1131isReadable (MkSocket _ _ _ _ status) = do
1132    value <- readMVar status
1133    return (value == Listening || value == Connected)
1134
1135isWritable  :: Socket -> IO Bool
1136isWritable = isReadable -- sort of.
1137
1138isAcceptable :: Socket -> IO Bool
1139#if defined(DOMAIN_SOCKET_SUPPORT)
1140isAcceptable (MkSocket _ AF_UNIX x _ status)
1141    | x == Stream || x == SeqPacket = do
1142        value <- readMVar status
1143        return (value == Connected || value == Bound || value == Listening)
1144isAcceptable (MkSocket _ AF_UNIX _ _ _) = return False
1145#endif
1146isAcceptable (MkSocket _ _ _ _ status) = do
1147    value <- readMVar status
1148    return (value == Connected || value == Listening)
1149
1150-- -----------------------------------------------------------------------------
1151-- Internet address manipulation routines:
1152
1153inet_addr :: String -> IO HostAddress
1154inet_addr ipstr = do
1155   withCString ipstr $ \str -> do
1156   had <- c_inet_addr str
1157   if had == -1
1158    then ioError (userError ("inet_addr: Malformed address: " ++ ipstr))
1159    else return had  -- network byte order
1160
1161inet_ntoa :: HostAddress -> IO String
1162inet_ntoa haddr = do
1163  pstr <- c_inet_ntoa haddr
1164  peekCString pstr
1165
1166-- | Turns a Socket into an 'Handle'. By default, the new handle is
1167-- unbuffered. Use 'System.IO.hSetBuffering' to change the buffering.
1168--
1169-- Note that since a 'Handle' is automatically closed by a finalizer
1170-- when it is no longer referenced, you should avoid doing any more
1171-- operations on the 'Socket' after calling 'socketToHandle'.  To
1172-- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose'
1173-- on the 'Handle'.
1174
1175#ifndef __PARALLEL_HASKELL__
1176socketToHandle :: Socket -> IOMode -> IO Handle
1177socketToHandle s@(MkSocket fd _ _ _ socketStatus) mode = do
1178 modifyMVar socketStatus $ \ status ->
1179    if status == ConvertedToHandle
1180        then ioError (userError ("socketToHandle: already a Handle"))
1181        else do
1182# if __GLASGOW_HASKELL__ >= 611
1183    h <- fdToHandle' (fromIntegral fd) (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-}
1184# elif __GLASGOW_HASKELL__ >= 608
1185    h <- fdToHandle' (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-}
1186# elif __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 608
1187    h <- openFd (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-}
1188# endif
1189    hSetBuffering h NoBuffering
1190    return (ConvertedToHandle, h)
1191#else
1192socketToHandle (MkSocket s family stype protocol status) m =
1193  error "socketToHandle not implemented in a parallel setup"
1194#endif
1195
1196-- | Pack a list of values into a bitmask.  The possible mappings from
1197-- value to bit-to-set are given as the first argument.  We assume
1198-- that each value can cause exactly one bit to be set; unpackBits will
1199-- break if this property is not true.
1200
1201packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b
1202
1203packBits mapping xs = foldl' pack 0 mapping
1204    where pack acc (k, v) | k `elem` xs = acc .|. v
1205                          | otherwise   = acc
1206
1207-- | Unpack a bitmask into a list of values.
1208
1209unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a]
1210
1211-- Be permissive and ignore unknown bit values. At least on OS X,
1212-- getaddrinfo returns an ai_flags field with bits set that have no
1213-- entry in <netdb.h>.
1214unpackBits [] _    = []
1215unpackBits ((k,v):xs) r
1216    | r .&. v /= 0 = k : unpackBits xs (r .&. complement v)
1217    | otherwise    = unpackBits xs r
1218
1219-----------------------------------------------------------------------------
1220-- Address and service lookups
1221
1222#if defined(IPV6_SOCKET_SUPPORT)
1223
1224-- | Flags that control the querying behaviour of 'getAddrInfo'.
1225data AddrInfoFlag
1226    = AI_ADDRCONFIG
1227    | AI_ALL
1228    | AI_CANONNAME
1229    | AI_NUMERICHOST
1230    | AI_NUMERICSERV
1231    | AI_PASSIVE
1232    | AI_V4MAPPED
1233    deriving (Eq, Read, Show, Typeable)
1234
1235aiFlagMapping :: [(AddrInfoFlag, CInt)]
1236
1237aiFlagMapping =
1238    [
1239#if HAVE_DECL_AI_ADDRCONFIG
1240     (AI_ADDRCONFIG, #const AI_ADDRCONFIG),
1241#else
1242     (AI_ADDRCONFIG, 0),
1243#endif
1244#if HAVE_DECL_AI_ALL
1245     (AI_ALL, #const AI_ALL),
1246#else
1247     (AI_ALL, 0),
1248#endif
1249     (AI_CANONNAME, #const AI_CANONNAME),
1250     (AI_NUMERICHOST, #const AI_NUMERICHOST),
1251#if HAVE_DECL_AI_NUMERICSERV
1252     (AI_NUMERICSERV, #const AI_NUMERICSERV),
1253#else
1254     (AI_NUMERICSERV, 0),
1255#endif
1256     (AI_PASSIVE, #const AI_PASSIVE),
1257#if HAVE_DECL_AI_V4MAPPED
1258     (AI_V4MAPPED, #const AI_V4MAPPED)
1259#else
1260     (AI_V4MAPPED, 0)
1261#endif
1262    ]
1263
1264-- | Indicate whether the given 'AddrInfoFlag' will have any effect on
1265-- this system.
1266addrInfoFlagImplemented :: AddrInfoFlag -> Bool
1267addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0
1268
1269data AddrInfo =
1270    AddrInfo {
1271        addrFlags :: [AddrInfoFlag],
1272        addrFamily :: Family,
1273        addrSocketType :: SocketType,
1274        addrProtocol :: ProtocolNumber,
1275        addrAddress :: SockAddr,
1276        addrCanonName :: Maybe String
1277        }
1278    deriving (Eq, Show, Typeable)
1279
1280instance Storable AddrInfo where
1281    sizeOf    _ = #const sizeof(struct addrinfo)
1282    alignment _ = alignment (undefined :: CInt)
1283
1284    peek p = do
1285        ai_flags <- (#peek struct addrinfo, ai_flags) p
1286        ai_family <- (#peek struct addrinfo, ai_family) p
1287        ai_socktype <- (#peek struct addrinfo, ai_socktype) p
1288        ai_protocol <- (#peek struct addrinfo, ai_protocol) p
1289        ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr
1290        ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p
1291
1292        ai_canonname <- if ai_canonname_ptr == nullPtr
1293                        then return Nothing
1294                        else liftM Just $ peekCString ai_canonname_ptr
1295
1296        socktype <- unpackSocketType' "AddrInfo.peek" ai_socktype
1297        return (AddrInfo
1298                {
1299                 addrFlags = unpackBits aiFlagMapping ai_flags,
1300                 addrFamily = unpackFamily ai_family,
1301                 addrSocketType = socktype,
1302                 addrProtocol = ai_protocol,
1303                 addrAddress = ai_addr,
1304                 addrCanonName = ai_canonname
1305                })
1306
1307    poke p (AddrInfo flags family socketType protocol _ _) = do
1308        c_stype <- packSocketTypeOrThrow "AddrInfo.poke" socketType
1309
1310        (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags)
1311        (#poke struct addrinfo, ai_family) p (packFamily family)
1312        (#poke struct addrinfo, ai_socktype) p c_stype
1313        (#poke struct addrinfo, ai_protocol) p protocol
1314
1315        -- stuff below is probably not needed, but let's zero it for safety
1316
1317        (#poke struct addrinfo, ai_addrlen) p (0::CSize)
1318        (#poke struct addrinfo, ai_addr) p nullPtr
1319        (#poke struct addrinfo, ai_canonname) p nullPtr
1320        (#poke struct addrinfo, ai_next) p nullPtr
1321
1322data NameInfoFlag
1323    = NI_DGRAM
1324    | NI_NAMEREQD
1325    | NI_NOFQDN
1326    | NI_NUMERICHOST
1327    | NI_NUMERICSERV
1328    deriving (Eq, Read, Show, Typeable)
1329
1330niFlagMapping :: [(NameInfoFlag, CInt)]
1331
1332niFlagMapping = [(NI_DGRAM, #const NI_DGRAM),
1333                 (NI_NAMEREQD, #const NI_NAMEREQD),
1334                 (NI_NOFQDN, #const NI_NOFQDN),
1335                 (NI_NUMERICHOST, #const NI_NUMERICHOST),
1336                 (NI_NUMERICSERV, #const NI_NUMERICSERV)]
1337
1338-- | Default hints for address lookup with 'getAddrInfo'.  The values
1339-- of the 'addrAddress' and 'addrCanonName' fields are 'undefined',
1340-- and are never inspected by 'getAddrInfo'.
1341
1342defaultHints :: AddrInfo
1343
1344defaultHints = AddrInfo {
1345                         addrFlags = [],
1346                         addrFamily = AF_UNSPEC,
1347                         addrSocketType = NoSocketType,
1348                         addrProtocol = defaultProtocol,
1349                         addrAddress = undefined,
1350                         addrCanonName = undefined
1351                        }
1352
1353-- | Resolve a host or service name to one or more addresses.
1354-- The 'AddrInfo' values that this function returns contain 'SockAddr'
1355-- values that you can pass directly to 'connect' or
1356-- 'bind'.
1357--
1358-- This function is protocol independent.  It can return both IPv4 and
1359-- IPv6 address information.
1360--
1361-- The 'AddrInfo' argument specifies the preferred query behaviour,
1362-- socket options, or protocol.  You can override these conveniently
1363-- using Haskell's record update syntax on 'defaultHints', for example
1364-- as follows:
1365--
1366-- @
1367--   myHints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }
1368-- @
1369--
1370-- Values for 'addrFlags' control query behaviour.  The supported
1371-- flags are as follows:
1372--
1373--   [@AI_PASSIVE@] If no 'HostName' value is provided, the network
1374--     address in each 'SockAddr'
1375--     will be left as a "wild card", i.e. as either 'iNADDR_ANY'
1376--     or 'iN6ADDR_ANY'.  This is useful for server applications that
1377--     will accept connections from any client.
1378--
1379--   [@AI_CANONNAME@] The 'addrCanonName' field of the first returned
1380--     'AddrInfo' will contain the "canonical name" of the host.
1381--
1382--   [@AI_NUMERICHOST@] The 'HostName' argument /must/ be a numeric
1383--     address in string form, and network name lookups will not be
1384--     attempted.
1385--
1386-- /Note/: Although the following flags are required by RFC 3493, they
1387-- may not have an effect on all platforms, because the underlying
1388-- network stack may not support them.  To see whether a flag from the
1389-- list below will have any effect, call 'addrInfoFlagImplemented'.
1390--
1391--   [@AI_NUMERICSERV@] The 'ServiceName' argument /must/ be a port
1392--     number in string form, and service name lookups will not be
1393--     attempted.
1394--
1395--   [@AI_ADDRCONFIG@] The list of returned 'AddrInfo' values will
1396--     only contain IPv4 addresses if the local system has at least
1397--     one IPv4 interface configured, and likewise for IPv6.
1398--
1399--   [@AI_V4MAPPED@] If an IPv6 lookup is performed, and no IPv6
1400--     addresses are found, IPv6-mapped IPv4 addresses will be
1401--     returned.
1402--
1403--   [@AI_ALL@] If 'AI_ALL' is specified, return all matching IPv6 and
1404--     IPv4 addresses.  Otherwise, this flag has no effect.
1405--
1406-- You must provide a 'Just' value for at least one of the 'HostName'
1407-- or 'ServiceName' arguments.  'HostName' can be either a numeric
1408-- network address (dotted quad for IPv4, colon-separated hex for
1409-- IPv6) or a hostname.  In the latter case, its addresses will be
1410-- looked up unless 'AI_NUMERICHOST' is specified as a hint.  If you
1411-- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as
1412-- a hint, network addresses in the result will contain the address of
1413-- the loopback interface.
1414--
1415-- If the query fails, this function throws an IO exception instead of
1416-- returning an empty list.  Otherwise, it returns a non-empty list
1417-- of 'AddrInfo' values.
1418--
1419-- There are several reasons why a query might result in several
1420-- values.  For example, the queried-for host could be multihomed, or
1421-- the service might be available via several protocols.
1422--
1423-- Note: the order of arguments is slightly different to that defined
1424-- for @getaddrinfo@ in RFC 2553.  The 'AddrInfo' parameter comes first
1425-- to make partial application easier.
1426--
1427-- Example:
1428-- @
1429--   let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }
1430--   addrs <- getAddrInfo (Just hints) (Just "www.haskell.org") (Just "http")
1431--   let addr = head addrs
1432--   sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1433--   connect sock (addrAddress addr)
1434-- @
1435
1436getAddrInfo :: Maybe AddrInfo -- ^ preferred socket type or protocol
1437            -> Maybe HostName -- ^ host name to look up
1438            -> Maybe ServiceName -- ^ service name to look up
1439            -> IO [AddrInfo] -- ^ resolved address…

Large files files are truncated, but you can click here to view the full file