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