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