PageRenderTime 59ms CodeModel.GetById 19ms RepoModel.GetById 0ms app.codeStats 0ms

/Network/Socket.hsc

https://github.com/hf6440/network
Unknown | 1673 lines | 1473 code | 200 blank | 0 comment | 0 complexity | d77799559c5a2ac36d3568829dc4138c MD5 | raw file

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

  1. {-# LANGUAGE CPP, ScopedTypeVariables #-}
  2. {-# OPTIONS_GHC -fno-warn-orphans #-}
  3. -----------------------------------------------------------------------------
  4. -- |
  5. -- Module : Network.Socket
  6. -- Copyright : (c) The University of Glasgow 2001
  7. -- License : BSD-style (see the file libraries/network/LICENSE)
  8. --
  9. -- Maintainer : libraries@haskell.org
  10. -- Stability : provisional
  11. -- Portability : portable
  12. --
  13. -- The "Network.Socket" module is for when you want full control over
  14. -- sockets. Essentially the entire C socket API is exposed through
  15. -- this module; in general the operations follow the behaviour of the C
  16. -- functions of the same name (consult your favourite Unix networking book).
  17. --
  18. -- A higher level interface to networking operations is provided
  19. -- through the module "Network".
  20. --
  21. -----------------------------------------------------------------------------
  22. #include "HsNet.h"
  23. -- NOTE: ##, we want this interpreted when compiling the .hs, not by hsc2hs.
  24. ##include "Typeable.h"
  25. -- In order to process this file, you need to have CALLCONV defined.
  26. module Network.Socket
  27. (
  28. -- * Types
  29. Socket(..)
  30. , Family(..)
  31. , isSupportedFamily
  32. , SocketType(..)
  33. , isSupportedSocketType
  34. , SockAddr(..)
  35. , SocketStatus(..)
  36. , HostAddress
  37. #if defined(IPV6_SOCKET_SUPPORT)
  38. , HostAddress6
  39. , FlowInfo
  40. , ScopeID
  41. #endif
  42. , ShutdownCmd(..)
  43. , ProtocolNumber
  44. , defaultProtocol
  45. , PortNumber(..)
  46. -- PortNumber is used non-abstractly in Network.BSD. ToDo: remove
  47. -- this use and make the type abstract.
  48. -- * Address operations
  49. , HostName
  50. , ServiceName
  51. #if defined(IPV6_SOCKET_SUPPORT)
  52. , AddrInfo(..)
  53. , AddrInfoFlag(..)
  54. , addrInfoFlagImplemented
  55. , defaultHints
  56. , getAddrInfo
  57. , NameInfoFlag(..)
  58. , getNameInfo
  59. #endif
  60. -- * Socket operations
  61. , socket
  62. #if defined(DOMAIN_SOCKET_SUPPORT)
  63. , socketPair
  64. #endif
  65. , connect
  66. , bind
  67. , listen
  68. , accept
  69. , getPeerName
  70. , getSocketName
  71. #ifdef HAVE_STRUCT_UCRED
  72. -- get the credentials of our domain socket peer.
  73. , getPeerCred
  74. #endif
  75. , socketPort
  76. , socketToHandle
  77. -- ** Sending and receiving data
  78. -- $sendrecv
  79. , sendTo
  80. , sendBufTo
  81. , recvFrom
  82. , recvBufFrom
  83. , send
  84. , recv
  85. , recvLen
  86. , sendBuf
  87. , recvBuf
  88. , inet_addr
  89. , inet_ntoa
  90. , shutdown
  91. , close
  92. -- ** Predicates on sockets
  93. , isConnected
  94. , isBound
  95. , isListening
  96. , isReadable
  97. , isWritable
  98. -- * Socket options
  99. , SocketOption(..)
  100. , isSupportedSocketOption
  101. , getSocketOption
  102. , setSocketOption
  103. -- * File descriptor transmission
  104. #ifdef DOMAIN_SOCKET_SUPPORT
  105. , sendFd
  106. , recvFd
  107. #endif
  108. -- * Special constants
  109. , aNY_PORT
  110. , iNADDR_ANY
  111. #if defined(IPV6_SOCKET_SUPPORT)
  112. , iN6ADDR_ANY
  113. #endif
  114. , sOMAXCONN
  115. , sOL_SOCKET
  116. #ifdef SCM_RIGHTS
  117. , sCM_RIGHTS
  118. #endif
  119. , maxListenQueue
  120. -- * Initialisation
  121. , withSocketsDo
  122. -- * Very low level operations
  123. -- in case you ever want to get at the underlying file descriptor..
  124. , fdSocket
  125. , mkSocket
  126. -- * Deprecated aliases
  127. -- $deprecated-aliases
  128. , bindSocket
  129. , sClose
  130. , sIsConnected
  131. , sIsBound
  132. , sIsListening
  133. , sIsReadable
  134. , sIsWritable
  135. -- * Internal
  136. -- | The following are exported ONLY for use in the BSD module and
  137. -- should not be used anywhere else.
  138. , packFamily
  139. , unpackFamily
  140. , packSocketType
  141. ) where
  142. import Data.Bits
  143. import Data.List (delete, foldl')
  144. import Data.Maybe (fromMaybe, isJust)
  145. import Data.Word (Word8, Word16, Word32)
  146. import Foreign.Ptr (Ptr, castPtr, nullPtr)
  147. import Foreign.Storable (Storable(..))
  148. import Foreign.C.Error
  149. import Foreign.C.String (CString, withCString, peekCString, peekCStringLen)
  150. import Foreign.C.Types (CUInt, CChar)
  151. #if __GLASGOW_HASKELL__ >= 703
  152. import Foreign.C.Types (CInt(..), CSize(..))
  153. #else
  154. import Foreign.C.Types (CInt, CSize)
  155. #endif
  156. import Foreign.Marshal.Alloc ( alloca, allocaBytes )
  157. import Foreign.Marshal.Array ( peekArray )
  158. import Foreign.Marshal.Utils ( maybeWith, with )
  159. import System.IO
  160. import Control.Monad (liftM, when)
  161. import Data.Ratio ((%))
  162. import qualified Control.Exception as E
  163. import Control.Concurrent.MVar
  164. import Data.Typeable
  165. import System.IO.Error
  166. import GHC.Conc (threadWaitRead, threadWaitWrite)
  167. ##if MIN_VERSION_base(4,3,1)
  168. import GHC.Conc (closeFdWith)
  169. ##endif
  170. # if defined(mingw32_HOST_OS)
  171. import GHC.Conc (asyncDoProc)
  172. import Foreign (FunPtr)
  173. # endif
  174. # if __GLASGOW_HASKELL__ >= 611
  175. import qualified GHC.IO.Device
  176. import GHC.IO.Handle.FD
  177. import GHC.IO.Exception
  178. import GHC.IO
  179. # else
  180. import GHC.IOBase
  181. import GHC.Handle
  182. # endif
  183. import qualified System.Posix.Internals
  184. # if __GLASGOW_HASKELL__ >= 611
  185. import GHC.IO.FD
  186. #endif
  187. import Network.Socket.Internal
  188. import Network.Socket.Types
  189. -- | Either a host name e.g., @\"haskell.org\"@ or a numeric host
  190. -- address string consisting of a dotted decimal IPv4 address or an
  191. -- IPv6 address e.g., @\"192.168.0.1\"@.
  192. type HostName = String
  193. type ServiceName = String
  194. -- ----------------------------------------------------------------------------
  195. -- On Windows, our sockets are not put in non-blocking mode (non-blocking
  196. -- is not supported for regular file descriptors on Windows, and it would
  197. -- be a pain to support it only for sockets). So there are two cases:
  198. --
  199. -- - the threaded RTS uses safe calls for socket operations to get
  200. -- non-blocking I/O, just like the rest of the I/O library
  201. --
  202. -- - with the non-threaded RTS, only some operations on sockets will be
  203. -- non-blocking. Reads and writes go through the normal async I/O
  204. -- system. accept() uses asyncDoProc so is non-blocking. A handful
  205. -- of others (recvFrom, sendFd, recvFd) will block all threads - if this
  206. -- is a problem, -threaded is the workaround.
  207. --
  208. ##if defined(mingw32_HOST_OS)
  209. ##define SAFE_ON_WIN safe
  210. ##else
  211. ##define SAFE_ON_WIN unsafe
  212. ##endif
  213. -----------------------------------------------------------------------------
  214. -- Socket types
  215. #if __GLASGOW_HASKELL__ >= 611 && defined(mingw32_HOST_OS)
  216. socket2FD (MkSocket fd _ _ _ _) =
  217. -- HACK, 1 means True
  218. FD{fdFD = fd,fdIsSocket_ = 1}
  219. #endif
  220. mkSocket :: CInt
  221. -> Family
  222. -> SocketType
  223. -> ProtocolNumber
  224. -> SocketStatus
  225. -> IO Socket
  226. mkSocket fd fam sType pNum stat = do
  227. mStat <- newMVar stat
  228. return (MkSocket fd fam sType pNum mStat)
  229. fdSocket :: Socket -> CInt
  230. fdSocket (MkSocket fd _ _ _ _) = fd
  231. -- | This is the default protocol for a given service.
  232. defaultProtocol :: ProtocolNumber
  233. defaultProtocol = 0
  234. -----------------------------------------------------------------------------
  235. -- SockAddr
  236. instance Show SockAddr where
  237. #if defined(DOMAIN_SOCKET_SUPPORT)
  238. showsPrec _ (SockAddrUnix str) = showString str
  239. #endif
  240. showsPrec _ (SockAddrInet port ha)
  241. = showString (unsafePerformIO (inet_ntoa ha))
  242. . showString ":"
  243. . shows port
  244. #if defined(IPV6_SOCKET_SUPPORT)
  245. showsPrec _ addr@(SockAddrInet6 port _ _ _)
  246. = showChar '['
  247. . showString (unsafePerformIO $
  248. fst `liftM` getNameInfo [NI_NUMERICHOST] True False addr >>=
  249. maybe (fail "showsPrec: impossible internal error") return)
  250. . showString "]:"
  251. . shows port
  252. #endif
  253. -----------------------------------------------------------------------------
  254. -- Connection Functions
  255. -- In the following connection and binding primitives. The names of
  256. -- the equivalent C functions have been preserved where possible. It
  257. -- should be noted that some of these names used in the C library,
  258. -- \tr{bind} in particular, have a different meaning to many Haskell
  259. -- programmers and have thus been renamed by appending the prefix
  260. -- Socket.
  261. -- | Create a new socket using the given address family, socket type
  262. -- and protocol number. The address family is usually 'AF_INET',
  263. -- 'AF_INET6', or 'AF_UNIX'. The socket type is usually 'Stream' or
  264. -- 'Datagram'. The protocol number is usually 'defaultProtocol'.
  265. -- If 'AF_INET6' is used, the 'IPv6Only' socket option is set to 0
  266. -- so that both IPv4 and IPv6 can be handled with one socket.
  267. socket :: Family -- Family Name (usually AF_INET)
  268. -> SocketType -- Socket Type (usually Stream)
  269. -> ProtocolNumber -- Protocol Number (getProtocolByName to find value)
  270. -> IO Socket -- Unconnected Socket
  271. socket family stype protocol = do
  272. c_stype <- packSocketTypeOrThrow "socket" stype
  273. fd <- throwSocketErrorIfMinus1Retry "socket" $
  274. c_socket (packFamily family) c_stype protocol
  275. setNonBlockIfNeeded fd
  276. socket_status <- newMVar NotConnected
  277. let sock = MkSocket fd family stype protocol socket_status
  278. #if HAVE_DECL_IPV6_V6ONLY
  279. # if defined(mingw32_HOST_OS)
  280. -- the IPv6Only option is only supported on Windows Vista and later,
  281. -- so trying to change it might throw an error
  282. when (family == AF_INET6) $
  283. E.catch (setSocketOption sock IPv6Only 0) $ (\(_ :: E.IOException) -> return ())
  284. # else
  285. when (family == AF_INET6) $ setSocketOption sock IPv6Only 0
  286. # endif
  287. #endif
  288. return sock
  289. -- | Build a pair of connected socket objects using the given address
  290. -- family, socket type, and protocol number. Address family, socket
  291. -- type, and protocol number are as for the 'socket' function above.
  292. -- Availability: Unix.
  293. #if defined(DOMAIN_SOCKET_SUPPORT)
  294. socketPair :: Family -- Family Name (usually AF_INET or AF_INET6)
  295. -> SocketType -- Socket Type (usually Stream)
  296. -> ProtocolNumber -- Protocol Number
  297. -> IO (Socket, Socket) -- unnamed and connected.
  298. socketPair family stype protocol = do
  299. allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do
  300. c_stype <- packSocketTypeOrThrow "socketPair" stype
  301. _rc <- throwSocketErrorIfMinus1Retry "socketpair" $
  302. c_socketpair (packFamily family) c_stype protocol fdArr
  303. [fd1,fd2] <- peekArray 2 fdArr
  304. s1 <- mkNonBlockingSocket fd1
  305. s2 <- mkNonBlockingSocket fd2
  306. return (s1,s2)
  307. where
  308. mkNonBlockingSocket fd = do
  309. setNonBlockIfNeeded fd
  310. stat <- newMVar Connected
  311. return (MkSocket fd family stype protocol stat)
  312. foreign import ccall unsafe "socketpair"
  313. c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt
  314. #endif
  315. -- | Set the socket to nonblocking, if applicable to this platform.
  316. setNonBlockIfNeeded :: CInt -> IO ()
  317. setNonBlockIfNeeded fd =
  318. #if __GLASGOW_HASKELL__ < 611
  319. System.Posix.Internals.setNonBlockingFD fd
  320. #else
  321. System.Posix.Internals.setNonBlockingFD fd True
  322. #endif
  323. -----------------------------------------------------------------------------
  324. -- Binding a socket
  325. -- | Bind the socket to an address. The socket must not already be
  326. -- bound. The 'Family' passed to @bind@ must be the
  327. -- same as that passed to 'socket'. If the special port number
  328. -- 'aNY_PORT' is passed then the system assigns the next available
  329. -- use port.
  330. bind :: Socket -- Unconnected Socket
  331. -> SockAddr -- Address to Bind to
  332. -> IO ()
  333. bind (MkSocket s _family _stype _protocol socketStatus) addr = do
  334. modifyMVar_ socketStatus $ \ status -> do
  335. if status /= NotConnected
  336. then
  337. ioError (userError ("bind: can't peform bind on socket in status " ++
  338. show status))
  339. else do
  340. withSockAddr addr $ \p_addr sz -> do
  341. _status <- throwSocketErrorIfMinus1Retry "bind" $ c_bind s p_addr (fromIntegral sz)
  342. return Bound
  343. -----------------------------------------------------------------------------
  344. -- Connecting a socket
  345. -- | Connect to a remote socket at address.
  346. connect :: Socket -- Unconnected Socket
  347. -> SockAddr -- Socket address stuff
  348. -> IO ()
  349. connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = do
  350. modifyMVar_ socketStatus $ \currentStatus -> do
  351. if currentStatus /= NotConnected && currentStatus /= Bound
  352. then
  353. ioError (userError ("connect: can't peform connect on socket in status " ++
  354. show currentStatus))
  355. else do
  356. withSockAddr addr $ \p_addr sz -> do
  357. let connectLoop = do
  358. r <- c_connect s p_addr (fromIntegral sz)
  359. if r == -1
  360. then do
  361. #if !(defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS))
  362. err <- getErrno
  363. case () of
  364. _ | err == eINTR -> connectLoop
  365. _ | err == eINPROGRESS -> connectBlocked
  366. -- _ | err == eAGAIN -> connectBlocked
  367. _otherwise -> throwSocketError "connect"
  368. #else
  369. rc <- c_getLastError
  370. case rc of
  371. #{const WSANOTINITIALISED} -> do
  372. withSocketsDo (return ())
  373. r <- c_connect s p_addr (fromIntegral sz)
  374. if r == -1
  375. then throwSocketError "connect"
  376. else return r
  377. _ -> throwSocketError "connect"
  378. #endif
  379. else return r
  380. connectBlocked = do
  381. threadWaitWrite (fromIntegral s)
  382. err <- getSocketOption sock SoError
  383. if (err == 0)
  384. then return 0
  385. else throwSocketErrorCode "connect" (fromIntegral err)
  386. connectLoop
  387. return Connected
  388. -----------------------------------------------------------------------------
  389. -- Listen
  390. -- | Listen for connections made to the socket. The second argument
  391. -- specifies the maximum number of queued connections and should be at
  392. -- least 1; the maximum value is system-dependent (usually 5).
  393. listen :: Socket -- Connected & Bound Socket
  394. -> Int -- Queue Length
  395. -> IO ()
  396. listen (MkSocket s _family _stype _protocol socketStatus) backlog = do
  397. modifyMVar_ socketStatus $ \ status -> do
  398. if status /= Bound
  399. then
  400. ioError (userError ("listen: can't peform listen on socket in status " ++
  401. show status))
  402. else do
  403. throwSocketErrorIfMinus1Retry "listen" (c_listen s (fromIntegral backlog))
  404. return Listening
  405. -----------------------------------------------------------------------------
  406. -- Accept
  407. --
  408. -- A call to `accept' only returns when data is available on the given
  409. -- socket, unless the socket has been set to non-blocking. It will
  410. -- return a new socket which should be used to read the incoming data and
  411. -- should then be closed. Using the socket returned by `accept' allows
  412. -- incoming requests to be queued on the original socket.
  413. -- | Accept a connection. The socket must be bound to an address and
  414. -- listening for connections. The return value is a pair @(conn,
  415. -- address)@ where @conn@ is a new socket object usable to send and
  416. -- receive data on the connection, and @address@ is the address bound
  417. -- to the socket on the other end of the connection.
  418. accept :: Socket -- Queue Socket
  419. -> IO (Socket, -- Readable Socket
  420. SockAddr) -- Peer details
  421. accept sock@(MkSocket s family stype protocol status) = do
  422. currentStatus <- readMVar status
  423. okay <- isAcceptable sock
  424. if not okay
  425. then
  426. ioError (userError ("accept: can't perform accept on socket (" ++ (show (family,stype,protocol)) ++") in status " ++
  427. show currentStatus))
  428. else do
  429. let sz = sizeOfSockAddrByFamily family
  430. allocaBytes sz $ \ sockaddr -> do
  431. #if defined(mingw32_HOST_OS)
  432. new_sock <-
  433. if threaded
  434. then with (fromIntegral sz) $ \ ptr_len ->
  435. throwSocketErrorIfMinus1Retry "Network.Socket.accept" $
  436. c_accept_safe s sockaddr ptr_len
  437. else do
  438. paramData <- c_newAcceptParams s (fromIntegral sz) sockaddr
  439. rc <- asyncDoProc c_acceptDoProc paramData
  440. new_sock <- c_acceptNewSock paramData
  441. c_free paramData
  442. when (rc /= 0) $
  443. throwSocketErrorCode "Network.Socket.accept" (fromIntegral rc)
  444. return new_sock
  445. #else
  446. with (fromIntegral sz) $ \ ptr_len -> do
  447. new_sock <-
  448. # ifdef HAVE_ACCEPT4
  449. throwSocketErrorIfMinus1RetryMayBlock "accept"
  450. (threadWaitRead (fromIntegral s))
  451. (c_accept4 s sockaddr ptr_len (#const SOCK_NONBLOCK))
  452. # else
  453. throwSocketErrorWaitRead sock "accept"
  454. (c_accept s sockaddr ptr_len)
  455. # endif /* HAVE_ACCEPT4 */
  456. #endif
  457. setNonBlockIfNeeded new_sock
  458. addr <- peekSockAddr sockaddr
  459. new_status <- newMVar Connected
  460. return ((MkSocket new_sock family stype protocol new_status), addr)
  461. #if defined(mingw32_HOST_OS)
  462. foreign import ccall unsafe "HsNet.h acceptNewSock"
  463. c_acceptNewSock :: Ptr () -> IO CInt
  464. foreign import ccall unsafe "HsNet.h newAcceptParams"
  465. c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ())
  466. foreign import ccall unsafe "HsNet.h &acceptDoProc"
  467. c_acceptDoProc :: FunPtr (Ptr () -> IO Int)
  468. foreign import ccall unsafe "free"
  469. c_free:: Ptr a -> IO ()
  470. #endif
  471. -----------------------------------------------------------------------------
  472. -- ** Sending and reciving data
  473. -- $sendrecv
  474. --
  475. -- Do not use the @send@ and @recv@ functions defined in this module
  476. -- in new code, as they incorrectly represent binary data as a Unicode
  477. -- string. As a result, these functions are inefficient and may lead
  478. -- to bugs in the program. Instead use the @send@ and @recv@
  479. -- functions defined in the 'Network.Socket.ByteString' module.
  480. -----------------------------------------------------------------------------
  481. -- sendTo & recvFrom
  482. -- | Send data to the socket. The recipient can be specified
  483. -- explicitly, so the socket need not be in a connected state.
  484. -- Returns the number of bytes sent. Applications are responsible for
  485. -- ensuring that all data has been sent.
  486. --
  487. -- NOTE: blocking on Windows unless you compile with -threaded (see
  488. -- GHC ticket #1129)
  489. sendTo :: Socket -- (possibly) bound/connected Socket
  490. -> String -- Data to send
  491. -> SockAddr
  492. -> IO Int -- Number of Bytes sent
  493. sendTo sock xs addr = do
  494. withCString xs $ \str -> do
  495. sendBufTo sock str (length xs) addr
  496. -- | Send data to the socket. The recipient can be specified
  497. -- explicitly, so the socket need not be in a connected state.
  498. -- Returns the number of bytes sent. Applications are responsible for
  499. -- ensuring that all data has been sent.
  500. sendBufTo :: Socket -- (possibly) bound/connected Socket
  501. -> Ptr a -> Int -- Data to send
  502. -> SockAddr
  503. -> IO Int -- Number of Bytes sent
  504. sendBufTo sock@(MkSocket s _family _stype _protocol _status) ptr nbytes addr = do
  505. withSockAddr addr $ \p_addr sz -> do
  506. liftM fromIntegral $
  507. throwSocketErrorWaitWrite sock "sendTo" $
  508. c_sendto s ptr (fromIntegral $ nbytes) 0{-flags-}
  509. p_addr (fromIntegral sz)
  510. -- | Receive data from the socket. The socket need not be in a
  511. -- connected state. Returns @(bytes, nbytes, address)@ where @bytes@
  512. -- is a @String@ of length @nbytes@ representing the data received and
  513. -- @address@ is a 'SockAddr' representing the address of the sending
  514. -- socket.
  515. --
  516. -- NOTE: blocking on Windows unless you compile with -threaded (see
  517. -- GHC ticket #1129)
  518. recvFrom :: Socket -> Int -> IO (String, Int, SockAddr)
  519. recvFrom sock nbytes =
  520. allocaBytes nbytes $ \ptr -> do
  521. (len, sockaddr) <- recvBufFrom sock ptr nbytes
  522. str <- peekCStringLen (ptr, len)
  523. return (str, len, sockaddr)
  524. -- | Receive data from the socket, writing it into buffer instead of
  525. -- creating a new string. The socket need not be in a connected
  526. -- state. Returns @(nbytes, address)@ where @nbytes@ is the number of
  527. -- bytes received and @address@ is a 'SockAddr' representing the
  528. -- address of the sending socket.
  529. --
  530. -- NOTE: blocking on Windows unless you compile with -threaded (see
  531. -- GHC ticket #1129)
  532. recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr)
  533. recvBufFrom sock@(MkSocket s family _stype _protocol _status) ptr nbytes
  534. | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvFrom")
  535. | otherwise =
  536. withNewSockAddr family $ \ptr_addr sz -> do
  537. alloca $ \ptr_len -> do
  538. poke ptr_len (fromIntegral sz)
  539. len <- throwSocketErrorWaitRead sock "recvFrom" $
  540. c_recvfrom s ptr (fromIntegral nbytes) 0{-flags-}
  541. ptr_addr ptr_len
  542. let len' = fromIntegral len
  543. if len' == 0
  544. then ioError (mkEOFError "Network.Socket.recvFrom")
  545. else do
  546. flg <- isConnected sock
  547. -- For at least one implementation (WinSock 2), recvfrom() ignores
  548. -- filling in the sockaddr for connected TCP sockets. Cope with
  549. -- this by using getPeerName instead.
  550. sockaddr <-
  551. if flg then
  552. getPeerName sock
  553. else
  554. peekSockAddr ptr_addr
  555. return (len', sockaddr)
  556. -----------------------------------------------------------------------------
  557. -- send & recv
  558. -- | Send data to the socket. The socket must be connected to a remote
  559. -- socket. Returns the number of bytes sent. Applications are
  560. -- responsible for ensuring that all data has been sent.
  561. send :: Socket -- Bound/Connected Socket
  562. -> String -- Data to send
  563. -> IO Int -- Number of Bytes sent
  564. send sock@(MkSocket s _family _stype _protocol _status) xs = do
  565. let len = length xs
  566. withCString xs $ \str -> do
  567. liftM fromIntegral $
  568. #if defined(mingw32_HOST_OS)
  569. # if __GLASGOW_HASKELL__ >= 611
  570. writeRawBufferPtr
  571. "Network.Socket.send"
  572. (socket2FD sock)
  573. (castPtr str)
  574. 0
  575. (fromIntegral len)
  576. #else
  577. writeRawBufferPtr
  578. "Network.Socket.send"
  579. (fromIntegral s)
  580. True
  581. str
  582. 0
  583. (fromIntegral len)
  584. #endif
  585. #else
  586. throwSocketErrorWaitWrite sock "send" $
  587. c_send s str (fromIntegral len) 0{-flags-}
  588. #endif
  589. -- | Send data to the socket. The socket must be connected to a remote
  590. -- socket. Returns the number of bytes sent. Applications are
  591. -- responsible for ensuring that all data has been sent.
  592. sendBuf :: Socket -- Bound/Connected Socket
  593. -> Ptr Word8 -- Pointer to the data to send
  594. -> Int -- Length of the buffer
  595. -> IO Int -- Number of Bytes sent
  596. sendBuf sock@(MkSocket s _family _stype _protocol _status) str len = do
  597. liftM fromIntegral $
  598. #if defined(mingw32_HOST_OS)
  599. # if __GLASGOW_HASKELL__ >= 611
  600. writeRawBufferPtr
  601. "Network.Socket.sendBuf"
  602. (socket2FD sock)
  603. (castPtr str)
  604. 0
  605. (fromIntegral len)
  606. # else
  607. writeRawBufferPtr
  608. "Network.Socket.sendBuf"
  609. (fromIntegral s)
  610. True
  611. str
  612. 0
  613. (fromIntegral len)
  614. # endif
  615. #else
  616. throwSocketErrorWaitWrite sock "sendBuf" $
  617. c_send s str (fromIntegral len) 0{-flags-}
  618. #endif
  619. -- | Receive data from the socket. The socket must be in a connected
  620. -- state. This function may return fewer bytes than specified. If the
  621. -- message is longer than the specified length, it may be discarded
  622. -- depending on the type of socket. This function may block until a
  623. -- message arrives.
  624. --
  625. -- Considering hardware and network realities, the maximum number of
  626. -- bytes to receive should be a small power of 2, e.g., 4096.
  627. --
  628. -- For TCP sockets, a zero length return value means the peer has
  629. -- closed its half side of the connection.
  630. recv :: Socket -> Int -> IO String
  631. recv sock l = recvLen sock l >>= \ (s,_) -> return s
  632. recvLen :: Socket -> Int -> IO (String, Int)
  633. recvLen sock@(MkSocket s _family _stype _protocol _status) nbytes
  634. | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recv")
  635. | otherwise = do
  636. allocaBytes nbytes $ \ptr -> do
  637. len <-
  638. #if defined(mingw32_HOST_OS)
  639. # if __GLASGOW_HASKELL__ >= 611
  640. readRawBufferPtr "Network.Socket.recvLen" (socket2FD sock) ptr 0
  641. (fromIntegral nbytes)
  642. #else
  643. readRawBufferPtr "Network.Socket.recvLen" (fromIntegral s) True ptr 0
  644. (fromIntegral nbytes)
  645. #endif
  646. #else
  647. throwSocketErrorWaitRead sock "recv" $
  648. c_recv s ptr (fromIntegral nbytes) 0{-flags-}
  649. #endif
  650. let len' = fromIntegral len
  651. if len' == 0
  652. then ioError (mkEOFError "Network.Socket.recv")
  653. else do
  654. s' <- peekCStringLen (castPtr ptr,len')
  655. return (s', len')
  656. -- | Receive data from the socket. The socket must be in a connected
  657. -- state. This function may return fewer bytes than specified. If the
  658. -- message is longer than the specified length, it may be discarded
  659. -- depending on the type of socket. This function may block until a
  660. -- message arrives.
  661. --
  662. -- Considering hardware and network realities, the maximum number of
  663. -- bytes to receive should be a small power of 2, e.g., 4096.
  664. --
  665. -- For TCP sockets, a zero length return value means the peer has
  666. -- closed its half side of the connection.
  667. recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int
  668. recvBuf sock p l = recvLenBuf sock p l
  669. recvLenBuf :: Socket -> Ptr Word8 -> Int -> IO Int
  670. recvLenBuf sock@(MkSocket s _family _stype _protocol _status) ptr nbytes
  671. | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf")
  672. | otherwise = do
  673. len <-
  674. #if defined(mingw32_HOST_OS)
  675. # if __GLASGOW_HASKELL__ >= 611
  676. readRawBufferPtr "Network.Socket.recvLenBuf" (socket2FD sock) ptr 0
  677. (fromIntegral nbytes)
  678. #else
  679. readRawBufferPtr "Network.Socket.recvLenBuf" (fromIntegral s) True ptr 0
  680. (fromIntegral nbytes)
  681. #endif
  682. #else
  683. throwSocketErrorWaitRead sock "recvBuf" $
  684. c_recv s (castPtr ptr) (fromIntegral nbytes) 0{-flags-}
  685. #endif
  686. let len' = fromIntegral len
  687. if len' == 0
  688. then ioError (mkEOFError "Network.Socket.recvBuf")
  689. else return len'
  690. -- ---------------------------------------------------------------------------
  691. -- socketPort
  692. --
  693. -- The port number the given socket is currently connected to can be
  694. -- determined by calling $port$, is generally only useful when bind
  695. -- was given $aNY\_PORT$.
  696. socketPort :: Socket -- Connected & Bound Socket
  697. -> IO PortNumber -- Port Number of Socket
  698. socketPort sock@(MkSocket _ AF_INET _ _ _) = do
  699. (SockAddrInet port _) <- getSocketName sock
  700. return port
  701. #if defined(IPV6_SOCKET_SUPPORT)
  702. socketPort sock@(MkSocket _ AF_INET6 _ _ _) = do
  703. (SockAddrInet6 port _ _ _) <- getSocketName sock
  704. return port
  705. #endif
  706. socketPort (MkSocket _ family _ _ _) =
  707. ioError (userError ("socketPort: not supported for Family " ++ show family))
  708. -- ---------------------------------------------------------------------------
  709. -- getPeerName
  710. -- Calling $getPeerName$ returns the address details of the machine,
  711. -- other than the local one, which is connected to the socket. This is
  712. -- used in programs such as FTP to determine where to send the
  713. -- returning data. The corresponding call to get the details of the
  714. -- local machine is $getSocketName$.
  715. getPeerName :: Socket -> IO SockAddr
  716. getPeerName (MkSocket s family _ _ _) = do
  717. withNewSockAddr family $ \ptr sz -> do
  718. with (fromIntegral sz) $ \int_star -> do
  719. throwSocketErrorIfMinus1Retry "getPeerName" $ c_getpeername s ptr int_star
  720. _sz <- peek int_star
  721. peekSockAddr ptr
  722. getSocketName :: Socket -> IO SockAddr
  723. getSocketName (MkSocket s family _ _ _) = do
  724. withNewSockAddr family $ \ptr sz -> do
  725. with (fromIntegral sz) $ \int_star -> do
  726. throwSocketErrorIfMinus1Retry "getSocketName" $ c_getsockname s ptr int_star
  727. peekSockAddr ptr
  728. -----------------------------------------------------------------------------
  729. -- Socket Properties
  730. -- | Socket options for use with 'setSocketOption' and 'getSocketOption'.
  731. --
  732. -- The existence of a constructor does not imply that the relevant option
  733. -- is supported on your system: see 'isSupportedSocketOption'
  734. data SocketOption
  735. = Debug -- ^ SO_DEBUG
  736. | ReuseAddr -- ^ SO_REUSEADDR
  737. | Type -- ^ SO_TYPE
  738. | SoError -- ^ SO_ERROR
  739. | DontRoute -- ^ SO_DONTROUTE
  740. | Broadcast -- ^ SO_BROADCAST
  741. | SendBuffer -- ^ SO_SNDBUF
  742. | RecvBuffer -- ^ SO_RCVBUF
  743. | KeepAlive -- ^ SO_KEEPALIVE
  744. | OOBInline -- ^ SO_OOBINLINE
  745. | TimeToLive -- ^ IP_TTL
  746. | MaxSegment -- ^ TCP_MAXSEG
  747. | NoDelay -- ^ TCP_NODELAY
  748. | Cork -- ^ TCP_CORK
  749. | Linger -- ^ SO_LINGER
  750. | ReusePort -- ^ SO_REUSEPORT
  751. | RecvLowWater -- ^ SO_RCVLOWAT
  752. | SendLowWater -- ^ SO_SNDLOWAT
  753. | RecvTimeOut -- ^ SO_RCVTIMEO
  754. | SendTimeOut -- ^ SO_SNDTIMEO
  755. | UseLoopBack -- ^ SO_USELOOPBACK
  756. | IPv6Only -- ^ IPV6_V6ONLY
  757. deriving (Show, Typeable)
  758. -- | Does the 'SocketOption' exist on this system?
  759. isSupportedSocketOption :: SocketOption -> Bool
  760. isSupportedSocketOption = isJust . packSocketOption
  761. -- | For a socket option, return Just (level, value) where level is the
  762. -- corresponding C option level constant (e.g. SOL_SOCKET) and value is
  763. -- the option constant itself (e.g. SO_DEBUG)
  764. -- If either constant does not exist, return Nothing.
  765. packSocketOption :: SocketOption -> Maybe (CInt, CInt)
  766. packSocketOption so =
  767. -- The Just here is a hack to disable GHC's overlapping pattern detection:
  768. -- the problem is if all constants are present, the fallback pattern is
  769. -- redundant, but if they aren't then it isn't. Hence we introduce an
  770. -- extra pattern (Nothing) that can't possibly happen, so that the
  771. -- fallback is always (in principle) necessary.
  772. -- I feel a little bad for including this, but such are the sacrifices we
  773. -- make while working with CPP - excluding the fallback pattern correctly
  774. -- would be a serious nuisance.
  775. -- (NB: comments elsewhere in this file refer to this one)
  776. case Just so of
  777. #ifdef SOL_SOCKET
  778. #ifdef SO_DEBUG
  779. Just Debug -> Just ((#const SOL_SOCKET), (#const SO_DEBUG))
  780. #endif
  781. #ifdef SO_REUSEADDR
  782. Just ReuseAddr -> Just ((#const SOL_SOCKET), (#const SO_REUSEADDR))
  783. #endif
  784. #ifdef SO_TYPE
  785. Just Type -> Just ((#const SOL_SOCKET), (#const SO_TYPE))
  786. #endif
  787. #ifdef SO_ERROR
  788. Just SoError -> Just ((#const SOL_SOCKET), (#const SO_ERROR))
  789. #endif
  790. #ifdef SO_DONTROUTE
  791. Just DontRoute -> Just ((#const SOL_SOCKET), (#const SO_DONTROUTE))
  792. #endif
  793. #ifdef SO_BROADCAST
  794. Just Broadcast -> Just ((#const SOL_SOCKET), (#const SO_BROADCAST))
  795. #endif
  796. #ifdef SO_SNDBUF
  797. Just SendBuffer -> Just ((#const SOL_SOCKET), (#const SO_SNDBUF))
  798. #endif
  799. #ifdef SO_RCVBUF
  800. Just RecvBuffer -> Just ((#const SOL_SOCKET), (#const SO_RCVBUF))
  801. #endif
  802. #ifdef SO_KEEPALIVE
  803. Just KeepAlive -> Just ((#const SOL_SOCKET), (#const SO_KEEPALIVE))
  804. #endif
  805. #ifdef SO_OOBINLINE
  806. Just OOBInline -> Just ((#const SOL_SOCKET), (#const SO_OOBINLINE))
  807. #endif
  808. #ifdef SO_LINGER
  809. Just Linger -> Just ((#const SOL_SOCKET), (#const SO_LINGER))
  810. #endif
  811. #ifdef SO_REUSEPORT
  812. Just ReusePort -> Just ((#const SOL_SOCKET), (#const SO_REUSEPORT))
  813. #endif
  814. #ifdef SO_RCVLOWAT
  815. Just RecvLowWater -> Just ((#const SOL_SOCKET), (#const SO_RCVLOWAT))
  816. #endif
  817. #ifdef SO_SNDLOWAT
  818. Just SendLowWater -> Just ((#const SOL_SOCKET), (#const SO_SNDLOWAT))
  819. #endif
  820. #ifdef SO_RCVTIMEO
  821. Just RecvTimeOut -> Just ((#const SOL_SOCKET), (#const SO_RCVTIMEO))
  822. #endif
  823. #ifdef SO_SNDTIMEO
  824. Just SendTimeOut -> Just ((#const SOL_SOCKET), (#const SO_SNDTIMEO))
  825. #endif
  826. #ifdef SO_USELOOPBACK
  827. Just UseLoopBack -> Just ((#const SOL_SOCKET), (#const SO_USELOOPBACK))
  828. #endif
  829. #endif // SOL_SOCKET
  830. #ifdef IPPROTO_IP
  831. #ifdef IP_TTL
  832. Just TimeToLive -> Just ((#const IPPROTO_IP), (#const IP_TTL))
  833. #endif
  834. #endif // IPPROTO_IP
  835. #ifdef IPPROTO_TCP
  836. #ifdef TCP_MAXSEG
  837. Just MaxSegment -> Just ((#const IPPROTO_TCP), (#const TCP_MAXSEG))
  838. #endif
  839. #ifdef TCP_NODELAY
  840. Just NoDelay -> Just ((#const IPPROTO_TCP), (#const TCP_NODELAY))
  841. #endif
  842. #ifdef TCP_CORK
  843. Just Cork -> Just ((#const IPPROTO_TCP), (#const TCP_CORK))
  844. #endif
  845. #endif // IPPROTO_TCP
  846. #ifdef IPPROTO_IPV6
  847. #if HAVE_DECL_IPV6_V6ONLY
  848. Just IPv6Only -> Just ((#const IPPROTO_IPV6), (#const IPV6_V6ONLY))
  849. #endif
  850. #endif // IPPROTO_IPV6
  851. _ -> Nothing
  852. -- | Return the option level and option value if they exist,
  853. -- otherwise throw an error that begins "Network.Socket." ++ the String
  854. -- parameter
  855. packSocketOption' :: String -> SocketOption -> IO (CInt, CInt)
  856. packSocketOption' caller so = maybe err return (packSocketOption so)
  857. where
  858. err = ioError . userError . concat $ ["Network.Socket.", caller,
  859. ": socket option ", show so, " unsupported on this system"]
  860. -- | Set a socket option that expects an Int value.
  861. -- There is currently no API to set e.g. the timeval socket options
  862. setSocketOption :: Socket
  863. -> SocketOption -- Option Name
  864. -> Int -- Option Value
  865. -> IO ()
  866. setSocketOption (MkSocket s _ _ _ _) so v = do
  867. (level, opt) <- packSocketOption' "setSocketOption" so
  868. with (fromIntegral v) $ \ptr_v -> do
  869. throwSocketErrorIfMinus1_ "setSocketOption" $
  870. c_setsockopt s level opt ptr_v
  871. (fromIntegral (sizeOf (undefined :: CInt)))
  872. return ()
  873. -- | Get a socket option that gives an Int value.
  874. -- There is currently no API to get e.g. the timeval socket options
  875. getSocketOption :: Socket
  876. -> SocketOption -- Option Name
  877. -> IO Int -- Option Value
  878. getSocketOption (MkSocket s _ _ _ _) so = do
  879. (level, opt) <- packSocketOption' "getSocketOption" so
  880. alloca $ \ptr_v ->
  881. with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do
  882. throwSocketErrorIfMinus1Retry "getSocketOption" $
  883. c_getsockopt s level opt ptr_v ptr_sz
  884. fromIntegral `liftM` peek ptr_v
  885. #ifdef HAVE_STRUCT_UCRED
  886. -- | Returns the processID, userID and groupID of the socket's peer.
  887. --
  888. -- Only available on platforms that support SO_PEERCRED on domain sockets.
  889. getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt)
  890. getPeerCred sock = do
  891. let fd = fdSocket sock
  892. let sz = (fromIntegral (#const sizeof(struct ucred)))
  893. with sz $ \ ptr_cr ->
  894. alloca $ \ ptr_sz -> do
  895. poke ptr_sz sz
  896. throwSocketErrorIfMinus1Retry "getPeerCred" $
  897. c_getsockopt fd (#const SOL_SOCKET) (#const SO_PEERCRED) ptr_cr ptr_sz
  898. pid <- (#peek struct ucred, pid) ptr_cr
  899. uid <- (#peek struct ucred, uid) ptr_cr
  900. gid <- (#peek struct ucred, gid) ptr_cr
  901. return (pid, uid, gid)
  902. #endif
  903. ##if !(MIN_VERSION_base(4,3,1))
  904. closeFdWith closer fd = closer fd
  905. ##endif
  906. #if defined(DOMAIN_SOCKET_SUPPORT)
  907. -- sending/receiving ancillary socket data; low-level mechanism
  908. -- for transmitting file descriptors, mainly.
  909. sendFd :: Socket -> CInt -> IO ()
  910. sendFd sock outfd = do
  911. throwSocketErrorWaitWrite sock "sendFd" $
  912. c_sendFd (fdSocket sock) outfd
  913. -- Note: If Winsock supported FD-passing, thi would have been
  914. -- incorrect (since socket FDs need to be closed via closesocket().)
  915. closeFd outfd
  916. recvFd :: Socket -> IO CInt
  917. recvFd sock = do
  918. theFd <- throwSocketErrorWaitRead sock "recvFd" $
  919. c_recvFd (fdSocket sock)
  920. return theFd
  921. foreign import ccall SAFE_ON_WIN "sendFd" c_sendFd :: CInt -> CInt -> IO CInt
  922. foreign import ccall SAFE_ON_WIN "recvFd" c_recvFd :: CInt -> IO CInt
  923. #endif
  924. -- ---------------------------------------------------------------------------
  925. -- Utility Functions
  926. aNY_PORT :: PortNumber
  927. aNY_PORT = 0
  928. -- | The IPv4 wild card address.
  929. iNADDR_ANY :: HostAddress
  930. iNADDR_ANY = htonl (#const INADDR_ANY)
  931. foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32
  932. #if defined(IPV6_SOCKET_SUPPORT)
  933. -- | The IPv6 wild card address.
  934. iN6ADDR_ANY :: HostAddress6
  935. iN6ADDR_ANY = (0, 0, 0, 0)
  936. #endif
  937. sOMAXCONN :: Int
  938. sOMAXCONN = #const SOMAXCONN
  939. sOL_SOCKET :: Int
  940. sOL_SOCKET = #const SOL_SOCKET
  941. #ifdef SCM_RIGHTS
  942. sCM_RIGHTS :: Int
  943. sCM_RIGHTS = #const SCM_RIGHTS
  944. #endif
  945. -- | This is the value of SOMAXCONN, typically 128.
  946. -- 128 is good enough for normal network servers but
  947. -- is too small for high performance servers.
  948. maxListenQueue :: Int
  949. maxListenQueue = sOMAXCONN
  950. -- -----------------------------------------------------------------------------
  951. data ShutdownCmd
  952. = ShutdownReceive
  953. | ShutdownSend
  954. | ShutdownBoth
  955. deriving Typeable
  956. sdownCmdToInt :: ShutdownCmd -> CInt
  957. sdownCmdToInt ShutdownReceive = 0
  958. sdownCmdToInt ShutdownSend = 1
  959. sdownCmdToInt ShutdownBoth = 2
  960. -- | Shut down one or both halves of the connection, depending on the
  961. -- second argument to the function. If the second argument is
  962. -- 'ShutdownReceive', further receives are disallowed. If it is
  963. -- 'ShutdownSend', further sends are disallowed. If it is
  964. -- 'ShutdownBoth', further sends and receives are disallowed.
  965. shutdown :: Socket -> ShutdownCmd -> IO ()
  966. shutdown (MkSocket s _ _ _ _) stype = do
  967. throwSocketErrorIfMinus1Retry "shutdown" (c_shutdown s (sdownCmdToInt stype))
  968. return ()
  969. -- -----------------------------------------------------------------------------
  970. -- | Close the socket. All future operations on the socket object
  971. -- will fail. The remote end will receive no more data (after queued
  972. -- data is flushed).
  973. close :: Socket -> IO ()
  974. close (MkSocket s _ _ _ socketStatus) = do
  975. modifyMVar_ socketStatus $ \ status ->
  976. case status of
  977. ConvertedToHandle ->
  978. ioError (userError ("close: converted to a Handle, use hClose instead"))
  979. Closed ->
  980. return status
  981. _ -> closeFdWith (closeFd . fromIntegral) (fromIntegral s) >> return Closed
  982. -- -----------------------------------------------------------------------------
  983. isConnected :: Socket -> IO Bool
  984. isConnected (MkSocket _ _ _ _ status) = do
  985. value <- readMVar status
  986. return (value == Connected)
  987. -- -----------------------------------------------------------------------------
  988. -- Socket Predicates
  989. isBound :: Socket -> IO Bool
  990. isBound (MkSocket _ _ _ _ status) = do
  991. value <- readMVar status
  992. return (value == Bound)
  993. isListening :: Socket -> IO Bool
  994. isListening (MkSocket _ _ _ _ status) = do
  995. value <- readMVar status
  996. return (value == Listening)
  997. isReadable :: Socket -> IO Bool
  998. isReadable (MkSocket _ _ _ _ status) = do
  999. value <- readMVar status
  1000. return (value == Listening || value == Connected)
  1001. isWritable :: Socket -> IO Bool
  1002. isWritable = isReadable -- sort of.
  1003. isAcceptable :: Socket -> IO Bool
  1004. #if defined(DOMAIN_SOCKET_SUPPORT)
  1005. isAcceptable (MkSocket _ AF_UNIX x _ status)
  1006. | x == Stream || x == SeqPacket = do
  1007. value <- readMVar status
  1008. return (value == Connected || value == Bound || value == Listening)
  1009. isAcceptable (MkSocket _ AF_UNIX _ _ _) = return False
  1010. #endif
  1011. isAcceptable (MkSocket _ _ _ _ status) = do
  1012. value <- readMVar status
  1013. return (value == Connected || value == Listening)
  1014. -- -----------------------------------------------------------------------------
  1015. -- Internet address manipulation routines:
  1016. inet_addr :: String -> IO HostAddress
  1017. inet_addr ipstr = do
  1018. withCString ipstr $ \str -> do
  1019. had <- c_inet_addr str
  1020. if had == -1
  1021. then ioError (userError ("inet_addr: Malformed address: " ++ ipstr))
  1022. else return had -- network byte order
  1023. inet_ntoa :: HostAddress -> IO String
  1024. inet_ntoa haddr = do
  1025. pstr <- c_inet_ntoa haddr
  1026. peekCString pstr
  1027. -- | Turns a Socket into an 'Handle'. By default, the new handle is
  1028. -- unbuffered. Use 'System.IO.hSetBuffering' to change the buffering.
  1029. --
  1030. -- Note that since a 'Handle' is automatically closed by a finalizer
  1031. -- when it is no longer referenced, you should avoid doing any more
  1032. -- operations on the 'Socket' after calling 'socketToHandle'. To
  1033. -- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose'
  1034. -- on the 'Handle'.
  1035. #ifndef __PARALLEL_HASKELL__
  1036. socketToHandle :: Socket -> IOMode -> IO Handle
  1037. socketToHandle s@(MkSocket fd _ _ _ socketStatus) mode = do
  1038. modifyMVar socketStatus $ \ status ->
  1039. if status == ConvertedToHandle
  1040. then ioError (userError ("socketToHandle: already a Handle"))
  1041. else do
  1042. # if __GLASGOW_HASKELL__ >= 611
  1043. h <- fdToHandle' (fromIntegral fd) (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-}
  1044. # elif __GLASGOW_HASKELL__ >= 608
  1045. h <- fdToHandle' (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-}
  1046. # elif __GLASGOW_HASKELL__ < 608
  1047. h <- openFd (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-}
  1048. # endif
  1049. hSetBuffering h NoBuffering
  1050. return (ConvertedToHandle, h)
  1051. #else
  1052. socketToHandle (MkSocket s family stype protocol status) m =
  1053. error "socketToHandle not implemented in a parallel setup"
  1054. #endif
  1055. -- | Pack a list of values into a bitmask. The possible mappings from
  1056. -- value to bit-to-set are given as the first argument. We assume
  1057. -- that each value can cause exactly one bit to be set; unpackBits will
  1058. -- break if this property is not true.
  1059. packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b
  1060. packBits mapping xs = foldl' pack 0 mapping
  1061. where pack acc (k, v) | k `elem` xs = acc .|. v
  1062. | otherwise = acc
  1063. -- | Unpack a bitmask into a list of values.
  1064. unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a]
  1065. -- Be permissive and ignore unknown bit values. At least on OS X,
  1066. -- getaddrinfo returns an ai_flags field with bits set that have no
  1067. -- entry in <netdb.h>.
  1068. unpackBits [] _ = []
  1069. unpackBits ((k,v):xs) r
  1070. | r .&. v /= 0 = k : unpackBits xs (r .&. complement v)
  1071. | otherwise = unpackBits xs r
  1072. -----------------------------------------------------------------------------
  1073. -- Address and service lookups
  1074. #if defined(IPV6_SOCKET_SUPPORT)
  1075. -- | Flags that control the querying behaviour of 'getAddrInfo'.
  1076. data AddrInfoFlag
  1077. = AI_ADDRCONFIG
  1078. | AI_ALL
  1079. | AI_CANONNAME
  1080. | AI_NUMERICHOST
  1081. | AI_NUMERICSERV
  1082. | AI_PASSIVE
  1083. | AI_V4MAPPED
  1084. deriving (Eq, Read, Show, Typeable)
  1085. aiFlagMapping :: [(AddrInfoFlag, CInt)]
  1086. aiFlagMapping =
  1087. [
  1088. #if HAVE_DECL_AI_ADDRCONFIG
  1089. (AI_ADDRCONFIG, #const AI_ADDRCONFIG),
  1090. #else
  1091. (AI_ADDRCONFIG, 0),
  1092. #endif
  1093. #if HAVE_DECL_AI_ALL
  1094. (AI_ALL, #const AI_ALL),
  1095. #else
  1096. (AI_ALL, 0),
  1097. #endif
  1098. (AI_CANONNAME, #const AI_CANONNAME),
  1099. (AI_NUMERICHOST, #const AI_NUMERICHOST),
  1100. #if HAVE_DECL_AI_NUMERICSERV
  1101. (AI_NUMERICSERV, #const AI_NUMERICSERV),
  1102. #else
  1103. (AI_NUMERICSERV, 0),
  1104. #endif
  1105. (AI_PASSIVE, #const AI_PASSIVE),
  1106. #if HAVE_DECL_AI_V4MAPPED
  1107. (AI_V4MAPPED, #const AI_V4MAPPED)
  1108. #else
  1109. (AI_V4MAPPED, 0)
  1110. #endif
  1111. ]
  1112. -- | Indicate whether the given 'AddrInfoFlag' will have any effect on
  1113. -- this system.
  1114. addrInfoFlagImplemented :: AddrInfoFlag -> Bool
  1115. addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0
  1116. data AddrInfo =
  1117. AddrInfo {
  1118. addrFlags :: [AddrInfoFlag],
  1119. addrFamily :: Family,
  1120. addrSocketType :: SocketType,
  1121. addrProtocol :: ProtocolNumber,
  1122. addrAddress :: SockAddr,
  1123. addrCanonName :: Maybe String
  1124. }
  1125. deriving (Eq, Show, Typeable)
  1126. instance Storable AddrInfo where
  1127. sizeOf _ = #const sizeof(struct addrinfo)
  1128. alignment _ = alignment (undefined :: CInt)
  1129. peek p = do
  1130. ai_flags <- (#peek struct addrinfo, ai_flags) p
  1131. ai_family <- (#peek struct addrinfo, ai_family) p
  1132. ai_socktype <- (#peek struct addrinfo, ai_socktype) p
  1133. ai_protocol <- (#peek struct addrinfo, ai_protocol) p
  1134. ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr
  1135. ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p
  1136. ai_canonname <- if ai_canonname_ptr == nullPtr
  1137. then return Nothing
  1138. else liftM Just $ peekCString ai_canonname_ptr
  1139. socktype <- unpackSocketType' "AddrInfo.peek" ai_socktype
  1140. return (AddrInfo
  1141. {
  1142. addrFlags = unpackBits aiFlagMapping ai_flags,
  1143. addrFamily = unpackFamily ai_family,
  1144. addrSocketType = socktype,
  1145. addrProtocol = ai_protocol,
  1146. addrAddress = ai_addr,
  1147. addrCanonName = ai_canonname
  1148. })
  1149. poke p (AddrInfo flags family socketType protocol _ _) = do
  1150. c_stype <- packSocketTypeOrThrow "AddrInfo.poke" socketType
  1151. (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags)
  1152. (#poke struct addrinfo, ai_family) p (packFamily family)
  1153. (#poke struct addrinfo, ai_socktype) p c_stype
  1154. (#poke struct addrinfo, ai_protocol) p protocol
  1155. -- stuff below is probably not needed, but let's zero it for safety
  1156. (#poke struct addrinfo, ai_addrlen) p (0::CSize)
  1157. (#poke struct addrinfo, ai_addr) p nullPtr
  1158. (#poke struct addrinfo, ai_canonname) p nullPtr
  1159. (#poke struct addrinfo, ai_next) p nullPtr
  1160. data NameInfoFlag
  1161. = NI_DGRAM
  1162. | NI_NAMEREQD
  1163. | NI_NOFQDN
  1164. | NI_NUMERICHOST
  1165. | NI_NUMERICSERV
  1166. deriving (Eq, Read, Show, Typeable)
  1167. niFlagMapping :: [(NameInfoFlag, CInt)]
  1168. niFlagMapping = [(NI_DGRAM, #const NI_DGRAM),
  1169. (NI_NAMEREQD, #const NI_NAMEREQD),
  1170. (NI_NOFQDN, #const NI_NOFQDN),
  1171. (NI_NUMERICHOST, #const NI_NUMERICHOST),
  1172. (NI_NUMERICSERV, #const NI_NUMERICSERV)]
  1173. -- | Default hints for address lookup with 'getAddrInfo'. The values
  1174. -- of the 'addrAddress' and 'addrCanonName' fields are 'undefined',
  1175. -- and are never inspected by 'getAddrInfo'.
  1176. defaultHints :: AddrInfo
  1177. defaultHints = AddrInfo {
  1178. addrFlags = [],
  1179. addrFamily = AF_UNSPEC,
  1180. addrSocketType = NoSocketType,
  1181. addrProtocol = defaultProtocol,
  1182. addrAddress = undefined,
  1183. addrCanonName = undefined
  1184. }
  1185. -- | Resolve a host or service name to one or more addresses.
  1186. -- The 'AddrInfo' values that this function returns contain 'SockAddr'
  1187. -- values that you can pass directly to 'connect' or
  1188. -- 'bind'.
  1189. --
  1190. -- This function is protocol independent. It can return both IPv4 and
  1191. -- IPv6 address information.
  1192. --
  1193. -- The 'AddrInfo' argument specifies the preferred query behaviour,
  1194. -- socket options, or protocol. You can override these conveniently
  1195. -- using Haskell's record update syntax on 'defaultHints', for example
  1196. -- as follows:
  1197. --
  1198. -- @
  1199. -- myHints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }
  1200. -- @
  1201. --
  1202. -- Values for 'addrFlags' control query behaviour. The supported
  1203. -- flags are as follows:
  1204. --
  1205. -- [@AI_PASSIVE@] If no 'HostName' value is provided, the network
  1206. -- address in each 'SockAddr'
  1207. -- will be left as a "wild card", i.e. as either 'iNADDR_ANY'
  1208. -- or 'iN6ADDR_ANY'. This is useful for server applications that
  1209. -- will accept connections from any client.
  1210. --
  1211. -- [@AI_CANONNAME@] The 'addrCanonName' field of the first returned
  1212. -- 'AddrInfo' will contain the "canonical name" of the host.
  1213. --
  1214. -- [@AI_NUMERICHOST@] The 'HostName' argument /must/ be a numeric
  1215. -- address in string form, and network name lookups will not be
  1216. -- attempted.
  1217. --
  1218. -- /Note/: Although the following flags are required by RFC 3493, they
  1219. -- may not have an effect on all platforms, because the underlying
  1220. -- network stack may not support them. To see whether a flag from the
  1221. -- list below will have any effect, call 'addrInfoFlagImplemented'.
  1222. --
  1223. -- [@AI_NUMERICSERV@] The 'ServiceName' argument /must/ be a port
  1224. -- number in string form, and service name lookups will not be
  1225. -- attempted.
  1226. --
  1227. -- [@AI_ADDRCONFIG@] The list of returned 'AddrInfo' values will
  1228. -- only contain IPv4 addresses if the local system has at least
  1229. -- one IPv4 interface configured, and likewise for IPv6.
  1230. --
  1231. -- [@AI_V4MAPPED@] If an IPv6 lookup is performed, and no IPv6
  1232. -- addresses are found, IPv6-mapped IPv4 addresses will be
  1233. -- returned.
  1234. --
  1235. -- [@AI_ALL@] If 'AI_ALL' is specified, return all matching IPv6 and
  1236. -- IPv4 addresses. Otherwise, this flag has no effect.
  1237. --
  1238. -- You must provide a 'Just' value for at least one of the 'HostName'
  1239. -- or 'ServiceName' arguments. 'HostName' can be either a numeric
  1240. -- network address (dotted quad for IPv4, colon-separated hex for
  1241. -- IPv6) or a hostname. In the latter case, its addresses will be
  1242. -- looked up unless 'AI_NUMERICHOST' is specified as a hint. If you
  1243. -- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as
  1244. -- a hint, network addresses in the result will contain the address of
  1245. -- the loopback interface.
  1246. --
  1247. -- If the query fails, this function throws an IO exception instead of
  1248. -- returning an empty list. Otherwise, it returns a non-empty list
  1249. -- of 'AddrInfo' values.
  1250. --
  1251. -- There are several reasons why a query might result in several
  1252. -- values. For example, the queried-for host could be multihomed, or
  1253. -- the service might be available via several protocols.
  1254. --
  1255. -- Note: the order of arguments is slightly different to that defined
  1256. -- for @getaddrinfo@ in RFC 2553. The 'AddrInfo' parameter comes first
  1257. -- to make partial application easier.
  1258. --
  1259. -- Example:
  1260. -- @
  1261. -- let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }
  1262. -- addrs <- getAddrInfo (Just hints) (Just "www.haskell.org") (Just "http")
  1263. -- let addr = head addrs
  1264. -- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
  1265. -- connect sock (addrAddress addr)
  1266. -- @
  1267. getAddrInfo :: Maybe AddrInfo -- ^ preferred socket type or protocol
  1268. -> Maybe HostName -- ^ host name to look up
  1269. -> Maybe ServiceName -- ^ service name to look up
  1270. -> IO [AddrInfo] -- ^ resolved addresses, with "best" first
  1271. getAddrInfo hints node service =
  1272. maybeWith withCString node $ \c_node ->
  1273. maybeWith withCString service $ \c_service ->
  1274. maybeWith with filteredHints $ \c_hints ->
  1275. alloca $ \ptr_ptr_addrs -> do
  1276. ret <- c_get

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