socket 0.6.2.0 → 0.7.0.0
raw patch · 12 files changed
+214/−67 lines, 12 filesdep ~QuickCheckdep ~tasty
Dependency ranges changed: QuickCheck, tasty
Files
- CHANGELOG.md +15/−0
- platform/linux/cbits/hs_socket.c +2/−2
- platform/linux/include/hs_socket.h +2/−0
- platform/linux/src/System/Socket/Internal/Platform.hsc +1/−10
- socket.cabal +5/−5
- src/System/Socket.hsc +1/−1
- src/System/Socket/Family/Inet.hsc +3/−0
- src/System/Socket/Family/Inet6.hsc +3/−0
- src/System/Socket/Internal/AddressInfo.hsc +3/−0
- src/System/Socket/Type/Stream.hsc +91/−16
- src/System/Socket/Unsafe.hsc +1/−3
- test/test.hs +87/−30
CHANGELOG.md view
@@ -1,3 +1,18 @@+0.7.0.0 Lars Petersen <info@lars-petersen.net> 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 <info@lars-petersen.net> 2016-08-15 * Added functions for constructing internet addresses without the need for IO
platform/linux/cbits/hs_socket.c view
@@ -1,7 +1,7 @@ #include <hs_socket.h> 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) {
platform/linux/include/hs_socket.h view
@@ -1,3 +1,5 @@+#define _GNU_SOURCE+ #include <stdint.h> #include <unistd.h> #include <fcntl.h>
platform/linux/src/System/Socket/Internal/Platform.hsc view
@@ -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"
socket.cabal view
@@ -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
src/System/Socket.hsc view
@@ -87,7 +87,7 @@ , HasNameInfo (..) -- * Flags -- ** MessageFlags- , MessageFlags ()+ , MessageFlags (..) , msgEndOfRecord , msgNoSignal , msgOutOfBand
src/System/Socket/Family/Inet.hsc view
@@ -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
src/System/Socket/Family/Inet6.hsc view
@@ -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
src/System/Socket/Internal/AddressInfo.hsc view
@@ -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
src/System/Socket/Type/Stream.hsc view
@@ -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
src/System/Socket/Unsafe.hsc view
@@ -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 )
test/test.hs view
@@ -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" ]