1{-# LANGUAGE CPP #-} 2 3#include "HsNetDef.h" 4 5module Network.Socket.Syscall where 6 7import Foreign.Marshal.Utils (with) 8import qualified Control.Exception as E 9# if defined(mingw32_HOST_OS) 10import System.IO.Error (catchIOError) 11#endif 12 13#if defined(mingw32_HOST_OS) 14import Foreign (FunPtr) 15import GHC.Conc (asyncDoProc) 16#else 17import Foreign.C.Error (getErrno, eINTR, eINPROGRESS) 18import GHC.Conc (threadWaitWrite) 19#endif 20 21#ifdef HAVE_ADVANCED_SOCKET_FLAGS 22import Network.Socket.Cbits 23#else 24import Network.Socket.Fcntl 25#endif 26 27import Network.Socket.Imports 28import Network.Socket.Internal 29import Network.Socket.Options 30import Network.Socket.Types 31 32-- ---------------------------------------------------------------------------- 33-- On Windows, our sockets are not put in non-blocking mode (non-blocking 34-- is not supported for regular file descriptors on Windows, and it would 35-- be a pain to support it only for sockets). So there are two cases: 36-- 37-- - the threaded RTS uses safe calls for socket operations to get 38-- non-blocking I/O, just like the rest of the I/O library 39-- 40-- - with the non-threaded RTS, only some operations on sockets will be 41-- non-blocking. Reads and writes go through the normal async I/O 42-- system. accept() uses asyncDoProc so is non-blocking. A handful 43-- of others (recvFrom, sendFd, recvFd) will block all threads - if this 44-- is a problem, -threaded is the workaround. 45-- 46 47----------------------------------------------------------------------------- 48-- Connection Functions 49 50-- In the following connection and binding primitives. The names of 51-- the equivalent C functions have been preserved where possible. It 52-- should be noted that some of these names used in the C library, 53-- \tr{bind} in particular, have a different meaning to many Haskell 54-- programmers and have thus been renamed by appending the prefix 55-- Socket. 56 57-- | Create a new socket using the given address family, socket type 58-- and protocol number. The address family is usually 'AF_INET', 59-- 'AF_INET6', or 'AF_UNIX'. The socket type is usually 'Stream' or 60-- 'Datagram'. The protocol number is usually 'defaultProtocol'. 61-- If 'AF_INET6' is used and the socket type is 'Stream' or 'Datagram', 62-- the 'IPv6Only' socket option is set to 0 so that both IPv4 and IPv6 63-- can be handled with one socket. 64-- 65-- >>> import Network.Socket 66-- >>> let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } 67-- >>> addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just "5000") 68-- >>> sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 69-- >>> Network.Socket.bind sock (addrAddress addr) 70-- >>> getSocketName sock 71-- 127.0.0.1:5000 72socket :: Family -- Family Name (usually AF_INET) 73 -> SocketType -- Socket Type (usually Stream) 74 -> ProtocolNumber -- Protocol Number (getProtocolByName to find value) 75 -> IO Socket -- Unconnected Socket 76socket family stype protocol = E.bracketOnError create c_close $ \fd -> do 77 -- Let's ensure that the socket (file descriptor) is closed even on 78 -- asynchronous exceptions. 79 setNonBlock fd 80 s <- mkSocket fd 81 -- This socket is not managed by the IO manager yet. 82 -- So, we don't have to call "close" which uses "closeFdWith". 83 unsetIPv6Only s 84 return s 85 where 86 create = do 87 c_stype <- modifyFlag <$> packSocketTypeOrThrow "socket" stype 88 throwSocketErrorIfMinus1Retry "Network.Socket.socket" $ 89 c_socket (packFamily family) c_stype protocol 90 91#ifdef HAVE_ADVANCED_SOCKET_FLAGS 92 modifyFlag c_stype = c_stype .|. sockNonBlock 93#else 94 modifyFlag c_stype = c_stype 95#endif 96 97#ifdef HAVE_ADVANCED_SOCKET_FLAGS 98 setNonBlock _ = return () 99#else 100 setNonBlock fd = setNonBlockIfNeeded fd 101#endif 102 103#if HAVE_DECL_IPV6_V6ONLY 104 unsetIPv6Only s = when (family == AF_INET6 && stype `elem` [Stream, Datagram]) $ 105# if defined(mingw32_HOST_OS) 106 -- The IPv6Only option is only supported on Windows Vista and later, 107 -- so trying to change it might throw an error. 108 setSocketOption s IPv6Only 0 `catchIOError` \_ -> return () 109# elif defined(__OpenBSD__) 110 -- don't change IPv6Only 111 return () 112# else 113 -- The default value of the IPv6Only option is platform specific, 114 -- so we explicitly set it to 0 to provide a common default. 115 setSocketOption s IPv6Only 0 116# endif 117#else 118 unsetIPv6Only _ = return () 119#endif 120 121----------------------------------------------------------------------------- 122-- Binding a socket 123 124-- | Bind the socket to an address. The socket must not already be 125-- bound. The 'Family' passed to @bind@ must be the 126-- same as that passed to 'socket'. If the special port number 127-- 'defaultPort' is passed then the system assigns the next available 128-- use port. 129bind :: SocketAddress sa => Socket -> sa -> IO () 130bind s sa = withSocketAddress sa $ \p_sa siz -> void $ withFdSocket s $ \fd -> do 131 let sz = fromIntegral siz 132 throwSocketErrorIfMinus1Retry "Network.Socket.bind" $ c_bind fd p_sa sz 133 134----------------------------------------------------------------------------- 135-- Connecting a socket 136 137-- | Connect to a remote socket at address. 138connect :: SocketAddress sa => Socket -> sa -> IO () 139connect s sa = withSocketsDo $ withSocketAddress sa $ \p_sa sz -> 140 connectLoop s p_sa (fromIntegral sz) 141 142connectLoop :: SocketAddress sa => Socket -> Ptr sa -> CInt -> IO () 143connectLoop s p_sa sz = withFdSocket s $ \fd -> loop fd 144 where 145 errLoc = "Network.Socket.connect: " ++ show s 146 loop fd = do 147 r <- c_connect fd p_sa sz 148 when (r == -1) $ do 149#if defined(mingw32_HOST_OS) 150 throwSocketError errLoc 151#else 152 err <- getErrno 153 case () of 154 _ | err == eINTR -> loop fd 155 _ | err == eINPROGRESS -> connectBlocked 156-- _ | err == eAGAIN -> connectBlocked 157 _otherwise -> throwSocketError errLoc 158 159 connectBlocked = do 160 withFdSocket s $ threadWaitWrite . fromIntegral 161 err <- getSocketOption s SoError 162 when (err /= 0) $ throwSocketErrorCode errLoc (fromIntegral err) 163#endif 164 165----------------------------------------------------------------------------- 166-- Listen 167 168-- | Listen for connections made to the socket. The second argument 169-- specifies the maximum number of queued connections and should be at 170-- least 1; the maximum value is system-dependent (usually 5). 171listen :: Socket -> Int -> IO () 172listen s backlog = withFdSocket s $ \fd -> do 173 throwSocketErrorIfMinus1Retry_ "Network.Socket.listen" $ 174 c_listen fd $ fromIntegral backlog 175 176----------------------------------------------------------------------------- 177-- Accept 178-- 179-- A call to `accept' only returns when data is available on the given 180-- socket, unless the socket has been set to non-blocking. It will 181-- return a new socket which should be used to read the incoming data and 182-- should then be closed. Using the socket returned by `accept' allows 183-- incoming requests to be queued on the original socket. 184 185-- | Accept a connection. The socket must be bound to an address and 186-- listening for connections. The return value is a pair @(conn, 187-- address)@ where @conn@ is a new socket object usable to send and 188-- receive data on the connection, and @address@ is the address bound 189-- to the socket on the other end of the connection. 190-- On Unix, FD_CLOEXEC is set to the new 'Socket'. 191accept :: SocketAddress sa => Socket -> IO (Socket, sa) 192accept listing_sock = withNewSocketAddress $ \new_sa sz -> 193 withFdSocket listing_sock $ \listing_fd -> do 194 new_sock <- callAccept listing_fd new_sa sz >>= mkSocket 195 new_addr <- peekSocketAddress new_sa 196 return (new_sock, new_addr) 197 where 198#if defined(mingw32_HOST_OS) 199 callAccept fd sa sz 200 | threaded = with (fromIntegral sz) $ \ ptr_len -> 201 throwSocketErrorIfMinus1Retry "Network.Socket.accept" $ 202 c_accept_safe fd sa ptr_len 203 | otherwise = do 204 paramData <- c_newAcceptParams fd (fromIntegral sz) sa 205 rc <- asyncDoProc c_acceptDoProc paramData 206 new_fd <- c_acceptNewSock paramData 207 c_free paramData 208 when (rc /= 0) $ 209 throwSocketErrorCode "Network.Socket.accept" (fromIntegral rc) 210 return new_fd 211#else 212 callAccept fd sa sz = with (fromIntegral sz) $ \ ptr_len -> do 213# ifdef HAVE_ADVANCED_SOCKET_FLAGS 214 throwSocketErrorWaitRead listing_sock "Network.Socket.accept" 215 (c_accept4 fd sa ptr_len (sockNonBlock .|. sockCloexec)) 216# else 217 new_fd <- throwSocketErrorWaitRead listing_sock "Network.Socket.accept" 218 (c_accept fd sa ptr_len) 219 setNonBlockIfNeeded new_fd 220 setCloseOnExecIfNeeded new_fd 221 return new_fd 222# endif /* HAVE_ADVANCED_SOCKET_FLAGS */ 223#endif 224 225foreign import CALLCONV unsafe "socket" 226 c_socket :: CInt -> CInt -> CInt -> IO CInt 227foreign import CALLCONV unsafe "bind" 228 c_bind :: CInt -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt 229foreign import CALLCONV SAFE_ON_WIN "connect" 230 c_connect :: CInt -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt 231foreign import CALLCONV unsafe "listen" 232 c_listen :: CInt -> CInt -> IO CInt 233 234#ifdef HAVE_ADVANCED_SOCKET_FLAGS 235foreign import CALLCONV unsafe "accept4" 236 c_accept4 :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> CInt -> IO CInt 237#else 238foreign import CALLCONV unsafe "accept" 239 c_accept :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CInt 240#endif 241 242#if defined(mingw32_HOST_OS) 243foreign import CALLCONV safe "accept" 244 c_accept_safe :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CInt 245foreign import ccall unsafe "rtsSupportsBoundThreads" 246 threaded :: Bool 247foreign import ccall unsafe "HsNet.h acceptNewSock" 248 c_acceptNewSock :: Ptr () -> IO CInt 249foreign import ccall unsafe "HsNet.h newAcceptParams" 250 c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ()) 251foreign import ccall unsafe "HsNet.h &acceptDoProc" 252 c_acceptDoProc :: FunPtr (Ptr () -> IO Int) 253foreign import ccall unsafe "free" 254 c_free:: Ptr a -> IO () 255#endif 256