ghc/lib/ghc/SocketPrim.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
   3 %
   4 % Last Modified: Fri Jul 21 15:14:43 1995
   5 % Darren J Moffat <moffatd@dcs.gla.ac.uk>
   6 \section[SocketPrim]{Low-level socket bindings}
   7
   8 The @SocketPrim@ module is for when you want full control over the
   9 sockets, something like what you have in C (which is very messy).
  10
  11 \begin{code}
  12 module SocketPrim (
  13
  14     Socket,
  15     Family(..),
  16     SocketType(..),
  17     SockAddr(..),
  18     HostAddress(..),
  19
  20     socket,             -- :: Family -> SocketType -> Int -> IO Socket
  21     connect,            -- :: Socket -> SockAddr -> IO ()
  22     bindSocket,         -- :: Socket -> SockAddr -> IO ()
  23     listen,             -- :: Socket -> Int -> IO ()
  24     accept,             -- :: Socket -> IO (Socket, SockAddr)
  25     getPeerName,        -- :: Socket -> IO SockAddr
  26     getSocketName,      -- :: Socket -> IO SockAddr
  27
  28     socketPort,         -- :: Socket -> IO Int
  29
  30     writeSocket,        -- :: Socket -> String -> IO Int
  31     readSocket,         -- :: Socket -> Int -> IO (String, Int)
  32     readSocketAll,      -- :: Socket -> IO String
  33
  34     socketToHandle,     -- :: Socket -> IO Handle
  35
  36 -- Alternative read/write interface not yet implemented.
  37 --    sendto            -- :: Socket -> String -> SockAddr -> IO Int
  38 --    recvfrm           -- :: Socket -> Int -> SockAddr -> IO (String, Int)
  39 --    sendmsg           -- :: Socket -> Message -> MsgFlags -> IO Int
  40 --    recvmsg           -- :: Socket -> MsgFlags -> IO Message
  41
  42     shutdown,           -- :: Socket -> Int -> IO ()
  43     sClose,             -- :: Socket -> IO ()
  44
  45     inet_addr,          -- :: String -> HostAddress
  46     inet_ntoa,          -- :: HostAddress -> String
  47
  48     sIsConnected,       -- :: Socket -> IO Bool
  49     sIsBound,           -- :: Socket -> IO Bool
  50     sIsListening,       -- :: Socket -> IO Bool
  51     sIsReadable,        -- :: Socket -> IO Bool
  52     sIsWritable,        -- :: Socket -> IO Bool
  53
  54
  55 -- Special Constants
  56
  57     aNY_PORT,
  58     iNADDR_ANY,
  59 --    sOL_SOCKET,
  60     sOMAXCONN,
  61     maxListenQueue,
  62
  63
  64 -- The following are exported ONLY for use in the BSD module and
  65 -- should not be used else where.
  66
  67     packFamily, unpackFamily,
  68     packSocketType,
  69     packSockAddr, unpackSockAddr
  70
  71 ) where
  72
  73 import CError
  74 import LibPosix
  75 import LibPosixUtil
  76 import PreludeGlaST
  77 import PreludePrimIO    ( newEmptyMVar, putMVar, _MVar )
  78 import PreludeStdIO
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection[Socket-SocketTypes]{Socket Types}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88
  89 There are a few possible ways to do this.  The first is convert the
  90 structs used in the C library into an equivalent Haskell type.  An
  91 other possible implementation is to keep all the internals in the C
  92 code and use an Int\# and a status flag. The second method is used here
  93 since a lot of the C structures are not required to be manipulated.
  94 Originally the status was non mutable so we had to return a new socket
  95 each time we changed the status.  This version now uses mutable
  96 variables to avoid the need to do this.  The result is a cleaner
  97 interface and better security since the application programmer now
  98 can't circumvent the status information to perform invalid operations
  99 on sockets.
 100
 101
 102 \begin{code}
 103 data SocketStatus
 104   -- Returned Status    Function called
 105   = NotConnected        -- socket
 106   | Bound               -- bindSocket
 107   | Listening           -- listen
 108   | Connected           -- connect/accept
 109   | Error String        -- Any
 110   deriving (Eq, Text)
 111
 112 data Socket
 113   = MkSocket
 114      Int                                  -- File Descriptor Part
 115      Family
 116      SocketType
 117      Int                                  -- Protocol Number
 118      (MutableVar _RealWorld SocketStatus) -- Status Flag
 119 \end{code}
 120
 121 In C bind takes either a $struct sockaddr\_in$ or a $struct
 122 sockaddr\_un$ but these are always type cast to $struct sockaddr$.  We
 123 attempt to emulate this and provide better type checking. Note that
 124 the socket family fields are redundant since this is caputured in the
 125 constructor names, it has thus be left out of the Haskell $SockAddr$
 126 data type.
 127
 128
 129 \begin{code}
 130 type HostAddress = _Word
 131
 132 data SockAddr           -- C Names
 133   = SockAddrUnix        -- struct sockaddr_un
 134         String          -- sun_path
 135
 136   | SockAddrInet        -- struct sockaddr_in
 137         Int             -- sin_port
 138         HostAddress     -- sin_addr
 139
 140   deriving Eq
 141 \end{code}
 142
 143
 144
 145 %************************************************************************
 146 %*                                                                      *
 147 \subsection[Socket-Connections]{Connection Functions}
 148 %*                                                                      *
 149 %************************************************************************
 150
 151
 152 In the following connection and binding primitives.  The names of the
 153 equivalent C functions have been preserved where possible. It should
 154 be noted that some of these names used in the C library, bind in
 155 particular, have a different meaning to many Haskell programmers and
 156 have thus been renamed by appending the prefix Socket.
 157
 158 Create an unconnected socket of the given family, type and protocol.
 159 The most common invocation of $socket$ is the following:
 160 \begin{verbatim}
 161    ...
 162    socket AF_INET Stream 6      >>= \ my_socket ->
 163    ...
 164 \end{verbatim}
 165
 166 \begin{code}
 167 socket :: Family ->     -- Family Name (usually AF_INET)
 168           SocketType -> -- Socket Type (usually Stream)
 169           Int ->        -- Protocol Number (getProtocolByName to find value)
 170           IO Socket     -- Unconnected Socket
 171
 172 socket family stype protocol =
 173     _ccall_ socket (packFamily family) (packSocketType stype) protocol
 174                                                 `thenPrimIO` \ s ->
 175     if s == -1 then
 176         getCErrorCode                           `thenPrimIO` \ errno ->
 177         (case errno of
 178             EACCES ->
 179                 fail "socket: Permission Denied"
 180             EMFILE  ->
 181                 fail "socket: No more descriptiors available"
 182             ENFILE  ->
 183                 fail "socket: System file table is full"
 184             ENOBUFS  ->
 185                 fail "socket: Insufficient Buffer space to create socket"
 186             EPROTONOSUPPOR ->
 187                 fail ("socket: Protocol " ++ show protocol ++
 188                         " not supported for Family " ++ show family)
 189             EPROTOTYPE ->
 190                 fail ("socket: Protocol " ++ show protocol ++
 191                         " wrong type for socket")
 192             _   ->
 193                 fail ("socket: " ++ (errorCodeToStr errno))
 194         )
 195     else
 196         newVar NotConnected                     `thenPrimIO` \ status ->
 197         return (MkSocket s family stype protocol status)
 198 \end{code}
 199
 200 Given a port number this {\em binds} the socket to that port. This
 201 means that the programmer is only interested in data being sent to
 202 that port number. The $Family$ passed to $bindSocket$ must
 203 be the same as that passed to $socket$.  If the special port
 204 number $aNY\_PORT$ is passed then the system assigns the next
 205 available use port.
 206
 207 Port numbers for standard unix services can be found by calling
 208 $getServiceEntry$.  These are traditionally port numbers below
 209 1000; although there are afew, namely NFS and IRC, which used higher
 210 numbered ports.
 211
 212 The port number allocated to a socket bound by using $aNY\_PORT$ can be
 213 found by calling $port$
 214
 215 \begin{code}
 216 bindSocket :: Socket ->                 -- Unconnected Socket
 217               SockAddr ->               -- Address to Bind to
 218               IO ()
 219
 220 bindSocket (MkSocket s family stype protocol status) addr =
 221     readVar status                              `thenST` \ currentStatus ->
 222     if currentStatus /= NotConnected then
 223         fail ("bindSocket: can't peform bind on socket in status " ++
 224             show currentStatus)
 225     else
 226         packSockAddr addr                               `thenPrimIO` \ addr' ->
 227         let (_,sz) = boundsOfByteArray addr' in
 228         _casm_ ``%r = bind(%0, (struct sockaddr*)%1, %2);''
 229             s addr' sz                                  `thenPrimIO` \ result ->
 230         if result == -1 then
 231             getCErrorCode                               `thenPrimIO` \ errno ->
 232             (case errno of
 233             EACCES      ->
 234                 fail "bindSocket: The requested address is protected"
 235             EADDRINUSE ->
 236                 fail "bindSocket: Address in use by another process"
 237             EADDRNOTAVAIL ->
 238                 fail "bindSocket: Address not available"
 239             EBADF       ->
 240                 fail "bindSocket: invalid descriptor"
 241             EFAULT      ->
 242                 fail "bindSocket: name parameter not in vaild user address space"
 243             EINVAL      ->
 244                 fail "bindSocket: namelen invalid size for given family"
 245             ENOTSOCK ->
 246                 fail "bindSocket: attempt to bind a non socket descriptor"
 247             _           ->
 248                 fail ("bindSocket: " ++ (errorCodeToStr errno))
 249           )
 250         else
 251           writeVar status (Bound)                               `seqPrimIO`
 252           return ()
 253 \end{code}
 254
 255
 256 Make a connection to an already opened socket on a given machine and port.
 257 assumes that we have already called createSocket, othewise it will fail.
 258
 259 This is the dual to $bindSocket$.  The {\em server} process will
 260 usually bind to a port number, the {\em client} will then connect to
 261 the same port number.  Port numbers of user applications are normally
 262 agreed in advance, otherwise we must rely on some hacky mechanism for telling
 263 the {\em otherside} what port number we have been allocated.
 264
 265 \begin{code}
 266 connect :: Socket ->                    -- Unconnected Socket
 267            SockAddr ->                  -- Socket address stuff
 268            IO ()
 269
 270 connect (MkSocket s family stype protocol status) addr =
 271       readVar status                             `thenST` \ currentStatus ->
 272       if currentStatus /= NotConnected then
 273         fail ("connect: can't peform connect on socket in status " ++
 274               show currentStatus)
 275       else
 276         packSockAddr addr                               `thenPrimIO` \ addr' ->
 277         let (_,sz) = boundsOfByteArray addr' in
 278         _casm_ ``%r = connect(%0,(struct sockaddr*)%1, %2);''
 279                  s addr' sz                             `thenPrimIO` \ result ->
 280         if result == -1 then
 281           getCErrorCode                                 `thenPrimIO` \ errno ->
 282           (case errno of
 283             EADDRINUSE ->
 284                 fail "connect: address in use"
 285             EADDRNOTAVAIL ->
 286                 fail "connect: address not available on remote machine"
 287             EAFNOSUPPORT ->
 288                 fail "connect: invalid socket address family"
 289             EALREADY ->
 290                 fail ("connect: socket in non-blocking and previous " ++
 291                      "attempt to connect not yet complteted")
 292             EBADF ->
 293                 fail "connect: socket in not a vaild descriptor"
 294             ECONNREFUSED ->
 295                 fail "connect: connection refused by peer"
 296             EFAULT ->
 297                 fail "connect: address parameter outside process address space"
 298             EINPROGRESS ->
 299                 fail ("connect: socket is non-blocking and connection can " ++
 300                      "not be completed imediately")
 301             EINTR ->
 302                 fail "connect: connection interrupted before delivery signal"
 303             EINVAL ->
 304                 fail ("connect: namlen not size of valid address for " ++
 305                      "specified family")
 306             EISCONN ->
 307                 fail "connect: socket is already connected"
 308             ENETUNREACH ->
 309                 fail "connect: network unreachable"
 310             ENOTSOCK ->
 311                 fail "connect: file descriptor passed instead of socket"
 312             ETIMEDOUT ->
 313                 fail "connect: timed out without establishing connection"
 314             _   ->
 315                 fail ("connect: " ++ (errorCodeToStr errno))
 316           )
 317         else
 318           writeVar status (Connected)                   `seqPrimIO`
 319           return ()
 320
 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 status) backlog =
 339       readVar status                             `thenST` \ currentStatus ->
 340       if currentStatus /= Bound then
 341         fail ("listen: can't peform listen on socket in status " ++
 342               show currentStatus)
 343       else
 344         _ccall_ listen s backlog                        `thenPrimIO` \ result ->
 345         if result == -1 then
 346           getCErrorCode                                 `thenPrimIO` \ errno ->
 347           (case errno of
 348             EBADF ->
 349                 fail "listen: socket file descriptor invalid"
 350             ENOTSOCK ->
 351                 fail "listen: file descriptor is not a socket"
 352             EOPNOTSUPP ->
 353                 fail "listen: not supported fro this type of socket"
 354             _   ->
 355                 fail ("listen: " ++ (errorCodeToStr errno))
 356           )
 357         else
 358           writeVar status (Listening)                   `seqPrimIO`
 359           return ()
 360 \end{code}
 361
 362 A call to $accept$ only returns when data is available on the given
 363 socket, unless the socket has been set to non-blocking.  It will
 364 return a new socket which should be used to read the incoming data and
 365 should then be closed. Using the socket returned by $accept$ allows
 366 incoming requests to be queued on the original socket.
 367
 368
 369 \begin{code}
 370 accept :: Socket ->                     -- Queue Socket
 371           IO (Socket,                   -- Readable Socket
 372               SockAddr)                 -- Peer details
 373
 374 accept sock@(MkSocket s family stype protocol status) =
 375     readVar status                          `thenST` \ currentStatus ->
 376     sIsAcceptable sock                      >>= \ okay ->
 377     if not okay then
 378         fail ("accept: can't peform accept on socket in status " ++
 379               show currentStatus)
 380     else
 381         allocSockAddr family                    `thenPrimIO` \ (ptr, sz) ->
 382         _casm_ ``%r = accept(%0,(struct sockaddr*)%1, &%2);''
 383                 s ptr sz                                `thenPrimIO` \ sock ->
 384         if sock == -1 then
 385             getCErrorCode                               `thenPrimIO` \ errno ->
 386             (case errno of
 387                 EBADF ->
 388                     fail "accept: descriptor is invalid"
 389                 EFAULT ->
 390                     fail "accept: addr is not in writeable part of address space"
 391                 ENOTSOCK ->
 392                     fail "accept: descriptor is not a socket"
 393                 EOPNOTSUPP ->
 394                     fail ("accept: socket not of type" ++ show stype)
 395                 EWOULDBLOCK ->
 396                     fail "accept: would block"
 397                 _       ->
 398                     fail ("accept: " ++ (errorCodeToStr errno))
 399             )
 400         else
 401             unpackSockAddr ptr                  `thenPrimIO` \ addr ->
 402             newVar Connected                    `thenPrimIO` \ status ->
 403             return ((MkSocket sock family stype protocol status), addr)
 404 \end{code}
 405
 406 %************************************************************************
 407 %*                                                                      *
 408 \subsection[Socket-DataPass]{Data Passing Primitives}
 409 %*                                                                      *
 410 %************************************************************************
 411
 412 To allow Haskell to talk to C programs we need to beable to
 413 communicate interms of byte streams. $writeSocket$ and
 414 $readSocket$ should only be used for this purpose and not for
 415 communication between Haskell programs.  Haskell programs should use
 416 the 1.3 IO hPutStr and associated machinery for communicating with
 417 each other.
 418
 419
 420 \begin{code}
 421 writeSocket ::  Socket ->               -- Connected Socket
 422                 String ->               -- Data to send
 423                 IO Int          -- Number of Bytes sent
 424
 425 writeSocket (MkSocket s family stype protocol status) xs =
 426     readVar status                              `thenST` \ currentStatus ->
 427     if not ((currentStatus /= Connected) || (currentStatus /= Listening)) then
 428         fail ("writeSocket: can't peform write on socket in status " ++
 429             show currentStatus)
 430     else
 431         _ccall_ write s xs (length xs)          `thenPrimIO` \ nbytes ->
 432         if nbytes == -1 then
 433             getCErrorCode                       `thenPrimIO` \ errno ->
 434             (case errno of
 435                 EBADF ->
 436                     fail "writeSocket: invalid file descriptor"
 437                 EDQUOT ->
 438                     fail "writeSocket: disk quota exhausted"
 439                 EFAULT ->
 440                     fail "writeSocket: data area outside address space"
 441                 EFBIG ->
 442                     fail "writeSocket: max file size limit exeeded"
 443                 EINTR ->
 444                     fail "writeSocket: interupt received before data written"
 445                 EINVAL ->
 446                     fail ("writeSocket: The stream is linked below a " ++
 447                             "multiplexor. The fd pointer was negative")
 448                 ENOSPC ->
 449                     fail "writeSocket: no space left on device"
 450                 ENXIO ->
 451                     fail "writeSocket: hangup occured on stream"
 452                 EPIPE ->
 453                     fail "writeSocket: attempt to write to unopened pipe"
 454                 ERANGE ->
 455                     fail "writeSocket: to much data to write"
 456                 EWOULDBLOCK ->
 457                     fail "writeSocket: would block"
 458                 EAGAIN ->
 459                     fail "writeSocket: would block"
 460                 _ ->
 461                     fail ("writeSocket: " ++ (errorCodeToStr errno))
 462             )
 463         else
 464             return nbytes
 465
 466 readSocket :: Socket ->         -- Connected Socket
 467               Int ->            -- Number of Bytes to Read
 468               IO (String, Int)  -- (Data Read, Number of Bytes)
 469
 470 readSocket (MkSocket s family stype protocol status) nbytes =
 471     readVar status                              `thenST` \ currentStatus ->
 472     if not ((currentStatus /= Connected) || (currentStatus /= Listening)) then
 473         fail ("readSocket: can't perform read on socket in status " ++
 474             show currentStatus)
 475     else
 476 --      newCharArray (0, nbytes)                `thenPrimIO` \ ptr \ ->
 477         _casm_ ``%r = (char*)malloc(1+sizeof(char)*%0);''       nbytes
 478                                                 `thenPrimIO` \ buffer ->
 479         _ccall_ read s buffer nbytes            `thenPrimIO` \ result ->
 480         if result == -1 then
 481             getCErrorCode                       `thenPrimIO` \ errno ->
 482             (case errno of
 483                 EAGAIN ->
 484                     fail "readSocket: no data to read (non-blocking)"
 485                 EBADF ->
 486                     fail "readSocket: invalid file descriptor"
 487                 EBADMSG ->
 488                     fail "readSocket: not a valid data message"
 489                 EFAULT ->
 490                     fail "readSocket: buffer outside allocated address space"
 491                 EINTR ->
 492                     fail "readSocket: interupted by signal before data"
 493                 EINVAL ->
 494                     fail ("readSocket: The stream is linked below a " ++
 495                         "multiplexor. The file descriptor pointer was negative")
 496                 EIO ->
 497                     fail "readSocket: IO error"
 498                 EISDIR ->
 499                     fail "readSocket: descriptor is an NFS directory"
 500                 EWOULDBLOCK ->
 501                     fail "readSocket: would block"
 502                 _ ->
 503                     fail ("readSocket: "  ++ (errorCodeToStr errno))
 504             )
 505         else
 506             return (_unpackPS (_packCString buffer), result)
 507
 508
 509 readSocketAll :: Socket -> IO String
 510 readSocketAll s =
 511     let
 512       loop xs =
 513         readSocket s 4096                       >>= \ (str, nbytes) ->
 514         if nbytes /= 0 then
 515             loop (str ++ xs)
 516         else
 517             return xs
 518     in
 519         loop ""
 520 \end{code}
 521
 522 The port number the given socket is currently connected to can be
 523 determined by calling $port$, is generally only useful when bind
 524 was given $aNY\_PORT$.
 525
 526 \begin{code}
 527 socketPort :: Socket ->                 -- Connected & Bound Socket
 528               IO Int                    -- Port Number of Socket
 529 socketPort sock@(MkSocket s AF_INET stype protocol status) =
 530     getSocketName sock              >>= \ (SockAddrInet port _) ->
 531     return port
 532 socketPort (MkSocket s family stype protocol status) =
 533     fail ("socketPort: not supported for Family " ++ show family)
 534 \end{code}
 535
 536 Calling $getPeerName$ returns the address details of the machine,
 537 other than the local one, which is connected to the socket. This is
 538 used in programs such as FTP to determine where to send the returning
 539 data.  The corresponding call to get the details of the local machine
 540 is $getSocketName$.
 541
 542 \begin{code}
 543 getPeerName   :: Socket -> IO SockAddr
 544 getPeerName (MkSocket s family stype protocol status) =
 545     allocSockAddr family                            `thenPrimIO` \ (ptr,sz) ->
 546     _casm_ ``%r = getpeername(%0,(struct sockaddr*)%1,&%2);''
 547              s ptr sz                               `thenPrimIO` \ result ->
 548     if result == -1 then
 549         getCErrorCode                               `thenPrimIO` \ errno ->
 550         fail ("getPeerName: " ++ (errorCodeToStr errno))
 551     else
 552         unpackSockAddr ptr                          `thenPrimIO` \ addr ->
 553         return addr
 554
 555 getSocketName :: Socket -> IO SockAddr
 556 getSocketName (MkSocket s family stype protocol status) =
 557     allocSockAddr family                            `thenPrimIO` \ (ptr,sz) ->
 558     _casm_ ``%r = getsockname(%0,(struct sockaddr*)%1, &%2);''
 559             s ptr sz                                `thenPrimIO` \ result ->
 560     if result == -1 then
 561         getCErrorCode                               `thenPrimIO` \ errno ->
 562         fail ("getSocketName: " ++ (errorCodeToStr errno))
 563     else
 564         unpackSockAddr ptr                          `thenPrimIO` \ addr ->
 565         return addr
 566 \end{code}
 567
 568
 569 %************************************************************************
 570 %*                                                                      *
 571 \subsection[Socket-Properties]{Socket Properties}
 572 %*                                                                      *
 573 %************************************************************************
 574
 575 \begin{code}
 576 {-
 577 data SocketOption =
 578       Debug
 579     | AcceptConnection
 580     | ReuseAddr
 581     | KeepAlive
 582     | DontRoute
 583     | Broadcast
 584     | UseLoopBack
 585     | Linger
 586     | OOBInline
 587     | SendBuffer
 588     | RecvBuffer
 589     | SendLowWater
 590     | RecvLowWater
 591     | SendTimeOut
 592     | RecvTimeOut
 593     | Error
 594     | Type
 595
 596 sOL_SOCKET = ``SOL_SOCKET''
 597
 598 setSocketOptions :: Socket ->
 599                     Int ->              -- Level
 600                     SocketOption ->     -- Option Name
 601                     String ->           -- Option Value
 602                     IO ()
 603
 604 getSocketOptons :: Socket ->
 605                    Int ->               -- Level
 606                    SocketOption ->      -- Option Name
 607                    IO String            -- Option Value
 608 -}
 609 \end{code}
 610
 611 A calling sequence table for the main functions is shown in the table below.
 612
 613 \begin{figure}[h]
 614 \begin{center}
 615 \begin{tabular}{|l|c|c|c|c|c|c|c|}
 616 \hline
 617 {\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\
 618 \hline
 619 {\bf Precedes} & & & & & & & \\
 620 \hline
 621 socket &        &         &            &        &        &      & \\
 622 \hline
 623 connect & +     &         &            &        &        &      & \\
 624 \hline
 625 bindSocket & +  &         &            &        &        &      & \\
 626 \hline
 627 listen &        &         & +          &        &        &      & \\
 628 \hline
 629 accept &        &         &            &  +     &        &      & \\
 630 \hline
 631 read   &        &   +     &            &  +     &  +     &  +   & + \\
 632 \hline
 633 write  &        &   +     &            &  +     &  +     &  +   & + \\
 634 \hline
 635 \end{tabular}
 636 \caption{Sequence Table for Major functions of Socket}
 637 \label{tab:api-seq}
 638 \end{center}
 639 \end{figure}
 640
 641 %************************************************************************
 642 %*                                                                      *
 643 \subsection[Socket-OSDefs]{OS Dependent Definitions}
 644 %*                                                                      *
 645 %************************************************************************
 646
 647
 648 The following Family and Socket Type declarations were manually derived
 649 from /usr/include/sys/socket.h on the appropriate machines.
 650
 651 Maybe a configure script that could parse the socket.h file to produce
 652 the following declaration is required to make it ``portable'' rather than
 653 using the dreaded \#ifdefs.
 654
 655 Presently only the following machine/os combinations are supported:
 656
 657 \begin{itemize}
 658 \item Intelx86/Linux
 659 \item SPARC/SunOS
 660 \item SPARC/Solaris
 661 \item Alpha/OSF
 662 \end{itemize}
 663
 664 \begin{code}
 665 unpackFamily    :: Int -> Family
 666 packFamily      :: Family -> Int
 667
 668 packSocketType  :: SocketType -> Int
 669 #ifdef sun
 670
 671 data Family =
 672           AF_UNSPEC     -- unspecified
 673         | AF_UNIX       -- local to host (pipes, portals
 674         | AF_INET       -- internetwork: UDP, TCP, etc
 675         | AF_IMPLINK    -- arpanet imp addresses
 676         | AF_PUP        -- pup protocols: e.g. BSP
 677         | AF_CHAOS      -- mit CHAOS protocols
 678         | AF_NS         -- XEROX NS protocols
 679         | AF_NBS        -- nbs protocols
 680         | AF_ECMA       -- european computer manufacturers
 681         | AF_DATAKIT    -- datakit protocols
 682         | AF_CCITT      -- CCITT protocols, X.25 etc
 683         | AF_SNA        -- IBM SNA
 684         | AF_DECnet     -- DECnet
 685         | AF_DLI        -- Direct data link interface
 686         | AF_LAT        -- LAT
 687         | AF_HYLINK     -- NSC Hyperchannel
 688         | AF_APPLETALK  -- Apple Talk
 689         | AF_NIT        -- Network Interface Tap
 690         | AF_802        -- IEEE 80.2, also ISO 8802
 691         | AF_OSI        -- umberella of all families used by OSI
 692         | AF_X25        -- CCITT X.25
 693         | AF_OSINET     -- AFI
 694         | AF_GOSSIP     -- US Government OSI
 695         | AF_IPX        -- Novell Internet Protocol
 696         deriving (Eq, Ord, Ix, Text)
 697
 698 packFamily = index (AF_UNSPEC, AF_IPX)
 699 unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
 700
 701 #endif
 702
 703 #ifdef __alpha__
 704
 705 data Family =
 706           AF_UNSPEC     -- unspecified
 707         | AF_UNIX       -- local to host (pipes, portals)
 708         | AF_INET       -- internetwork: UDP, TCP, etc.
 709         | AF_IMPLINK    -- arpanet imp addresses
 710         | AF_PUP        -- pup protocols: e.g. BSP
 711         | AF_CHAOS      -- mit CHAOS protocols
 712         | AF_NS         -- XEROX NS protocols
 713         | AF_ISO        -- ISO protocols
 714         | AF_ECMA       -- european computer manufacturers
 715         | AF_DATAKIT    -- datakit protocols
 716         | AF_CCITT      -- CCITT protocols, X.25 etc
 717         | AF_SNA        -- IBM SNA
 718         | AF_DECnet     -- DECnet
 719         | AF_DLI        -- DEC Direct data link interface
 720         | AF_LAT        -- LAT
 721         | AF_HYLINK     -- NSC Hyperchannel
 722         | AF_APPLETALK  -- Apple Talk
 723         | AF_ROUTE      -- Internal Routing Protocol
 724         | AF_LINK       -- Link layer interface
 725         | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
 726         | AF_NETMAN     -- DNA Network Management
 727         | AF_X25        -- X25 protocol
 728         | AF_CTF        -- Common Trace Facility
 729         | AF_WAN        -- Wide Area Network protocols
 730         deriving (Eq, Ord, Ix, Text)
 731
 732 packFamily = index (AF_UNSPEC, AF_WAN)
 733 unpackFamily family = (range (AF_UNSPEC, AF_WAN))!!family
 734 #endif
 735
 736
 737 #ifdef linux
 738 data Family =
 739           AF_UNSPEC
 740         | AF_UNIX
 741         | AF_INET
 742         | AF_AX25
 743         | AF_IPX
 744         deriving (Eq, Ord, Ix, Text)
 745
 746 packFamily = index (AF_UNSPEC, AF_IPX)
 747 unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
 748
 749 #endif
 750
 751 -- Alpha running OSF or a SPARC with SunOS, rather than Solaris.
 752
 753 #if __alpha__ || (sun && !__svr4__)
 754 data SocketType =
 755           Stream
 756         | Datagram
 757         | Raw
 758         | RDM
 759         | SeqPacket
 760         deriving (Eq, Ord, Ix, Text)
 761
 762 packSocketType stype = 1 + (index (Stream, SeqPacket) stype)
 763 #endif
 764
 765 -- This is a Sun running Solaris rather than SunOS
 766
 767 #if sun && __svr4__
 768 data SocketType =
 769           Datagram
 770         | Stream
 771         | NC_TPI_COTS_ORD
 772         | Raw
 773         | RDM
 774         | SeqPacket
 775         deriving (Eq, Ord, Ix, Text)
 776
 777 packSocketType stype = 1 + (index (Datagram, SeqPacket) stype)
 778 #endif
 779
 780
 781 #if linux
 782 data SocketType =
 783           Stream
 784         | Datagram
 785         | Raw
 786         | RDM
 787         | SeqPacket
 788         | Packet
 789         deriving (Eq, Ord, Ix, Text)
 790
 791 packSocketType stype = 1 + (index (Stream, Packet) stype)
 792 #endif
 793 \end{code}
 794
 795 %************************************************************************
 796 %*                                                                      *
 797 \subsection[Socket-Util]{Utility Functions}
 798 %*                                                                      *
 799 %************************************************************************
 800
 801 \begin{code}
 802 aNY_PORT = 0::Int
 803 iNADDR_ANY = ``INADDR_ANY''::_Word
 804 sOMAXCONN = ``SOMAXCONN''::Int
 805 maxListenQueue = sOMAXCONN
 806
 807 -------------------------------------------------------------------------------
 808 shutdown :: Socket -> Int -> IO ()
 809 shutdown (MkSocket s family stype protocol status) t =
 810     primIOToIO (_ccall_ shutdown s t)
 811
 812 -------------------------------------------------------------------------------
 813
 814 sClose   :: Socket -> IO ()
 815 sClose (MkSocket s family stype protocol status) =
 816     primIOToIO (_ccall_ close s)
 817
 818 -------------------------------------------------------------------------------
 819
 820 inet_addr :: String -> HostAddress
 821 inet_addr ipstr = unsafePerformPrimIO (_ccall_ inet_addr ipstr)
 822
 823 -------------------------------------------------------------------------------
 824
 825 inet_ntoa :: HostAddress -> String
 826 inet_ntoa haddr = unsafePerformPrimIO (
 827     _casm_ ``struct in_addr addr;
 828              addr.s_addr = htonl(%0);
 829              %r = inet_ntoa (addr);'' haddr    `thenPrimIO` \ str ->
 830     returnPrimIO (_unpackPS (_packCString str)))
 831
 832 -------------------------------------------------------------------------------
 833
 834 sIsConnected :: Socket -> IO Bool
 835 sIsConnected (MkSocket s family stype protocol status) =
 836     readVar status                      `thenST` \ value ->
 837     return (value == Connected)
 838
 839 -------------------------------------------------------------------------------
 840
 841 sIsBound :: Socket -> IO Bool
 842 sIsBound (MkSocket s family stype protocol status) =
 843     readVar status                      `thenST` \ value ->
 844     return (value == Bound)
 845
 846 -------------------------------------------------------------------------------
 847
 848 sIsListening :: Socket -> IO Bool
 849 sIsListening (MkSocket s family stype protocol status) =
 850     readVar status                      `thenST` \ value ->
 851     return (value == Listening)
 852
 853 -------------------------------------------------------------------------------
 854
 855 sIsReadable  :: Socket -> IO Bool
 856 sIsReadable (MkSocket s family stype protocol status) =
 857     readVar status                      `thenST` \ value ->
 858     return (value == Listening || value == Connected)
 859
 860 -------------------------------------------------------------------------------
 861
 862 sIsWritable  :: Socket -> IO Bool
 863 sIsWritable = sIsReadable
 864
 865 -------------------------------------------------------------------------------
 866
 867 sIsAcceptable :: Socket -> IO Bool
 868 sIsAcceptable (MkSocket s AF_UNIX Stream protocol status) =
 869     readVar status                      `thenST` \ value ->
 870     return (value == Connected || value == Bound || value == Listening)
 871 sIsAcceptable (MkSocket s AF_UNIX _ protocol status) =
 872     return False
 873 sIsAcceptable (MkSocket s _ stype protocol status) =
 874     readVar status                      `thenST` \ value ->
 875     return (value == Connected || value == Listening)
 876
 877 -------------------------------------------------------------------------------
 878
 879 {-
 880 sSetBlocking :: Socket -> Bool -> IO ()
 881 sIsBlocking  :: Socket -> IO Bool
 882 -}
 883
 884 -------------------------------------------------------------------------------
 885
 886 allocSockAddr :: Family -> PrimIO (_MutableByteArray _RealWorld Int, Int)
 887 allocSockAddr AF_UNIX =
 888     newCharArray (0,``sizeof(struct sockaddr_un)'')     `thenPrimIO` \ ptr ->
 889     let
 890         (_,sz) = boundsOfByteArray ptr
 891     in
 892     returnPrimIO (ptr, sz)
 893 allocSockAddr AF_INET =
 894     newCharArray (0,``sizeof(struct sockaddr_in)'')     `thenPrimIO` \ ptr ->
 895     let
 896         (_,sz) = boundsOfByteArray ptr
 897     in
 898     returnPrimIO (ptr, sz)
 899
 900 -------------------------------------------------------------------------------
 901
 902 unpackSockAddr :: _MutableByteArray _RealWorld Int -> PrimIO SockAddr
 903 unpackSockAddr arr =
 904     _casm_ ``%r = ((struct sockaddr*)%0)->sa_family;'' arr `thenPrimIO` \ fam ->
 905     case unpackFamily fam of
 906         AF_UNIX -> unpackSockAddrUnix arr
 907         AF_INET -> unpackSockAddrInet arr
 908
 909 -------------------------------------------------------------------------------
 910
 911 unpackSockAddrUnix :: (_MutableByteArray _RealWorld Int) -> PrimIO SockAddr
 912 unpackSockAddrUnix ptr =
 913     _casm_ ``%r = ((struct sockaddr_un*)%0)->sun_path;'' ptr
 914                                                 `thenPrimIO` \ str ->
 915     strcpy str                                  `thenPrimIO` \ path ->
 916     returnPrimIO (SockAddrUnix path)
 917
 918 -------------------------------------------------------------------------------
 919
 920 unpackSockAddrInet :: (_MutableByteArray _RealWorld Int) -> PrimIO SockAddr
 921 unpackSockAddrInet ptr =
 922     _casm_ ``%r = ntohs(((struct sockaddr_in*)%0)->sin_port);'' ptr
 923                                                 `thenPrimIO` \ port ->
 924     _casm_ ``%r = ntohl(((struct sockaddr_in*)%0)->sin_addr.s_addr);'' ptr
 925                                                 `thenPrimIO` \ address ->
 926     returnPrimIO (SockAddrInet port address)
 927
 928 -------------------------------------------------------------------------------
 929
 930
 931 packSockAddr :: SockAddr -> PrimIO (_MutableByteArray _RealWorld Int)
 932 packSockAddr (SockAddrUnix path) =
 933     allocSockAddr AF_UNIX                               `thenPrimIO` \ (ptr,_) ->
 934     _casm_ ``(((struct sockaddr_un *)%0)->sun_family) = AF_UNIX;''
 935                 ptr                                     `thenPrimIO` \ () ->
 936     _casm_ ``strcpy ((((struct sockaddr_un *)%0)->sun_path),%1);''
 937                 ptr path                                `thenPrimIO` \ () ->
 938     returnPrimIO ptr
 939
 940 packSockAddr (SockAddrInet port address) =
 941     allocSockAddr AF_INET                               `thenPrimIO` \ (ptr,_) ->
 942     _casm_ ``(((struct sockaddr_in *)%0)->sin_family) = AF_INET;''
 943                 ptr                                     `thenPrimIO` \ () ->
 944     _casm_ ``(((struct sockaddr_in *)%0)->sin_port) = htons((int)%1);''
 945                 ptr port                                `thenPrimIO` \ () ->
 946     _casm_ ``(((struct sockaddr_in *)%0)->sin_addr.s_addr) = htonl(%1);''
 947                 ptr address                             `thenPrimIO` \ () ->
 948     returnPrimIO ptr
 949
 950 -------------------------------------------------------------------------------
 951
 952 socketToHandle :: Socket -> IO Handle
 953 socketToHandle (MkSocket s family stype protocol status) =
 954     _casm_ ``%r = fdopen (%0, "r+");'' s     `thenPrimIO` \ ptr ->
 955     newEmptyMVar                             >>= \ handle ->
 956     putMVar handle (_SocketHandle ptr False) >>
 957     return handle
 958
 959 -------------------------------------------------------------------------------
 960 \end{code}