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