%
-% (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" #-}
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 ()
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)
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}
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
| 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(!),
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}
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
-> 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
-> 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
-> 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
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}
%************************************************************************
-> 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 =
(\ _ -> 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
\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,
\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)
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)
%************************************************************************
\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.
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
#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
#endif
-#if freebsd_TARGET_OS
+#if freebsd2_TARGET_OS || freebsd3_TARGET_OS
data Family =
AF_UNSPEC -- unspecified
-- 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
-- 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 =
Raw -> ``SOCK_RAW''
RDM -> ``SOCK_RDM''
SeqPacket -> ``SOCK_SEQPACKET''
- Packet -> ``SOCK_PACKET''
#endif
%************************************************************************
\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
-------------------------------------------------------------------------------
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)
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)
-------------------------------------------------------------------------------
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.
#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
#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}
projects / ghc-hetmet.git / blobdiff