PageRenderTime 55ms CodeModel.GetById 18ms RepoModel.GetById 0ms app.codeStats 0ms

/Network/Socket.hsc

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

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