diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.5.1.0 Lars Petersen 2015-06-22 + + * Exposed `unsafeGetSocketOption` and `unsafeSetSocketOption`. + * Exposed `socketWaitRead` and `socketWaitWrite` through `System.Socket.Unsafe`. + 0.5.0.0 Lars Petersen 2015-06-19 * Introduced newtypes `Port`, `FlowInfo` and `ScopeId` in Inet6 family. diff --git a/platform/linux/src/System/Socket/Internal/Platform.hsc b/platform/linux/src/System/Socket/Internal/Platform.hsc --- a/platform/linux/src/System/Socket/Internal/Platform.hsc +++ b/platform/linux/src/System/Socket/Internal/Platform.hsc @@ -11,12 +11,22 @@ import System.Socket.Internal.Message import System.Socket.Internal.Exception -socketWaitWrite' :: Fd -> Int -> IO (IO ()) -socketWaitWrite' fd _ = do +unsafeSocketWaitWrite :: Fd -> Int -> IO (IO ()) +unsafeSocketWaitWrite fd _ = do threadWaitWriteSTM fd >>= return . atomically . fst -socketWaitRead' :: Fd -> Int -> IO (IO ()) -socketWaitRead' fd _ = do +-- | Blocks until a socket should be tried for reading. +-- +-- > safeSocketWaitRead = do +-- > wait <- withMVar msock $ \sock-> do +-- > -- Register while holding a lock on the socket descriptor. +-- > unsafeSocketWaitRead sock 0 +-- > -- Do the waiting without keeping the socket descriptor locked. +-- > wait +unsafeSocketWaitRead :: Fd -- ^ Socket descriptor + -> Int -- ^ How many times has it been tried unsuccessfully so far? (currently only relevant on Windows) + -> IO (IO ()) -- ^ The outer action registers the waiting, the inner does the actual wait. +unsafeSocketWaitRead fd _ = do threadWaitReadSTM fd >>= return . atomically . fst type CSSize diff --git a/platform/win32/src/System/Socket/Internal/Platform.hsc b/platform/win32/src/System/Socket/Internal/Platform.hsc --- a/platform/win32/src/System/Socket/Internal/Platform.hsc +++ b/platform/win32/src/System/Socket/Internal/Platform.hsc @@ -13,12 +13,12 @@ import System.Socket.Internal.Message import System.Socket.Internal.Exception -socketWaitWrite' :: Fd -> Int -> IO (IO ()) -socketWaitWrite' _ iteration = do +unsafeSocketWaitWrite :: Fd -> Int -> IO (IO ()) +unsafeSocketWaitWrite _ iteration = do return (threadDelay $ 1 `shiftL` min iteration 20) -socketWaitRead' :: Fd -> Int -> IO (IO ()) -socketWaitRead' _ iteration = do +unsafeSocketWaitRead :: Fd -> Int -> IO (IO ()) +unsafeSocketWaitRead _ iteration = do return (threadDelay $ 1 `shiftL` min iteration 20) type CSSize diff --git a/socket.cabal b/socket.cabal --- a/socket.cabal +++ b/socket.cabal @@ -1,53 +1,15 @@ name: socket -version: 0.5.0.0 +version: 0.5.1.0 synopsis: A portable and extensible sockets library. description: - /Motivation/ - . - This library aims to expose a minimal and platform-independant interface for - POSIX compliant networking code. - . - /Implementation Philosophy/ - . - - Every operation and every flag exposed should be supported with same - semantics on every platform. If this cannot be guaranteed it should - be supplied by another (extension) package. - Examples for things that have been ripped out of this library are: - Unix sockets, SCTP, vectored IO (for now). - . - - Absolutely no conditional exports. - . - - No `#ifdef` madness in the Haskell sources. The Haskell binding code - uses the FFI to reference the platform's native networking functions. - If they are not Posix compliant (i.e. on Windows) an level of - indirection is introduced to create an Posix compliant equivalent in C - using whatever the plaform specific building blocks are. - . - /Platform Support/ - . - /Linux/: Working. - . - /BSD/: Unknown. Should work. Please report if not. - . - /OS X/: Unknown. Please report if you have a Mac. + This library is a minimal and platform-independant interface for + BSD style networking. . - /Windows/: Fully supported on Windows7 (maybe Vista) or higher :-) + The following is a list of known extension packages: . - GHCs runtime system on Windows does not offer an event notification mechanism for sockets. - The original [network](https://hackage.haskell.org/package/network) library - suffers from this, too. For example, connection attempts are uninterruptible etc. - The approach taken to circumvent this in this library is to poll the - non-blocking sockets with increasing delay. This guarantees interruptability - and fairness between different threads. It allows for decent throughput - while also keeping CPU consumption on a moderate level if a socket has not seen - events for a longer period of time (maximum of 1 second delay after 20 - polling iterations). The only drawback is potentially reduced response time - of your application. The good part: Heavy load (e.g. connection requests or - incoming traffic) will reduce this problem. Eventually your accepting thread - won't wait at all if there are several connection requests queued. + - https://hackage.haskell.org/package/socket-sctp . - This workaround may be removed if someone is willing to sacrifice to improve - the IO manager on Windows. + Also see README.md for details. license: MIT license-file: LICENSE diff --git a/src/System/Socket.hsc b/src/System/Socket.hsc --- a/src/System/Socket.hsc +++ b/src/System/Socket.hsc @@ -287,7 +287,7 @@ -- The manpage says that in this case the connection -- shall be established asynchronously and one is -- supposed to wait. - wait <- socketWaitWrite' fd 0 + wait <- unsafeSocketWaitWrite fd 0 return (Just wait) else do throwIO e @@ -315,7 +315,7 @@ return Nothing else if e == eAlready then do -- The previous connection attempt is still pending. - Just <$> socketWaitWrite' fd iteration + Just <$> unsafeSocketWaitWrite fd iteration else do -- The previous connection failed (results in EINPROGRESS or -- EWOULBLOCK here) or something else is wrong. @@ -325,7 +325,7 @@ else do -- This means the last connection attempt succeeded immediately. -- Linux does this when connecting to the same address when the - -- socketWaitWrite' call signals writeability. + -- unsafeSocketWaitWrite call signals writeability. return Nothing case mwait' of Nothing -> do @@ -406,7 +406,7 @@ e <- c_get_last_socket_error if e == eWouldBlock || e == eAgain then do - socketWaitRead' fd iteration >>= return . Left + unsafeSocketWaitRead fd iteration >>= return . Left else if e == eInterrupted -- On EINTR it is good practice to just retry. then retry diff --git a/src/System/Socket/Family/Inet6.hsc b/src/System/Socket/Family/Inet6.hsc --- a/src/System/Socket/Family/Inet6.hsc +++ b/src/System/Socket/Family/Inet6.hsc @@ -26,6 +26,7 @@ import Control.Applicative import Foreign.Ptr +import Foreign.C.Types import Foreign.Storable import Foreign.Marshal.Utils @@ -182,8 +183,8 @@ instance GetSocketOption V6Only where getSocketOption s = - V6Only <$> getSocketOptionBool s (#const IPPROTO_IPV6) (#const IPV6_V6ONLY) + V6Only . ((/=0) :: CInt -> Bool) <$> unsafeGetSocketOption s (#const IPPROTO_IPV6) (#const IPV6_V6ONLY) instance SetSocketOption V6Only where setSocketOption s (V6Only o) = - setSocketOptionBool s (#const IPPROTO_IPV6) (#const IPV6_V6ONLY) o + unsafeSetSocketOption s (#const IPPROTO_IPV6) (#const IPV6_V6ONLY) (if o then 1 else 0 :: CInt) diff --git a/src/System/Socket/Internal/Socket.hsc b/src/System/Socket/Internal/Socket.hsc --- a/src/System/Socket/Internal/Socket.hsc +++ b/src/System/Socket/Internal/Socket.hsc @@ -1,13 +1,9 @@ module System.Socket.Internal.Socket ( Socket (..) , GetSocketOption (..) - , getSocketOptionBool - , getSocketOptionInt - , getSocketOptionCInt + , unsafeGetSocketOption , SetSocketOption (..) - , setSocketOptionBool - , setSocketOptionInt - , setSocketOptionCInt + , unsafeSetSocketOption , Error (..) , ReuseAddress (..) ) where @@ -66,7 +62,7 @@ instance GetSocketOption Error where getSocketOption s = - Error . SocketException <$> getSocketOptionCInt s (#const SOL_SOCKET) (#const SO_ERROR) + Error . SocketException <$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_ERROR) -- | @SO_REUSEADDR@ data ReuseAddress @@ -75,88 +71,37 @@ instance GetSocketOption ReuseAddress where getSocketOption s = - ReuseAddress <$> getSocketOptionBool s (#const SOL_SOCKET) (#const SO_REUSEADDR) + ReuseAddress . ((/=0) :: CInt -> Bool) <$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_REUSEADDR) instance SetSocketOption ReuseAddress where setSocketOption s (ReuseAddress o) = - setSocketOptionBool s (#const SOL_SOCKET) (#const SO_REUSEADDR) o + unsafeSetSocketOption s (#const SOL_SOCKET) (#const SO_REUSEADDR) (if o then 1 else 0 :: CInt) ------------------------------------------------------------------------------- -- Unsafe helpers ------------------------------------------------------------------------------- -setSocketOptionBool :: Socket f t p -> CInt -> CInt -> Bool -> IO () -setSocketOptionBool (Socket mfd) level name value = do - withMVar mfd $ \fd-> - alloca $ \vPtr-> do - if value - then poke vPtr 1 - else poke vPtr 0 - i <- c_setsockopt fd level name - (vPtr :: Ptr CInt) - (fromIntegral $ sizeOf (undefined :: CInt)) - when (i < 0) $ do - c_get_last_socket_error >>= throwIO - -getSocketOptionBool :: Socket f t p -> CInt -> CInt -> IO Bool -getSocketOptionBool (Socket mfd) level name = do - withMVar mfd $ \fd-> - alloca $ \vPtr-> do - alloca $ \lPtr-> do - i <- c_getsockopt fd level name - (vPtr :: Ptr CInt) - (lPtr :: Ptr CInt) - if i < 0 then do - c_get_last_socket_error >>= throwIO - else do - v <- peek vPtr - return (v == 1) - -setSocketOptionInt :: Socket f t p -> CInt -> CInt -> Int -> IO () -setSocketOptionInt (Socket mfd) level name value = do - withMVar mfd $ \fd-> - alloca $ \vPtr-> do - poke vPtr (fromIntegral value :: CInt) - i <- c_setsockopt fd level name - (vPtr :: Ptr CInt) - (fromIntegral $ sizeOf (undefined :: CInt)) - when (i < 0) $ do - c_get_last_socket_error >>= throwIO - -getSocketOptionInt :: Socket f t p -> CInt -> CInt -> IO Int -getSocketOptionInt (Socket mfd) level name = do - withMVar mfd $ \fd-> - alloca $ \vPtr-> do - alloca $ \lPtr-> do - i <- c_getsockopt fd level name - (vPtr :: Ptr CInt) - (lPtr :: Ptr CInt) - if i < 0 then do - c_get_last_socket_error >>= throwIO - else do - v <- peek vPtr - return (fromIntegral v) - -setSocketOptionCInt :: Socket f t p -> CInt -> CInt -> CInt -> IO () -setSocketOptionCInt (Socket mfd) level name value = do +unsafeSetSocketOption :: Storable a => Socket f t p -> CInt -> CInt -> a -> IO () +unsafeSetSocketOption (Socket mfd) level name value = do withMVar mfd $ \fd-> alloca $ \vPtr-> do poke vPtr value i <- c_setsockopt fd level name - (vPtr :: Ptr CInt) - (fromIntegral $ sizeOf (undefined :: CInt)) + vPtr + (fromIntegral $ sizeOf value) when (i < 0) $ do c_get_last_socket_error >>= throwIO -getSocketOptionCInt :: Socket f t p -> CInt -> CInt -> IO CInt -getSocketOptionCInt (Socket mfd) level name = do +unsafeGetSocketOption :: Storable a => Socket f t p -> CInt -> CInt -> IO a +unsafeGetSocketOption (Socket mfd) level name = do + u <- return undefined withMVar mfd $ \fd-> alloca $ \vPtr-> do alloca $ \lPtr-> do - i <- c_getsockopt fd level name - (vPtr :: Ptr CInt) - (lPtr :: Ptr CInt) + poke lPtr (fromIntegral $ sizeOf u) + i <- c_getsockopt fd level name vPtr (lPtr :: Ptr CInt) if i < 0 then do c_get_last_socket_error >>= throwIO else do - peek vPtr + x <- peek vPtr + return (x `asTypeOf` u) diff --git a/src/System/Socket/Unsafe.hsc b/src/System/Socket/Unsafe.hsc --- a/src/System/Socket/Unsafe.hsc +++ b/src/System/Socket/Unsafe.hsc @@ -1,14 +1,25 @@ module System.Socket.Unsafe ( - -- * tryWaitAndRetry - tryWaitAndRetry -- * unsafeSend - , unsafeSend + unsafeSend -- * unsafeSendTo , unsafeSendTo -- * unsafeReceive , unsafeReceive -- * unsafeReceiveFrom , unsafeReceiveFrom + -- * Socket Options + -- ** unsafeGetSocketOption + , unsafeGetSocketOption + -- ** unsafeSetSocketOption + , unsafeSetSocketOption + -- * Waiting For Events + -- ** unsafeSocketWaitRead + , unsafeSocketWaitRead + -- ** unsafeSocketWaitWrite + , unsafeSocketWaitWrite + -- * Other Helpers + -- ** tryWaitRetryLoop + , tryWaitRetryLoop ) where import Data.Function @@ -33,22 +44,22 @@ unsafeSend :: Socket a t p -> Ptr a -> CSize -> MessageFlags -> IO CInt unsafeSend s bufPtr bufSize flags = do - tryWaitAndRetry s socketWaitWrite' (\fd-> c_send fd bufPtr bufSize (flags `mappend` msgNoSignal) ) + tryWaitRetryLoop s unsafeSocketWaitWrite (\fd-> c_send fd bufPtr bufSize (flags `mappend` msgNoSignal) ) unsafeSendTo :: Socket f t p -> Ptr b -> CSize -> MessageFlags -> Ptr (SocketAddress f) -> CInt -> IO CInt unsafeSendTo s bufPtr bufSize flags addrPtr addrSize = do - tryWaitAndRetry s socketWaitWrite' (\fd-> c_sendto fd bufPtr (fromIntegral bufSize) (flags `mappend` msgNoSignal) addrPtr addrSize) + tryWaitRetryLoop s unsafeSocketWaitWrite (\fd-> c_sendto fd bufPtr (fromIntegral bufSize) (flags `mappend` msgNoSignal) addrPtr addrSize) unsafeReceive :: Socket a t p -> Ptr b -> CSize -> MessageFlags -> IO CInt unsafeReceive s bufPtr bufSize flags = - tryWaitAndRetry s socketWaitRead' (\fd-> c_recv fd bufPtr bufSize flags) + tryWaitRetryLoop s unsafeSocketWaitRead (\fd-> c_recv fd bufPtr bufSize flags) unsafeReceiveFrom :: Socket f t p -> Ptr b -> CSize -> MessageFlags -> Ptr (SocketAddress f) -> Ptr CInt -> IO CInt unsafeReceiveFrom s bufPtr bufSize flags addrPtr addrSizePtr = do - tryWaitAndRetry s socketWaitRead' (\fd-> c_recvfrom fd bufPtr bufSize flags addrPtr addrSizePtr) + tryWaitRetryLoop s unsafeSocketWaitRead (\fd-> c_recvfrom fd bufPtr bufSize flags addrPtr addrSizePtr) -tryWaitAndRetry :: Socket f t p -> (Fd -> Int-> IO (IO ())) -> (Fd -> IO CInt) -> IO CInt -tryWaitAndRetry (Socket mfd) getWaitAction action = loop 0 +tryWaitRetryLoop :: Socket f t p -> (Fd -> Int-> IO (IO ())) -> (Fd -> IO CInt) -> IO CInt +tryWaitRetryLoop (Socket mfd) getWaitAction action = loop 0 where loop iteration = do ewr <- withMVar mfd $ \fd-> do