[project @ 1999-07-29 13:57:34 by sof]
[ghc-hetmet.git] / ghc / lib / misc / SocketPrim.lhs
index 3ec51fd..809cd85 100644 (file)
@@ -1,10 +1,10 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1995-1998
 %
 \section[SocketPrim]{Low-level socket bindings}
 
 The @SocketPrim@ module is for when you want full control over the
-sockets, something like what you have in C (which is very messy).
+sockets, exposing the C socket API.
 
 \begin{code}      
 {-# OPTIONS -#include "stgio.h" -#include "cbits/ghcSockets.h" #-}
@@ -19,8 +19,9 @@ module SocketPrim (
     SockAddr(..),
     HostAddress,
     ShutdownCmd(..),
+    ProtocolNumber,
 
-    socket,            -- :: Family -> SocketType -> Int -> IO Socket 
+    socket,            -- :: Family -> SocketType -> ProtocolNumber -> IO Socket 
     connect,           -- :: Socket -> SockAddr -> IO ()
     bindSocket,                -- :: Socket -> SockAddr -> IO ()
     listen,            -- :: Socket -> Int -> IO ()
@@ -28,7 +29,7 @@ module SocketPrim (
     getPeerName,       -- :: Socket -> IO SockAddr
     getSocketName,     -- :: Socket -> IO SockAddr
 
-    socketPort,                -- :: Socket -> IO Int
+    socketPort,                -- :: Socket -> IO PortNumber
 
     writeSocket,       -- :: Socket -> String -> IO Int
     readSocket,                -- :: Socket -> Int -> IO (String, Int)
@@ -36,56 +37,66 @@ module SocketPrim (
 
     socketToHandle,    -- :: Socket -> IO Handle
 
--- Alternative read/write interface not yet implemented.
---    sendto           -- :: Socket -> String -> SockAddr -> IO Int
---    recvfrm          -- :: Socket -> Int -> SockAddr -> IO (String, Int)
+    sendTo,            -- :: Socket -> String -> SockAddr -> IO Int
+    recvFrom,          -- :: Socket -> Int -> IO (String, Int, SockAddr)
 --    sendmsg          -- :: Socket -> Message -> MsgFlags -> IO Int
 --    recvmsg          -- :: Socket -> MsgFlags -> IO Message
 
-    shutdown,          -- :: Socket -> ShutdownCmd -> IO ()
-    sClose,            -- :: Socket -> IO ()
 
-    inet_addr,         -- :: String -> HostAddress
-    inet_ntoa,         -- :: HostAddress -> String
+    inet_addr,         -- :: String -> IO HostAddress
+    inet_ntoa,         -- :: HostAddress -> IO String
 
     sIsConnected,      -- :: Socket -> IO Bool
     sIsBound,          -- :: Socket -> IO Bool
     sIsListening,      -- :: Socket -> IO Bool 
     sIsReadable,       -- :: Socket -> IO Bool
     sIsWritable,       -- :: Socket -> IO Bool
+    shutdown,          -- :: Socket -> ShutdownCmd -> IO ()
+    sClose,            -- :: Socket -> IO ()
+
+    -- socket opts
+    SocketOption(..),
+    getSocketOption,     -- :: Socket -> SocketOption -> IO Int
+    setSocketOption,     -- :: Socket -> SocketOption -> Int -> IO ()
 
+    PortNumber(..),
+    mkPortNumber,          -- :: Int -> PortNumber
 
 -- Special Constants
 
     aNY_PORT,
     iNADDR_ANY,
---    sOL_SOCKET,
     sOMAXCONN,
     maxListenQueue,
 
 
 -- The following are exported ONLY for use in the BSD module and
--- should not be used else where.
+-- should not be used anywhere else.
 
     packFamily, unpackFamily,
     packSocketType,
     packSockAddr, unpackSockAddr
 
+    , withSocketsDo  -- :: IO a -> IO a
+
 ) where
  
 import GlaExts
 import ST
+import Ix
+import Weak        ( addForeignFinalizer )
 import PrelIOBase  -- IOError, Handle representation
 import PrelHandle
 import Foreign
+import Addr        ( nullAddr )
 
-import Posix
-import PosixUtil
 import IO
 import IOExts      ( IORef, newIORef, readIORef, writeIORef )
-import PackedString ( unpackPS, byteArrayToPS, unpackCString, packCBytesST )
-
-import Ix
+import CString      ( unpackNBytesBAIO,
+                     unpackCStringIO,
+                     unpackCStringLenIO,
+                     allocChars
+                   )
 \end{code}
 
 
@@ -101,13 +112,13 @@ structs used in the C library into an equivalent Haskell type.    An
 other possible implementation is to keep all the internals in the C
 code and use an Int\# and a status flag. The second method is used here
 since a lot of the C structures are not required to be manipulated.
-Originally the status was non mutable so we had to return a new socket
+
+Originally the status was non-mutable so we had to return a new socket
 each time we changed the status.  This version now uses mutable
 variables to avoid the need to do this.         The result is a cleaner
 interface and better security since the application programmer now
 can't circumvent the status information to perform invalid operations
-on sockets.          
-
+on sockets.
 
 \begin{code}  
 data SocketStatus
@@ -117,20 +128,21 @@ data SocketStatus
   | Listening          -- listen
   | Connected          -- connect/accept
   | Error String       -- Any
-  deriving (Eq, Show)
+    deriving (Eq, Show)
 
 data Socket
-  = MkSocket 
-     Int                                 -- File Descriptor Part
-     Family                              
-     SocketType                                  
-     Int                                 -- Protocol Number
-     (IORef SocketStatus) -- Status Flag
+  = MkSocket
+           Int                  -- File Descriptor
+           Family                                
+           SocketType                            
+           Int                  -- Protocol Number
+           (IORef SocketStatus) -- Status Flag
 \end{code}
 
 The scheme used for addressing sockets is somewhat quirky. The
 calls in the BSD socket API that need to know the socket address all
 operate in terms of \tr{struct sockaddr}, a `virtual' type of socket address. 
+
 The Internet family of sockets are addressed as \tr{struct sockaddr\_in},
 so when calling functions that operate on \tr{struct sockaddr}, we have
 to type cast the Internet socket address into a \tr{struct sockaddr}. By luck(!),
@@ -142,20 +154,59 @@ and use a union/algebraic type for the different families. Currently only
 Unix domain sockets and the Internet family is supported.
 
 \begin{code}
+
+-- NOTE: HostAddresses are represented in network byte order.
+--       Functions that expect the address in machine byte order
+--       will have to perform the necessary translation.
 type HostAddress = Word
 
+--
+-- newtyped to prevent accidental use of sane-looking
+-- port numbers that haven't actually been converted to
+-- network-byte-order first.
+--
+newtype PortNumber = PNum Int  -- 16-bit value stored in network byte order.
+                    deriving ( Eq )
+
+instance Show PortNumber where
+  showsPrec p pn = showsPrec p (ntohs pn)
+
+mkPortNumber :: Int -> PortNumber
+mkPortNumber v = unsafePerformIO $ do
+   po <- _casm_ ``%r=(int)htons((int)%0); '' v
+   return (PNum po)
+
+ntohs :: PortNumber -> Int
+ntohs (PNum po) = unsafePerformIO (_casm_ ``%r=(int)ntohs((int)%0); '' po)
+
+instance Num PortNumber where
+   fromInt     i = mkPortNumber i
+   fromInteger i = fromInt (fromInteger i)
+    -- for completeness.
+   (+) x y   = mkPortNumber (ntohs x + ntohs y)
+   (-) x y   = mkPortNumber (ntohs x - ntohs y)
+   negate x  = mkPortNumber (-ntohs x)
+   (*) x y   = mkPortNumber (ntohs x * ntohs y)
+   abs n     = mkPortNumber (abs (ntohs n))
+   signum n  = mkPortNumber (signum (ntohs n))
+
 data SockAddr          -- C Names                              
-#ifndef cygwin32_TARGET_OS
-  = SockAddrUnix       -- struct sockaddr_un
-       String          -- sun_path
-  |
+#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
+  = SockAddrUnix        -- struct sockaddr_un
+        String          -- sun_path
+  | SockAddrInet       -- struct sockaddr_in
+       PortNumber      -- sin_port  (network byte order)
+       HostAddress     -- sin_addr  (ditto)
 #else
-  =
+  = SockAddrInet       -- struct sockaddr_in
+       PortNumber      -- sin_port  (network byte order)
+       HostAddress     -- sin_addr  (ditto)
+
 #endif
-    SockAddrInet       -- struct sockaddr_in
-       Int             -- sin_port
-       HostAddress     -- sin_addr
-  deriving Eq
+    deriving Eq
+
+type ProtocolNumber = Int
+
 \end{code}
 
 
@@ -173,23 +224,24 @@ have thus been renamed by appending the prefix Socket.
 
 Create an unconnected socket of the given family, type and protocol.
 The most common invocation of $socket$ is the following:
+
 \begin{verbatim}
    ...
-   socket AF_INET Stream 6     >>= \ my_socket ->
+   my_socket <- socket AF_INET Stream 6
    ...
 \end{verbatim}
 
 \begin{code}      
-socket :: Family       -- Family Name (usually AF_INET)
-       -> SocketType   -- Socket Type (usually Stream)
-       -> Int          -- Protocol Number (getProtocolByName to find value)
-       -> IO Socket    -- Unconnected Socket
+socket :: Family        -- Family Name (usually AF_INET)
+       -> SocketType    -- Socket Type (usually Stream)
+       -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
+       -> IO Socket     -- Unconnected Socket
 
 socket family stype protocol = do
     status <- _ccall_ createSocket (packFamily family) 
-                        (packSocketType stype) 
-                        protocol
-    case status of
+                                  (packSocketType stype) 
+                                  protocol
+    case (status::Int) of
       -1 -> constructErrorAndFail "socket"
       n  -> do
        socket_status <- newIORef NotConnected
@@ -216,29 +268,29 @@ bindSocket :: Socket      -- Unconnected Socket
           -> SockAddr  -- Address to Bind to
           -> IO ()
 
-bindSocket (MkSocket s family stype protocol socketStatus) addr = do
-#ifndef cygwin32_TARGET_OS
- let isDomainSocket = if family == AF_UNIX then 1 else (0::Int)
+bindSocket (MkSocket s _family _stype _protocol socketStatus) addr = do
+#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
+ let isDomainSocket = if _family == AF_UNIX then 1 else (0::Int)
 #else
  let isDomainSocket = 0
 #endif
  currentStatus <- readIORef socketStatus
  if currentStatus /= NotConnected 
   then
-   fail (userError ("bindSocket: can't peform bind on socket in status " ++
+   ioError (userError ("bindSocket: can't peform bind on socket in status " ++
         show currentStatus))
   else do
    addr' <- packSockAddr addr
-   let (_,sz) = boundsOfByteArray addr'
-   status <- _ccall_ bindSocket s addr' sz isDomainSocket
-   case status of
+   let (_,sz) = boundsOfMutableByteArray addr'
+   status <- _ccall_ bindSocket s addr' sz (isDomainSocket::Int)
+   case (status::Int) of
      -1 -> constructErrorAndFail "bindSocket"
-     0  -> writeIORef socketStatus (Bound)
+     _  -> writeIORef socketStatus (Bound)
 \end{code}
        
 
 Make a connection to an already opened socket on a given machine and port.
-assumes that we have already called createSocket, othewise it will fail.
+assumes that we have already called createSocket, otherwise it will fail.
                        
 This is the dual to $bindSocket$.  The {\em server} process will
 usually bind to a port number, the {\em client} will then connect to 
@@ -251,24 +303,24 @@ connect :: Socket -- Unconnected Socket
        -> SockAddr     -- Socket address stuff
        -> IO ()
 
-connect (MkSocket s family stype protocol socketStatus) addr = do
-#ifndef cygwin32_TARGET_OS
- let isDomainSocket = if family == AF_UNIX then 1 else (0::Int)
+connect (MkSocket s _family _stype _protocol socketStatus) addr = do
+#ifndef _WIN32
+ let isDomainSocket = if _family == AF_UNIX then 1 else (0::Int)
 #else
  let isDomainSocket = 0
 #endif
  currentStatus <- readIORef socketStatus
  if currentStatus /= NotConnected 
   then
-   fail (userError ("connect: can't peform connect on socket in status " ++
+   ioError (userError ("connect: can't peform connect on socket in status " ++
          show currentStatus))
   else do
    addr' <- packSockAddr addr
-   let (_,sz) = boundsOfByteArray addr'
-   status <- _ccall_ connectSocket s addr' sz isDomainSocket
-   case status of
+   let (_,sz) = boundsOfMutableByteArray addr'
+   status <- _ccall_ connectSocket s addr' sz (isDomainSocket::Int)
+   case (status::Int) of
      -1 -> constructErrorAndFail "connect"
-     0 -> writeIORef socketStatus Connected
+     _  -> writeIORef socketStatus Connected
 \end{code}
        
 The programmer must call $listen$ to tell the system software
@@ -286,17 +338,17 @@ listen :: Socket  -- Connected & Bound Socket
        -> Int    -- Queue Length
        -> IO ()
 
-listen (MkSocket s family stype protocol socketStatus) backlog = do
+listen (MkSocket s _family _stype _protocol socketStatus) backlog = do
  currentStatus <- readIORef socketStatus
  if currentStatus /= Bound 
    then
-    fail (userError ("listen: can't peform listen on socket in status " ++
+    ioError (userError ("listen: can't peform listen on socket in status " ++
           show currentStatus))
    else do
     status <- _ccall_ listenSocket s backlog
-    case status of
+    case (status::Int) of
       -1 -> constructErrorAndFail "listen"
-      0  -> writeIORef socketStatus Listening
+      _  -> writeIORef socketStatus Listening
 \end{code}
 
 A call to $accept$ only returns when data is available on the given
@@ -315,20 +367,20 @@ accept sock@(MkSocket s family stype protocol status) = do
  okay <- sIsAcceptable sock
  if not okay
    then
-     fail (userError ("accept: can't peform accept on socket in status " ++
+     ioError (userError ("accept: can't peform accept on socket in status " ++
         show currentStatus))
    else do
      (ptr, sz) <- allocSockAddr family
-     int_star <- stToIO (newIntArray (0,1))
+     int_star <- stToIO (newIntArray ((0::Int),1))
      stToIO (writeIntArray int_star 0 sz)
-     sock <- _ccall_ acceptSocket s ptr int_star
-     case sock of
+     new_sock <- _ccall_ acceptSocket s ptr int_star
+     case (new_sock::Int) of
          -1 -> constructErrorAndFail "accept"
          _  -> do
-               sz <- stToIO (readIntArray int_star 0)
-               addr <- unpackSockAddr ptr sz
-               status <- newIORef Connected
-               return ((MkSocket sock family stype protocol status), addr)
+               a_sz <- stToIO (readIntArray int_star 0)
+               addr <- unpackSockAddr ptr a_sz
+               new_status <- newIORef Connected
+               return ((MkSocket new_sock family stype protocol new_status), addr)
 \end{code}
 
 %************************************************************************
@@ -350,36 +402,57 @@ writeSocket :: Socket     -- Connected Socket
            -> String   -- Data to send
            -> IO Int   -- Number of Bytes sent
 
-writeSocket (MkSocket s family stype protocol status) xs = do
+writeSocket (MkSocket s _family _stype _protocol status) xs = do
  currentStatus <- readIORef status
- if not ((currentStatus /= Connected) || (currentStatus /= Listening)) 
+ if not ((currentStatus == Connected) || (currentStatus == Listening))
    then
-    fail (userError ("writeSocket: can't peform write on socket in status " ++
+    ioError (userError ("writeSocket: can't peform write on socket in status " ++
           show currentStatus))
    else do
     nbytes <- _ccall_ writeDescriptor s xs (length xs)
-    case nbytes of
+    case (nbytes::Int) of
       -1 -> constructErrorAndFail "writeSocket"
       _  -> return nbytes
 
-readSocket :: Socket           -- Connected Socket
+
+sendTo :: Socket       -- Bound/Connected Socket
+       -> String       -- Data to send
+       -> SockAddr
+       -> IO Int       -- Number of Bytes sent
+
+sendTo (MkSocket s _family _stype _protocol status) xs addr = do
+ currentStatus <- readIORef status
+ if not ((currentStatus == Connected) || (currentStatus == Listening) || (currentStatus == Bound))
+   then
+    ioError (userError ("sendTo: can't peform write on socket in status " ++
+          show currentStatus))
+   else do
+    addr' <- packSockAddr addr
+    let (_,sz) = boundsOfMutableByteArray addr'
+    nbytes <- _ccall_ sendTo__ s xs (length xs) addr' sz
+    case (nbytes::Int) of
+      -1 -> constructErrorAndFail "sendTo"
+      _  -> return nbytes
+
+readSocket :: Socket           -- Connected (or bound) Socket
           -> Int               -- Number of Bytes to Read
           -> IO (String, Int)  -- (Data Read, Number of Bytes)
 
-readSocket (MkSocket s family stype protocol status) nbytes = do
+readSocket (MkSocket s _family _stype _protocol status) nbytes = do
  currentStatus <- readIORef status
- if not ((currentStatus /= Connected) || (currentStatus /= Listening))
+ if not ((currentStatus == Connected) || (currentStatus == Listening))
    then
-    fail (userError ("readSocket: can't perform read on socket in status " ++
+    ioError (userError ("readSocket: can't perform read on socket in status " ++
          show currentStatus))
    else do
-    ptr <- stToIO (newCharArray (0, nbytes))
-    nbytes <- _ccall_ readDescriptor s ptr nbytes
-    case nbytes of
+    ptr  <- allocChars nbytes
+    rlen <- _ccall_ readDescriptor s ptr nbytes
+    case (rlen::Int) of
       -1 -> constructErrorAndFail "readSocket"
       n  -> do
            barr <- stToIO (unsafeFreezeByteArray ptr)
-            return (unpackPS (byteArrayToPS barr), n)
+           str  <- unpackNBytesBAIO barr n
+            return (str, n)
 
 readSocketAll :: Socket -> IO String
 readSocketAll s =
@@ -394,6 +467,26 @@ readSocketAll s =
        (\ _ -> return xs)
     in
        loop ""
+
+recvFrom :: Socket -> Int -> IO (String, Int, SockAddr)
+recvFrom (MkSocket s _family _stype _protocol status) nbytes = do
+ currentStatus <- readIORef status
+ if not ((currentStatus == Connected) || (currentStatus == Listening) || (currentStatus == Bound))
+   then
+    ioError (userError ("recvFrom: can't perform read on socket in status " ++
+         show currentStatus))
+   else do
+    ptr    <- allocChars nbytes 
+    (ptr_addr,_) <- allocSockAddr AF_INET
+    rlen   <- _ccall_ recvFrom__ s ptr nbytes ptr_addr
+    case (rlen::Int) of
+      -1 -> constructErrorAndFail "recvFrom"
+      n  -> do
+           barr <- stToIO (unsafeFreezeByteArray ptr)
+           addr <- unpackSockAddrInet ptr_addr
+           str  <- unpackNBytesBAIO barr n
+            return (str, n, addr)
+
 \end{code}
 
 The port number the given socket is currently connected to can be
@@ -402,12 +495,12 @@ was given $aNY\_PORT$.
 
 \begin{code}
 socketPort :: Socket           -- Connected & Bound Socket
-          -> IO Int            -- Port Number of Socket
-socketPort sock@(MkSocket s AF_INET stype protocol status) =
+          -> IO PortNumber     -- Port Number of Socket
+socketPort sock@(MkSocket _ AF_INET _ _ _) =
     getSocketName sock >>= \(SockAddrInet port _) ->
     return port
-socketPort (MkSocket s family stype protocol status) =
-    fail (userError ("socketPort: not supported for Family " ++ show family))
+socketPort (MkSocket _ family _ _ _) =
+    ioError (userError ("socketPort: not supported for Family " ++ show family))
 \end{code}
 
 Calling $getPeerName$ returns the address details of the machine,
@@ -419,12 +512,12 @@ is $getSocketName$.
 \begin{code}
 getPeerName   :: Socket -> IO SockAddr
 
-getPeerName (MkSocket s family stype protocol status) = do
- (ptr, sz) <- allocSockAddr family
- int_star <- stToIO (newIntArray (0,1))
- stToIO (writeIntArray int_star 0 sz)
+getPeerName (MkSocket s family _ _ _) = do
+ (ptr, a_sz) <- allocSockAddr family
+ int_star <- stToIO (newIntArray ((0::Int),1))
+ stToIO (writeIntArray int_star 0 a_sz)
  status <- _ccall_ getPeerName s ptr int_star
- case status of
+ case (status::Int) of
    -1 -> constructErrorAndFail "getPeerName"
    _  -> do
          sz <- stToIO (readIntArray int_star 0)
@@ -432,12 +525,12 @@ getPeerName (MkSocket s family stype protocol status) = do
     
 getSocketName :: Socket -> IO SockAddr
 
-getSocketName (MkSocket s family stype protocol status) = do
- (ptr, sz) <- allocSockAddr family
- int_star <- stToIO (newIntArray (0,1))
- stToIO (writeIntArray int_star 0 sz)
- status <- _ccall_ getSockName s ptr int_star
- case status of
+getSocketName (MkSocket s family _ _ _) = do
+ (ptr, a_sz) <- allocSockAddr family
+ int_star <- stToIO (newIntArray ((0::Int),1))
+ stToIO (writeIntArray int_star 0 a_sz)
+ rc <- _ccall_ getSockName s ptr int_star
+ case (rc::Int) of
    -1 -> constructErrorAndFail "getSocketName"
    _  -> do
          sz <- stToIO (readIntArray int_star 0)
@@ -454,39 +547,76 @@ getSocketName (MkSocket s family stype protocol status) = do
 %************************************************************************
 
 \begin{code}
-{-
-data SocketOption =
-      Debug
-    | AcceptConnection
-    | ReuseAddr
-    | KeepAlive
-    | DontRoute
-    | Broadcast
-    | UseLoopBack
-    | Linger
-    | OOBInline
-    | SendBuffer
-    | RecvBuffer
-    | SendLowWater
-    | RecvLowWater
-    | SendTimeOut
-    | RecvTimeOut
-    | Error
-    | Type
-
-sOL_SOCKET = ``SOL_SOCKET''
-
-setSocketOptions :: Socket ->
-                   Int ->              -- Level
-                   SocketOption ->     -- Option Name
-                   String ->           -- Option Value
-                   IO ()
-
-getSocketOptons :: Socket ->
-                  Int ->               -- Level
-                  SocketOption ->      -- Option Name
-                  IO String            -- Option Value
--}
+data SocketOption
+    = Debug         {- SO_DEBUG     -}
+    | ReuseAddr     {- SO_REUSEADDR -}
+    | Type          {- SO_TYPE      -}
+    | SoError       {- SO_ERROR     -}
+    | DontRoute     {- SO_DONTROUTE -}
+    | Broadcast     {- SO_BROADCAST -}
+    | SendBuffer    {- SO_SNDBUF    -}
+    | RecvBuffer    {- SO_RCVBUF    -}
+    | KeepAlive     {- SO_KEEPALIVE -}
+    | OOBInline     {- SO_OOBINLINE -}
+#ifndef _WIN32
+    | MaxSegment    {- TCP_MAXSEG   -}
+#endif
+    | NoDelay       {- TCP_NODELAY  -}
+--    | Linger        {- SO_LINGER    -}
+#if 0
+    | ReusePort     {- SO_REUSEPORT -} -- BSD only?
+    | RecvLowWater  {- SO_RCVLOWAT  -}
+    | SendLowWater  {- SO_SNDLOWAT  -}
+    | RecvTimeOut   {- SO_RCVTIMEO  -}
+    | SendTimeOut   {- SO_SNDTIMEO  -}
+    | UseLoopBack   {- SO_USELOOPBACK -}  -- not used, I believe.
+#endif
+
+packSocketOption :: SocketOption -> Int
+packSocketOption so =
+  case so of
+    Debug         -> ``SO_DEBUG''
+    ReuseAddr     -> ``SO_REUSEADDR''
+    Type          -> ``SO_TYPE''
+    SoError       -> ``SO_ERROR''
+    DontRoute     -> ``SO_DONTROUTE''
+    Broadcast     -> ``SO_BROADCAST''
+    SendBuffer    -> ``SO_SNDBUF''
+    RecvBuffer    -> ``SO_RCVBUF''
+    KeepAlive     -> ``SO_KEEPALIVE''
+    OOBInline     -> ``SO_OOBINLINE''
+#ifndef _WIN32
+    MaxSegment    -> ``TCP_MAXSEG''
+#endif
+    NoDelay       -> ``TCP_NODELAY''
+#if 0
+    ReusePort     -> ``SO_REUSEPORT''  -- BSD only?
+    RecvLowWater  -> ``SO_RCVLOWAT''
+    SendLowWater  -> ``SO_SNDLOWAT''
+    RecvTimeOut   -> ``SO_RCVTIMEO''
+    SendTimeOut   -> ``SO_SNDTIMEO''
+    UseLoopBack   -> ``SO_USELOOPBACK''
+#endif
+
+setSocketOption :: Socket 
+               -> SocketOption -- Option Name
+               -> Int           -- Option Value
+               -> IO ()
+setSocketOption (MkSocket s _ _ _ _) so v = do
+   rc <- _ccall_ setSocketOption__ s (packSocketOption so) v
+   if rc /= (0::Int)
+    then constructErrorAndFail "setSocketOption"
+    else return ()
+
+getSocketOption :: Socket
+               -> SocketOption  -- Option Name
+               -> IO Int         -- Option Value
+getSocketOption (MkSocket s _ _ _ _) so = do
+   rc <- _ccall_ getSocketOption__ s (packSocketOption so)
+   if rc == -1 -- let's just hope that value isn't taken..
+    then constructErrorAndFail "getSocketOption"
+    else return rc
+
 \end{code}
 
 A calling sequence table for the main functions is shown in the table below.
@@ -527,7 +657,7 @@ write  &    &   +     &            &  +     &  +     &  +   & + \\
 
     
 The following Family and Socket Type declarations were manually derived
-from /usr/include/sys/socket.h on the appropriate machines.
+from @<sys/socket.h>@ on the appropriate machines.
 
 Maybe a configure script that could parse the socket.h file to produce
 the following declaration is required to make it ``portable'' rather than
@@ -585,11 +715,11 @@ unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
 
 #endif
 
-#if cygwin32_TARGET_OS
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
  
 data Family = 
          AF_UNSPEC     -- unspecified
-       --NOT SUPPORTED: AF_UNIX        -- local to host (pipes, portals)
+       | AF_UNIX       -- local to host (pipes, portals)
        | AF_INET       -- internetwork: UDP, TCP, etc
        | AF_IMPLINK    -- arpanet imp addresses
        | AF_PUP        -- pup protocols: e.g. BSP
@@ -769,7 +899,7 @@ unpackFamily family = (range (AF_UNSPEC, AF_MAX))!!family
 
 #endif
 
-#if freebsd_TARGET_OS
+#if freebsd2_TARGET_OS || freebsd3_TARGET_OS
 
 data Family = 
                AF_UNSPEC       -- unspecified 
@@ -814,7 +944,7 @@ unpackFamily family = (range (AF_UNSPEC, AF_MAX))!!family
 -- Alpha running OSF or a SPARC with SunOS, rather than Solaris.
 
 #if osf1_TARGET_OS || osf3_TARGET_OS || sunos4_TARGET_OS || hpux_TARGET_OS || \
-       aix_TARGET_OS || freebsd_TARGET_OS
+       aix_TARGET_OS || freebsd2_TARGET_OS || freebsd3_TARGET_OS
 data SocketType = 
          Stream 
        | Datagram
@@ -828,14 +958,13 @@ packSocketType stype = 1 + (index (Stream, SeqPacket) stype)
 
 -- This is for a box running cygwin32 toolchain.
 
-#if defined(cygwin32_TARGET_OS)
+#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
 data SocketType = 
          Stream 
        | Datagram
        | Raw 
        | RDM       -- reliably delivered msg
        | SeqPacket
-       | Packet
        deriving (Eq, Ord, Ix, Show)
        
 packSocketType stype =
@@ -845,7 +974,6 @@ packSocketType stype =
    Raw       -> ``SOCK_RAW''
    RDM       -> ``SOCK_RDM'' 
    SeqPacket -> ``SOCK_SEQPACKET''
-   Packet    -> ``SOCK_PACKET''
 
 #endif
 
@@ -886,9 +1014,16 @@ packSocketType stype = 1 + (index (Stream, Packet) stype)
 %************************************************************************
 
 \begin{code}
-aNY_PORT = 0::Int
-iNADDR_ANY = ``INADDR_ANY''::Word
-sOMAXCONN = ``SOMAXCONN''::Int
+aNY_PORT :: PortNumber 
+aNY_PORT = mkPortNumber 0
+
+iNADDR_ANY :: HostAddress
+iNADDR_ANY = unsafePerformIO (_casm_ `` %r = htonl(INADDR_ANY); '')
+
+sOMAXCONN :: Int
+sOMAXCONN = ``SOMAXCONN''
+
+maxListenQueue :: Int
 maxListenQueue = sOMAXCONN
 
 -------------------------------------------------------------------------------
@@ -906,73 +1041,58 @@ shutdown :: Socket -> ShutdownCmd -> IO ()
 shutdown (MkSocket s _ _ _ _) stype = do
   let t = sdownCmdToInt stype
   status <- _ccall_ shutdownSocket s t
-  case status of
+  case (status::Int) of
     -1 -> constructErrorAndFail "shutdown"
     _  -> return ()
 
 -------------------------------------------------------------------------------
 
 sClose  :: Socket -> IO ()
-sClose (MkSocket s family stype protocol status) = _ccall_ close s
-
--------------------------------------------------------------------------------
-
-inet_addr :: String -> HostAddress
-inet_addr ipstr = unsafePerformIO (_ccall_ inet_addr ipstr)
-
--------------------------------------------------------------------------------
-
-inet_ntoa :: HostAddress -> String
-inet_ntoa haddr = unsafePerformIO (
-    _casm_ ``struct in_addr addr;
-            addr.s_addr = htonl(%0);
-            %r = inet_ntoa (addr);'' haddr    >>= \ str ->
-    return (unpackCString str))
+sClose (MkSocket s _ _ _ _) = _ccall_ close s
 
 -------------------------------------------------------------------------------
 
 sIsConnected :: Socket -> IO Bool
-sIsConnected (MkSocket s family stype protocol status) = do
+sIsConnected (MkSocket _ _ _ _ status) = do
     value <- readIORef status
     return (value == Connected)        
 
 -------------------------------------------------------------------------------
 
 sIsBound :: Socket -> IO Bool
-sIsBound (MkSocket s family stype protocol status) = do
+sIsBound (MkSocket _ _ _ _ status) = do
     value <- readIORef status
     return (value == Bound)    
 
 -------------------------------------------------------------------------------
 
 sIsListening :: Socket -> IO Bool
-sIsListening (MkSocket s family stype protocol status) = do
+sIsListening (MkSocket _ _ _  _ status) = do
     value <- readIORef status
     return (value == Listening)        
 
 -------------------------------------------------------------------------------
 
 sIsReadable  :: Socket -> IO Bool
-sIsReadable (MkSocket s family stype protocol status) = do
+sIsReadable (MkSocket _ _ _ _ status) = do
     value <- readIORef status
     return (value == Listening || value == Connected)
 
 -------------------------------------------------------------------------------
 
 sIsWritable  :: Socket -> IO Bool
-sIsWritable = sIsReadable
+sIsWritable = sIsReadable -- sort of.
 
 -------------------------------------------------------------------------------
 
 sIsAcceptable :: Socket -> IO Bool
-#ifndef cygwin32_TARGET_OS
-sIsAcceptable (MkSocket s AF_UNIX Stream protocol status) = do
+#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
+sIsAcceptable (MkSocket _ AF_UNIX Stream _ status) = do
     value <- readIORef status
     return (value == Connected || value == Bound || value == Listening)
-sIsAcceptable (MkSocket s AF_UNIX _ protocol status) = 
-    return False
+sIsAcceptable (MkSocket _ AF_UNIX _ _ _) = return False
 #endif
-sIsAcceptable (MkSocket s _ stype protocol status) = do
+sIsAcceptable (MkSocket _ _ _ _ status) = do
     value <- readIORef status
     return (value == Connected || value == Listening)
     
@@ -983,20 +1103,45 @@ sSetBlocking :: Socket -> Bool -> IO ()
 sIsBlocking  :: Socket -> IO Bool
 -}
 
+\end{code}
+
+Internet address manipulation routines:
+
+\begin{code}
+inet_addr :: String -> IO HostAddress
+inet_addr ipstr = do
+   had <- _ccall_ inet_addr ipstr
+   if had == (W# (int2Word# (negateInt# 1#))) -- hack to avoid depending on Int.intToWord here.
+    then ioError (userError ("inet_addr: Malformed address: " ++ ipstr))
+    else return had  -- network byte order
+
+inet_ntoa :: HostAddress -> IO String
+inet_ntoa haddr = do
+  pstr <- _casm_ ``struct in_addr addr;
+                  addr.s_addr = %0;
+                  %r = inet_ntoa (addr);'' haddr
+  -- unpack straight away, since pstr points to static buffer.
+  unpackCStringIO pstr
+
+\end{code}
+
+Marshaling and allocation helper functions:
+
+\begin{code}
 -------------------------------------------------------------------------------
 
 allocSockAddr :: Family -> IO (MutableByteArray RealWorld Int, Int)
 
-#ifndef cygwin32_TARGET_OS
+#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
 allocSockAddr AF_UNIX = do
-    ptr <- stToIO (newCharArray (0,``sizeof(struct sockaddr_un)''))
-    let (_,sz) = boundsOfByteArray ptr
+    ptr <- allocChars ``sizeof(struct sockaddr_un)''
+    let (_,sz) = boundsOfMutableByteArray ptr
     return (ptr, sz)
 #endif
 
 allocSockAddr AF_INET = do
-    ptr <- stToIO (newCharArray (0,``sizeof(struct sockaddr_in)''))
-    let (_,sz) = boundsOfByteArray ptr
+    ptr <- allocChars ``sizeof(struct sockaddr_in)''
+    let (_,sz) = boundsOfMutableByteArray ptr
     return (ptr, sz)
 
 -------------------------------------------------------------------------------
@@ -1005,60 +1150,57 @@ unpackSockAddr :: MutableByteArray RealWorld Int -> Int -> IO SockAddr
 unpackSockAddr arr len = do
     fam <- _casm_ ``%r = ((struct sockaddr*)%0)->sa_family;'' arr
     case unpackFamily fam of
-#ifndef cygwin32_TARGET_OS
+#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
        AF_UNIX -> unpackSockAddrUnix arr (len - ``sizeof(short)'')
 #endif
        AF_INET -> unpackSockAddrInet arr
 
 -------------------------------------------------------------------------------
 
+#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
+
 {-
-  sun_path is *not* NULL terminated, hence we *do* the need to know the
+  sun_path is *not* NULL terminated, hence we *do* need to know the
   length of it.
 -}
-#ifndef cygwin32_TARGET_OS
 unpackSockAddrUnix :: (MutableByteArray RealWorld Int) -> Int -> IO SockAddr
 unpackSockAddrUnix ptr len = do
     char_star <- _casm_ ``%r = ((struct sockaddr_un*)%0)->sun_path;'' ptr
-    path <- stToIO (packCBytesST len char_star)
-    return (SockAddrUnix (unpackPS path))
+    path      <- unpackCStringLenIO char_star len
+    return (SockAddrUnix path)
+
 #endif
+
 -------------------------------------------------------------------------------
 
 unpackSockAddrInet :: (MutableByteArray RealWorld Int) -> IO SockAddr
 unpackSockAddrInet ptr = do
-    port <- _casm_ ``%r = ntohs(((struct sockaddr_in*)%0)->sin_port);'' ptr
-    addr <- _casm_ ``%r = ntohl(((struct sockaddr_in*)%0)->sin_addr.s_addr);'' 
-                  ptr
-    return (SockAddrInet port addr)
+  port <- _casm_ ``%r = ((struct sockaddr_in*)%0)->sin_port;''        ptr
+  addr <- _casm_ ``%r = ((struct sockaddr_in*)%0)->sin_addr.s_addr;'' ptr
+  return (SockAddrInet (PNum port) addr)
 
 -------------------------------------------------------------------------------
 
 
 packSockAddr :: SockAddr -> IO (MutableByteArray RealWorld Int)
-#ifndef cygwin32_TARGET_OS
+#if !defined(cygwin32_TARGET_OS) && !defined(mingw32_TARGET_OS)
 packSockAddr (SockAddrUnix path) = do
     (ptr,_) <- allocSockAddr AF_UNIX
-    _casm_ ``(((struct sockaddr_un *)%0)->sun_family) = AF_UNIX;'' 
-          ptr
-    _casm_ ``strcpy ((((struct sockaddr_un *)%0)->sun_path),%1);'' 
-          ptr path
+    _casm_ ``(((struct sockaddr_un *)%0)->sun_family) = AF_UNIX;''    ptr
+    _casm_ ``strcpy ((((struct sockaddr_un *)%0)->sun_path),%1);''    ptr path
     return ptr
 #endif
-packSockAddr (SockAddrInet port address) = do
-    (ptr,_) <- allocSockAddr AF_INET
-    _casm_ ``(((struct sockaddr_in *)%0)->sin_family) = AF_INET;'' 
-          ptr
-    _casm_ ``(((struct sockaddr_in *)%0)->sin_port) = htons((int)%1);''        
-          ptr port
-    _casm_ ``(((struct sockaddr_in *)%0)->sin_addr.s_addr) = htonl(%1);'' 
-          ptr address
-    return ptr
+packSockAddr (SockAddrInet (PNum port) address) = do
+  (ptr,_) <- allocSockAddr AF_INET
+  _casm_ ``(((struct sockaddr_in *)%0)->sin_family) = AF_INET;''  ptr
+  _casm_ ``(((struct sockaddr_in *)%0)->sin_port) = (int)%1;''    ptr port
+  _casm_ ``(((struct sockaddr_in *)%0)->sin_addr.s_addr) = %1;''  ptr address
+  return ptr
 
 -------------------------------------------------------------------------------
 \end{code}
 
-@socketHandle@ turns a @Socket@ into a 1.3 @Handle@. By default, the new
+@socketHandle@ turns a @Socket@ into a Haskell IO @Handle@. By default, the new
 handle will not be buffered, use @hSetBuffering@ if you want to change
 it subsequently.
 
@@ -1066,19 +1208,31 @@ it subsequently.
 #ifndef __PARALLEL_HASKELL__
 socketToHandle :: Socket -> IOMode -> IO Handle
 
-socketToHandle (MkSocket s family stype protocol status) m = do
-    ptr <- _casm_ ``%r = fdopen (%0, (char *)%1);'' s m'
-    fp <- makeForeignObj ptr (``&freeFile'' :: Addr)
-    hndl <- newHandle (htype fp Nothing False)
-    hSetBuffering hndl NoBuffering
-    return hndl
+socketToHandle (MkSocket fd _ _ _ _) m = do
+    fileobj <- _ccall_ openFd fd (file_mode::Int) (file_flags::Int)
+    if fileobj == nullAddr then
+       ioError (userError "socketHandle: Failed to open file desc")
+     else do
+       fo <- mkForeignObj fileobj
+       addForeignFinalizer fo (freeFileObject fo)
+       mkBuffer__ fo 0  -- not buffered
+       hndl <- newHandle (Handle__ fo htype NoBuffering socket_str)
+       return hndl
  where
-  m' = 
+  socket_str = "<socket: "++show fd
+#ifdef _WIN32
+  file_flags = flush_on_close + 1024{-I'm a socket fd, me!-}
+#else
+  file_flags = flush_on_close
+#endif
+
+  (flush_on_close, file_mode) =
    case m of 
-     ReadMode      -> "r"
-     WriteMode     -> "w"
-     AppendMode    -> "a"
-     ReadWriteMode -> "r+"
+           AppendMode    -> (1, 0)
+           WriteMode     -> (1, 1)
+           ReadMode      -> (0, 2)
+           ReadWriteMode -> (1, 3)
+
   htype = 
    case m of 
      ReadMode      -> ReadHandle
@@ -1091,3 +1245,28 @@ socketToHandle (MkSocket s family stype protocol status) m =
 #endif
 \end{code}
 
+If you're using WinSock, the programmer has to call a startup
+routine before starting to use the goods. So, if you want to
+stay portable across all ghc-supported platforms, you have to
+use @withSocketsDo@...:
+
+\begin{code}
+withSocketsDo :: IO a -> IO a
+#if !defined(HAVE_WINSOCK_H) || defined(cygwin32_TARGET_OS)
+withSocketsDo x = x
+#else
+withSocketsDo act = do
+   x <- initWinSock
+   if ( x /= 0 ) then
+     ioError (userError "Failed to initialise WinSock")
+    else do
+      v <- act
+      shutdownWinSock
+      return v
+
+foreign import "initWinSock" initWinSock :: IO Int
+foreign import "shutdownWinSock" shutdownWinSock :: IO ()
+
+#endif
+
+\end{code}