diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,18 @@ +0.7.0.0 Lars Petersen 2016-11-13 + + * Added function `sendAllLazy` and `sendAllBuilder`. Changed the signature and + semantics of `sendAll` (thus the major version bump). + + * The `MessageFlags` constructor is now exported (kudos to Shea Levy for noting + that this is necessary when writing extension libraries). + + * GHC 8 introduces a built-in alignment macro which is now used when present. + This prevents re-definition warnings. + + * Fixed implicit function declaration warning concerning accept4. + Defining `GNU_SOURCE` in the header file declares `accept4` when present + (see man accept4). + 0.6.2.0 Lars Petersen 2016-08-15 * Added functions for constructing internet addresses without the need for IO diff --git a/platform/linux/cbits/hs_socket.c b/platform/linux/cbits/hs_socket.c --- a/platform/linux/cbits/hs_socket.c +++ b/platform/linux/cbits/hs_socket.c @@ -1,7 +1,7 @@ #include int hs_socket (int domain, int type, int protocol, int *err) { -#ifdef SOCK_NONBLOCK +#ifdef __USE_GNU // On Linux, there is an optimized way to set a socket non-blocking int fd = socket(domain, type | SOCK_NONBLOCK, protocol); if (fd >= 0) { @@ -42,7 +42,7 @@ } int hs_accept (int sockfd, struct sockaddr *addr, int *addrlen, int *err) { -#ifdef SOCK_NONBLOCK +#ifdef __USE_GNU // On Linux, there is an optimized way to set a socket non-blocking int fd = accept4(sockfd, addr, addrlen, SOCK_NONBLOCK); if (fd >= 0) { diff --git a/platform/linux/include/hs_socket.h b/platform/linux/include/hs_socket.h --- a/platform/linux/include/hs_socket.h +++ b/platform/linux/include/hs_socket.h @@ -1,3 +1,5 @@ +#define _GNU_SOURCE + #include #include #include 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 @@ -1,21 +1,12 @@ module System.Socket.Internal.Platform where -import Control.Applicative ((<$>)) -import Control.Exception -import Control.Monad (when, join) - +import Control.Monad (join) import Foreign.Ptr import Foreign.C.Types import Foreign.C.String -import Foreign.Storable -import Foreign.Marshal.Alloc - import GHC.Conc (threadWaitReadSTM, threadWaitWriteSTM, atomically) - import System.Posix.Types ( Fd(..) ) - import System.Socket.Internal.Message -import System.Socket.Internal.Exception #include "hs_socket.h" diff --git a/socket.cabal b/socket.cabal --- a/socket.cabal +++ b/socket.cabal @@ -1,5 +1,5 @@ name: socket -version: 0.6.2.0 +version: 0.7.0.0 synopsis: An extensible socket library. description: This library is a minimal cross-platform interface for @@ -70,10 +70,10 @@ test.hs build-depends: base >= 4.7 && < 5 - , tasty >= 0.11 + , tasty , tasty-hunit , tasty-quickcheck - , QuickCheck >= 2.9 && <3 + , QuickCheck >= 2.9 , async , bytestring , socket @@ -91,10 +91,10 @@ -threaded build-depends: base >= 4.7 && < 5 - , tasty >= 0.11 + , tasty , tasty-hunit , tasty-quickcheck - , QuickCheck >= 2.9 && <3 + , QuickCheck >= 2.9 , async , bytestring , socket diff --git a/src/System/Socket.hsc b/src/System/Socket.hsc --- a/src/System/Socket.hsc +++ b/src/System/Socket.hsc @@ -87,7 +87,7 @@ , HasNameInfo (..) -- * Flags -- ** MessageFlags - , MessageFlags () + , MessageFlags (..) , msgEndOfRecord , msgNoSignal , msgOutOfBand diff --git a/src/System/Socket/Family/Inet.hsc b/src/System/Socket/Family/Inet.hsc --- a/src/System/Socket/Family/Inet.hsc +++ b/src/System/Socket/Family/Inet.hsc @@ -49,7 +49,10 @@ import System.Socket.Internal.Platform #include "hs_socket.h" + +#if __GLASGOW_HASKELL__ < 800 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif -- | The [Internet Protocol version 4](https://en.wikipedia.org/wiki/IPv4). data Inet 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 @@ -49,7 +49,10 @@ import System.Socket.Internal.Platform #include "hs_socket.h" + +#if __GLASGOW_HASKELL__ < 800 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif -- | The [Internet Protocol version 4](https://en.wikipedia.org/wiki/IPv4). data Inet6 diff --git a/src/System/Socket/Internal/AddressInfo.hsc b/src/System/Socket/Internal/AddressInfo.hsc --- a/src/System/Socket/Internal/AddressInfo.hsc +++ b/src/System/Socket/Internal/AddressInfo.hsc @@ -62,7 +62,10 @@ import System.Socket.Internal.Platform #include "hs_socket.h" + +#if __GLASGOW_HASKELL__ < 800 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif ------------------------------------------------------------------------------- -- AddressInfo diff --git a/src/System/Socket/Type/Stream.hsc b/src/System/Socket/Type/Stream.hsc --- a/src/System/Socket/Type/Stream.hsc +++ b/src/System/Socket/Type/Stream.hsc @@ -10,21 +10,33 @@ module System.Socket.Type.Stream ( -- * Stream Stream - -- * Convenience Operations - -- ** sendAll, receiveAll + -- ** Specialized send operations + -- *** sendAll , sendAll + -- *** sendAllLazy + , sendAllLazy + -- *** sendAllBuilder + , sendAllBuilder + -- ** Specialized receive operations + -- *** receiveAll , receiveAll ) where +import Control.Exception (throwIO) import Control.Monad (when) import Data.Int +import Data.Word import Data.Monoid +import Foreign.Ptr +import Foreign.Marshal.Alloc import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Builder.Extra as BB +import qualified Data.ByteString.Builder.Internal as BB import qualified Data.ByteString.Lazy as LBS import System.Socket +import System.Socket.Unsafe #include "hs_socket.h" @@ -33,21 +45,84 @@ instance Type Stream where typeNumber _ = (#const SOCK_STREAM) -------------------------------------------------------------------------------- --- Convenience Operations -------------------------------------------------------------------------------- +-- | Sends a whole `BS.ByteString` with as many system calls as necessary +-- and returns the bytes sent (in this case just the `BS.ByteString`s +-- `BS.length`). +sendAll :: Socket f Stream p -> BS.ByteString -> MessageFlags -> IO Int +sendAll s bs flags = do + BS.unsafeUseAsCStringLen bs (uncurry sendAllPtr) + return (BS.length bs) + where + sendAllPtr :: Ptr a -> Int -> IO () + sendAllPtr ptr len = do + sent <- fromIntegral `fmap` unsafeSend s ptr (fromIntegral len) flags + when (sent < len) $ sendAllPtr (plusPtr ptr sent) (len - sent) --- | Like `send`, but operates on lazy `Data.ByteString.Lazy.ByteString`s and --- continues until all data has been sent or an exception occured. -sendAll ::Socket f Stream p -> LBS.ByteString -> MessageFlags -> IO () -sendAll s lbs flags = - LBS.foldlChunks - (\x bs-> x >> sendAll' bs - ) (return ()) lbs +-- | Like `sendAll`, but operates on lazy `Data.ByteString.Lazy.ByteString`s. +-- +-- It uses `sendAll` internally to send all chunks sequentially. The lock on +-- the socket is acquired for each chunk separately, so the socket can be read +-- from in an interleaving fashion. +sendAllLazy :: Socket f Stream p -> LBS.ByteString -> MessageFlags -> IO Int64 +sendAllLazy s lbs flags = + LBS.foldlChunks f (return 0) lbs where - sendAll' bs = do - sent <- send s bs flags - when (sent < BS.length bs) $ sendAll' (BS.drop sent bs) + f action bs = do + sent <- action + sent' <- fromIntegral `fmap` sendAll s bs flags + return $! sent + sent' + +-- | Sends a whole `BB.Builder` without allocating `BS.ByteString`s. +-- If performance is an issue, this operation should be preferred over all +-- other solutions for sending stream data. +-- +-- The operation `alloca`tes a single buffer of the given size on entry and +-- reuses this buffer until the whole `BB.Builder` has been sent. +-- The count of all bytes sent is returned as there is no other efficient +-- way to determine a `BB.Builder`s size without actually building it. +sendAllBuilder :: Socket f Stream p -> Int -> BB.Builder -> MessageFlags -> IO Int64 +sendAllBuilder s bufsize builder flags = do + allocaBytes bufsize g + where + g ptr = writeStep (BB.runPut $ BB.putBuilder builder) 0 + where + bufferRange :: BB.BufferRange + bufferRange = + BB.BufferRange ptr (plusPtr ptr bufsize) + writeStep :: BB.BuildStep a -> Int64 -> IO Int64 + writeStep step alreadySent = + BB.fillWithBuildStep step whenDone whenFull whenChunk bufferRange + where + whenDone ptrToNextFreeByte _ + | len > 0 = do + sendAllPtr ptr len + return $! alreadySent + fromIntegral len + | otherwise = + return alreadySent + where + len = minusPtr ptrToNextFreeByte ptr + whenFull ptrToNextFreeByte minBytesRequired nextStep + | minBytesRequired > bufsize = + throwIO eNoBufferSpace + | otherwise = do + sendAllPtr ptr len + writeStep nextStep $! alreadySent + fromIntegral len + where + len = minusPtr ptrToNextFreeByte ptr + whenChunk ptrToNextFreeByte bs nextStep = do + sendAllPtr ptr len + if BS.null bs + then + writeStep nextStep $! alreadySent + fromIntegral len + else do + bsLen <- sendAll s bs flags + writeStep nextStep $! alreadySent + fromIntegral (len + bsLen) + where + len = minusPtr ptrToNextFreeByte ptr + sendAllPtr :: Ptr Word8 -> Int -> IO () + sendAllPtr ptr len = do + sent <- fromIntegral `fmap` unsafeSend s ptr (fromIntegral len) flags + when (sent < len) $ sendAllPtr (plusPtr ptr sent) (len - sent) -- | Like `receive`, but operates on lazy `Data.ByteString.Lazy.ByteString`s and -- continues until either an empty part has been received (peer closed 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 @@ -34,8 +34,6 @@ , tryWaitRetryLoop ) where -import Data.Function - import Control.Applicative ((<$>)) import Control.Monad import Control.Exception @@ -55,7 +53,7 @@ #include "hs_socket.h" -unsafeSend :: Socket a t p -> Ptr a -> CSize -> MessageFlags -> IO CInt +unsafeSend :: Socket a t p -> Ptr b -> CSize -> MessageFlags -> IO CInt unsafeSend s bufPtr bufSize flags = do tryWaitRetryLoop s unsafeSocketWaitWrite (\fd-> c_send fd bufPtr bufSize flags ) diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,29 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Concurrent ( threadDelay ) -import Control.Concurrent.Async ( async, race, poll, cancel, concurrently, wait ) -import Control.Exception ( try, bracket, throwIO, catch ) -import Control.Monad ( when, unless, void ) - -import Prelude hiding ( head ) - -import Data.Maybe ( isJust ) -import Data.Monoid ( mempty ) -import Data.Int ( Int64 ) -import qualified Data.ByteString.Lazy as LBS - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as QC - -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Family.Inet6 -import System.Socket.Type.Stream -import System.Socket.Type.Datagram -import System.Socket.Protocol.TCP -import System.Socket.Protocol.UDP +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async, cancel, concurrently, poll, + race, wait) +import Control.Exception (bracket, catch, throwIO, try) +import Control.Monad (unless, void, when) +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int64) +import Data.Maybe (isJust) +import Data.Monoid (mempty, mappend) +import Prelude hiding (head) +import System.Socket +import System.Socket.Family.Inet +import System.Socket.Family.Inet6 +import System.Socket.Protocol.TCP +import System.Socket.Protocol.UDP +import System.Socket.Type.Datagram +import System.Socket.Type.Stream +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC main :: IO () main = defaultMain $ testGroup "socket" @@ -71,7 +69,7 @@ case p of Just (Left ex) -> assertFailure "unexpected exception" Just (Right _) -> assertFailure "unexpected connect" - Nothing -> void $ cancel a + Nothing -> void $ cancel a ] ] @@ -167,7 +165,7 @@ setSocketOption sock (ReuseAddress True) listen sock 5 `catch` \e-> case e of _ | e == eOperationNotSupported -> return () - _ -> assertFailure "expected eOperationNotSupported" + _ -> assertFailure "expected eOperationNotSupported" ] , testGroup "Inet/Stream/TCP" [ testCase "listen on bound socket" $ bracket @@ -267,7 +265,7 @@ group07 :: TestTree group07 = testGroup "sendAll/receiveAll" [ testGroup "Inet/Stream/TCP" - [ testCase "send and receive a 128MB chunk" $ bracket + [ testCase "sendAll and receiveAll a 128MB chunk" $ bracket ( do server <- socket :: IO (Socket Inet Stream TCP) client <- socket :: IO (Socket Inet Stream TCP) @@ -289,11 +287,68 @@ receiveAll peerSock msgSize mempty threadDelay 100000 connect client addr - sendAll client msg mempty + sent <- sendAll client (LBS.toStrict msg) mempty close client msgReceived <- wait serverRecv + when (fromIntegral sent /= LBS.length msg) (assertFailure "sendAll reported wrong size.") when (msgReceived /= msg) (assertFailure "Received message was bogus.") ) + , testCase "sendAllLazy and receiveAll a 128MB chunk" $ bracket + ( do + server <- socket :: IO (Socket Inet Stream TCP) + client <- socket :: IO (Socket Inet Stream TCP) + return (server, client) + ) + ( \(server,client)-> do + close server + close client + ) + ( \(server,client)-> do + let addr = SocketAddressInet inetLoopback port + let msgSize = 128*1024*1024 + 1 :: Int64 + let msg = LBS.replicate msgSize 23 + setSocketOption server (ReuseAddress True) + bind server addr + listen server 5 + serverRecv <- async $ do + (peerSock, peerAddr) <- accept server + receiveAll peerSock msgSize mempty + threadDelay 100000 + connect client addr + sent <- sendAllLazy client msg mempty + close client + msgReceived <- wait serverRecv + when (sent /= LBS.length msg) (assertFailure "sendAllLazy reported wrong size.") + when (msgReceived /= msg) (assertFailure "Received message was bogus.") + ) + , testCase "sendAllBuilder and receiveAll a 128MB chunk" $ bracket + ( do + server <- socket :: IO (Socket Inet Stream TCP) + client <- socket :: IO (Socket Inet Stream TCP) + return (server, client) + ) + ( \(server,client)-> do + close server + close client + ) + ( \(server,client)-> do + let addr = SocketAddressInet inetLoopback port + let msgSize = 128*1024*1024 + 1 :: Int64 + let msg = LBS.replicate msgSize 23 + setSocketOption server (ReuseAddress True) + bind server addr + listen server 5 + serverRecv <- async $ do + (peerSock, peerAddr) <- accept server + receiveAll peerSock msgSize mempty + threadDelay 100000 + connect client addr + sent <- sendAllBuilder client 512 (foldr (\bs-> (BB.byteString bs `mappend`)) mempty $ LBS.toChunks msg) mempty + close client + msgReceived <- wait serverRecv + when (sent /= LBS.length msg) (assertFailure "sendAllBuilder reported wrong size.") + when (msgReceived /= msg) (assertFailure "Received message was bogus.") + ) ] ] @@ -311,6 +366,7 @@ ) ( \(server,client)-> do setSocketOption server (V6Only True) + setSocketOption server (ReuseAddress True) bind server (SocketAddressInet6 inet6Any port6 0 0) threadDelay 1000000 -- wait for the listening socket being set up sendTo client "PING" mempty (SocketAddressInet inetLoopback port) @@ -318,7 +374,7 @@ ( void $ receiveFrom server 4096 mempty ) ( threadDelay 1000000 ) case eith of - Left () -> assertFailure "expected timeout" + Left () -> assertFailure "expected timeout" Right () -> return () -- timeout is the expected behaviour ) , testCase "absent" $ bracket @@ -333,6 +389,7 @@ ) ( \(server,client)-> do setSocketOption server (V6Only False) + setSocketOption server (ReuseAddress True) bind server (SocketAddressInet6 inet6Any port6 0 0) threadDelay 1000000 -- wait for the listening socket being set up sendTo client "PING" mempty (SocketAddressInet inetLoopback port) @@ -340,7 +397,7 @@ ( void $ receiveFrom server 4096 mempty ) ( threadDelay 1000000 ) case eith of - Left () -> return () + Left () -> return () Right () -> assertFailure "expected packet" ) ] @@ -364,7 +421,7 @@ , testCase "getAddrInfo \"\" \"\"" $ void (getAddressInfo Nothing Nothing mempty :: IO [AddressInfo Inet Stream TCP]) `catch` \e-> case e of _ | e == eaiNoName -> return () - _ -> assertFailure "expected eaiNoName" + _ -> assertFailure "expected eaiNoName" ]