PageRenderTime 74ms CodeModel.GetById 23ms RepoModel.GetById 1ms app.codeStats 0ms

/hugs98-Nov2003/fptools/libraries/network/Network/Socket.hsc

https://github.com/gitpan/Language-Haskell
Unknown | 1855 lines | 1658 code | 197 blank | 0 comment | 0 complexity | bfa73b9e0845b19e01885aaa0c1b1f06 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause

Large files files are truncated, but you can click here to view the full file

  1. {-# OPTIONS -fglasgow-exts #-}
  2. -----------------------------------------------------------------------------
  3. -- |
  4. -- Module : Network.Socket
  5. -- Copyright : (c) The University of Glasgow 2001
  6. -- License : BSD-style (see the file libraries/core/LICENSE)
  7. --
  8. -- Maintainer : libraries@haskell.org
  9. -- Stability : provisional
  10. -- Portability : portable
  11. --
  12. -- The "Network.Socket" module is for when you want full control over
  13. -- sockets. Essentially the entire C socket API is exposed through
  14. -- this module; in general the operations follow the behaviour of the C
  15. -- functions of the same name (consult your favourite Unix networking book).
  16. --
  17. -- A higher level interface to networking operations is provided
  18. -- through the module "Network".
  19. --
  20. -----------------------------------------------------------------------------
  21. #include "HsNet.h"
  22. #if defined(HAVE_WINSOCK_H) && !defined(cygwin32_TARGET_OS)
  23. #define WITH_WINSOCK 1
  24. #endif
  25. #if !defined(mingw32_TARGET_OS) && !defined(_WIN32)
  26. #define DOMAIN_SOCKET_SUPPORT 1
  27. #endif
  28. #if !defined(CALLCONV)
  29. #ifdef WITH_WINSOCK
  30. #define CALLCONV stdcall
  31. #else
  32. #define CALLCONV ccall
  33. #endif
  34. #endif
  35. -- In order to process this file, you need to have CALLCONV defined.
  36. module Network.Socket (
  37. -- * Types
  38. Socket(..), -- instance Eq, Show
  39. Family(..),
  40. SocketType(..),
  41. SockAddr(..),
  42. SocketStatus(..),
  43. HostAddress,
  44. ShutdownCmd(..),
  45. ProtocolNumber,
  46. PortNumber(..),
  47. -- * Socket Operations
  48. socket, -- :: Family -> SocketType -> ProtocolNumber -> IO Socket
  49. #if defined(DOMAIN_SOCKET_SUPPORT)
  50. socketPair, -- :: Family -> SocketType -> ProtocolNumber -> IO (Socket, Socket)
  51. #endif
  52. connect, -- :: Socket -> SockAddr -> IO ()
  53. bindSocket, -- :: Socket -> SockAddr -> IO ()
  54. listen, -- :: Socket -> Int -> IO ()
  55. accept, -- :: Socket -> IO (Socket, SockAddr)
  56. getPeerName, -- :: Socket -> IO SockAddr
  57. getSocketName, -- :: Socket -> IO SockAddr
  58. #ifdef SO_PEERCRED
  59. -- get the credentials of our domain socket peer.
  60. getPeerCred, -- :: Socket -> IO (CUInt{-pid-}, CUInt{-uid-}, CUInt{-gid-})
  61. #endif
  62. socketPort, -- :: Socket -> IO PortNumber
  63. socketToHandle, -- :: Socket -> IOMode -> IO Handle
  64. sendTo, -- :: Socket -> String -> SockAddr -> IO Int
  65. recvFrom, -- :: Socket -> Int -> IO (String, Int, SockAddr)
  66. send, -- :: Socket -> String -> IO Int
  67. recv, -- :: Socket -> Int -> IO String
  68. recvLen, -- :: Socket -> Int -> IO (String, Int)
  69. inet_addr, -- :: String -> IO HostAddress
  70. inet_ntoa, -- :: HostAddress -> IO String
  71. shutdown, -- :: Socket -> ShutdownCmd -> IO ()
  72. sClose, -- :: Socket -> IO ()
  73. -- ** Predicates on sockets
  74. sIsConnected, -- :: Socket -> IO Bool
  75. sIsBound, -- :: Socket -> IO Bool
  76. sIsListening, -- :: Socket -> IO Bool
  77. sIsReadable, -- :: Socket -> IO Bool
  78. sIsWritable, -- :: Socket -> IO Bool
  79. -- * Socket options
  80. SocketOption(..),
  81. getSocketOption, -- :: Socket -> SocketOption -> IO Int
  82. setSocketOption, -- :: Socket -> SocketOption -> Int -> IO ()
  83. -- * File descriptor transmission
  84. #ifdef DOMAIN_SOCKET_SUPPORT
  85. sendFd, -- :: Socket -> CInt -> IO ()
  86. recvFd, -- :: Socket -> IO CInt
  87. -- Note: these two will disappear shortly
  88. sendAncillary, -- :: Socket -> Int -> Int -> Int -> Ptr a -> Int -> IO ()
  89. recvAncillary, -- :: Socket -> Int -> Int -> IO (Int,Int,Int,Ptr a)
  90. #endif
  91. -- * Special Constants
  92. aNY_PORT, -- :: PortNumber
  93. iNADDR_ANY, -- :: HostAddress
  94. sOMAXCONN, -- :: Int
  95. sOL_SOCKET, -- :: Int
  96. #ifdef SCM_RIGHTS
  97. sCM_RIGHTS, -- :: Int
  98. #endif
  99. maxListenQueue, -- :: Int
  100. -- * Initialisation
  101. withSocketsDo, -- :: IO a -> IO a
  102. -- * Very low level operations
  103. -- in case you ever want to get at the underlying file descriptor..
  104. fdSocket, -- :: Socket -> CInt
  105. mkSocket, -- :: CInt -> Family
  106. -- -> SocketType
  107. -- -> ProtocolNumber
  108. -- -> SocketStatus
  109. -- -> IO Socket
  110. -- * Internal
  111. -- | The following are exported ONLY for use in the BSD module and
  112. -- should not be used anywhere else.
  113. packFamily, unpackFamily,
  114. packSocketType,
  115. throwSocketErrorIfMinus1_
  116. ) where
  117. #ifdef __HUGS__
  118. import Hugs.Prelude
  119. import Hugs.IO ( openFd )
  120. {-# CBITS HsNet.c initWinSock.c ancilData.c winSockErr.c #-}
  121. #endif
  122. import Data.Word ( Word8, Word16, Word32 )
  123. import Foreign.Ptr ( Ptr, castPtr, plusPtr )
  124. import Foreign.Storable ( Storable(..) )
  125. import Foreign.C.Error
  126. import Foreign.C.String ( withCString, peekCString, peekCStringLen, castCharToCChar )
  127. import Foreign.C.Types ( CInt, CUInt, CChar, CSize )
  128. import Foreign.Marshal.Alloc ( alloca, allocaBytes )
  129. import Foreign.Marshal.Array ( peekArray, pokeArray0 )
  130. import Foreign.Marshal.Utils ( with )
  131. import System.IO
  132. import Control.Monad ( liftM, when )
  133. import Data.Ratio ( (%) )
  134. import qualified Control.Exception
  135. import Control.Concurrent.MVar
  136. #ifdef __GLASGOW_HASKELL__
  137. import GHC.Conc (threadWaitRead, threadWaitWrite)
  138. # if defined(mingw32_TARGET_OS)
  139. import GHC.Conc (asyncDoProc)
  140. import Foreign( FunPtr )
  141. # endif
  142. import GHC.Handle
  143. import GHC.IOBase
  144. import qualified System.Posix.Internals
  145. #endif
  146. -----------------------------------------------------------------------------
  147. -- Socket types
  148. -- There are a few possible ways to do this. The first is convert the
  149. -- structs used in the C library into an equivalent Haskell type. An
  150. -- other possible implementation is to keep all the internals in the C
  151. -- code and use an Int## and a status flag. The second method is used
  152. -- here since a lot of the C structures are not required to be
  153. -- manipulated.
  154. -- Originally the status was non-mutable so we had to return a new
  155. -- socket each time we changed the status. This version now uses
  156. -- mutable variables to avoid the need to do this. The result is a
  157. -- cleaner interface and better security since the application
  158. -- programmer now can't circumvent the status information to perform
  159. -- invalid operations on sockets.
  160. data SocketStatus
  161. -- Returned Status Function called
  162. = NotConnected -- socket
  163. | Bound -- bindSocket
  164. | Listening -- listen
  165. | Connected -- connect/accept
  166. deriving (Eq, Show)
  167. data Socket
  168. = MkSocket
  169. CInt -- File Descriptor
  170. Family
  171. SocketType
  172. ProtocolNumber -- Protocol Number
  173. (MVar SocketStatus) -- Status Flag
  174. mkSocket :: CInt
  175. -> Family
  176. -> SocketType
  177. -> ProtocolNumber
  178. -> SocketStatus
  179. -> IO Socket
  180. mkSocket fd fam sType pNum stat = do
  181. mStat <- newMVar stat
  182. return (MkSocket fd fam sType pNum mStat)
  183. instance Eq Socket where
  184. (MkSocket _ _ _ _ m1) == (MkSocket _ _ _ _ m2) = m1 == m2
  185. instance Show Socket where
  186. showsPrec n (MkSocket fd _ _ _ _) =
  187. showString "<socket: " . shows fd . showString ">"
  188. fdSocket :: Socket -> CInt
  189. fdSocket (MkSocket fd _ _ _ _) = fd
  190. type ProtocolNumber = CInt
  191. -- NOTE: HostAddresses are represented in network byte order.
  192. -- Functions that expect the address in machine byte order
  193. -- will have to perform the necessary translation.
  194. type HostAddress = Word32
  195. ----------------------------------------------------------------------------
  196. -- Port Numbers
  197. --
  198. -- newtyped to prevent accidental use of sane-looking
  199. -- port numbers that haven't actually been converted to
  200. -- network-byte-order first.
  201. --
  202. newtype PortNumber = PortNum Word16 deriving ( Eq, Ord )
  203. instance Show PortNumber where
  204. showsPrec p pn = showsPrec p (portNumberToInt pn)
  205. intToPortNumber :: Int -> PortNumber
  206. intToPortNumber v = PortNum (htons (fromIntegral v))
  207. portNumberToInt :: PortNumber -> Int
  208. portNumberToInt (PortNum po) = fromIntegral (ntohs po)
  209. foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16
  210. foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16
  211. --foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32
  212. foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32
  213. instance Enum PortNumber where
  214. toEnum = intToPortNumber
  215. fromEnum = portNumberToInt
  216. instance Num PortNumber where
  217. fromInteger i = intToPortNumber (fromInteger i)
  218. -- for completeness.
  219. (+) x y = intToPortNumber (portNumberToInt x + portNumberToInt y)
  220. (-) x y = intToPortNumber (portNumberToInt x - portNumberToInt y)
  221. negate x = intToPortNumber (-portNumberToInt x)
  222. (*) x y = intToPortNumber (portNumberToInt x * portNumberToInt y)
  223. abs n = intToPortNumber (abs (portNumberToInt n))
  224. signum n = intToPortNumber (signum (portNumberToInt n))
  225. instance Real PortNumber where
  226. toRational x = toInteger x % 1
  227. instance Integral PortNumber where
  228. quotRem a b = let (c,d) = quotRem (portNumberToInt a) (portNumberToInt b) in
  229. (intToPortNumber c, intToPortNumber d)
  230. toInteger a = toInteger (portNumberToInt a)
  231. instance Storable PortNumber where
  232. sizeOf _ = sizeOf (undefined :: Word16)
  233. alignment _ = alignment (undefined :: Word16)
  234. poke p (PortNum po) = poke (castPtr p) po
  235. peek p = PortNum `liftM` peek (castPtr p)
  236. -----------------------------------------------------------------------------
  237. -- SockAddr
  238. -- The scheme used for addressing sockets is somewhat quirky. The
  239. -- calls in the BSD socket API that need to know the socket address
  240. -- all operate in terms of struct sockaddr, a `virtual' type of
  241. -- socket address.
  242. -- The Internet family of sockets are addressed as struct sockaddr_in,
  243. -- so when calling functions that operate on struct sockaddr, we have
  244. -- to type cast the Internet socket address into a struct sockaddr.
  245. -- Instances of the structure for different families might *not* be
  246. -- the same size. Same casting is required of other families of
  247. -- sockets such as Xerox NS. Similarly for Unix domain sockets.
  248. -- To represent these socket addresses in Haskell-land, we do what BSD
  249. -- didn't do, and use a union/algebraic type for the different
  250. -- families. Currently only Unix domain sockets and the Internet family
  251. -- are supported.
  252. data SockAddr -- C Names
  253. = SockAddrInet
  254. PortNumber -- sin_port (network byte order)
  255. HostAddress -- sin_addr (ditto)
  256. #if defined(DOMAIN_SOCKET_SUPPORT)
  257. | SockAddrUnix
  258. String -- sun_path
  259. #endif
  260. deriving (Eq)
  261. #if defined(WITH_WINSOCK) || defined(cygwin32_TARGET_OS)
  262. type CSaFamily = (#type unsigned short)
  263. #elif defined(darwin_TARGET_OS)
  264. type CSaFamily = (#type u_char)
  265. #else
  266. type CSaFamily = (#type sa_family_t)
  267. #endif
  268. -- we can't write an instance of Storable for SockAddr, because the Storable
  269. -- class can't easily handle alternatives.
  270. #if defined(DOMAIN_SOCKET_SUPPORT)
  271. pokeSockAddr p (SockAddrUnix path) = do
  272. (#poke struct sockaddr_un, sun_family) p ((#const AF_UNIX) :: CSaFamily)
  273. let pathC = map castCharToCChar path
  274. pokeArray0 0 ((#ptr struct sockaddr_un, sun_path) p) pathC
  275. #endif
  276. pokeSockAddr p (SockAddrInet (PortNum port) addr) = do
  277. (#poke struct sockaddr_in, sin_family) p ((#const AF_INET) :: CSaFamily)
  278. (#poke struct sockaddr_in, sin_port) p port
  279. (#poke struct sockaddr_in, sin_addr) p addr
  280. peekSockAddr p = do
  281. family <- (#peek struct sockaddr, sa_family) p
  282. case family :: CSaFamily of
  283. #if defined(DOMAIN_SOCKET_SUPPORT)
  284. (#const AF_UNIX) -> do
  285. str <- peekCString ((#ptr struct sockaddr_un, sun_path) p)
  286. return (SockAddrUnix str)
  287. #endif
  288. (#const AF_INET) -> do
  289. addr <- (#peek struct sockaddr_in, sin_addr) p
  290. port <- (#peek struct sockaddr_in, sin_port) p
  291. return (SockAddrInet (PortNum port) addr)
  292. -- size of struct sockaddr by family
  293. #if defined(DOMAIN_SOCKET_SUPPORT)
  294. sizeOfSockAddr_Family AF_UNIX = #const sizeof(struct sockaddr_un)
  295. #endif
  296. sizeOfSockAddr_Family AF_INET = #const sizeof(struct sockaddr_in)
  297. -- size of struct sockaddr by SockAddr
  298. #if defined(DOMAIN_SOCKET_SUPPORT)
  299. sizeOfSockAddr (SockAddrUnix _) = #const sizeof(struct sockaddr_un)
  300. #endif
  301. sizeOfSockAddr (SockAddrInet _ _) = #const sizeof(struct sockaddr_in)
  302. withSockAddr :: SockAddr -> (Ptr SockAddr -> Int -> IO a) -> IO a
  303. withSockAddr addr f = do
  304. let sz = sizeOfSockAddr addr
  305. allocaBytes sz $ \p -> pokeSockAddr p addr >> f (castPtr p) sz
  306. withNewSockAddr :: Family -> (Ptr SockAddr -> Int -> IO a) -> IO a
  307. withNewSockAddr family f = do
  308. let sz = sizeOfSockAddr_Family family
  309. allocaBytes sz $ \ptr -> f ptr sz
  310. -----------------------------------------------------------------------------
  311. -- Connection Functions
  312. -- In the following connection and binding primitives. The names of
  313. -- the equivalent C functions have been preserved where possible. It
  314. -- should be noted that some of these names used in the C library,
  315. -- \tr{bind} in particular, have a different meaning to many Haskell
  316. -- programmers and have thus been renamed by appending the prefix
  317. -- Socket.
  318. -- Create an unconnected socket of the given family, type and
  319. -- protocol. The most common invocation of $socket$ is the following:
  320. -- ...
  321. -- my_socket <- socket AF_INET Stream 6
  322. -- ...
  323. socket :: Family -- Family Name (usually AF_INET)
  324. -> SocketType -- Socket Type (usually Stream)
  325. -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
  326. -> IO Socket -- Unconnected Socket
  327. socket family stype protocol = do
  328. fd <- throwSocketErrorIfMinus1Retry "socket" $
  329. c_socket (packFamily family) (packSocketType stype) protocol
  330. #if !defined(__HUGS__)
  331. System.Posix.Internals.setNonBlockingFD fd
  332. #endif
  333. socket_status <- newMVar NotConnected
  334. return (MkSocket fd family stype protocol socket_status)
  335. -- Create an unnamed pair of connected sockets, given family, type and
  336. -- protocol. Differs from a normal pipe in being a bi-directional channel
  337. -- of communication.
  338. #if defined(DOMAIN_SOCKET_SUPPORT)
  339. socketPair :: Family -- Family Name (usually AF_INET)
  340. -> SocketType -- Socket Type (usually Stream)
  341. -> ProtocolNumber -- Protocol Number
  342. -> IO (Socket, Socket) -- unnamed and connected.
  343. socketPair family stype protocol = do
  344. allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do
  345. rc <- throwSocketErrorIfMinus1Retry "socketpair" $
  346. c_socketpair (packFamily family)
  347. (packSocketType stype)
  348. protocol fdArr
  349. [fd1,fd2] <- peekArray 2 fdArr
  350. s1 <- mkSocket fd1
  351. s2 <- mkSocket fd2
  352. return (s1,s2)
  353. where
  354. mkSocket fd = do
  355. #if !defined(__HUGS__)
  356. System.Posix.Internals.setNonBlockingFD fd
  357. #endif
  358. stat <- newMVar Connected
  359. return (MkSocket fd family stype protocol stat)
  360. foreign import ccall unsafe "socketpair"
  361. c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt
  362. #endif
  363. -----------------------------------------------------------------------------
  364. -- Binding a socket
  365. --
  366. -- Given a port number this {\em binds} the socket to that port. This
  367. -- means that the programmer is only interested in data being sent to
  368. -- that port number. The $Family$ passed to $bindSocket$ must
  369. -- be the same as that passed to $socket$. If the special port
  370. -- number $aNY\_PORT$ is passed then the system assigns the next
  371. -- available use port.
  372. --
  373. -- Port numbers for standard unix services can be found by calling
  374. -- $getServiceEntry$. These are traditionally port numbers below
  375. -- 1000; although there are afew, namely NFS and IRC, which used higher
  376. -- numbered ports.
  377. --
  378. -- The port number allocated to a socket bound by using $aNY\_PORT$ can be
  379. -- found by calling $port$
  380. bindSocket :: Socket -- Unconnected Socket
  381. -> SockAddr -- Address to Bind to
  382. -> IO ()
  383. bindSocket (MkSocket s _family _stype _protocol socketStatus) addr = do
  384. modifyMVar_ socketStatus $ \ status -> do
  385. if status /= NotConnected
  386. then
  387. ioError (userError ("bindSocket: can't peform bind on socket in status " ++
  388. show status))
  389. else do
  390. withSockAddr addr $ \p_addr sz -> do
  391. status <- throwSocketErrorIfMinus1Retry "bind" $ c_bind s p_addr (fromIntegral sz)
  392. return Bound
  393. -----------------------------------------------------------------------------
  394. -- Connecting a socket
  395. --
  396. -- Make a connection to an already opened socket on a given machine
  397. -- and port. assumes that we have already called createSocket,
  398. -- otherwise it will fail.
  399. --
  400. -- This is the dual to $bindSocket$. The {\em server} process will
  401. -- usually bind to a port number, the {\em client} will then connect
  402. -- to the same port number. Port numbers of user applications are
  403. -- normally agreed in advance, otherwise we must rely on some meta
  404. -- protocol for telling the other side what port number we have been
  405. -- allocated.
  406. connect :: Socket -- Unconnected Socket
  407. -> SockAddr -- Socket address stuff
  408. -> IO ()
  409. connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = do
  410. modifyMVar_ socketStatus $ \currentStatus -> do
  411. if currentStatus /= NotConnected
  412. then
  413. ioError (userError ("connect: can't peform connect on socket in status " ++
  414. show currentStatus))
  415. else do
  416. withSockAddr addr $ \p_addr sz -> do
  417. let connectLoop = do
  418. r <- c_connect s p_addr (fromIntegral sz)
  419. if r == -1
  420. then do
  421. #if !(defined(HAVE_WINSOCK_H) && !defined(cygwin32_TARGET_OS))
  422. err <- getErrno
  423. case () of
  424. _ | err == eINTR -> connectLoop
  425. _ | err == eINPROGRESS -> connectBlocked
  426. -- _ | err == eAGAIN -> connectBlocked
  427. otherwise -> throwErrno "connect"
  428. #else
  429. rc <- c_getLastError
  430. case rc of
  431. 10093 -> do -- WSANOTINITIALISED
  432. withSocketsDo (return ())
  433. r <- c_connect s p_addr (fromIntegral sz)
  434. if r == -1
  435. then (c_getLastError >>= throwSocketError "connect")
  436. else return r
  437. _ -> throwSocketError "connect" rc
  438. #endif
  439. else return r
  440. connectBlocked = do
  441. #if !defined(__HUGS__)
  442. threadWaitWrite (fromIntegral s)
  443. #endif
  444. err <- getSocketOption sock SoError
  445. if (err == 0)
  446. then return 0
  447. else do ioError (errnoToIOError "connect"
  448. (Errno (fromIntegral err))
  449. Nothing Nothing)
  450. connectLoop
  451. return Connected
  452. -----------------------------------------------------------------------------
  453. -- Listen
  454. --
  455. -- The programmer must call $listen$ to tell the system software that
  456. -- they are now interested in receiving data on this port. This must
  457. -- be called on the bound socket before any calls to read or write
  458. -- data are made.
  459. -- The programmer also gives a number which indicates the length of
  460. -- the incoming queue of unread messages for this socket. On most
  461. -- systems the maximum queue length is around 5. To remove a message
  462. -- from the queue for processing a call to $accept$ should be made.
  463. listen :: Socket -- Connected & Bound Socket
  464. -> Int -- Queue Length
  465. -> IO ()
  466. listen (MkSocket s _family _stype _protocol socketStatus) backlog = do
  467. modifyMVar_ socketStatus $ \ status -> do
  468. if status /= Bound
  469. then
  470. ioError (userError ("listen: can't peform listen on socket in status " ++
  471. show status))
  472. else do
  473. throwSocketErrorIfMinus1Retry "listen" (c_listen s (fromIntegral backlog))
  474. return Listening
  475. -----------------------------------------------------------------------------
  476. -- Accept
  477. --
  478. -- A call to `accept' only returns when data is available on the given
  479. -- socket, unless the socket has been set to non-blocking. It will
  480. -- return a new socket which should be used to read the incoming data and
  481. -- should then be closed. Using the socket returned by `accept' allows
  482. -- incoming requests to be queued on the original socket.
  483. accept :: Socket -- Queue Socket
  484. -> IO (Socket, -- Readable Socket
  485. SockAddr) -- Peer details
  486. accept sock@(MkSocket s family stype protocol status) = do
  487. currentStatus <- readMVar status
  488. okay <- sIsAcceptable sock
  489. if not okay
  490. then
  491. ioError (userError ("accept: can't perform accept on socket (" ++ (show (family,stype,protocol)) ++") in status " ++
  492. show currentStatus))
  493. else do
  494. let sz = sizeOfSockAddr_Family family
  495. allocaBytes sz $ \ sockaddr -> do
  496. #if defined(mingw32_TARGET_OS) && !defined(__HUGS__)
  497. paramData <- c_newAcceptParams s (fromIntegral sz) sockaddr
  498. rc <- asyncDoProc c_acceptDoProc paramData
  499. new_sock <- c_acceptNewSock paramData
  500. c_free paramData
  501. when (rc /= 0)
  502. (ioError (errnoToIOError "Network.Socket.accept" (Errno (fromIntegral rc)) Nothing Nothing))
  503. #else
  504. with (fromIntegral sz) $ \ ptr_len -> do
  505. new_sock <-
  506. # if !defined(__HUGS__)
  507. throwErrnoIfMinus1Retry_repeatOnBlock "accept"
  508. (threadWaitRead (fromIntegral s))
  509. # endif
  510. (c_accept s sockaddr ptr_len)
  511. # if !defined(__HUGS__)
  512. System.Posix.Internals.setNonBlockingFD new_sock
  513. # endif
  514. #endif
  515. addr <- peekSockAddr sockaddr
  516. new_status <- newMVar Connected
  517. return ((MkSocket new_sock family stype protocol new_status), addr)
  518. #if defined(mingw32_TARGET_OS) && !defined(__HUGS__)
  519. foreign import ccall unsafe "HsNet.h acceptNewSock"
  520. c_acceptNewSock :: Ptr () -> IO CInt
  521. foreign import ccall unsafe "HsNet.h newAcceptParams"
  522. c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ())
  523. foreign import ccall unsafe "HsNet.h &acceptDoProc"
  524. c_acceptDoProc :: FunPtr (Ptr () -> IO Int)
  525. foreign import ccall unsafe "free"
  526. c_free:: Ptr a -> IO ()
  527. #endif
  528. -----------------------------------------------------------------------------
  529. -- sendTo & recvFrom
  530. sendTo :: Socket -- (possibly) bound/connected Socket
  531. -> String -- Data to send
  532. -> SockAddr
  533. -> IO Int -- Number of Bytes sent
  534. sendTo (MkSocket s _family _stype _protocol status) xs addr = do
  535. withSockAddr addr $ \p_addr sz -> do
  536. withCString xs $ \str -> do
  537. liftM fromIntegral $
  538. #if !defined(__HUGS__)
  539. throwErrnoIfMinus1Retry_repeatOnBlock "sendTo"
  540. (threadWaitWrite (fromIntegral s)) $
  541. #endif
  542. c_sendto s str (fromIntegral $ length xs) 0{-flags-}
  543. p_addr (fromIntegral sz)
  544. recvFrom :: Socket -> Int -> IO (String, Int, SockAddr)
  545. recvFrom sock@(MkSocket s _family _stype _protocol status) nbytes
  546. | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvFrom")
  547. | otherwise =
  548. allocaBytes nbytes $ \ptr -> do
  549. withNewSockAddr AF_INET $ \ptr_addr sz -> do
  550. alloca $ \ptr_len -> do
  551. poke ptr_len (fromIntegral sz)
  552. len <-
  553. #if !defined(__HUGS__)
  554. throwErrnoIfMinus1Retry_repeatOnBlock "recvFrom"
  555. (threadWaitRead (fromIntegral s)) $
  556. #endif
  557. c_recvfrom s ptr (fromIntegral nbytes) 0{-flags-}
  558. ptr_addr ptr_len
  559. let len' = fromIntegral len
  560. if len' == 0
  561. then ioError (mkEOFError "Network.Socket.recvFrom")
  562. else do
  563. flg <- sIsConnected sock
  564. -- For at least one implementation (WinSock 2), recvfrom() ignores
  565. -- filling in the sockaddr for connected TCP sockets. Cope with
  566. -- this by using getPeerName instead.
  567. sockaddr <-
  568. if flg then
  569. getPeerName sock
  570. else
  571. peekSockAddr ptr_addr
  572. str <- peekCStringLen (ptr,len')
  573. return (str, len', sockaddr)
  574. -----------------------------------------------------------------------------
  575. -- send & recv
  576. send :: Socket -- Bound/Connected Socket
  577. -> String -- Data to send
  578. -> IO Int -- Number of Bytes sent
  579. send (MkSocket s _family _stype _protocol status) xs = do
  580. withCString xs $ \str -> do
  581. liftM fromIntegral $
  582. #if !defined(__HUGS__)
  583. throwErrnoIfMinus1Retry_repeatOnBlock "send"
  584. (threadWaitWrite (fromIntegral s)) $
  585. #endif
  586. c_send s str (fromIntegral $ length xs) 0{-flags-}
  587. recv :: Socket -> Int -> IO String
  588. recv sock l = recvLen sock l >>= \ (s,_) -> return s
  589. recvLen :: Socket -> Int -> IO (String, Int)
  590. recvLen sock@(MkSocket s _family _stype _protocol status) nbytes
  591. | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recv")
  592. | otherwise = do
  593. allocaBytes nbytes $ \ptr -> do
  594. len <-
  595. #if !defined(__HUGS__)
  596. throwErrnoIfMinus1Retry_repeatOnBlock "recv"
  597. (threadWaitRead (fromIntegral s)) $
  598. #endif
  599. c_recv s ptr (fromIntegral nbytes) 0{-flags-}
  600. let len' = fromIntegral len
  601. if len' == 0
  602. then ioError (mkEOFError "Network.Socket.recv")
  603. else do
  604. s <- peekCStringLen (ptr,len')
  605. return (s, len')
  606. -- ---------------------------------------------------------------------------
  607. -- socketPort
  608. --
  609. -- The port number the given socket is currently connected to can be
  610. -- determined by calling $port$, is generally only useful when bind
  611. -- was given $aNY\_PORT$.
  612. socketPort :: Socket -- Connected & Bound Socket
  613. -> IO PortNumber -- Port Number of Socket
  614. socketPort sock@(MkSocket _ AF_INET _ _ _) = do
  615. (SockAddrInet port _) <- getSocketName sock
  616. return port
  617. socketPort (MkSocket _ family _ _ _) =
  618. ioError (userError ("socketPort: not supported for Family " ++ show family))
  619. -- ---------------------------------------------------------------------------
  620. -- getPeerName
  621. -- Calling $getPeerName$ returns the address details of the machine,
  622. -- other than the local one, which is connected to the socket. This is
  623. -- used in programs such as FTP to determine where to send the
  624. -- returning data. The corresponding call to get the details of the
  625. -- local machine is $getSocketName$.
  626. getPeerName :: Socket -> IO SockAddr
  627. getPeerName (MkSocket s family _ _ _) = do
  628. withNewSockAddr family $ \ptr sz -> do
  629. with (fromIntegral sz) $ \int_star -> do
  630. throwSocketErrorIfMinus1Retry "getPeerName" $ c_getpeername s ptr int_star
  631. sz <- peek int_star
  632. peekSockAddr ptr
  633. getSocketName :: Socket -> IO SockAddr
  634. getSocketName (MkSocket s family _ _ _) = do
  635. withNewSockAddr family $ \ptr sz -> do
  636. with (fromIntegral sz) $ \int_star -> do
  637. throwSocketErrorIfMinus1Retry "getSocketName" $ c_getsockname s ptr int_star
  638. peekSockAddr ptr
  639. -----------------------------------------------------------------------------
  640. -- Socket Properties
  641. data SocketOption
  642. = DummySocketOption__
  643. #ifdef SO_DEBUG
  644. | Debug {- SO_DEBUG -}
  645. #endif
  646. #ifdef SO_REUSEADDR
  647. | ReuseAddr {- SO_REUSEADDR -}
  648. #endif
  649. #ifdef SO_TYPE
  650. | Type {- SO_TYPE -}
  651. #endif
  652. #ifdef SO_ERROR
  653. | SoError {- SO_ERROR -}
  654. #endif
  655. #ifdef SO_DONTROUTE
  656. | DontRoute {- SO_DONTROUTE -}
  657. #endif
  658. #ifdef SO_BROADCAST
  659. | Broadcast {- SO_BROADCAST -}
  660. #endif
  661. #ifdef SO_SNDBUF
  662. | SendBuffer {- SO_SNDBUF -}
  663. #endif
  664. #ifdef SO_RCVBUF
  665. | RecvBuffer {- SO_RCVBUF -}
  666. #endif
  667. #ifdef SO_KEEPALIVE
  668. | KeepAlive {- SO_KEEPALIVE -}
  669. #endif
  670. #ifdef SO_OOBINLINE
  671. | OOBInline {- SO_OOBINLINE -}
  672. #endif
  673. #ifdef IP_TTL
  674. | TimeToLive {- IP_TTL -}
  675. #endif
  676. #ifdef TCP_MAXSEG
  677. | MaxSegment {- TCP_MAXSEG -}
  678. #endif
  679. #ifdef TCP_NODELAY
  680. | NoDelay {- TCP_NODELAY -}
  681. #endif
  682. #ifdef SO_LINGER
  683. | Linger {- SO_LINGER -}
  684. #endif
  685. #ifdef SO_REUSEPORT
  686. | ReusePort {- SO_REUSEPORT -}
  687. #endif
  688. #ifdef SO_RCVLOWAT
  689. | RecvLowWater {- SO_RCVLOWAT -}
  690. #endif
  691. #ifdef SO_SNDLOWAT
  692. | SendLowWater {- SO_SNDLOWAT -}
  693. #endif
  694. #ifdef SO_RCVTIMEO
  695. | RecvTimeOut {- SO_RCVTIMEO -}
  696. #endif
  697. #ifdef SO_SNDTIMEO
  698. | SendTimeOut {- SO_SNDTIMEO -}
  699. #endif
  700. #ifdef SO_USELOOPBACK
  701. | UseLoopBack {- SO_USELOOPBACK -}
  702. #endif
  703. socketOptLevel :: SocketOption -> CInt
  704. socketOptLevel so =
  705. case so of
  706. #ifdef IP_TTL
  707. TimeToLive -> #const IPPROTO_IP
  708. #endif
  709. #ifdef TCP_MAXSEG
  710. MaxSegment -> #const IPPROTO_TCP
  711. #endif
  712. #ifdef TCP_NODELAY
  713. NoDelay -> #const IPPROTO_TCP
  714. #endif
  715. _ -> #const SOL_SOCKET
  716. packSocketOption :: SocketOption -> CInt
  717. packSocketOption so =
  718. case so of
  719. #ifdef SO_DEBUG
  720. Debug -> #const SO_DEBUG
  721. #endif
  722. #ifdef SO_REUSEADDR
  723. ReuseAddr -> #const SO_REUSEADDR
  724. #endif
  725. #ifdef SO_TYPE
  726. Type -> #const SO_TYPE
  727. #endif
  728. #ifdef SO_ERROR
  729. SoError -> #const SO_ERROR
  730. #endif
  731. #ifdef SO_DONTROUTE
  732. DontRoute -> #const SO_DONTROUTE
  733. #endif
  734. #ifdef SO_BROADCAST
  735. Broadcast -> #const SO_BROADCAST
  736. #endif
  737. #ifdef SO_SNDBUF
  738. SendBuffer -> #const SO_SNDBUF
  739. #endif
  740. #ifdef SO_RCVBUF
  741. RecvBuffer -> #const SO_RCVBUF
  742. #endif
  743. #ifdef SO_KEEPALIVE
  744. KeepAlive -> #const SO_KEEPALIVE
  745. #endif
  746. #ifdef SO_OOBINLINE
  747. OOBInline -> #const SO_OOBINLINE
  748. #endif
  749. #ifdef IP_TTL
  750. TimeToLive -> #const IP_TTL
  751. #endif
  752. #ifdef TCP_MAXSEG
  753. MaxSegment -> #const TCP_MAXSEG
  754. #endif
  755. #ifdef TCP_NODELAY
  756. NoDelay -> #const TCP_NODELAY
  757. #endif
  758. #ifdef SO_LINGER
  759. Linger -> #const SO_LINGER
  760. #endif
  761. #ifdef SO_REUSEPORT
  762. ReusePort -> #const SO_REUSEPORT
  763. #endif
  764. #ifdef SO_RCVLOWAT
  765. RecvLowWater -> #const SO_RCVLOWAT
  766. #endif
  767. #ifdef SO_SNDLOWAT
  768. SendLowWater -> #const SO_SNDLOWAT
  769. #endif
  770. #ifdef SO_RCVTIMEO
  771. RecvTimeOut -> #const SO_RCVTIMEO
  772. #endif
  773. #ifdef SO_SNDTIMEO
  774. SendTimeOut -> #const SO_SNDTIMEO
  775. #endif
  776. #ifdef SO_USELOOPBACK
  777. UseLoopBack -> #const SO_USELOOPBACK
  778. #endif
  779. setSocketOption :: Socket
  780. -> SocketOption -- Option Name
  781. -> Int -- Option Value
  782. -> IO ()
  783. setSocketOption (MkSocket s _ _ _ _) so v = do
  784. with (fromIntegral v) $ \ptr_v -> do
  785. throwErrnoIfMinus1_ "setSocketOption" $
  786. c_setsockopt s (socketOptLevel so) (packSocketOption so) ptr_v
  787. (fromIntegral (sizeOf v))
  788. return ()
  789. getSocketOption :: Socket
  790. -> SocketOption -- Option Name
  791. -> IO Int -- Option Value
  792. getSocketOption (MkSocket s _ _ _ _) so = do
  793. alloca $ \ptr_v ->
  794. with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do
  795. throwErrnoIfMinus1 "getSocketOption" $
  796. c_getsockopt s (socketOptLevel so) (packSocketOption so) ptr_v ptr_sz
  797. fromIntegral `liftM` peek ptr_v
  798. #ifdef SO_PEERCRED
  799. -- | Returns the processID, userID and groupID of the socket's peer.
  800. --
  801. -- Only available on platforms that support SO_PEERCRED on domain sockets.
  802. getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt)
  803. getPeerCred sock = do
  804. let fd = fdSocket sock
  805. let sz = (fromIntegral (#const sizeof(struct ucred)))
  806. with sz $ \ ptr_cr ->
  807. alloca $ \ ptr_sz -> do
  808. poke ptr_sz sz
  809. throwErrnoIfMinus1 "getPeerCred" $
  810. c_getsockopt fd (#const SOL_SOCKET) (#const SO_PEERCRED) ptr_cr ptr_sz
  811. pid <- (#peek struct ucred, pid) ptr_cr
  812. uid <- (#peek struct ucred, uid) ptr_cr
  813. gid <- (#peek struct ucred, gid) ptr_cr
  814. return (pid, uid, gid)
  815. #endif
  816. #if defined(DOMAIN_SOCKET_SUPPORT)
  817. -- sending/receiving ancillary socket data; low-level mechanism
  818. -- for transmitting file descriptors, mainly.
  819. sendFd :: Socket -> CInt -> IO ()
  820. sendFd sock outfd = do
  821. let fd = fdSocket sock
  822. #if !defined(__HUGS__)
  823. throwErrnoIfMinus1Retry_repeatOnBlock "sendFd"
  824. (threadWaitWrite (fromIntegral fd)) $
  825. c_sendFd fd outfd
  826. #else
  827. c_sendFd fd outfd
  828. #endif
  829. -- Note: If Winsock supported FD-passing, thi would have been
  830. -- incorrect (since socket FDs need to be closed via closesocket().)
  831. c_close outfd
  832. return ()
  833. recvFd :: Socket -> IO CInt
  834. recvFd sock = do
  835. let fd = fdSocket sock
  836. theFd <-
  837. #if !defined(__HUGS__)
  838. throwErrnoIfMinus1Retry_repeatOnBlock "recvFd"
  839. (threadWaitRead (fromIntegral fd)) $
  840. #endif
  841. c_recvFd fd
  842. return theFd
  843. sendAncillary :: Socket
  844. -> Int
  845. -> Int
  846. -> Int
  847. -> Ptr a
  848. -> Int
  849. -> IO ()
  850. sendAncillary sock level ty flags datum len = do
  851. let fd = fdSocket sock
  852. _ <-
  853. #if !defined(__HUGS__)
  854. throwErrnoIfMinus1Retry_repeatOnBlock "sendAncillary"
  855. (threadWaitWrite (fromIntegral fd)) $
  856. #endif
  857. c_sendAncillary fd (fromIntegral level) (fromIntegral ty)
  858. (fromIntegral flags) datum (fromIntegral len)
  859. return ()
  860. recvAncillary :: Socket
  861. -> Int
  862. -> Int
  863. -> IO (Int,Int,Ptr a,Int)
  864. recvAncillary sock flags len = do
  865. let fd = fdSocket sock
  866. alloca $ \ ptr_len ->
  867. alloca $ \ ptr_lev ->
  868. alloca $ \ ptr_ty ->
  869. alloca $ \ ptr_pData -> do
  870. poke ptr_len (fromIntegral len)
  871. _ <-
  872. #if !defined(__HUGS__)
  873. throwErrnoIfMinus1Retry_repeatOnBlock "recvAncillary"
  874. (threadWaitRead (fromIntegral fd)) $
  875. #endif
  876. c_recvAncillary fd ptr_lev ptr_ty (fromIntegral flags) ptr_pData ptr_len
  877. len <- fromIntegral `liftM` peek ptr_len
  878. lev <- fromIntegral `liftM` peek ptr_lev
  879. ty <- fromIntegral `liftM` peek ptr_ty
  880. pD <- peek ptr_pData
  881. return (lev,ty,pD, len)
  882. foreign import ccall unsafe "sendAncillary"
  883. c_sendAncillary :: CInt -> CInt -> CInt -> CInt -> Ptr a -> CInt -> IO CInt
  884. foreign import ccall unsafe "recvAncillary"
  885. c_recvAncillary :: CInt -> Ptr CInt -> Ptr CInt -> CInt -> Ptr (Ptr a) -> Ptr CInt -> IO CInt
  886. foreign import ccall unsafe "sendFd" c_sendFd :: CInt -> CInt -> IO CInt
  887. foreign import ccall unsafe "recvFd" c_recvFd :: CInt -> IO CInt
  888. #endif
  889. {-
  890. A calling sequence table for the main functions is shown in the table below.
  891. \begin{figure}[h]
  892. \begin{center}
  893. \begin{tabular}{|l|c|c|c|c|c|c|c|}d
  894. \hline
  895. {\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\
  896. \hline
  897. {\bf Precedes} & & & & & & & \\
  898. \hline
  899. socket & & & & & & & \\
  900. \hline
  901. connect & + & & & & & & \\
  902. \hline
  903. bindSocket & + & & & & & & \\
  904. \hline
  905. listen & & & + & & & & \\
  906. \hline
  907. accept & & & & + & & & \\
  908. \hline
  909. read & & + & & + & + & + & + \\
  910. \hline
  911. write & & + & & + & + & + & + \\
  912. \hline
  913. \end{tabular}
  914. \caption{Sequence Table for Major functions of Socket}
  915. \label{tab:api-seq}
  916. \end{center}
  917. \end{figure}
  918. -}
  919. -- ---------------------------------------------------------------------------
  920. -- OS Dependent Definitions
  921. unpackFamily :: CInt -> Family
  922. packFamily :: Family -> CInt
  923. packSocketType :: SocketType -> CInt
  924. -- | Address Families.
  925. --
  926. -- This data type might have different constructors depending on what is
  927. -- supported by the operating system.
  928. data Family
  929. = AF_UNSPEC -- unspecified
  930. #ifdef AF_UNIX
  931. | AF_UNIX -- local to host (pipes, portals
  932. #endif
  933. #ifdef AF_INET
  934. | AF_INET -- internetwork: UDP, TCP, etc
  935. #endif
  936. #ifdef AF_INET6
  937. | AF_INET6 -- Internet Protocol version 6
  938. #endif
  939. #ifdef AF_IMPLINK
  940. | AF_IMPLINK -- arpanet imp addresses
  941. #endif
  942. #ifdef AF_PUP
  943. | AF_PUP -- pup protocols: e.g. BSP
  944. #endif
  945. #ifdef AF_CHAOS
  946. | AF_CHAOS -- mit CHAOS protocols
  947. #endif
  948. #ifdef AF_NS
  949. | AF_NS -- XEROX NS protocols
  950. #endif
  951. #ifdef AF_NBS
  952. | AF_NBS -- nbs protocols
  953. #endif
  954. #ifdef AF_ECMA
  955. | AF_ECMA -- european computer manufacturers
  956. #endif
  957. #ifdef AF_DATAKIT
  958. | AF_DATAKIT -- datakit protocols
  959. #endif
  960. #ifdef AF_CCITT
  961. | AF_CCITT -- CCITT protocols, X.25 etc
  962. #endif
  963. #ifdef AF_SNA
  964. | AF_SNA -- IBM SNA
  965. #endif
  966. #ifdef AF_DECnet
  967. | AF_DECnet -- DECnet
  968. #endif
  969. #ifdef AF_DLI
  970. | AF_DLI -- Direct data link interface
  971. #endif
  972. #ifdef AF_LAT
  973. | AF_LAT -- LAT
  974. #endif
  975. #ifdef AF_HYLINK
  976. | AF_HYLINK -- NSC Hyperchannel
  977. #endif
  978. #ifdef AF_APPLETALK
  979. | AF_APPLETALK -- Apple Talk
  980. #endif
  981. #ifdef AF_ROUTE
  982. | AF_ROUTE -- Internal Routing Protocol
  983. #endif
  984. #ifdef AF_NETBIOS
  985. | AF_NETBIOS -- NetBios-style addresses
  986. #endif
  987. #ifdef AF_NIT
  988. | AF_NIT -- Network Interface Tap
  989. #endif
  990. #ifdef AF_802
  991. | AF_802 -- IEEE 802.2, also ISO 8802
  992. #endif
  993. #ifdef AF_ISO
  994. | AF_ISO -- ISO protocols
  995. #endif
  996. #ifdef AF_OSI
  997. | AF_OSI -- umbrella of all families used by OSI
  998. #endif
  999. #ifdef AF_NETMAN
  1000. | AF_NETMAN -- DNA Network Management
  1001. #endif
  1002. #ifdef AF_X25
  1003. | AF_X25 -- CCITT X.25
  1004. #endif
  1005. #ifdef AF_AX25
  1006. | AF_AX25
  1007. #endif
  1008. #ifdef AF_OSINET
  1009. | AF_OSINET -- AFI
  1010. #endif
  1011. #ifdef AF_GOSSIP
  1012. | AF_GOSSIP -- US Government OSI
  1013. #endif
  1014. #ifdef AF_IPX
  1015. | AF_IPX -- Novell Internet Protocol
  1016. #endif
  1017. #ifdef Pseudo_AF_XTP
  1018. | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
  1019. #endif
  1020. #ifdef AF_CTF
  1021. | AF_CTF -- Common Trace Facility
  1022. #endif
  1023. #ifdef AF_WAN
  1024. | AF_WAN -- Wide Area Network protocols
  1025. #endif
  1026. #ifdef AF_SDL
  1027. | AF_SDL -- SGI Data Link for DLPI
  1028. #endif
  1029. #ifdef AF_NETWARE
  1030. | AF_NETWARE
  1031. #endif
  1032. #ifdef AF_NDD
  1033. | AF_NDD
  1034. #endif
  1035. #ifdef AF_INTF
  1036. | AF_INTF -- Debugging use only
  1037. #endif
  1038. #ifdef AF_COIP
  1039. | AF_COIP -- connection-oriented IP, aka ST II
  1040. #endif
  1041. #ifdef AF_CNT
  1042. | AF_CNT -- Computer Network Technology
  1043. #endif
  1044. #ifdef Pseudo_AF_RTIP
  1045. | Pseudo_AF_RTIP -- Help Identify RTIP packets
  1046. #endif
  1047. #ifdef Pseudo_AF_PIP
  1048. | Pseudo_AF_PIP -- Help Identify PIP packets
  1049. #endif
  1050. #ifdef AF_SIP
  1051. | AF_SIP -- Simple Internet Protocol
  1052. #endif
  1053. #ifdef AF_ISDN
  1054. | AF_ISDN -- Integrated Services Digital Network
  1055. #endif
  1056. #ifdef Pseudo_AF_KEY
  1057. | Pseudo_AF_KEY -- Internal key-management function
  1058. #endif
  1059. #ifdef AF_NATM
  1060. | AF_NATM -- native ATM access
  1061. #endif
  1062. #ifdef AF_ARP
  1063. | AF_ARP -- (rev.) addr. res. prot. (RFC 826)
  1064. #endif
  1065. #ifdef Pseudo_AF_HDRCMPLT
  1066. | Pseudo_AF_HDRCMPLT -- Used by BPF to not rewrite hdrs in iface output
  1067. #endif
  1068. #ifdef AF_ENCAP
  1069. | AF_ENCAP
  1070. #endif
  1071. #ifdef AF_LINK
  1072. | AF_LINK -- Link layer interface
  1073. #endif
  1074. #ifdef AF_RAW
  1075. | AF_RAW -- Link layer interface
  1076. #endif
  1077. #ifdef AF_RIF
  1078. | AF_RIF -- raw interface
  1079. #endif
  1080. deriving (Eq, Ord, Read, Show)
  1081. ------ ------
  1082. packFamily f = case f of
  1083. AF_UNSPEC -> #const AF_UNSPEC
  1084. #ifdef AF_UNIX
  1085. AF_UNIX -> #const AF_UNIX
  1086. #endif
  1087. #ifdef AF_INET
  1088. AF_INET -> #const AF_INET
  1089. #endif
  1090. #ifdef AF_INET6
  1091. AF_INET6 -> #const AF_INET6
  1092. #endif
  1093. #ifdef AF_IMPLINK
  1094. AF_IMPLINK -> #const AF_IMPLINK
  1095. #endif
  1096. #ifdef AF_PUP
  1097. AF_PUP -> #const AF_PUP
  1098. #endif
  1099. #ifdef AF_CHAOS
  1100. AF_CHAOS -> #const AF_CHAOS
  1101. #endif
  1102. #ifdef AF_NS
  1103. AF_NS -> #const AF_NS
  1104. #endif
  1105. #ifdef AF_NBS
  1106. AF_NBS -> #const AF_NBS
  1107. #endif
  1108. #ifdef AF_ECMA
  1109. AF_ECMA -> #const AF_ECMA
  1110. #endif
  1111. #ifdef AF_DATAKIT
  1112. AF_DATAKIT -> #const AF_DATAKIT
  1113. #endif
  1114. #ifdef AF_CCITT
  1115. AF_CCITT -> #const AF_CCITT
  1116. #endif
  1117. #ifdef AF_SNA
  1118. AF_SNA -> #const AF_SNA
  1119. #endif
  1120. #ifdef AF_DECnet
  1121. AF_DECnet -> #const AF_DECnet
  1122. #endif
  1123. #ifdef AF_DLI
  1124. AF_DLI -> #const AF_DLI
  1125. #endif
  1126. #ifdef AF_LAT
  1127. AF_LAT -> #const AF_LAT
  1128. #endif
  1129. #ifdef AF_HYLINK
  1130. AF_HYLINK -> #const AF_HYLINK
  1131. #endif
  1132. #ifdef AF_APPLETALK
  1133. AF_APPLETALK -> #const AF_APPLETALK
  1134. #endif
  1135. #ifdef AF_ROUTE
  1136. AF_ROUTE -> #const AF_ROUTE
  1137. #endif
  1138. #ifdef AF_NETBIOS
  1139. AF_NETBIOS -> #const AF_NETBIOS
  1140. #endif
  1141. #ifdef AF_NIT
  1142. AF_NIT -> #const AF_NIT
  1143. #endif
  1144. #ifdef AF_802
  1145. AF_802 -> #const AF_802
  1146. #endif
  1147. #ifdef AF_ISO
  1148. AF_ISO -> #const AF_ISO
  1149. #endif
  1150. #ifdef AF_OSI
  1151. AF_OSI -> #const AF_OSI
  1152. #endif
  1153. #ifdef AF_NETMAN
  1154. AF_NETMAN -> #const AF_NETMAN
  1155. #endif
  1156. #ifdef AF_X25
  1157. AF_X25 -> #const AF_X25
  1158. #endif
  1159. #ifdef AF_AX25
  1160. AF_AX25 -> #const AF_AX25
  1161. #endif
  1162. #ifdef AF_OSINET
  1163. AF_OSINET -> #const AF_OSINET
  1164. #endif
  1165. #ifdef AF_GOSSIP
  1166. AF_GOSSIP -> #const AF_GOSSIP
  1167. #endif
  1168. #ifdef AF_IPX
  1169. AF_IPX -> #const AF_IPX
  1170. #endif
  1171. #ifdef Pseudo_AF_XTP
  1172. Pseudo_AF_XTP -> #const Pseudo_AF_XTP
  1173. #endif
  1174. #ifdef AF_CTF
  1175. AF_CTF -> #const AF_CTF
  1176. #endif
  1177. #ifdef AF_WAN
  1178. AF_WAN -> #const AF_WAN
  1179. #endif
  1180. #ifdef AF_SDL
  1181. AF_SDL -> #const AF_SDL
  1182. #endif
  1183. #ifdef AF_NETWARE
  1184. AF_NETWARE -> #const AF_NETWARE
  1185. #endif
  1186. #ifdef AF_NDD
  1187. AF_NDD -> #const AF_NDD
  1188. #endif
  1189. #ifdef AF_INTF
  1190. AF_INTF -> #const AF_INTF
  1191. #endif
  1192. #ifdef AF_COIP
  1193. AF_COIP -> #const AF_COIP
  1194. #endif
  1195. #ifdef AF_CNT
  1196. AF_CNT -> #const AF_CNT
  1197. #endif
  1198. #ifdef Pseudo_AF_RTIP
  1199. Pseudo_AF_RTIP -> #const Pseudo_AF_RTIP
  1200. #endif
  1201. #ifdef Pseudo_AF_PIP
  1202. Pseudo_AF_PIP -> #const Pseudo_AF_PIP
  1203. #endif
  1204. #ifdef AF_SIP
  1205. AF_SIP -> #const AF_SIP
  1206. #endif
  1207. #ifdef AF_ISDN
  1208. AF_ISDN -> #const AF_ISDN
  1209. #endif
  1210. #ifdef Pseudo_AF_KEY
  1211. Pseudo_AF_KEY -> #const Pseudo_AF_KEY
  1212. #endif
  1213. #ifdef AF_NATM
  1214. AF_NATM -> #const AF_NATM
  1215. #endif
  1216. #ifdef AF_ARP
  1217. AF_ARP -> #const AF_ARP
  1218. #endif
  1219. #ifdef Pseudo_AF_HDRCMPLT
  1220. Pseudo_AF_HDRCMPLT -> #const Pseudo_AF_HDRCMPLT
  1221. #endif
  1222. #ifdef AF_ENCAP
  1223. AF_ENCAP -> #const AF_ENCAP
  1224. #endif
  1225. #ifdef AF_LINK
  1226. AF_LINK -> #const AF_LINK
  1227. #endif
  1228. #ifdef AF_RAW
  1229. AF_RAW -> #const AF_RAW
  1230. #endif
  1231. #ifdef AF_RIF
  1232. AF_RIF -> #const AF_RIF
  1233. #endif
  1234. --------- ----------
  1235. unpackFamily f = case f of
  1236. (#const AF_UNSPEC) -> AF_UNSPEC
  1237. #ifdef AF_UNIX
  1238. (#const AF_UNIX) -> AF_UNIX
  1239. #endif
  1240. #ifdef AF_INET
  1241. (#const AF_INET) -> AF_INET
  1242. #endif
  1243. #ifdef AF_INET6
  1244. (#const AF_INET6) -> AF_INET6
  1245. #endif
  1246. #ifdef AF_IMPLINK
  1247. (#const AF_IMPLINK) -> AF_IMPLINK
  1248. #endif
  1249. #ifdef AF_PUP
  1250. (#const AF_PUP) -> AF_PUP
  1251. #endif
  1252. #ifdef AF_CHAOS
  1253. (#const AF_CHAOS) -> AF_CHAOS
  1254. #endif
  1255. #ifdef AF_NS
  1256. (#const AF_NS) -> AF_NS
  1257. #endif
  1258. #ifdef AF_NBS
  1259. (#const AF_NBS) -> AF_NBS
  1260. #endif
  1261. #ifdef AF_ECMA
  1262. (#const AF_ECMA) -> AF_ECMA
  1263. #endif
  1264. #ifdef AF_DATAKIT
  1265. (#const AF_DATAKIT) -> AF_DATAKIT
  1266. #endif
  1267. #ifdef AF_CCITT
  1268. (#const AF_CCITT) -> AF_CCITT
  1269. #endif
  1270. #ifdef AF_SNA
  1271. (#const AF_SNA) -> AF_SNA
  1272. #endif
  1273. #ifdef AF_DECnet
  1274. (#const AF_DECnet) -> AF_DECnet
  1275. #endif
  1276. #ifdef AF_DLI
  1277. (#const AF_DLI) -> AF_DLI
  1278. #endif
  1279. #ifdef AF_LAT
  1280. (#const AF_LAT) -> AF_LAT
  1281. #endif
  1282. #ifdef AF_HYLINK
  1283. (#const AF_HYLINK) -> AF_HYLINK
  1284. #endif
  1285. #ifdef AF_APPLETALK
  1286. (#const AF_APPLETALK) -> AF_APPLETALK
  1287. #endif
  1288. #ifdef AF_ROUTE
  1289. (#const AF_ROUTE) -> AF_ROUTE
  1290. #endif
  1291. #ifdef AF_NETBIOS
  1292. (#const AF_NETBIOS) -> AF_NETBIOS
  1293. #endif
  1294. #ifdef AF_NIT
  1295. (#const AF_NIT) -> AF_NIT
  1296. #endif
  1297. #ifdef AF_802
  1298. (#const AF_802) -> AF_802
  1299. #endif
  1300. #ifdef AF_ISO
  1301. (#const AF_ISO) -> AF_ISO
  1302. #endif
  1303. #ifdef AF_OSI
  1304. # if (!defined(AF_ISO)) || (defined(AF_ISO) && (AF_ISO != AF_OSI))
  1305. (#const AF_OSI) -> AF_OSI
  1306. # endif
  1307. #endif
  1308. #ifdef AF_NETMAN
  1309. (#const AF_NETMAN) -> AF_NETMAN
  1310. #endif
  1311. #ifdef AF_X25
  1312. (#const AF_X25) -> AF_X25
  1313. #endif
  1314. #ifdef AF_AX25
  1315. (#const AF_AX25) -> AF_AX25
  1316. #endif
  1317. #ifdef AF_OSINET
  1318. (#const AF_OSINET) -> AF_OSINET
  1319. #endif
  1320. #ifdef AF_GOSSIP
  1321. (#const AF_GOSSIP) -> AF_GOSSIP
  1322. #endif
  1323. #ifdef AF_IPX
  1324. (#const AF_IPX) -> AF_IPX
  1325. #endif
  1326. #ifdef Pseudo_AF_XTP
  1327. (#const Pseudo_AF_XTP) -> Pseudo_AF_XTP
  1328. #endif
  1329. #ifdef AF_CTF
  1330. (#const AF_CTF) -> AF_CTF
  1331. #endif
  1332. #ifdef AF_WAN
  1333. (#const AF_WAN) -> AF_WAN
  1334. #endif
  1335. #ifdef AF_SDL
  1336. (#const AF_SDL) -> AF_SDL
  1337. #endif
  1338. #ifdef AF_NETWARE
  1339. (#const AF_NETWARE) -> AF_NETWARE
  1340. #endif
  1341. #ifdef AF_NDD
  1342. (#const AF_NDD) -> AF_NDD
  1343. #endif
  1344. #ifdef AF_INTF
  1345. (#const AF_INTF) -> AF_INTF
  1346. #endif
  1347. #ifdef AF_COIP
  1348. (#const AF_COIP) -> AF_COIP
  1349. #endif
  1350. #ifdef AF_CNT
  1351. (#const AF_CNT) -> AF_CNT
  1352. #endif
  1353. #ifdef Pseudo_AF_RTIP
  1354. (#const Pseudo_AF_RTIP) -> Pseudo_AF_RTIP
  1355. #endif
  1356. #ifdef Pseudo_AF_PIP
  1357. (#const Pseudo_AF_PIP) -> Pseudo_AF_PIP
  1358. #endif
  1359. #ifdef AF_SIP
  1360. (#const AF_SIP) -> AF_SIP
  1361. #endif
  1362. #ifdef AF_ISDN
  1363. (#const AF_ISDN) -> AF_ISDN
  1364. #endif
  1365. #ifdef Pseudo_AF_KEY
  1366. (#const Pseudo_AF_KEY) -> Pseudo_AF_KEY
  1367. #endif
  1368. #ifdef AF_NATM
  1369. (#const AF_NATM) -> AF_NATM
  1370. #endif
  1371. #ifdef AF_ARP
  1372. (#const AF_ARP) -> AF_ARP
  1373. #endif
  1374. #ifdef Pseudo_AF_HDRCMPLT
  1375. (#const Pseudo_AF_HDRCMPLT) -> Pseudo_AF_HDRCMPLT
  1376. #endif
  1377. #ifdef AF_ENCAP
  1378. (#const AF_ENCAP) -> AF_ENCAP
  1379. #endif
  1380. #ifdef AF_LINK
  1381. (#const AF_LINK) -> AF_LINK
  1382. #endif
  1383. #ifdef AF_RAW
  1384. (#const AF_RAW) -> AF_RAW
  1385. #endif
  1386. #ifdef AF_RIF
  1387. (#const AF_RIF) -> AF_RIF
  1388. #endif
  1389. -- Socket Types.
  1390. -- | Socket Types.
  1391. --
  1392. -- This data type might have different constructors depending on what is
  1393. -- supported by the operating system.
  1394. data SocketType
  1395. = NoSocketType
  1396. #ifdef SOCK_STREAM
  1397. | Stream
  1398. #endif
  1399. #ifdef SOCK_DGRAM
  1400. | Datagram
  1401. #endif
  1402. #ifdef SOCK_RAW
  1403. | Raw
  1404. #endif
  1405. #ifdef SOCK_RDM
  1406. | RDM
  1407. #endif
  1408. #ifdef SOCK_SEQPACKET
  1409. | SeqPacket
  1410. #endif
  1411. deriving (Eq, Ord, Read, Show)
  1412. packSocketType stype = case stype of
  1413. NoSocketType -> 0
  1414. #ifdef SOCK_STREAM
  1415. Stream -> #const SOCK_STREAM
  1416. #endif
  1417. #ifdef SOCK_DGRAM
  1418. Datagram -> #const SOCK_DGRAM
  1419. #endif
  1420. #ifdef SOCK_RAW
  1421. Raw -> #const SOCK_RAW
  1422. #endif
  1423. #ifdef SOCK_RDM
  1424. RDM -> #const SOCK_RDM
  1425. #endif
  1426. #ifdef SOCK_SEQPACKET
  1427. SeqPacket -> #const SOCK_SEQPACKET
  1428. #endif
  1429. -- ---------------------------------------------------------------------------
  1430. -- Utility Functions
  1431. aNY_PORT :: PortNumber
  1432. aNY_PORT = 0
  1433. iNADDR_ANY :: HostAddress
  1434. iNADDR_ANY = htonl (#const INADDR_ANY)
  1435. sOMAXCONN :: Int
  1436. sOMAXCONN = #const SOMAXCONN
  1437. sOL_SOCKET :: Int
  1438. sOL_SOCKET = #const SOL_SOCKET
  1439. #ifdef SCM_RIGHTS
  1440. sCM_RIGHTS :: Int
  1441. sCM_RIGHTS = #const SCM_RIGHTS
  1442. #endif
  1443. maxListenQueue :: Int
  1444. maxListenQueue = sOMAXCONN
  1445. -- -----------------------------------------------------------------------------
  1446. data ShutdownCmd
  1447. = ShutdownReceive
  1448. | ShutdownSend
  1449. | ShutdownBoth
  1450. sdownCmdToInt :: ShutdownCmd -> CInt
  1451. sdownCmdToInt ShutdownReceive = 0
  1452. sdownCmdToInt ShutdownSend = 1
  1453. sdownCmdToInt ShutdownBoth = 2
  1454. shutdown :: Socket -> ShutdownCmd -> IO ()
  1455. shutdown (MkSocket s _ _ _ _) stype = do
  1456. throwSocketErrorIfMinus1Retry "shutdown" (c_shutdown s (sdownCmdToInt stype))
  1457. return ()
  1458. -- -----------------------------------------------------------------------------
  1459. sClose :: Socket -> IO ()
  1460. sClose (MkSocket s _ _ _ _) = do c_close s; return ()
  1461. -- -----------------------------------------------------------------------------
  1462. sIsConnected :: Socket -> IO Bool
  1463. sIsConnected (MkSocket _ _ _ _ status) = do
  1464. value <- readMVar status
  1465. return (value == Connected)
  1466. -- -----------------------------------------------------------------------------
  1467. -- Socket Predicates
  1468. sIsBound :: Socket -> IO Bool
  1469. sIsBound (MkSocket _ _ _ _ status) = do
  1470. value <- readMVar status
  1471. return (value == Bound)
  1472. sIsListening :: Socket -> IO Bool
  1473. sIsListening (MkSocket _ _ _ _ status) = do
  1474. value <- readMVar status
  1475. return (value == Listening)
  1476. sIsReadable :: Socket -> IO Bool
  1477. sIsReadable (MkSocket _ _ _ _ status) = do
  1478. value <- readMVar status
  1479. return (value == Listening || value == Connected)
  1480. sIsWritable :: Socket -> IO Bool
  1481. sIsWritable = sIsReadable -- sort of.
  1482. sIsAcceptable :: Socket -> IO Bool
  1483. #if defined(DOMAIN_SOCKET_SUPPORT)
  1484. sIsAcceptable (MkSocket _ AF_UNIX Stream _ status) = do
  1485. value <- readMVar status
  1486. return (value == Connected || value == Bound || value == Listening)
  1487. sIsAcceptable (MkSocket _ AF_UNIX _ _ _) = return False
  1488. #endif
  1489. sIsAcceptable (MkSocket _ _ _ _ status) = do
  1490. value <- readMVar status
  1491. return (value == Connected || value == Listening)
  1492. -- -----------------------------------------------------------------------------
  1493. -- Internet address manipulation routines:
  1494. inet_addr :: String -> IO HostAddress
  1495. inet_addr ipstr = do
  1496. withCString ipstr $ \str -> do
  1497. had <- c_inet_addr str
  1498. if had == -1
  1499. then ioError (userError ("inet_addr: Malformed address: " ++ ipstr))
  1500. else return had -- network byte order
  1501. inet_ntoa :: HostAddress -> IO String
  1502. inet_ntoa haddr = do
  1503. pstr <- c_inet_ntoa haddr
  1504. peekCString pstr
  1505. -- socketHandle turns a Socket into a Haskell IO Handle. By default, the new
  1506. -- handle is unbuffered. Use hSetBuffering to alter this.
  1507. #ifndef __PARALLEL_HASKELL__
  1508. socketToHandle :: Socket -> IOMode -> IO Handle
  1509. socketToHandle s@(MkSocket fd _ _ _ _) mode = do
  1510. # ifdef __GLASGOW_HASKELL__
  1511. openFd (fromIntegral fd) (Just System.Posix.Internals.Stream) (show s) mode True{-bin-} False{-no truncate-}
  1512. # endif
  1513. # ifdef __HUGS__
  1514. openFd (fromIntegral fd) True{-is a socket-} mode True{-bin-}
  1515. # endif
  1516. #else
  1517. socketToHandle (MkSocket s family stype protocol status) m =
  1518. error "socketToHandle not implemented in a parallel setup"
  1519. #endif
  1520. mkInvalidRecvArgError :: String -> IOError
  1521. mkInvalidRecvArgError loc = IOError Nothing
  1522. #ifdef __GLASGOW_HASKELL__
  1523. InvalidArgument
  1524. #else
  1525. IllegalOperation
  1526. #endif
  1527. loc "non-positive length" Nothing
  1528. mkEOFError :: String -> IOError
  1529. mkEOFError loc = IOError Nothing EOF loc "end of file" Nothing
  1530. -- ---------------------------------------------------------------------------
  1531. -- WinSock support
  1532. {-| On Windows operating systems, the networking subsystem has to be
  1533. initialised using 'withSocketsDo' before any networking operations can
  1534. be used. eg.
  1535. > main = withSocketsDo $ do {...}
  1536. Although this is only strictly necessary on Windows platforms, it is
  1537. harmless on other platforms, so for portability it is good practice to
  1538. use it all the time.
  1539. -}
  1540. withSocketsDo :: IO a -> IO a
  1541. #if !defined(WITH_WINSOCK)
  1542. withSocketsDo x = x
  1543. #else
  1544. withSocketsDo act = do
  1545. x <- initWinSock
  1546. if ( x /= 0 ) then
  1547. ioError (userError "Failed to initialise WinSock")
  1548. else do
  1549. act `Control.Exception.finally` shutdownWinSock
  1550. foreign import ccall unsafe "initWinSock" initWinSock :: IO Int
  1551. foreign import ccall unsafe "shutdownWinSock" shutdownWinSock :: IO ()
  1552. #endif
  1553. -- ---------------------------------------------------------------------------
  1554. -- foreign imports from the C library
  1555. foreign import ccall unsafe "my_inet_ntoa"
  1556. c_inet_ntoa :: HostAddress -> IO (Ptr CChar)
  1557. foreign import CALLCONV unsafe "inet_addr"
  1558. c_inet_addr :: Ptr CChar -> IO HostAddress
  1559. foreign import CALLCONV unsafe "shutdown"
  1560. c_shutdown :: CInt -> CInt -> IO CInt
  1561. #if !defined(WITH_WINSOCK)
  1562. foreign import ccall unsafe "close"
  1563. c_close :: CInt -> IO CInt
  1564. #else
  1565. foreign import stdcall unsafe "closesocket"
  1566. c_close :: CInt -> IO CInt
  1567. #endif
  1568. foreign import CALLCONV unsafe "socket"
  1569. c_socket :: CInt -> CInt -> CInt -> IO CInt
  1570. foreign import CALLCONV unsafe "bind"
  1571. c_bind :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt
  1572. foreign import CALLCONV unsafe "connect"
  1573. c_connect :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt
  1574. foreign import CALLCONV unsafe "accept"
  1575. c_accept :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt
  1576. foreign import CALLCONV unsafe "listen"
  1577. c_listen :: CInt -> CInt -> IO CInt
  1578. foreign import CALLCONV unsafe "send"
  1579. c_send :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
  1580. foreign import CALLCONV unsafe "sendto"
  1581. c_sendto :: CInt -> Ptr CChar -> CSize -> CInt -> Ptr SockAddr -> CInt -> IO CInt
  1582. foreign import CALLCONV unsafe "recv"
  1583. c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
  1584. foreign import CALLCONV unsafe "recvfrom"
  1585. c_recvfrom :: CInt -> Ptr CChar -> CSize -> CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt
  1586. foreign import CALLCONV unsafe "getpeername"
  1587. c_getpeername :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt
  1588. foreign import CALLCONV unsafe "getsockname"
  1589. c_getsockname :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt
  1590. foreign import CALLCONV unsafe "getsockopt"
  1591. c_getsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt
  1592. foreign import CALLCONV unsafe "setsoc…

Large files files are truncated, but you can click here to view the full file