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        let c_stype = modifyFlag $ packSocketType 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