+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-% Last Modified: Fri Jul 21 15:14:43 1995
-% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-\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).
-
-\begin{code}
-module SocketPrim (
-
- Socket,
- Family(..),
- SocketType(..),
- SockAddr(..),
- HostAddress(..),
-
- socket, -- :: Family -> SocketType -> Int -> IO Socket
- connect, -- :: Socket -> SockAddr -> IO ()
- bindSocket, -- :: Socket -> SockAddr -> IO ()
- listen, -- :: Socket -> Int -> IO ()
- accept, -- :: Socket -> IO (Socket, SockAddr)
- getPeerName, -- :: Socket -> IO SockAddr
- getSocketName, -- :: Socket -> IO SockAddr
-
- socketPort, -- :: Socket -> IO Int
-
- writeSocket, -- :: Socket -> String -> IO Int
- readSocket, -- :: Socket -> Int -> IO (String, Int)
- readSocketAll, -- :: Socket -> IO String
-
- socketToHandle, -- :: Socket -> IO Handle
-
--- Alternative read/write interface not yet implemented.
--- sendto -- :: Socket -> String -> SockAddr -> IO Int
--- recvfrm -- :: Socket -> Int -> SockAddr -> IO (String, Int)
--- sendmsg -- :: Socket -> Message -> MsgFlags -> IO Int
--- recvmsg -- :: Socket -> MsgFlags -> IO Message
-
- shutdown, -- :: Socket -> Int -> IO ()
- sClose, -- :: Socket -> IO ()
-
- inet_addr, -- :: String -> HostAddress
- inet_ntoa, -- :: HostAddress -> String
-
- sIsConnected, -- :: Socket -> IO Bool
- sIsBound, -- :: Socket -> IO Bool
- sIsListening, -- :: Socket -> IO Bool
- sIsReadable, -- :: Socket -> IO Bool
- sIsWritable, -- :: Socket -> IO Bool
-
-
--- 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.
-
- packFamily, unpackFamily,
- packSocketType,
- packSockAddr, unpackSockAddr
-
-) where
-
-import CError
-import LibPosix
-import LibPosixUtil
-import PreludeGlaST
-import PreludePrimIO ( newEmptyMVar, putMVar, _MVar )
-import PreludeStdIO
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Socket-SocketTypes]{Socket Types}
-%* *
-%************************************************************************
-
-
-There are a few possible ways to do this. The first is convert the
-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
-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.
-
-
-\begin{code}
-data SocketStatus
- -- Returned Status Function called
- = NotConnected -- socket
- | Bound -- bindSocket
- | Listening -- listen
- | Connected -- connect/accept
- | Error String -- Any
- deriving (Eq, Text)
-
-data Socket
- = MkSocket
- Int -- File Descriptor Part
- Family
- SocketType
- Int -- Protocol Number
- (MutableVar _RealWorld SocketStatus) -- Status Flag
-\end{code}
-
-In C bind takes either a $struct sockaddr\_in$ or a $struct
-sockaddr\_un$ but these are always type cast to $struct sockaddr$. We
-attempt to emulate this and provide better type checking. Note that
-the socket family fields are redundant since this is caputured in the
-constructor names, it has thus be left out of the Haskell $SockAddr$
-data type.
-
-
-\begin{code}
-type HostAddress = _Word
-
-data SockAddr -- C Names
- = SockAddrUnix -- struct sockaddr_un
- String -- sun_path
-
- | SockAddrInet -- struct sockaddr_in
- Int -- sin_port
- HostAddress -- sin_addr
-
- deriving Eq
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection[Socket-Connections]{Connection Functions}
-%* *
-%************************************************************************
-
-
-In the following connection and binding primitives. The names of the
-equivalent C functions have been preserved where possible. It should
-be noted that some of these names used in the C library, bind in
-particular, have a different meaning to many Haskell programmers and
-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 ->
- ...
-\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 stype protocol =
- _ccall_ socket (packFamily family) (packSocketType stype) protocol
- `thenPrimIO` \ s ->
- if s == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EACCES ->
- fail "socket: Permission Denied"
- EMFILE ->
- fail "socket: No more descriptiors available"
- ENFILE ->
- fail "socket: System file table is full"
- ENOBUFS ->
- fail "socket: Insufficient Buffer space to create socket"
- EPROTONOSUPPOR ->
- fail ("socket: Protocol " ++ show protocol ++
- " not supported for Family " ++ show family)
- EPROTOTYPE ->
- fail ("socket: Protocol " ++ show protocol ++
- " wrong type for socket")
- _ ->
- fail ("socket: " ++ (errorCodeToStr errno))
- )
- else
- newVar NotConnected `thenPrimIO` \ status ->
- return (MkSocket s family stype protocol status)
-\end{code}
-
-Given a port number this {\em binds} the socket to that port. This
-means that the programmer is only interested in data being sent to
-that port number. The $Family$ passed to $bindSocket$ must
-be the same as that passed to $socket$. If the special port
-number $aNY\_PORT$ is passed then the system assigns the next
-available use port.
-
-Port numbers for standard unix services can be found by calling
-$getServiceEntry$. These are traditionally port numbers below
-1000; although there are afew, namely NFS and IRC, which used higher
-numbered ports.
-
-The port number allocated to a socket bound by using $aNY\_PORT$ can be
-found by calling $port$
-
-\begin{code}
-bindSocket :: Socket -> -- Unconnected Socket
- SockAddr -> -- Address to Bind to
- IO ()
-
-bindSocket (MkSocket s family stype protocol status) addr =
- readVar status `thenST` \ currentStatus ->
- if currentStatus /= NotConnected then
- fail ("bindSocket: can't peform bind on socket in status " ++
- show currentStatus)
- else
- packSockAddr addr `thenPrimIO` \ addr' ->
- let (_,sz) = boundsOfByteArray addr' in
- _casm_ ``%r = bind(%0, (struct sockaddr*)%1, %2);''
- s addr' sz `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EACCES ->
- fail "bindSocket: The requested address is protected"
- EADDRINUSE ->
- fail "bindSocket: Address in use by another process"
- EADDRNOTAVAIL ->
- fail "bindSocket: Address not available"
- EBADF ->
- fail "bindSocket: invalid descriptor"
- EFAULT ->
- fail "bindSocket: name parameter not in vaild user address space"
- EINVAL ->
- fail "bindSocket: namelen invalid size for given family"
- ENOTSOCK ->
- fail "bindSocket: attempt to bind a non socket descriptor"
- _ ->
- fail ("bindSocket: " ++ (errorCodeToStr errno))
- )
- else
- writeVar status (Bound) `seqPrimIO`
- return ()
-\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.
-
-This is the dual to $bindSocket$. The {\em server} process will
-usually bind to a port number, the {\em client} will then connect to
-the same port number. Port numbers of user applications are normally
-agreed in advance, otherwise we must rely on some hacky mechanism for telling
-the {\em otherside} what port number we have been allocated.
-
-\begin{code}
-connect :: Socket -> -- Unconnected Socket
- SockAddr -> -- Socket address stuff
- IO ()
-
-connect (MkSocket s family stype protocol status) addr =
- readVar status `thenST` \ currentStatus ->
- if currentStatus /= NotConnected then
- fail ("connect: can't peform connect on socket in status " ++
- show currentStatus)
- else
- packSockAddr addr `thenPrimIO` \ addr' ->
- let (_,sz) = boundsOfByteArray addr' in
- _casm_ ``%r = connect(%0,(struct sockaddr*)%1, %2);''
- s addr' sz `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EADDRINUSE ->
- fail "connect: address in use"
- EADDRNOTAVAIL ->
- fail "connect: address not available on remote machine"
- EAFNOSUPPORT ->
- fail "connect: invalid socket address family"
- EALREADY ->
- fail ("connect: socket in non-blocking and previous " ++
- "attempt to connect not yet complteted")
- EBADF ->
- fail "connect: socket in not a vaild descriptor"
- ECONNREFUSED ->
- fail "connect: connection refused by peer"
- EFAULT ->
- fail "connect: address parameter outside process address space"
- EINPROGRESS ->
- fail ("connect: socket is non-blocking and connection can " ++
- "not be completed imediately")
- EINTR ->
- fail "connect: connection interrupted before delivery signal"
- EINVAL ->
- fail ("connect: namlen not size of valid address for " ++
- "specified family")
- EISCONN ->
- fail "connect: socket is already connected"
- ENETUNREACH ->
- fail "connect: network unreachable"
- ENOTSOCK ->
- fail "connect: file descriptor passed instead of socket"
- ETIMEDOUT ->
- fail "connect: timed out without establishing connection"
- _ ->
- fail ("connect: " ++ (errorCodeToStr errno))
- )
- else
- writeVar status (Connected) `seqPrimIO`
- return ()
-
-\end{code}
-
-The programmer must call $listen$ to tell the system software
-that they are now interested in receiving data on this port. This
-must be called on the bound socket before any calls to read or write
-data are made.
-
-The programmer also gives a number which indicates the length of the
-incoming queue of unread messages for this socket. On most systems the
-maximum queue length is around 5. To remove a message from the queue
-for processing a call to $accept$ should be made.
-
-\begin{code}
-listen :: Socket -> -- Connected & Bound Socket
- Int -> -- Queue Length
- IO ()
-
-listen (MkSocket s family stype protocol status) backlog =
- readVar status `thenST` \ currentStatus ->
- if currentStatus /= Bound then
- fail ("listen: can't peform listen on socket in status " ++
- show currentStatus)
- else
- _ccall_ listen s backlog `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EBADF ->
- fail "listen: socket file descriptor invalid"
- ENOTSOCK ->
- fail "listen: file descriptor is not a socket"
- EOPNOTSUPP ->
- fail "listen: not supported fro this type of socket"
- _ ->
- fail ("listen: " ++ (errorCodeToStr errno))
- )
- else
- writeVar status (Listening) `seqPrimIO`
- return ()
-\end{code}
-
-A call to $accept$ only returns when data is available on the given
-socket, unless the socket has been set to non-blocking. It will
-return a new socket which should be used to read the incoming data and
-should then be closed. Using the socket returned by $accept$ allows
-incoming requests to be queued on the original socket.
-
-
-\begin{code}
-accept :: Socket -> -- Queue Socket
- IO (Socket, -- Readable Socket
- SockAddr) -- Peer details
-
-accept sock@(MkSocket s family stype protocol status) =
- readVar status `thenST` \ currentStatus ->
- sIsAcceptable sock >>= \ okay ->
- if not okay then
- fail ("accept: can't peform accept on socket in status " ++
- show currentStatus)
- else
- allocSockAddr family `thenPrimIO` \ (ptr, sz) ->
- _casm_ ``%r = accept(%0,(struct sockaddr*)%1, &%2);''
- s ptr sz `thenPrimIO` \ sock ->
- if sock == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EBADF ->
- fail "accept: descriptor is invalid"
- EFAULT ->
- fail "accept: addr is not in writeable part of address space"
- ENOTSOCK ->
- fail "accept: descriptor is not a socket"
- EOPNOTSUPP ->
- fail ("accept: socket not of type" ++ show stype)
- EWOULDBLOCK ->
- fail "accept: would block"
- _ ->
- fail ("accept: " ++ (errorCodeToStr errno))
- )
- else
- unpackSockAddr ptr `thenPrimIO` \ addr ->
- newVar Connected `thenPrimIO` \ status ->
- return ((MkSocket sock family stype protocol status), addr)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Socket-DataPass]{Data Passing Primitives}
-%* *
-%************************************************************************
-
-To allow Haskell to talk to C programs we need to beable to
-communicate interms of byte streams. $writeSocket$ and
-$readSocket$ should only be used for this purpose and not for
-communication between Haskell programs. Haskell programs should use
-the 1.3 IO hPutStr and associated machinery for communicating with
-each other.
-
-
-\begin{code}
-writeSocket :: Socket -> -- Connected Socket
- String -> -- Data to send
- IO Int -- Number of Bytes sent
-
-writeSocket (MkSocket s family stype protocol status) xs =
- readVar status `thenST` \ currentStatus ->
- if not ((currentStatus /= Connected) || (currentStatus /= Listening)) then
- fail ("writeSocket: can't peform write on socket in status " ++
- show currentStatus)
- else
- _ccall_ write s xs (length xs) `thenPrimIO` \ nbytes ->
- if nbytes == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EBADF ->
- fail "writeSocket: invalid file descriptor"
- EDQUOT ->
- fail "writeSocket: disk quota exhausted"
- EFAULT ->
- fail "writeSocket: data area outside address space"
- EFBIG ->
- fail "writeSocket: max file size limit exeeded"
- EINTR ->
- fail "writeSocket: interupt received before data written"
- EINVAL ->
- fail ("writeSocket: The stream is linked below a " ++
- "multiplexor. The fd pointer was negative")
- ENOSPC ->
- fail "writeSocket: no space left on device"
- ENXIO ->
- fail "writeSocket: hangup occured on stream"
- EPIPE ->
- fail "writeSocket: attempt to write to unopened pipe"
- ERANGE ->
- fail "writeSocket: to much data to write"
- EWOULDBLOCK ->
- fail "writeSocket: would block"
- EAGAIN ->
- fail "writeSocket: would block"
- _ ->
- fail ("writeSocket: " ++ (errorCodeToStr errno))
- )
- else
- return nbytes
-
-readSocket :: Socket -> -- Connected Socket
- Int -> -- Number of Bytes to Read
- IO (String, Int) -- (Data Read, Number of Bytes)
-
-readSocket (MkSocket s family stype protocol status) nbytes =
- readVar status `thenST` \ currentStatus ->
- if not ((currentStatus /= Connected) || (currentStatus /= Listening)) then
- fail ("readSocket: can't perform read on socket in status " ++
- show currentStatus)
- else
--- newCharArray (0, nbytes) `thenPrimIO` \ ptr \ ->
- _casm_ ``%r = (char*)malloc(1+sizeof(char)*%0);'' nbytes
- `thenPrimIO` \ buffer ->
- _ccall_ read s buffer nbytes `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EAGAIN ->
- fail "readSocket: no data to read (non-blocking)"
- EBADF ->
- fail "readSocket: invalid file descriptor"
- EBADMSG ->
- fail "readSocket: not a valid data message"
- EFAULT ->
- fail "readSocket: buffer outside allocated address space"
- EINTR ->
- fail "readSocket: interupted by signal before data"
- EINVAL ->
- fail ("readSocket: The stream is linked below a " ++
- "multiplexor. The file descriptor pointer was negative")
- EIO ->
- fail "readSocket: IO error"
- EISDIR ->
- fail "readSocket: descriptor is an NFS directory"
- EWOULDBLOCK ->
- fail "readSocket: would block"
- _ ->
- fail ("readSocket: " ++ (errorCodeToStr errno))
- )
- else
- return (_unpackPS (_packCString buffer), result)
-
-
-readSocketAll :: Socket -> IO String
-readSocketAll s =
- let
- loop xs =
- readSocket s 4096 >>= \ (str, nbytes) ->
- if nbytes /= 0 then
- loop (str ++ xs)
- else
- return xs
- in
- loop ""
-\end{code}
-
-The port number the given socket is currently connected to can be
-determined by calling $port$, is generally only useful when bind
-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) =
- getSocketName sock >>= \ (SockAddrInet port _) ->
- return port
-socketPort (MkSocket s family stype protocol status) =
- fail ("socketPort: not supported for Family " ++ show family)
-\end{code}
-
-Calling $getPeerName$ returns the address details of the machine,
-other than the local one, which is connected to the socket. This is
-used in programs such as FTP to determine where to send the returning
-data. The corresponding call to get the details of the local machine
-is $getSocketName$.
-
-\begin{code}
-getPeerName :: Socket -> IO SockAddr
-getPeerName (MkSocket s family stype protocol status) =
- allocSockAddr family `thenPrimIO` \ (ptr,sz) ->
- _casm_ ``%r = getpeername(%0,(struct sockaddr*)%1,&%2);''
- s ptr sz `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- fail ("getPeerName: " ++ (errorCodeToStr errno))
- else
- unpackSockAddr ptr `thenPrimIO` \ addr ->
- return addr
-
-getSocketName :: Socket -> IO SockAddr
-getSocketName (MkSocket s family stype protocol status) =
- allocSockAddr family `thenPrimIO` \ (ptr,sz) ->
- _casm_ ``%r = getsockname(%0,(struct sockaddr*)%1, &%2);''
- s ptr sz `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- fail ("getSocketName: " ++ (errorCodeToStr errno))
- else
- unpackSockAddr ptr `thenPrimIO` \ addr ->
- return addr
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Socket-Properties]{Socket Properties}
-%* *
-%************************************************************************
-
-\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
--}
-\end{code}
-
-A calling sequence table for the main functions is shown in the table below.
-
-\begin{figure}[h]
-\begin{center}
-\begin{tabular}{|l|c|c|c|c|c|c|c|}
-\hline
-{\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\
-\hline
-{\bf Precedes} & & & & & & & \\
-\hline
-socket & & & & & & & \\
-\hline
-connect & + & & & & & & \\
-\hline
-bindSocket & + & & & & & & \\
-\hline
-listen & & & + & & & & \\
-\hline
-accept & & & & + & & & \\
-\hline
-read & & + & & + & + & + & + \\
-\hline
-write & & + & & + & + & + & + \\
-\hline
-\end{tabular}
-\caption{Sequence Table for Major functions of Socket}
-\label{tab:api-seq}
-\end{center}
-\end{figure}
-
-%************************************************************************
-%* *
-\subsection[Socket-OSDefs]{OS Dependent Definitions}
-%* *
-%************************************************************************
-
-
-The following Family and Socket Type declarations were manually derived
-from /usr/include/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
-using the dreaded \#ifdefs.
-
-Presently only the following machine/os combinations are supported:
-
-\begin{itemize}
-\item Intelx86/Linux
-\item SPARC/SunOS
-\item SPARC/Solaris
-\item Alpha/OSF
-\end{itemize}
-
-\begin{code}
-unpackFamily :: Int -> Family
-packFamily :: Family -> Int
-
-packSocketType :: SocketType -> Int
-#ifdef sun
-
-data Family =
- AF_UNSPEC -- unspecified
- | 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
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_NBS -- nbs protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_NIT -- Network Interface Tap
- | AF_802 -- IEEE 80.2, also ISO 8802
- | AF_OSI -- umberella of all families used by OSI
- | AF_X25 -- CCITT X.25
- | AF_OSINET -- AFI
- | AF_GOSSIP -- US Government OSI
- | AF_IPX -- Novell Internet Protocol
- deriving (Eq, Ord, Ix, Text)
-
-packFamily = index (AF_UNSPEC, AF_IPX)
-unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
-
-#endif
-
-#ifdef __alpha__
-
-data Family =
- AF_UNSPEC -- unspecified
- | 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
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_ISO -- ISO protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- DEC Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_ROUTE -- Internal Routing Protocol
- | AF_LINK -- Link layer interface
- | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
- | AF_NETMAN -- DNA Network Management
- | AF_X25 -- X25 protocol
- | AF_CTF -- Common Trace Facility
- | AF_WAN -- Wide Area Network protocols
- deriving (Eq, Ord, Ix, Text)
-
-packFamily = index (AF_UNSPEC, AF_WAN)
-unpackFamily family = (range (AF_UNSPEC, AF_WAN))!!family
-#endif
-
-
-#ifdef linux
-data Family =
- AF_UNSPEC
- | AF_UNIX
- | AF_INET
- | AF_AX25
- | AF_IPX
- deriving (Eq, Ord, Ix, Text)
-
-packFamily = index (AF_UNSPEC, AF_IPX)
-unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
-
-#endif
-
--- Alpha running OSF or a SPARC with SunOS, rather than Solaris.
-
-#if __alpha__ || (sun && !__svr4__)
-data SocketType =
- Stream
- | Datagram
- | Raw
- | RDM
- | SeqPacket
- deriving (Eq, Ord, Ix, Text)
-
-packSocketType stype = 1 + (index (Stream, SeqPacket) stype)
-#endif
-
--- This is a Sun running Solaris rather than SunOS
-
-#if sun && __svr4__
-data SocketType =
- Datagram
- | Stream
- | NC_TPI_COTS_ORD
- | Raw
- | RDM
- | SeqPacket
- deriving (Eq, Ord, Ix, Text)
-
-packSocketType stype = 1 + (index (Datagram, SeqPacket) stype)
-#endif
-
-
-#if linux
-data SocketType =
- Stream
- | Datagram
- | Raw
- | RDM
- | SeqPacket
- | Packet
- deriving (Eq, Ord, Ix, Text)
-
-packSocketType stype = 1 + (index (Stream, Packet) stype)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Socket-Util]{Utility Functions}
-%* *
-%************************************************************************
-
-\begin{code}
-aNY_PORT = 0::Int
-iNADDR_ANY = ``INADDR_ANY''::_Word
-sOMAXCONN = ``SOMAXCONN''::Int
-maxListenQueue = sOMAXCONN
-
--------------------------------------------------------------------------------
-shutdown :: Socket -> Int -> IO ()
-shutdown (MkSocket s family stype protocol status) t =
- primIOToIO (_ccall_ shutdown s t)
-
--------------------------------------------------------------------------------
-
-sClose :: Socket -> IO ()
-sClose (MkSocket s family stype protocol status) =
- primIOToIO (_ccall_ close s)
-
--------------------------------------------------------------------------------
-
-inet_addr :: String -> HostAddress
-inet_addr ipstr = unsafePerformPrimIO (_ccall_ inet_addr ipstr)
-
--------------------------------------------------------------------------------
-
-inet_ntoa :: HostAddress -> String
-inet_ntoa haddr = unsafePerformPrimIO (
- _casm_ ``struct in_addr addr;
- addr.s_addr = htonl(%0);
- %r = inet_ntoa (addr);'' haddr `thenPrimIO` \ str ->
- returnPrimIO (_unpackPS (_packCString str)))
-
--------------------------------------------------------------------------------
-
-sIsConnected :: Socket -> IO Bool
-sIsConnected (MkSocket s family stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Connected)
-
--------------------------------------------------------------------------------
-
-sIsBound :: Socket -> IO Bool
-sIsBound (MkSocket s family stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Bound)
-
--------------------------------------------------------------------------------
-
-sIsListening :: Socket -> IO Bool
-sIsListening (MkSocket s family stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Listening)
-
--------------------------------------------------------------------------------
-
-sIsReadable :: Socket -> IO Bool
-sIsReadable (MkSocket s family stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Listening || value == Connected)
-
--------------------------------------------------------------------------------
-
-sIsWritable :: Socket -> IO Bool
-sIsWritable = sIsReadable
-
--------------------------------------------------------------------------------
-
-sIsAcceptable :: Socket -> IO Bool
-sIsAcceptable (MkSocket s AF_UNIX Stream protocol status) =
- readVar status `thenST` \ value ->
- return (value == Connected || value == Bound || value == Listening)
-sIsAcceptable (MkSocket s AF_UNIX _ protocol status) =
- return False
-sIsAcceptable (MkSocket s _ stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Connected || value == Listening)
-
--------------------------------------------------------------------------------
-
-{-
-sSetBlocking :: Socket -> Bool -> IO ()
-sIsBlocking :: Socket -> IO Bool
--}
-
--------------------------------------------------------------------------------
-
-allocSockAddr :: Family -> PrimIO (_MutableByteArray _RealWorld Int, Int)
-allocSockAddr AF_UNIX =
- newCharArray (0,``sizeof(struct sockaddr_un)'') `thenPrimIO` \ ptr ->
- let
- (_,sz) = boundsOfByteArray ptr
- in
- returnPrimIO (ptr, sz)
-allocSockAddr AF_INET =
- newCharArray (0,``sizeof(struct sockaddr_in)'') `thenPrimIO` \ ptr ->
- let
- (_,sz) = boundsOfByteArray ptr
- in
- returnPrimIO (ptr, sz)
-
--------------------------------------------------------------------------------
-
-unpackSockAddr :: _MutableByteArray _RealWorld Int -> PrimIO SockAddr
-unpackSockAddr arr =
- _casm_ ``%r = ((struct sockaddr*)%0)->sa_family;'' arr `thenPrimIO` \ fam ->
- case unpackFamily fam of
- AF_UNIX -> unpackSockAddrUnix arr
- AF_INET -> unpackSockAddrInet arr
-
--------------------------------------------------------------------------------
-
-unpackSockAddrUnix :: (_MutableByteArray _RealWorld Int) -> PrimIO SockAddr
-unpackSockAddrUnix ptr =
- _casm_ ``%r = ((struct sockaddr_un*)%0)->sun_path;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ path ->
- returnPrimIO (SockAddrUnix path)
-
--------------------------------------------------------------------------------
-
-unpackSockAddrInet :: (_MutableByteArray _RealWorld Int) -> PrimIO SockAddr
-unpackSockAddrInet ptr =
- _casm_ ``%r = ntohs(((struct sockaddr_in*)%0)->sin_port);'' ptr
- `thenPrimIO` \ port ->
- _casm_ ``%r = ntohl(((struct sockaddr_in*)%0)->sin_addr.s_addr);'' ptr
- `thenPrimIO` \ address ->
- returnPrimIO (SockAddrInet port address)
-
--------------------------------------------------------------------------------
-
-
-packSockAddr :: SockAddr -> PrimIO (_MutableByteArray _RealWorld Int)
-packSockAddr (SockAddrUnix path) =
- allocSockAddr AF_UNIX `thenPrimIO` \ (ptr,_) ->
- _casm_ ``(((struct sockaddr_un *)%0)->sun_family) = AF_UNIX;''
- ptr `thenPrimIO` \ () ->
- _casm_ ``strcpy ((((struct sockaddr_un *)%0)->sun_path),%1);''
- ptr path `thenPrimIO` \ () ->
- returnPrimIO ptr
-
-packSockAddr (SockAddrInet port address) =
- allocSockAddr AF_INET `thenPrimIO` \ (ptr,_) ->
- _casm_ ``(((struct sockaddr_in *)%0)->sin_family) = AF_INET;''
- ptr `thenPrimIO` \ () ->
- _casm_ ``(((struct sockaddr_in *)%0)->sin_port) = htons((int)%1);''
- ptr port `thenPrimIO` \ () ->
- _casm_ ``(((struct sockaddr_in *)%0)->sin_addr.s_addr) = htonl(%1);''
- ptr address `thenPrimIO` \ () ->
- returnPrimIO ptr
-
--------------------------------------------------------------------------------
-
-socketToHandle :: Socket -> IO Handle
-socketToHandle (MkSocket s family stype protocol status) =
- _casm_ ``%r = fdopen (%0, "r+");'' s `thenPrimIO` \ ptr ->
- newEmptyMVar >>= \ handle ->
- putMVar handle (_SocketHandle ptr False) >>
- return handle
-
--------------------------------------------------------------------------------
-\end{code}
projects / ghc-hetmet.git / blobdiff