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