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