ghc/lib/misc/SocketPrim.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-1998
   3 %
   4 \section[SocketPrim]{Low-level socket bindings}
   5
   6 The @SocketPrim@ module is for when you want full control over the
   7 sockets, exposing the C socket API.
   8
   9 \begin{code}
  10 {-# OPTIONS -#include "stgio.h" -#include "cbits/ghcSockets.h" #-}
  11
  12 #include "config.h"
  13
  14 module SocketPrim (
  15
  16     Socket,
  17     Family(..),
  18     SocketType(..),
  19     SockAddr(..),
  20     HostAddress,
  21     ShutdownCmd(..),
  22     ProtocolNumber,
  23
  24     socket,             -- :: Family -> SocketType -> ProtocolNumber -> IO Socket
  25     connect,            -- :: Socket -> SockAddr -> IO ()
  26     bindSocket,         -- :: Socket -> SockAddr -> IO ()
  27     listen,             -- :: Socket -> Int -> IO ()
  28     accept,             -- :: Socket -> IO (Socket, SockAddr)
  29     getPeerName,        -- :: Socket -> IO SockAddr
  30     getSocketName,      -- :: Socket -> IO SockAddr
  31
  32     socketPort,         -- :: Socket -> IO PortNumber
  33
  34     writeSocket,        -- :: Socket -> String -> IO Int
  35     readSocket,         -- :: Socket -> Int -> IO (String, Int)
  36     readSocketAll,      -- :: Socket -> IO String
  37
  38     socketToHandle,     -- :: Socket -> IO Handle
  39
  40     sendTo,             -- :: Socket -> String -> SockAddr -> IO Int
  41     recvFrom,           -- :: Socket -> Int -> IO (String, Int, SockAddr)
  42 --    sendmsg           -- :: Socket -> Message -> MsgFlags -> IO Int
  43 --    recvmsg           -- :: Socket -> MsgFlags -> IO Message
  44
  45
  46     inet_addr,          -- :: String -> IO HostAddress
  47     inet_ntoa,          -- :: HostAddress -> IO String
  48
  49     sIsConnected,       -- :: Socket -> IO Bool
  50     sIsBound,           -- :: Socket -> IO Bool
  51     sIsListening,       -- :: Socket -> IO Bool
  52     sIsReadable,        -- :: Socket -> IO Bool
  53     sIsWritable,        -- :: Socket -> IO Bool
  54     shutdown,           -- :: Socket -> ShutdownCmd -> IO ()
  55     sClose,             -- :: Socket -> IO ()
  56
  57     -- socket opts
  58     SocketOption(..),
  59     getSocketOption,     -- :: Socket -> SocketOption -> IO Int
  60     setSocketOption,     -- :: Socket -> SocketOption -> Int -> IO ()
  61
  62     PortNumber(..),
  63     mkPortNumber,           -- :: Int -> PortNumber
  64
  65 -- Special Constants
  66
  67     aNY_PORT,
  68     iNADDR_ANY,
  69     sOMAXCONN,
  70     maxListenQueue,
  71
  72
  73 -- The following are exported ONLY for use in the BSD module and
  74 -- should not be used anywhere else.
  75
  76     packFamily, unpackFamily,
  77     packSocketType,
  78     packSockAddr, unpackSockAddr
  79
  80     , withSocketsDo  -- :: IO a -> IO a
  81
  82 ) where
  83
  84 import GlaExts
  85 import ST
  86 import Ix
  87 import Weak         ( addForeignFinalizer )
  88 import PrelIOBase  -- IOError, Handle representation
  89 import PrelHandle
  90 import Foreign
  91 import Addr         ( nullAddr )
  92
  93 import IO
  94 import IOExts       ( IORef, newIORef, readIORef, writeIORef )
  95 import CString      ( unpackNBytesBAIO,
  96                       unpackCStringIO,
  97                       unpackCStringLenIO,
  98                       allocChars
  99                     )
 100 \end{code}
 101
 102
 103 %************************************************************************
 104 %*                                                                      *
 105 \subsection[Socket-SocketTypes]{Socket Types}
 106 %*                                                                      *
 107 %************************************************************************
 108
 109
 110 There are a few possible ways to do this.  The first is convert the
 111 structs used in the C library into an equivalent Haskell type.  An
 112 other possible implementation is to keep all the internals in the C
 113 code and use an Int\# and a status flag. The second method is used here
 114 since a lot of the C structures are not required to be manipulated.
 115
 116 Originally the status was non-mutable so we had to return a new socket
 117 each time we changed the status.  This version now uses mutable
 118 variables to avoid the need to do this.  The result is a cleaner
 119 interface and better security since the application programmer now
 120 can't circumvent the status information to perform invalid operations
 121 on sockets.
 122
 123 \begin{code}
 124 data SocketStatus
 125   -- Returned Status    Function called
 126   = NotConnected        -- socket
 127   | Bound               -- bindSocket
 128   | Listening           -- listen
 129   | Connected           -- connect/accept
 130   | Error String        -- Any
 131     deriving (Eq, Show)
 132
 133 data Socket
 134   = MkSocket
 135             Int                  -- File Descriptor
 136             Family
 137             SocketType
 138             Int                  -- Protocol Number
 139             (IORef SocketStatus) -- Status Flag
 140 \end{code}
 141
 142 The scheme used for addressing sockets is somewhat quirky. The
 143 calls in the BSD socket API that need to know the socket address all
 144 operate in terms of \tr{struct sockaddr}, a `virtual' type of socket address.
 145
 146 The Internet family of sockets are addressed as \tr{struct sockaddr\_in},
 147 so when calling functions that operate on \tr{struct sockaddr}, we have
 148 to type cast the Internet socket address into a \tr{struct sockaddr}. By luck(!),
 149 the two structures are of the same size. Same casting is required of other
 150 families of sockets such as Xerox NS. Similarly for Unix domain sockets.
 151
 152 To represent these socket addresses in Haskell-land, we do what BSD didn't do,
 153 and use a union/algebraic type for the different families. Currently only
 154 Unix domain sockets and the Internet family is supported.
 155
 156 \begin{code}
 157
 158 -- NOTE: HostAddresses are represented in network byte order.
 159 --       Functions that expect the address in machine byte order
 160 --       will have to perform the necessary translation.
 161 type HostAddress = Word
 162
 163 --
 164 -- newtyped to prevent accidental use of sane-looking
 165 -- port numbers that haven't actually been converted to
 166 -- network-byte-order first.
 167 --
 168 newtype PortNumber = PNum Int  -- 16-bit value stored in network byte order.
 169                      deriving ( Eq )
 170
 171 instance Show PortNumber where
 172   showsPrec p pn = showsPrec p (ntohs pn)
 173
 174 mkPortNumber :: Int -> PortNumber
 175 mkPortNumber v = unsafePerformIO $ do
 176    po <- _casm_ ``%r=(int)htons((int)%0); '' v
 177    return (PNum po)
 178
 179 ntohs :: PortNumber -> Int
 180 ntohs (PNum po) = unsafePerformIO (_casm_ ``%r=(int)ntohs((int)%0); '' po)
 181
 182 instance Num PortNumber where
 183    fromInt     i = mkPortNumber i
 184    fromInteger i = fromInt (fromInteger i)
 185     -- for completeness.
 186    (+) x y   = mkPortNumber (ntohs x + ntohs y)
 187    (-) x y   = mkPortNumber (ntohs x - ntohs y)
 188    negate x  = mkPortNumber (-ntohs x)
 189    (*) x y   = mkPortNumber (ntohs x * ntohs y)
 190    abs n     = mkPortNumber (abs (ntohs n))
 191    signum n  = mkPortNumber (signum (ntohs n))
 192
 193 data SockAddr           -- C Names
 194 #if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
 195   = SockAddrUnix        -- struct sockaddr_un
 196         String          -- sun_path
 197   | SockAddrInet        -- struct sockaddr_in
 198         PortNumber      -- sin_port  (network byte order)
 199         HostAddress     -- sin_addr  (ditto)
 200 #else
 201   = SockAddrInet        -- struct sockaddr_in
 202         PortNumber      -- sin_port  (network byte order)
 203         HostAddress     -- sin_addr  (ditto)
 204
 205 #endif
 206     deriving Eq
 207
 208 type ProtocolNumber = Int
 209
 210 \end{code}
 211
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection[Socket-Connections]{Connection Functions}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 In the following connection and binding primitives.  The names of the
 220 equivalent C functions have been preserved where possible. It should
 221 be noted that some of these names used in the C library, \tr{bind} in
 222 particular, have a different meaning to many Haskell programmers and
 223 have thus been renamed by appending the prefix Socket.
 224
 225 Create an unconnected socket of the given family, type and protocol.
 226 The most common invocation of $socket$ is the following:
 227
 228 \begin{verbatim}
 229    ...
 230    my_socket <- socket AF_INET Stream 6
 231    ...
 232 \end{verbatim}
 233
 234 \begin{code}
 235 socket :: Family         -- Family Name (usually AF_INET)
 236        -> SocketType     -- Socket Type (usually Stream)
 237        -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
 238        -> IO Socket      -- Unconnected Socket
 239
 240 socket family stype protocol = do
 241     status <- _ccall_ createSocket (packFamily family)
 242                                    (packSocketType stype)
 243                                    protocol
 244     case (status::Int) of
 245       -1 -> constructErrorAndFail "socket"
 246       n  -> do
 247         socket_status <- newIORef NotConnected
 248         return (MkSocket n family stype protocol socket_status)
 249 \end{code}
 250
 251 Given a port number this {\em binds} the socket to that port. This
 252 means that the programmer is only interested in data being sent to
 253 that port number. The $Family$ passed to $bindSocket$ must
 254 be the same as that passed to $socket$.  If the special port
 255 number $aNY\_PORT$ is passed then the system assigns the next
 256 available use port.
 257
 258 Port numbers for standard unix services can be found by calling
 259 $getServiceEntry$.  These are traditionally port numbers below
 260 1000; although there are afew, namely NFS and IRC, which used higher
 261 numbered ports.
 262
 263 The port number allocated to a socket bound by using $aNY\_PORT$ can be
 264 found by calling $port$
 265
 266 \begin{code}
 267 bindSocket :: Socket    -- Unconnected Socket
 268            -> SockAddr  -- Address to Bind to
 269            -> IO ()
 270
 271 bindSocket (MkSocket s _family _stype _protocol socketStatus) addr = do
 272 #if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
 273  let isDomainSocket = if _family == AF_UNIX then 1 else (0::Int)
 274 #else
 275  let isDomainSocket = 0
 276 #endif
 277  currentStatus <- readIORef socketStatus
 278  if currentStatus /= NotConnected
 279   then
 280    ioError (userError ("bindSocket: can't peform bind on socket in status " ++
 281          show currentStatus))
 282   else do
 283    addr' <- packSockAddr addr
 284    let (_,sz) = boundsOfMutableByteArray addr'
 285    status <- _ccall_ bindSocket s addr' sz (isDomainSocket::Int)
 286    case (status::Int) of
 287      -1 -> constructErrorAndFail "bindSocket"
 288      _  -> writeIORef socketStatus (Bound)
 289 \end{code}
 290
 291
 292 Make a connection to an already opened socket on a given machine and port.
 293 assumes that we have already called createSocket, otherwise it will fail.
 294
 295 This is the dual to $bindSocket$.  The {\em server} process will
 296 usually bind to a port number, the {\em client} will then connect to
 297 the same port number.  Port numbers of user applications are normally
 298 agreed in advance, otherwise we must rely on some meta protocol for telling
 299 the other side what port number we have been allocated.
 300
 301 \begin{code}
 302 connect :: Socket       -- Unconnected Socket
 303         -> SockAddr     -- Socket address stuff
 304         -> IO ()
 305
 306 connect (MkSocket s _family _stype _protocol socketStatus) addr = do
 307 #ifndef _WIN32
 308  let isDomainSocket = if _family == AF_UNIX then 1 else (0::Int)
 309 #else
 310  let isDomainSocket = 0
 311 #endif
 312  currentStatus <- readIORef socketStatus
 313  if currentStatus /= NotConnected
 314   then
 315    ioError (userError ("connect: can't peform connect on socket in status " ++
 316          show currentStatus))
 317   else do
 318    addr' <- packSockAddr addr
 319    let (_,sz) = boundsOfMutableByteArray addr'
 320    status <- _ccall_ connectSocket s addr' sz (isDomainSocket::Int)
 321    case (status::Int) of
 322      -1 -> constructErrorAndFail "connect"
 323      _  -> writeIORef socketStatus Connected
 324 \end{code}
 325
 326 The programmer must call $listen$ to tell the system software
 327 that they are now interested in receiving data on this port.  This
 328 must be called on the bound socket before any calls to read or write
 329 data are made.
 330
 331 The programmer also gives a number which indicates the length of the
 332 incoming queue of unread messages for this socket. On most systems the
 333 maximum queue length is around 5.  To remove a message from the queue
 334 for processing a call to $accept$ should be made.
 335
 336 \begin{code}
 337 listen :: Socket  -- Connected & Bound Socket
 338        -> Int     -- Queue Length
 339        -> IO ()
 340
 341 listen (MkSocket s _family _stype _protocol socketStatus) backlog = do
 342  currentStatus <- readIORef socketStatus
 343  if currentStatus /= Bound
 344    then
 345     ioError (userError ("listen: can't peform listen on socket in status " ++
 346           show currentStatus))
 347    else do
 348     status <- _ccall_ listenSocket s backlog
 349     case (status::Int) of
 350       -1 -> constructErrorAndFail "listen"
 351       _  -> writeIORef socketStatus Listening
 352 \end{code}
 353
 354 A call to $accept$ only returns when data is available on the given
 355 socket, unless the socket has been set to non-blocking.  It will
 356 return a new socket which should be used to read the incoming data and
 357 should then be closed. Using the socket returned by $accept$ allows
 358 incoming requests to be queued on the original socket.
 359
 360 \begin{code}
 361 accept :: Socket                        -- Queue Socket
 362        -> IO (Socket,                   -- Readable Socket
 363               SockAddr)                 -- Peer details
 364
 365 accept sock@(MkSocket s family stype protocol status) = do
 366  currentStatus <- readIORef status
 367  okay <- sIsAcceptable sock
 368  if not okay
 369    then
 370      ioError (userError ("accept: can't peform accept on socket in status " ++
 371          show currentStatus))
 372    else do
 373      (ptr, sz) <- allocSockAddr family
 374      int_star <- stToIO (newIntArray ((0::Int),1))
 375      stToIO (writeIntArray int_star 0 sz)
 376      new_sock <- _ccall_ acceptSocket s ptr int_star
 377      case (new_sock::Int) of
 378           -1 -> constructErrorAndFail "accept"
 379           _  -> do
 380                 a_sz <- stToIO (readIntArray int_star 0)
 381                 addr <- unpackSockAddr ptr a_sz
 382                 new_status <- newIORef Connected
 383                 return ((MkSocket new_sock family stype protocol new_status), addr)
 384 \end{code}
 385
 386 %************************************************************************
 387 %*                                                                      *
 388 \subsection[Socket-DataPass]{Data Passing Primitives}
 389 %*                                                                      *
 390 %************************************************************************
 391
 392 To allow Haskell to talk to C programs we need to be able to
 393 communicate in terms of byte streams. @writeSocket@ and
 394 @readSocket@ should only be used for this purpose and not for
 395 communication between Haskell programs.  Haskell programs should use
 396 the 1.3 IO hPutStr and associated machinery for communicating with
 397 each other.
 398
 399
 400 \begin{code}
 401 writeSocket :: Socket   -- Connected Socket
 402             -> String   -- Data to send
 403             -> IO Int   -- Number of Bytes sent
 404
 405 writeSocket (MkSocket s _family _stype _protocol status) xs = do
 406  currentStatus <- readIORef status
 407  if not ((currentStatus == Connected) || (currentStatus == Listening))
 408    then
 409     ioError (userError ("writeSocket: can't peform write on socket in status " ++
 410           show currentStatus))
 411    else do
 412     nbytes <- _ccall_ writeDescriptor s xs (length xs)
 413     case (nbytes::Int) of
 414       -1 -> constructErrorAndFail "writeSocket"
 415       _  -> return nbytes
 416
 417
 418 sendTo :: Socket        -- Bound/Connected Socket
 419        -> String        -- Data to send
 420        -> SockAddr
 421        -> IO Int        -- Number of Bytes sent
 422
 423 sendTo (MkSocket s _family _stype _protocol status) xs addr = do
 424  currentStatus <- readIORef status
 425  if not ((currentStatus == Connected) || (currentStatus == Listening) || (currentStatus == Bound))
 426    then
 427     ioError (userError ("sendTo: can't peform write on socket in status " ++
 428           show currentStatus))
 429    else do
 430     addr' <- packSockAddr addr
 431     let (_,sz) = boundsOfMutableByteArray addr'
 432     nbytes <- _ccall_ sendTo__ s xs (length xs) addr' sz
 433     case (nbytes::Int) of
 434       -1 -> constructErrorAndFail "sendTo"
 435       _  -> return nbytes
 436
 437 readSocket :: Socket            -- Connected (or bound) Socket
 438            -> Int               -- Number of Bytes to Read
 439            -> IO (String, Int)  -- (Data Read, Number of Bytes)
 440
 441 readSocket (MkSocket s _family _stype _protocol status) nbytes = do
 442  currentStatus <- readIORef status
 443  if not ((currentStatus == Connected) || (currentStatus == Listening))
 444    then
 445     ioError (userError ("readSocket: can't perform read on socket in status " ++
 446           show currentStatus))
 447    else do
 448     ptr  <- allocChars nbytes
 449     rlen <- _ccall_ readDescriptor s ptr nbytes
 450     case (rlen::Int) of
 451       -1 -> constructErrorAndFail "readSocket"
 452       n  -> do
 453             barr <- stToIO (unsafeFreezeByteArray ptr)
 454             str  <- unpackNBytesBAIO barr n
 455             return (str, n)
 456
 457 readSocketAll :: Socket -> IO String
 458 readSocketAll s =
 459     let
 460       loop xs =
 461        catch
 462         (readSocket s 4096                      >>= \ (str, nbytes) ->
 463          if nbytes /= 0 then
 464             loop (str ++ xs)
 465          else
 466             return xs)
 467         (\ _ -> return xs)
 468     in
 469         loop ""
 470
 471 recvFrom :: Socket -> Int -> IO (String, Int, SockAddr)
 472 recvFrom (MkSocket s _family _stype _protocol status) nbytes = do
 473  currentStatus <- readIORef status
 474  if not ((currentStatus == Connected) || (currentStatus == Listening) || (currentStatus == Bound))
 475    then
 476     ioError (userError ("recvFrom: can't perform read on socket in status " ++
 477           show currentStatus))
 478    else do
 479     ptr    <- allocChars nbytes
 480     (ptr_addr,_) <- allocSockAddr AF_INET
 481     rlen   <- _ccall_ recvFrom__ s ptr nbytes ptr_addr
 482     case (rlen::Int) of
 483       -1 -> constructErrorAndFail "recvFrom"
 484       n  -> do
 485             barr <- stToIO (unsafeFreezeByteArray ptr)
 486             addr <- unpackSockAddrInet ptr_addr
 487             str  <- unpackNBytesBAIO barr n
 488             return (str, n, addr)
 489
 490 \end{code}
 491
 492 The port number the given socket is currently connected to can be
 493 determined by calling $port$, is generally only useful when bind
 494 was given $aNY\_PORT$.
 495
 496 \begin{code}
 497 socketPort :: Socket            -- Connected & Bound Socket
 498            -> IO PortNumber     -- Port Number of Socket
 499 socketPort sock@(MkSocket _ AF_INET _ _ _) =
 500     getSocketName sock >>= \(SockAddrInet port _) ->
 501     return port
 502 socketPort (MkSocket _ family _ _ _) =
 503     ioError (userError ("socketPort: not supported for Family " ++ show family))
 504 \end{code}
 505
 506 Calling $getPeerName$ returns the address details of the machine,
 507 other than the local one, which is connected to the socket. This is
 508 used in programs such as FTP to determine where to send the returning
 509 data.  The corresponding call to get the details of the local machine
 510 is $getSocketName$.
 511
 512 \begin{code}
 513 getPeerName   :: Socket -> IO SockAddr
 514
 515 getPeerName (MkSocket s family _ _ _) = do
 516  (ptr, a_sz) <- allocSockAddr family
 517  int_star <- stToIO (newIntArray ((0::Int),1))
 518  stToIO (writeIntArray int_star 0 a_sz)
 519  status <- _ccall_ getPeerName s ptr int_star
 520  case (status::Int) of
 521    -1 -> constructErrorAndFail "getPeerName"
 522    _  -> do
 523           sz <- stToIO (readIntArray int_star 0)
 524           unpackSockAddr ptr sz
 525
 526 getSocketName :: Socket -> IO SockAddr
 527
 528 getSocketName (MkSocket s family _ _ _) = do
 529  (ptr, a_sz) <- allocSockAddr family
 530  int_star <- stToIO (newIntArray ((0::Int),1))
 531  stToIO (writeIntArray int_star 0 a_sz)
 532  rc <- _ccall_ getSockName s ptr int_star
 533  case (rc::Int) of
 534    -1 -> constructErrorAndFail "getSocketName"
 535    _  -> do
 536          sz <- stToIO (readIntArray int_star 0)
 537          unpackSockAddr ptr sz
 538
 539
 540 \end{code}
 541
 542
 543 %************************************************************************
 544 %*                                                                      *
 545 \subsection[Socket-Properties]{Socket Properties}
 546 %*                                                                      *
 547 %************************************************************************
 548
 549 \begin{code}
 550 data SocketOption
 551     = Debug         {- SO_DEBUG     -}
 552     | ReuseAddr     {- SO_REUSEADDR -}
 553     | Type          {- SO_TYPE      -}
 554     | SoError       {- SO_ERROR     -}
 555     | DontRoute     {- SO_DONTROUTE -}
 556     | Broadcast     {- SO_BROADCAST -}
 557     | SendBuffer    {- SO_SNDBUF    -}
 558     | RecvBuffer    {- SO_RCVBUF    -}
 559     | KeepAlive     {- SO_KEEPALIVE -}
 560     | OOBInline     {- SO_OOBINLINE -}
 561 #ifndef _WIN32
 562     | MaxSegment    {- TCP_MAXSEG   -}
 563 #endif
 564     | NoDelay       {- TCP_NODELAY  -}
 565 --    | Linger        {- SO_LINGER    -}
 566 #if 0
 567     | ReusePort     {- SO_REUSEPORT -}  -- BSD only?
 568     | RecvLowWater  {- SO_RCVLOWAT  -}
 569     | SendLowWater  {- SO_SNDLOWAT  -}
 570     | RecvTimeOut   {- SO_RCVTIMEO  -}
 571     | SendTimeOut   {- SO_SNDTIMEO  -}
 572     | UseLoopBack   {- SO_USELOOPBACK -}  -- not used, I believe.
 573 #endif
 574
 575 packSocketOption :: SocketOption -> Int
 576 packSocketOption so =
 577   case so of
 578     Debug         -> ``SO_DEBUG''
 579     ReuseAddr     -> ``SO_REUSEADDR''
 580     Type          -> ``SO_TYPE''
 581     SoError       -> ``SO_ERROR''
 582     DontRoute     -> ``SO_DONTROUTE''
 583     Broadcast     -> ``SO_BROADCAST''
 584     SendBuffer    -> ``SO_SNDBUF''
 585     RecvBuffer    -> ``SO_RCVBUF''
 586     KeepAlive     -> ``SO_KEEPALIVE''
 587     OOBInline     -> ``SO_OOBINLINE''
 588 #ifndef _WIN32
 589     MaxSegment    -> ``TCP_MAXSEG''
 590 #endif
 591     NoDelay       -> ``TCP_NODELAY''
 592 #if 0
 593     ReusePort     -> ``SO_REUSEPORT''   -- BSD only?
 594     RecvLowWater  -> ``SO_RCVLOWAT''
 595     SendLowWater  -> ``SO_SNDLOWAT''
 596     RecvTimeOut   -> ``SO_RCVTIMEO''
 597     SendTimeOut   -> ``SO_SNDTIMEO''
 598     UseLoopBack   -> ``SO_USELOOPBACK''
 599 #endif
 600
 601 setSocketOption :: Socket
 602                 -> SocketOption -- Option Name
 603                 -> Int           -- Option Value
 604                 -> IO ()
 605 setSocketOption (MkSocket s _ _ _ _) so v = do
 606    rc <- _ccall_ setSocketOption__ s (packSocketOption so) v
 607    if rc /= (0::Int)
 608     then constructErrorAndFail "setSocketOption"
 609     else return ()
 610
 611 getSocketOption :: Socket
 612                 -> SocketOption  -- Option Name
 613                 -> IO Int         -- Option Value
 614 getSocketOption (MkSocket s _ _ _ _) so = do
 615    rc <- _ccall_ getSocketOption__ s (packSocketOption so)
 616    if rc == -1 -- let's just hope that value isn't taken..
 617     then constructErrorAndFail "getSocketOption"
 618     else return rc
 619
 620 \end{code}
 621
 622 A calling sequence table for the main functions is shown in the table below.
 623
 624 \begin{figure}[h]
 625 \begin{center}
 626 \begin{tabular}{|l|c|c|c|c|c|c|c|}
 627 \hline
 628 {\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\
 629 \hline
 630 {\bf Precedes} & & & & & & & \\
 631 \hline
 632 socket &        &         &            &        &        &      & \\
 633 \hline
 634 connect & +     &         &            &        &        &      & \\
 635 \hline
 636 bindSocket & +  &         &            &        &        &      & \\
 637 \hline
 638 listen &        &         & +          &        &        &      & \\
 639 \hline
 640 accept &        &         &            &  +     &        &      & \\
 641 \hline
 642 read   &        &   +     &            &  +     &  +     &  +   & + \\
 643 \hline
 644 write  &        &   +     &            &  +     &  +     &  +   & + \\
 645 \hline
 646 \end{tabular}
 647 \caption{Sequence Table for Major functions of Socket}
 648 \label{tab:api-seq}
 649 \end{center}
 650 \end{figure}
 651
 652 %************************************************************************
 653 %*                                                                      *
 654 \subsection[Socket-OSDefs]{OS Dependent Definitions}
 655 %*                                                                      *
 656 %************************************************************************
 657
 658
 659 The following Family and Socket Type declarations were manually derived
 660 from @<sys/socket.h>@ on the appropriate machines.
 661
 662 Maybe a configure script that could parse the socket.h file to produce
 663 the following declaration is required to make it ``portable'' rather than
 664 using the dreaded \#ifdefs.
 665
 666 Presently only the following machine/os combinations are supported:
 667
 668 \begin{itemize}
 669 \item Intelx86/Linux
 670 \item SPARC/SunOS
 671 \item SPARC/Solaris
 672 \item Alpha/OSF
 673 \item HPPA/HPUX9
 674 \item MIPS/IRIX6.2
 675 \end{itemize}
 676
 677 \begin{code}
 678 unpackFamily    :: Int -> Family
 679 packFamily      :: Family -> Int
 680
 681 packSocketType  :: SocketType -> Int
 682
 683
 684 #if sunos4_TARGET_OS || solaris2_TARGET_OS
 685
 686 data Family =
 687           AF_UNSPEC     -- unspecified
 688         | AF_UNIX       -- local to host (pipes, portals
 689         | AF_INET       -- internetwork: UDP, TCP, etc
 690         | AF_IMPLINK    -- arpanet imp addresses
 691         | AF_PUP        -- pup protocols: e.g. BSP
 692         | AF_CHAOS      -- mit CHAOS protocols
 693         | AF_NS         -- XEROX NS protocols
 694         | AF_NBS        -- nbs protocols
 695         | AF_ECMA       -- european computer manufacturers
 696         | AF_DATAKIT    -- datakit protocols
 697         | AF_CCITT      -- CCITT protocols, X.25 etc
 698         | AF_SNA        -- IBM SNA
 699         | AF_DECnet     -- DECnet
 700         | AF_DLI        -- Direct data link interface
 701         | AF_LAT        -- LAT
 702         | AF_HYLINK     -- NSC Hyperchannel
 703         | AF_APPLETALK  -- Apple Talk
 704         | AF_NIT        -- Network Interface Tap
 705         | AF_802        -- IEEE 802.2, also ISO 8802
 706         | AF_OSI        -- umbrella of all families used by OSI
 707         | AF_X25        -- CCITT X.25
 708         | AF_OSINET     -- AFI
 709         | AF_GOSSIP     -- US Government OSI
 710         | AF_IPX        -- Novell Internet Protocol
 711         deriving (Eq, Ord, Ix, Show)
 712
 713 packFamily = index (AF_UNSPEC, AF_IPX)
 714 unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
 715
 716 #endif
 717
 718 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 719
 720 data Family =
 721           AF_UNSPEC     -- unspecified
 722         | AF_UNIX       -- local to host (pipes, portals)
 723         | AF_INET       -- internetwork: UDP, TCP, etc
 724         | AF_IMPLINK    -- arpanet imp addresses
 725         | AF_PUP        -- pup protocols: e.g. BSP
 726         | AF_CHAOS      -- mit CHAOS protocols
 727         | AF_NS         -- XEROX NS protocols
 728         | AF_ISO        -- ISO protocols
 729         | AF_OSI        -- OSI protocols
 730         | AF_ECMA       -- european computer manufacturers
 731         | AF_DATAKIT    -- datakit protocols
 732         | AF_CCITT      -- CCITT protocols, X.25 etc
 733         | AF_SNA        -- IBM SNA
 734         | AF_DECnet     -- DECnet
 735         | AF_DLI        -- Direct data link interface
 736         | AF_LAT        -- LAT
 737         | AF_HYLINK     -- NSC Hyperchannel
 738         | AF_APPLETALK  -- Apple Talk
 739         | AF_NETBIOS    -- NetBios-style addresses
 740         deriving (Eq, Ord, Ix, Show)
 741
 742 packFamily = index (AF_UNSPEC, AF_NETBIOS)
 743 unpackFamily family = (range (AF_UNSPEC, AF_NETBIOS))!!family
 744
 745
 746 #endif
 747
 748 #if hpux_TARGET_OS
 749
 750 data Family =
 751           AF_UNSPEC     -- unspecified
 752         | AF_UNIX       -- local to host (pipes, portals
 753         | AF_INET       -- internetwork: UDP, TCP, etc
 754         | AF_IMPLINK    -- arpanet imp addresses
 755         | AF_PUP        -- pup protocols: e.g. BSP
 756         | AF_CHAOS      -- mit CHAOS protocols
 757         | AF_NS         -- XEROX NS protocols
 758         | AF_NBS        -- nbs protocols
 759         | AF_ECMA       -- european computer manufacturers
 760         | AF_DATAKIT    -- datakit protocols
 761         | AF_CCITT      -- CCITT protocols, X.25 etc
 762         | AF_SNA        -- IBM SNA
 763         | AF_DECnet     -- DECnet
 764         | AF_DLI        -- Direct data link interface
 765         | AF_LAT        -- LAT
 766         | AF_HYLINK     -- NSC Hyperchannel
 767         | AF_APPLETALK  -- Apple Talk
 768         | AF_NIT        -- Network Interface Tap
 769         deriving (Eq, Ord, Ix, Show)
 770
 771 packFamily = index (AF_UNSPEC, AF_NIT)
 772 unpackFamily family = (range (AF_UNSPEC, AF_NIT))!!family
 773
 774 #endif
 775
 776 #if osf1_TARGET_OS || osf3_TARGET_OS
 777
 778 data Family =
 779           AF_UNSPEC     -- unspecified
 780         | AF_UNIX       -- local to host (pipes, portals)
 781         | AF_INET       -- internetwork: UDP, TCP, etc.
 782         | AF_IMPLINK    -- arpanet imp addresses
 783         | AF_PUP        -- pup protocols: e.g. BSP
 784         | AF_CHAOS      -- mit CHAOS protocols
 785         | AF_NS         -- XEROX NS protocols
 786         | AF_ISO        -- ISO protocols
 787         | AF_ECMA       -- european computer manufacturers
 788         | AF_DATAKIT    -- datakit protocols
 789         | AF_CCITT      -- CCITT protocols, X.25 etc
 790         | AF_SNA        -- IBM SNA
 791         | AF_DECnet     -- DECnet
 792         | AF_DLI        -- DEC Direct data link interface
 793         | AF_LAT        -- LAT
 794         | AF_HYLINK     -- NSC Hyperchannel
 795         | AF_APPLETALK  -- Apple Talk
 796         | AF_ROUTE      -- Internal Routing Protocol
 797         | AF_LINK       -- Link layer interface
 798         | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
 799         | AF_NETMAN     -- DNA Network Management
 800         | AF_X25        -- X25 protocol
 801         | AF_CTF        -- Common Trace Facility
 802         | AF_WAN        -- Wide Area Network protocols
 803         deriving (Eq, Ord, Ix, Show)
 804
 805 packFamily = index (AF_UNSPEC, AF_WAN)
 806 unpackFamily family = (range (AF_UNSPEC, AF_WAN))!!family
 807 #endif
 808
 809 #if linux_TARGET_OS
 810
 811 data Family =
 812           AF_UNSPEC
 813         | AF_UNIX
 814         | AF_INET
 815         | AF_AX25
 816         | AF_IPX
 817         deriving (Eq, Ord, Ix, Show)
 818
 819 packFamily = index (AF_UNSPEC, AF_IPX)
 820 unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
 821
 822 #endif
 823
 824 #if irix_TARGET_OS
 825
 826 data Family =
 827           AF_UNSPEC             -- unspecified
 828         | AF_UNIX               -- backward compatibility
 829         | AF_INET               -- internetwork: UDP, TCP, etc.
 830         | AF_IMPLINK            -- arpanet imp addresses
 831         | AF_PUP                -- pup protocols: e.g. BSP
 832         | AF_CHAOS              -- mit CHAOS protocols
 833         | AF_NS                 -- XEROX NS protocols
 834         | AF_ISO                -- ISO protocols
 835         | AF_ECMA               -- european computer manufacturers
 836         | AF_DATAKIT            -- datakit protocols
 837         | AF_CCITT              -- CCITT protocols, X.25 etc
 838         | AF_SNA                -- IBM SNA
 839         | AF_DECnet             -- DECnet
 840         | AF_DLI                -- DEC Direct data link interface
 841         | AF_LAT                -- LAT
 842         | AF_HYLINK             -- NSC Hyperchannel
 843         | AF_APPLETALK          -- Apple Talk
 844         | AF_ROUTE              -- Internal Routing Protocol
 845         | AF_RAW                -- Link layer interface
 846
 847 -- these two overlap AF_ROUTE and AF_RAW
 848 --      | AF_NIT                -- Network Interface Tap
 849 --      | AF_802                -- IEEE 802.2, also ISO 8802
 850
 851         | AF_OSI                -- umbrella for all families used by OSI
 852         | AF_X25                -- CCITT X.25
 853         | AF_OSINET             -- AFI
 854         | AF_GOSIP              -- US Government OSI
 855
 856         | AF_SDL                -- SGI Data Link for DLPI
 857         | AF_INET6              -- Internet Protocol version 6
 858         | AF_LINK               -- Link layer interface
 859         deriving (Eq, Ord, Ix, Show)
 860
 861 packFamily = index (AF_UNSPEC, AF_LINK)
 862 unpackFamily family = (range (AF_UNSPEC, AF_LINK))!!family
 863
 864 #endif
 865
 866 #if aix_TARGET_OS
 867
 868 data Family =
 869         AF_UNSPEC       -- unspecified
 870       | AF_UNIX         -- local to host (pipes, portals)
 871       | AF_INET         -- internetwork: UDP, TCP, etc.
 872       | AF_IMPLINK      -- arpanet imp addresses
 873       | AF_PUP          -- pup protocols: e.g. BSP
 874       | AF_CHAOS        -- mit CHAOS protocols
 875       | AF_NS           -- XEROX NS protocols
 876       | AF_ISO          -- ISO protocols
 877 --    | AF_OSI is the same as AF_ISO on AIX
 878       | AF_ECMA         -- european computer manufacturers
 879       | AF_DATAKIT      -- datakit protocols
 880       | AF_CCITT        -- CCITT protocols, X.25 etc
 881       | AF_SNA          -- IBM SNA
 882       | AF_DECnet       -- DECnet
 883       | AF_DLI          -- DEC Direct data link interface
 884       | AF_LAT          -- LAT
 885       | AF_HYLINK       -- NSC Hyperchannel
 886       | AF_APPLETALK    -- Apple Talk
 887       | AF_ROUTE        -- Internal Routing Protocol
 888       | AF_LINK         -- Link layer interface
 889       | Pseudo_AF_XTP   -- eXpress Transfer Protocol (no AF)
 890       | AF_INTF         -- Debugging use only
 891       | AF_RIF          -- raw interface
 892       | AF_NETWARE
 893       | AF_NDD
 894       | AF_MAX
 895         deriving (Eq, Ord, Ix, Show)
 896
 897 packFamily = index (AF_UNSPEC, AF_MAX)
 898 unpackFamily family = (range (AF_UNSPEC, AF_MAX))!!family
 899
 900 #endif
 901
 902 #if freebsd2_TARGET_OS || freebsd3_TARGET_OS
 903
 904 data Family =
 905         AF_UNSPEC       -- unspecified
 906       | AF_UNIX         -- local to host (pipes, portals)
 907       | AF_INET         -- internetwork: UDP, TCP, etc.
 908       | AF_IMPLINK      -- arpanet imp addresses
 909       | AF_PUP          -- pup protocols: e.g. BSP
 910       | AF_CHAOS        -- mit CHAOS protocols
 911       | AF_NS           -- XEROX NS protocols
 912       | AF_ISO          -- ISO protocols
 913 --    | AF_OSI is the same as AF_ISO
 914       | AF_ECMA         -- european computer manufacturers
 915       | AF_DATAKIT      -- datakit protocols
 916       | AF_CCITT        -- CCITT protocols, X.25 etc
 917       | AF_SNA          -- IBM SNA
 918       | AF_DECnet       -- DECnet
 919       | AF_DLI          -- DEC Direct data link interface
 920       | AF_LAT          -- LAT
 921       | AF_HYLINK       -- NSC Hyperchannel
 922       | AF_APPLETALK    -- Apple Talk
 923       | AF_ROUTE        -- Internal Routing Protocol
 924       | AF_LINK         -- Link layer interface
 925       | Pseudo_AF_XTP   -- eXpress Transfer Protocol (no AF)
 926       | AF_COIP         -- connection-oriented IP, aka ST II
 927       | AF_CNT          -- Computer Network Technology
 928       | Psuedo_AF_RTIP  -- Help Identify RTIP packets
 929       | AF_IPX          -- Novell Internet Protocol
 930       | AF_SIP          -- Simple Internet Protocol
 931       | Pseudo_AF_PIP   -- Help Identify PIP packets
 932       | AF_ISDN         -- Integrated Services Digital Network
 933 --    | AF_E164 is the same as AF_ISDN
 934       | Pseudo_AF_KEY   -- Internal key-management function
 935       | AF_INET6        -- IPv6
 936       | AF_MAX
 937         deriving (Eq, Ord, Ix, Show)
 938
 939 packFamily = index (AF_UNSPEC, AF_MAX)
 940 unpackFamily family = (range (AF_UNSPEC, AF_MAX))!!family
 941
 942 #endif
 943
 944 -- Alpha running OSF or a SPARC with SunOS, rather than Solaris.
 945
 946 #if osf1_TARGET_OS || osf3_TARGET_OS || sunos4_TARGET_OS || hpux_TARGET_OS || \
 947         aix_TARGET_OS || freebsd2_TARGET_OS || freebsd3_TARGET_OS
 948 data SocketType =
 949           Stream
 950         | Datagram
 951         | Raw
 952         | RDM
 953         | SeqPacket
 954         deriving (Eq, Ord, Ix, Show)
 955
 956 packSocketType stype = 1 + (index (Stream, SeqPacket) stype)
 957 #endif
 958
 959 -- This is for a box running cygwin32 toolchain.
 960
 961 #if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
 962 data SocketType =
 963           Stream
 964         | Datagram
 965         | Raw
 966         | RDM       -- reliably delivered msg
 967         | SeqPacket
 968         deriving (Eq, Ord, Ix, Show)
 969
 970 packSocketType stype =
 971  case stype of
 972    Stream    -> ``SOCK_STREAM''
 973    Datagram  -> ``SOCK_DGRAM''
 974    Raw       -> ``SOCK_RAW''
 975    RDM       -> ``SOCK_RDM''
 976    SeqPacket -> ``SOCK_SEQPACKET''
 977
 978 #endif
 979
 980 -- This is a Sun running Solaris rather than SunOS or SGI running IRIX
 981
 982 #if defined(solaris2_TARGET_OS) || defined(irix_TARGET_OS)
 983 data SocketType =
 984           Datagram
 985         | Stream
 986         | NC_TPI_COTS_ORD
 987         | Raw
 988         | RDM
 989         | SeqPacket
 990         deriving (Eq, Ord, Ix, Show)
 991
 992 packSocketType stype = 1 + (index (Datagram, SeqPacket) stype)
 993 #endif
 994
 995
 996 #if linux_TARGET_OS
 997 data SocketType =
 998           Stream
 999         | Datagram
1000         | Raw
1001         | RDM
1002         | SeqPacket
1003         | Packet
1004         deriving (Eq, Ord, Ix, Show)
1005
1006 packSocketType stype = 1 + (index (Stream, Packet) stype)
1007 #endif
1008 \end{code}
1009
1010 %************************************************************************
1011 %*                                                                      *
1012 \subsection[Socket-Util]{Utility Functions}
1013 %*                                                                      *
1014 %************************************************************************
1015
1016 \begin{code}
1017 aNY_PORT :: PortNumber
1018 aNY_PORT = mkPortNumber 0
1019
1020 iNADDR_ANY :: HostAddress
1021 iNADDR_ANY = unsafePerformIO (_casm_ `` %r = htonl(INADDR_ANY); '')
1022
1023 sOMAXCONN :: Int
1024 sOMAXCONN = ``SOMAXCONN''
1025
1026 maxListenQueue :: Int
1027 maxListenQueue = sOMAXCONN
1028
1029 -------------------------------------------------------------------------------
1030 data ShutdownCmd
1031  = ShutdownReceive
1032  | ShutdownSend
1033  | ShutdownBoth
1034
1035 sdownCmdToInt :: ShutdownCmd -> Int
1036 sdownCmdToInt ShutdownReceive = 0
1037 sdownCmdToInt ShutdownSend    = 1
1038 sdownCmdToInt ShutdownBoth    = 2
1039
1040 shutdown :: Socket -> ShutdownCmd -> IO ()
1041 shutdown (MkSocket s _ _ _ _) stype = do
1042   let t = sdownCmdToInt stype
1043   status <- _ccall_ shutdownSocket s t
1044   case (status::Int) of
1045     -1 -> constructErrorAndFail "shutdown"
1046     _  -> return ()
1047
1048 -------------------------------------------------------------------------------
1049
1050 sClose   :: Socket -> IO ()
1051 sClose (MkSocket s _ _ _ _) = _ccall_ close s
1052
1053 -------------------------------------------------------------------------------
1054
1055 sIsConnected :: Socket -> IO Bool
1056 sIsConnected (MkSocket _ _ _ _ status) = do
1057     value <- readIORef status
1058     return (value == Connected)
1059
1060 -------------------------------------------------------------------------------
1061
1062 sIsBound :: Socket -> IO Bool
1063 sIsBound (MkSocket _ _ _ _ status) = do
1064     value <- readIORef status
1065     return (value == Bound)
1066
1067 -------------------------------------------------------------------------------
1068
1069 sIsListening :: Socket -> IO Bool
1070 sIsListening (MkSocket _ _ _  _ status) = do
1071     value <- readIORef status
1072     return (value == Listening)
1073
1074 -------------------------------------------------------------------------------
1075
1076 sIsReadable  :: Socket -> IO Bool
1077 sIsReadable (MkSocket _ _ _ _ status) = do
1078     value <- readIORef status
1079     return (value == Listening || value == Connected)
1080
1081 -------------------------------------------------------------------------------
1082
1083 sIsWritable  :: Socket -> IO Bool
1084 sIsWritable = sIsReadable -- sort of.
1085
1086 -------------------------------------------------------------------------------
1087
1088 sIsAcceptable :: Socket -> IO Bool
1089 #if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
1090 sIsAcceptable (MkSocket _ AF_UNIX Stream _ status) = do
1091     value <- readIORef status
1092     return (value == Connected || value == Bound || value == Listening)
1093 sIsAcceptable (MkSocket _ AF_UNIX _ _ _) = return False
1094 #endif
1095 sIsAcceptable (MkSocket _ _ _ _ status) = do
1096     value <- readIORef status
1097     return (value == Connected || value == Listening)
1098
1099 -------------------------------------------------------------------------------
1100
1101 {-
1102 sSetBlocking :: Socket -> Bool -> IO ()
1103 sIsBlocking  :: Socket -> IO Bool
1104 -}
1105
1106 \end{code}
1107
1108 Internet address manipulation routines:
1109
1110 \begin{code}
1111 inet_addr :: String -> IO HostAddress
1112 inet_addr ipstr = do
1113    had <- _ccall_ inet_addr ipstr
1114    if had == (W# (int2Word# (negateInt# 1#))) -- hack to avoid depending on Int.intToWord here.
1115     then ioError (userError ("inet_addr: Malformed address: " ++ ipstr))
1116     else return had  -- network byte order
1117
1118 inet_ntoa :: HostAddress -> IO String
1119 inet_ntoa haddr = do
1120   pstr <- _casm_ ``struct in_addr addr;
1121                    addr.s_addr = %0;
1122                    %r = inet_ntoa (addr);'' haddr
1123   -- unpack straight away, since pstr points to static buffer.
1124   unpackCStringIO pstr
1125
1126 \end{code}
1127
1128 Marshaling and allocation helper functions:
1129
1130 \begin{code}
1131 -------------------------------------------------------------------------------
1132
1133 allocSockAddr :: Family -> IO (MutableByteArray RealWorld Int, Int)
1134
1135 #if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
1136 allocSockAddr AF_UNIX = do
1137     ptr <- allocChars ``sizeof(struct sockaddr_un)''
1138     let (_,sz) = boundsOfMutableByteArray ptr
1139     return (ptr, sz)
1140 #endif
1141
1142 allocSockAddr AF_INET = do
1143     ptr <- allocChars ``sizeof(struct sockaddr_in)''
1144     let (_,sz) = boundsOfMutableByteArray ptr
1145     return (ptr, sz)
1146
1147 -------------------------------------------------------------------------------
1148
1149 unpackSockAddr :: MutableByteArray RealWorld Int -> Int -> IO SockAddr
1150 unpackSockAddr arr len = do
1151     fam <- _casm_ ``%r = ((struct sockaddr*)%0)->sa_family;'' arr
1152     case unpackFamily fam of
1153 #if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
1154         AF_UNIX -> unpackSockAddrUnix arr (len - ``sizeof(short)'')
1155 #endif
1156         AF_INET -> unpackSockAddrInet arr
1157
1158 -------------------------------------------------------------------------------
1159
1160 #if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
1161
1162 {-
1163   sun_path is *not* NULL terminated, hence we *do* need to know the
1164   length of it.
1165 -}
1166 unpackSockAddrUnix :: (MutableByteArray RealWorld Int) -> Int -> IO SockAddr
1167 unpackSockAddrUnix ptr len = do
1168     char_star <- _casm_ ``%r = ((struct sockaddr_un*)%0)->sun_path;'' ptr
1169     path      <- unpackCStringLenIO char_star len
1170     return (SockAddrUnix path)
1171
1172 #endif
1173
1174 -------------------------------------------------------------------------------
1175
1176 unpackSockAddrInet :: (MutableByteArray RealWorld Int) -> IO SockAddr
1177 unpackSockAddrInet ptr = do
1178   port <- _casm_ ``%r = ((struct sockaddr_in*)%0)->sin_port;''        ptr
1179   addr <- _casm_ ``%r = ((struct sockaddr_in*)%0)->sin_addr.s_addr;'' ptr
1180   return (SockAddrInet (PNum port) addr)
1181
1182 -------------------------------------------------------------------------------
1183
1184
1185 packSockAddr :: SockAddr -> IO (MutableByteArray RealWorld Int)
1186 #if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
1187 packSockAddr (SockAddrUnix path) = do
1188     (ptr,_) <- allocSockAddr AF_UNIX
1189     _casm_ ``(((struct sockaddr_un *)%0)->sun_family) = AF_UNIX;''    ptr
1190     _casm_ ``strcpy ((((struct sockaddr_un *)%0)->sun_path),%1);''    ptr path
1191     return ptr
1192 #endif
1193 packSockAddr (SockAddrInet (PNum port) address) = do
1194   (ptr,_) <- allocSockAddr AF_INET
1195   _casm_ ``(((struct sockaddr_in *)%0)->sin_family) = AF_INET;''  ptr
1196   _casm_ ``(((struct sockaddr_in *)%0)->sin_port) = (int)%1;''    ptr port
1197   _casm_ ``(((struct sockaddr_in *)%0)->sin_addr.s_addr) = %1;''  ptr address
1198   return ptr
1199
1200 -------------------------------------------------------------------------------
1201 \end{code}
1202
1203 @socketHandle@ turns a @Socket@ into a Haskell IO @Handle@. By default, the new
1204 handle will not be buffered, use @hSetBuffering@ if you want to change
1205 it subsequently.
1206
1207 \begin{code}
1208 #ifndef __PARALLEL_HASKELL__
1209 socketToHandle :: Socket -> IOMode -> IO Handle
1210
1211 socketToHandle (MkSocket fd _ _ _ _) m = do
1212     fileobj <- _ccall_ openFd fd (file_mode::Int) (file_flags::Int)
1213     if fileobj == nullAddr then
1214        ioError (userError "socketHandle: Failed to open file desc")
1215      else do
1216        fo <- mkForeignObj fileobj
1217        addForeignFinalizer fo (freeFileObject fo)
1218        mkBuffer__ fo 0  -- not buffered
1219        hndl <- newHandle (Handle__ fo htype NoBuffering socket_str)
1220        return hndl
1221  where
1222   socket_str = "<socket: "++show fd
1223 #ifdef _WIN32
1224   file_flags = flush_on_close + 1024{-I'm a socket fd, me!-}
1225 #else
1226   file_flags = flush_on_close
1227 #endif
1228
1229   (flush_on_close, file_mode) =
1230    case m of
1231            AppendMode    -> (1, 0)
1232            WriteMode     -> (1, 1)
1233            ReadMode      -> (0, 2)
1234            ReadWriteMode -> (1, 3)
1235
1236   htype =
1237    case m of
1238      ReadMode      -> ReadHandle
1239      WriteMode     -> WriteHandle
1240      AppendMode    -> AppendHandle
1241      ReadWriteMode -> ReadWriteHandle
1242 #else
1243 socketToHandle (MkSocket s family stype protocol status) m =
1244   error "socketToHandle not implemented in a parallel setup"
1245 #endif
1246 \end{code}
1247
1248 If you're using WinSock, the programmer has to call a startup
1249 routine before starting to use the goods. So, if you want to
1250 stay portable across all ghc-supported platforms, you have to
1251 use @withSocketsDo@...:
1252
1253 \begin{code}
1254 withSocketsDo :: IO a -> IO a
1255 #if !defined(HAVE_WINSOCK_H) || defined(cygwin32_TARGET_OS)
1256 withSocketsDo x = x
1257 #else
1258 withSocketsDo act = do
1259    x <- initWinSock
1260    if ( x /= 0 ) then
1261      ioError (userError "Failed to initialise WinSock")
1262     else do
1263       v <- act
1264       shutdownWinSock
1265       return v
1266
1267 foreign import "initWinSock" initWinSock :: IO Int
1268 foreign import "shutdownWinSock" shutdownWinSock :: IO ()
1269
1270 #endif
1271
1272 \end{code}