socket 0.5.3.1 → 0.6.0.0
raw patch · 33 files changed
+969/−685 lines, 33 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +25/−4
- CONTRIBUTORS.txt +1/−0
- README.md +7/−16
- platform/linux/include/hs_socket.h +19/−0
- platform/win32/cbits/hs_socket.c +1/−1
- platform/win32/include/hs_socket.h +19/−0
- socket.cabal +3/−8
- src/System/Socket.hsc +82/−232
- src/System/Socket/Family.hs +0/−11
- src/System/Socket/Family/Inet.hsc +106/−75
- src/System/Socket/Family/Inet6.hsc +242/−109
- src/System/Socket/Internal/AddressInfo.hsc +65/−49
- src/System/Socket/Internal/Exception.hsc +134/−49
- src/System/Socket/Internal/Message.hsc +15/−9
- src/System/Socket/Internal/Socket.hsc +44/−15
- src/System/Socket/Protocol.hs +0/−12
- src/System/Socket/Protocol/TCP.hsc +10/−1
- src/System/Socket/Protocol/UDP.hsc +10/−1
- src/System/Socket/Type.hs +0/−9
- src/System/Socket/Type/Datagram.hsc +10/−1
- src/System/Socket/Type/Raw.hsc +10/−1
- src/System/Socket/Type/SequentialPacket.hsc +10/−1
- src/System/Socket/Type/Stream.hsc +69/−2
- src/System/Socket/Unsafe.hsc +17/−7
- tests/AddrInfo.hs +7/−6
- tests/EOPNOTSUPP.hs +4/−4
- tests/EPIPE.hs +4/−2
- tests/IPV6_V6ONLY.hs +11/−9
- tests/NonBlockingIO.hs +5/−3
- tests/PingPong.hs +6/−4
- tests/TCP-sendAndRecvAll.hs +4/−2
- tests/TCP.hs +13/−19
- tests/UDP.hs +16/−23
CHANGELOG.md view
@@ -1,6 +1,20 @@-0.5.3.1 Lars Petersen <info@lars-petersen.net> 2016-04-10-- * Fixed `AddrInfo` test suite. Should now work even in a `chroot()` environment.+0.6.0.0 Lars Petersen <info@lars-petersen.net> 2016-03-26+ * Improved and adapted documentation.+ * Merged `GetSocketOption` and `SetSocketOption` to one single type class+ `SocketOption`.+ * `getNameInfo` now returns `NameInfo` instead of a tuple.+ * Added all theoretically possible `SocketExceptions`.+ * The type class `GetNameInfo` has been renamed to `HasNameInfo`.+ * The type class `GetAddressInfo` has been renamed to `HasAddressInfo`.+ * Removed operation `withConnectedSocket` without replacement.+ It should not be part of this minimal library. Its code can be retrieved from the repository if needed.+ * The operations `sendAll` and `receiveAll` are now exported through+ `System.Socket.Type.Stream` and no longer trough the main module.+ They are very specific, solely stream-oriented and just wrappers around+ the basic operations. Such operations shouldn't pollute the main module.+ * Issue #10: Ben Gamari reported that the associated type `SocketAddress`+ is not injective which would lead to compilation failure on GHC 8.* .+ This is fixed by using a data family instead. 0.5.3.0 Lars Petersen <info@lars-petersen.net> 2015-08-09 @@ -9,7 +23,14 @@ 0.5.2.0 Lars Petersen <info@lars-petersen.net> 2015-07-08 - * Don't set `msgNoSignal` automatically with `send` and `sendTo`. This implicit behaviour is a bad design decision. The implications of this change are rather limited. The behaviour/correctness of an application is only affected if it hooked SIGPIPE. GHC's RTS by default ignores SIGPIPE since #1619. You're still advised to adapt your applications to use `msgNoSignal` explicitly when writing on stream oriented sockets. Otherwise the RTS gets unnecessarily interrupted. This is harmless, but annoying and not desired when developing high-performance applications.+ * Don't set `msgNoSignal` automatically with `send` and `sendTo`. This implicit+ behaviour is a bad design decision. The implications of this change are+ rather limited. The behaviour/correctness of an application is only affected+ if it hooked SIGPIPE. GHC's RTS by default ignores SIGPIPE since #1619.+ You're still advised to adapt your applications to use `msgNoSignal`+ explicitly when writing on stream oriented sockets. Otherwise the RTS gets+ unnecessarily interrupted. This is harmless, but annoying and not desired+ when developing high-performance applications. * Define `msgNoSignal` as 0 if not available and documented this behaviour. * Added new exception value `ePipe`.
CONTRIBUTORS.txt view
@@ -1,3 +1,4 @@+Ben Gamari (issue #10) Niklas Hambüchen (issue #9) Michael Fox (reported issue #7) Bryan O'Sullivan (legitimately criticised the bizarre naming)
README.md view
@@ -7,7 +7,7 @@ ### Motivation -This library aims to expose a minimal and platform-independant interface for+This library aims to expose a minimal and cross platform interface for POSIX compliant networking code. ### Implementation Philosophy@@ -15,19 +15,14 @@ - 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:- - Support for Unix sockets which don't have an equivalent on Windows.- - Support for SCTP.- - Support for vectored IO (at least unless it can be guaranteed to- be supported on all platforms). - 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.+ If they are not POSIX compliant (i.e. on Windows) a level of+ indirection is introduced to create a POSIX compliant equivalent in C+ using whatever the platform specific building blocks are. ### Platform Support @@ -35,10 +30,6 @@ Working. -#### BSD--Unknown. Should work. Please report if not.- #### MacOS Working.@@ -47,11 +38,11 @@ Fully supported on Windows7 (maybe Vista) or higher :-) -GHCs runtime system on Windows does not offer an event notification mechanism for sockets.+GHC's 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.+suffers from this, too. For example, connection attempts are non-interruptible etc. The approach taken to circumvent this in this library is to poll the-non-blocking sockets with increasing delay. This guarantees interruptability+non-blocking sockets with increasing delay. This guarantees non-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
platform/linux/include/hs_socket.h view
@@ -29,6 +29,25 @@ #define SETIMEDOUT ETIMEDOUT #define SEPIPE EPIPE #define SEOPNOTSUPP EOPNOTSUPP+#define SENOTSOCK ENOTSOCK+#define SEDESTADDRREQ EDESTADDRREQ+#define SEMSGSIZE EMSGSIZE+#define SEPROTOTYPE EPROTOTYPE+#define SENOPROTOOPT ENOPROTOOPT+#define SESOCKTNOSUPPORT ESOCKTNOSUPPORT+#define SEPFNOSUPPORT EPFNOSUPPORT+#define SEAFNOSUPPORT EAFNOSUPPORT+#define SEADDRINUSE EADDRINUSE+#define SEADDRNOTAVAIL EADDRNOTAVAIL+#define SENETDOWN ENETDOWN+#define SENETRESET ENETRESET+#define SECONNABORTED ECONNABORTED+#define SECONNRESET ECONNRESET+#define SENOBUFS ENOBUFS+#define SESHUTDOWN ESHUTDOWN+#define SETOOMANYREFS ETOOMANYREFS+#define SEHOSTDOWN EHOSTDOWN+#define SEHOSTUNREACH EHOSTUNREACH /* MSG_NOSIGNAL might not be available (i.e. on MacOSX and Solaris). * In this case it gets defined as 0. This is relatively
platform/win32/cbits/hs_socket.c view
@@ -49,7 +49,7 @@ }; int hs_setnonblocking(int fd) {- // If iMode = 0, blocking is enabled; + // If iMode = 0, blocking is enabled; // If iMode != 0, non-blocking mode is enabled. u_long iMode = 1; return ioctlsocket(fd, FIONBIO, &iMode);
platform/win32/include/hs_socket.h view
@@ -127,3 +127,22 @@ #define SETIMEDOUT WSAETIMEDOUT #define SEPIPE WSAECONNABORTED #define SEOPNOTSUPP WSAEOPNOTSUPP+#define SENOTSOCK WSAENOTSOCK+#define SEHOSTUNREACH WSAEHOSTUNREACH+#define SEHOSTDOWN WSAEHOSTDOWN+#define SETOOMANYREFS WSAETOOMANYREFS+#define SESHUTDOWN WSAESHUTDOWN+#define SENOBUFS WSAENOBUFS+#define SENETRESET WSAENETRESET+#define SENETDOWN WSAENETDOWN+#define SECONNABORTED WSAECONNABORTED+#define SECONNRESET WSAECONNRESET+#define SEADDRNOTAVAIL WSAEADDRNOTAVAIL+#define SEADDRINUSE WSAEADDRINUSE+#define SEAFNOSUPPORT WSAEAFNOSUPPORT+#define SEPFNOSUPPORT WSAEPFNOSUPPORT+#define SESOCKTNOSUPPORT WSAESOCKTNOSUPPORT+#define SENOPROTOOPT WSAENOPROTOOPT+#define SEPROTOTYPE WSAEPROTOTYPE+#define SEMSGSIZE WSAEMSGSIZE+#define SEDESTADDRREQ WSAEDESTADDRREQ
socket.cabal view
@@ -1,11 +1,9 @@ name: socket-version: 0.5.3.1-synopsis: A portable and extensible sockets library.+version: 0.6.0.0+synopsis: An extensible socket library. description:- This library is a minimal and platform-independant interface for+ This library is a minimal and cross platform interface for BSD style networking.- .- Also see README.md for details. license: MIT license-file: LICENSE@@ -29,15 +27,12 @@ library exposed-modules: System.Socket- , System.Socket.Family , System.Socket.Family.Inet , System.Socket.Family.Inet6- , System.Socket.Type , System.Socket.Type.Raw , System.Socket.Type.Datagram , System.Socket.Type.Stream , System.Socket.Type.SequentialPacket- , System.Socket.Protocol , System.Socket.Protocol.UDP , System.Socket.Protocol.TCP , System.Socket.Unsafe
src/System/Socket.hsc view
@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies, FlexibleContexts, ScopedTypeVariables #-}------------------------------------------------------------------------------+-------------------------------------------------------------------------------- -- | -- Module : System.Socket -- Copyright : (c) Lars Petersen 2015@@ -8,60 +8,55 @@ -- Maintainer : info@lars-petersen.net -- Stability : experimental ----- This starts a TCP server on localhost, sends @"Hello world!"@ to--- connecting peers and closes the connection immediately.--- -- > {-# LANGUAGE OverloadedStrings #-} -- > module Main where -- >--- > import System.Socket--- > import System.Socket.Family.Inet as Inet--- > import Data.Monoid--- > import Data.ByteString--- > import Control.Monad--- > import Control.Concurrent--- > import Control.Exception+-- > import Control.Exception ( bracket, catch )+-- > import Control.Monad ( forever ) -- >--- > main :: IO ()--- > main = do--- > s <- socket :: IO (Socket Inet Stream TCP)--- > setSocketOption s (ReuseAddress True)--- > bind s addr--- > listen s 5--- > forever $ do--- > (peer,_) <- accept s--- > forkIO $ do--- > sendAll peer "Hello world!" msgNoSignal `finally` close peer--- > where--- > addr = SocketAddressInet Inet.loopback 8080------ This downloads the Haskell website and prints it to stdout.--- Note the use of IPv4-mapped `Inet6` addresses: This will work--- even if you don't have IPv6 connectivity yet and is the preferred method--- when writing new applications.------ > {-# LANGUAGE OverloadedStrings #-}--- > module Main where--- > --- > import Data.Monoid--- > import Data.ByteString.Lazy as B -- > import System.Socket--- > +-- > import System.Socket.Family.Inet6+-- > import System.Socket.Type.Stream+-- > import System.Socket.Protocol.TCP+-- > -- > main :: IO ()--- > main = do--- > withConnectedSocket "www.haskell.org" "80" (aiAll `mappend` aiV4Mapped) $ \sock-> do--- > let _ = sock :: Socket Inet6 Stream TCP--- > sendAll sock "GET / HTTP/1.0\r\nHost: www.haskell.org\r\n\r\n" msgNoSignal--- > x <- receiveAll sock (1024*1024*1024) mempty--- > B.putStr x------------------------------------------------------------------------------+-- > main = bracket+-- > ( socket :: IO (Socket Inet6 Stream TCP) )+-- > ( \s-> do+-- > close s+-- > putStrLn "Listening socket closed."+-- > )+-- > ( \s-> do+-- > setSocketOption s (ReuseAddress True)+-- > setSocketOption s (V6Only False)+-- > bind s (SocketAddressInet6 inet6Any 8080 0 0)+-- > listen s 5+-- > putStrLn "Listening socket ready..."+-- > forever $ acceptAndHandle s `catch` \e-> print (e :: SocketException)+-- > )+-- >+-- > acceptAndHandle :: Socket Inet6 Stream TCP -> IO ()+-- > acceptAndHandle s = bracket+-- > ( accept s )+-- > ( \(p, addr)-> do+-- > close p+-- > putStrLn $ "Closed connection to " ++ show addr+-- > )+-- > ( \(p, addr)-> do+-- > putStrLn $ "Accepted connection from " ++ show addr+-- > sendAll p "Hello world!" msgNoSignal+-- > )+-------------------------------------------------------------------------------- module System.Socket (- -- * Name Resolution- AddressInfo (..)- -- ** getAddressInfo- , GetAddressInfo (..)- -- ** getNameInfo- , GetNameInfo (..)+ -- * Socket+ Socket ()+ , SocketAddress ()+ -- ** Family+ , Family (..)+ -- ** Type+ , Type (..)+ -- ** Protocol+ , Protocol (..) -- * Operations -- ** socket , socket@@ -79,67 +74,26 @@ , receive, receiveFrom -- ** close , close- -- * Convenience Operations- -- ** withConnectedSocket- , withConnectedSocket- -- ** sendAll- , sendAll- -- ** receiveAll- , receiveAll- -- * Sockets- , Socket (..)- -- ** Families- , Family (..)- -- *** Inet- , Inet- -- *** Inet6- , Inet6- -- ** Types- , Type (..)- -- *** Datagram- , Datagram- -- *** Raw- , Raw- -- *** SequentialPacket- , SequentialPacket- -- *** Stream- , Stream- -- ** Protocols- , Protocol (..)- -- *** UDP- , UDP- -- *** TCP- , TCP- -- * Exceptions- -- ** SocketException- , module System.Socket.Internal.Exception- -- ** AddressInfoException- , AddressInfoException (..)- , eaiAgain- , eaiBadFlags- , eaiFail- , eaiFamily- , eaiMemory- , eaiNoName- , eaiSocketType- , eaiService- , eaiSystem- -- * Socket Options- -- ** getSocketOption- , GetSocketOption (..)- -- ** setSocketOption- , SetSocketOption (..)+ -- * Options+ , SocketOption (..) , Error (..) , ReuseAddress (..)+ -- * Name Resolution+ -- ** getAddressInfo+ , AddressInfo (..)+ , HasAddressInfo (..)+ -- ** getNameInfo+ , NameInfo (..)+ , HasNameInfo (..) -- * Flags -- ** MessageFlags- , MessageFlags (..)+ , MessageFlags () , msgEndOfRecord , msgNoSignal , msgOutOfBand , msgWaitAll -- ** AddressInfoFlags- , AddressInfoFlags (..)+ , AddressInfoFlags () , aiAddressConfig , aiAll , aiCanonicalName@@ -148,12 +102,26 @@ , aiPassive , aiV4Mapped -- ** NameInfoFlags- , NameInfoFlags (..)+ , NameInfoFlags () , niNameRequired , niDatagram , niNoFullyQualifiedDomainName , niNumericHost , niNumericService+ -- * Exceptions+ -- ** SocketException+ , module System.Socket.Internal.Exception+ -- ** AddressInfoException+ , AddressInfoException (..)+ , eaiAgain+ , eaiBadFlags+ , eaiFail+ , eaiFamily+ , eaiMemory+ , eaiNoName+ , eaiSocketType+ , eaiService+ , eaiSystem ) where import Control.Exception@@ -162,13 +130,8 @@ import Control.Concurrent import Data.Function-import Data.Monoid-import Data.Int 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.Lazy as LBS import GHC.Conc (closeFdWith) @@ -184,20 +147,6 @@ import System.Socket.Internal.AddressInfo import System.Socket.Internal.Platform -import System.Socket.Family-import System.Socket.Family.Inet-import System.Socket.Family.Inet6--import System.Socket.Type-import System.Socket.Type.Datagram-import System.Socket.Type.Raw-import System.Socket.Type.SequentialPacket-import System.Socket.Type.Stream--import System.Socket.Protocol-import System.Socket.Protocol.UDP-import System.Socket.Protocol.TCP- #include "hs_socket.h" -- | Creates a new socket.@@ -271,7 +220,7 @@ -- failed. It should be closed then. -- - Also see [these considerations](http://cr.yp.to/docs/connect.html) on -- the problems with connecting non-blocking sockets.-connect :: Family f => Socket f t p -> SocketAddress f -> IO ()+connect :: (Family f, Storable (SocketAddress f)) => Socket f t p -> SocketAddress f -> IO () connect (Socket mfd) addr = do alloca $ \addrPtr-> do poke addrPtr addr@@ -315,7 +264,7 @@ return Nothing else if e == eAlready then do -- The previous connection attempt is still pending.- Just <$> unsafeSocketWaitWrite fd iteration+ Just Control.Applicative.<$> unsafeSocketWaitWrite fd iteration else do -- The previous connection failed (results in EINPROGRESS or -- EWOULBLOCK here) or something else is wrong.@@ -345,7 +294,7 @@ -- [argued here](http://stackoverflow.com/a/14485305). -- - This operation throws `SocketException`s. Consult your @man@ page for -- details and specific @errno@s.-bind :: (Family f) => Socket f t p -> SocketAddress f -> IO ()+bind :: (Family f, Storable (SocketAddress f)) => Socket f t p -> SocketAddress f -> IO () bind (Socket mfd) addr = do alloca $ \addrPtr-> do poke addrPtr addr@@ -388,10 +337,10 @@ -- details and specific @errno@s. -- - This operation catches `eAgain`, `eWouldBlock` and `eInterrupted` internally -- and retries automatically.-accept :: (Family f) => Socket f t p -> IO (Socket f t p, SocketAddress f)+accept :: (Family f, Storable (SocketAddress f)) => Socket f t p -> IO (Socket f t p, SocketAddress f) accept s@(Socket mfd) = accept' where- accept' :: forall f t p. (Family f) => IO (Socket f t p, SocketAddress f)+ accept' :: forall f t p. (Family f, Storable (SocketAddress f)) => IO (Socket f t p, SocketAddress f) accept' = do -- Allocate local (!) memory for the address. alloca $ \addrPtr-> do@@ -412,7 +361,7 @@ then retry else throwIO e -- This is the critical section: We got a valid descriptor we have not yet returned.- else do + else do i <- c_setnonblocking ft if i < 0 then do c_get_last_socket_error >>= throwIO@@ -437,7 +386,7 @@ -- - The operation returns the number of bytes sent. On `Datagram` and -- `SequentialPacket` sockets certain assurances on atomicity exist and `eAgain` or -- `eWouldBlock` are returned until the whole message would fit--- into the send buffer. +-- into the send buffer. -- - This operation throws `SocketException`s. Consult @man 3p send@ for -- details and specific @errno@s. -- - `eAgain`, `eWouldBlock` and `eInterrupted` and handled internally and won't@@ -449,8 +398,8 @@ unsafeSend s (castPtr bufPtr) (fromIntegral bufSize) flags return (fromIntegral bytesSent) --- | Like `send`, but allows for specifying a destination address.-sendTo ::(Family f) => Socket f t p -> BS.ByteString -> MessageFlags -> SocketAddress f -> IO Int+-- | Like `send`, but allows to specify a destination address.+sendTo ::(Family f, Storable (SocketAddress f)) => Socket f t p -> BS.ByteString -> MessageFlags -> SocketAddress f -> IO Int sendTo s bs flags addr = do bytesSent <- alloca $ \addrPtr-> do poke addrPtr addr@@ -479,10 +428,10 @@ ) -- | Like `receive`, but additionally yields the peer address.-receiveFrom :: (Family f) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f)+receiveFrom :: (Family f, Storable (SocketAddress f)) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f) receiveFrom = receiveFrom' where- receiveFrom' :: forall f t p. (Family f) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f)+ receiveFrom' :: forall f t p. (Family f, Storable (SocketAddress f)) => Socket f t p -> Int -> MessageFlags -> IO (BS.ByteString, SocketAddress f) receiveFrom' s bufSize flags = do alloca $ \addrPtr-> do alloca $ \addrSizePtr-> do@@ -505,7 +454,7 @@ -- - This operation wakes up all threads that are currently blocking on this -- socket. All other threads are guaranteed not to block on operations on this socket in the future. -- Threads that perform operations other than `close` on this socket will fail with `eBadFileDescriptor`--- after the socket has been closed (`close` replaces the +-- after the socket has been closed (`close` replaces the -- `System.Posix.Types.Fd` in the `Control.Concurrent.MVar.MVar` with @-1@ -- to reliably avoid use-after-free situations). -- - This operation potentially throws `SocketException`s (only @EIO@ is@@ -528,7 +477,7 @@ i <- c_close fd if i < 0 then do e <- c_get_last_socket_error- if e == eInterrupted + if e == eInterrupted then retry else throwIO e else return ()@@ -536,102 +485,3 @@ -- When we arrive here, no exception has been thrown and the descriptor has been closed. -- We put an invalid file descriptor into the MVar. return (-1)------------------------------------------------------------------------------------ Convenience Operations------------------------------------------------------------------------------------ | 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- where- sendAll' bs = do- sent <- send s bs flags- when (sent < BS.length bs) $ sendAll' (BS.drop sent bs)---- | Like `receive`, but operates on lazy `Data.ByteString.Lazy.ByteString`s and--- continues until either an empty part has been received (peer closed--- the connection) or given buffer limit has been exceeded or an--- exception occured.------ - The `Data.Int.Int64` parameter is a soft limit on how many bytes to receive.--- Collection is stopped if the limit has been exceeded. The result might--- be up to one internal buffer size longer than the given limit.--- If the returned `Data.ByteString.Lazy.ByteString`s length is lower or--- eqal than the limit, the data has not been truncated and the--- transmission is complete.-receiveAll :: Socket f Stream p -> Int64 -> MessageFlags -> IO LBS.ByteString-receiveAll sock maxLen flags = collect 0 mempty- where- collect len accum- | len > maxLen = do- build accum- | otherwise = do- bs <- receive sock BB.smallChunkSize flags- if BS.null bs then do- build accum- else do- collect (len + fromIntegral (BS.length bs))- $! (accum `mappend` BB.byteString bs)- build accum = do- return (BB.toLazyByteString accum)---- | Looks up a name and executes an supplied action with a connected socket.------ - The addresses returned by `getAddressInfo` are tried in sequence until a--- connection has been established or all have been tried.--- - If `connect` fails on all addresses the exception that occured on the--- last connection attempt is thrown.--- - The supplied action is executed at most once with the first established--- connection.--- - If the address family is `Inet6`, `V6Only` is set to `False` which--- means the other end may be both IPv4 or IPv6.--- - All sockets created by this operation get closed automatically.--- - This operation throws `AddressInfoException`s, `SocketException`s and all--- exceptions that that the supplied action might throw.------ > withConnectedSocket "wwww.haskell.org" "80" (aiAll `mappend` aiV4Mapped) $ \sock-> do--- > let _ = sock :: Socket Inet6 Stream TCP--- > doSomethingWithSocket sock-withConnectedSocket :: forall f t p a.- ( GetAddressInfo f, Type t, Protocol p)- => BS.ByteString- -> BS.ByteString- -> AddressInfoFlags- -> (Socket f t p -> IO a)- -> IO a-withConnectedSocket host serv flags action = do- addrs <- getAddressInfo (Just host) (Just serv) flags :: IO [AddressInfo f t p]- tryAddrs addrs- where- tryAddrs :: [AddressInfo f t p] -> IO a- tryAddrs [] = do- -- This should not happen.- throwIO eaiNoName- tryAddrs (addr:addrs) = do- eith <- bracket- ( socket )- ( close )- ( \sock-> do- configureSocketSpecific sock- connected <- try (connect sock $ socketAddress addr)- case connected of- Left e -> return (Left (e :: SocketException))- Right _ -> Right <$> action sock- )- case eith of- Left e ->- -- Rethrow the last exception if there are no more addresses to try.- if null addrs- then throwIO e- else tryAddrs addrs- Right a -> do- return a-- configureSocketSpecific sock = do- when (familyNumber (undefined :: f) == familyNumber (undefined :: Inet6)) $ do- setSocketOption sock (V6Only False)
− src/System/Socket/Family.hs
@@ -1,11 +0,0 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}-module System.Socket.Family- ( Family (..)- ) where--import Foreign.C.Types-import Foreign.Storable--class (Storable (SocketAddress f)) => Family f where- type SocketAddress f- familyNumber :: f -> CInt
src/System/Socket/Family/Inet.hsc view
@@ -1,64 +1,69 @@-{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving #-}+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Family.Inet- ( Inet- -- * Addresses- , SocketAddressInet (..)- , Address ()- , Port (..)- -- ** Special Address Constants- -- *** allHostsGroup- , allHostsGroup- -- *** any- , System.Socket.Family.Inet.any- -- *** broadcast- , broadcast- -- *** loopback- , loopback- -- *** maxLocalGroup- , maxLocalGroup- -- *** none- , none- -- *** unspecificGroup- , unspecificGroup- -- * Socket Options+ ( -- * Inet+ Inet+ -- ** InetAddress+ , InetAddress+ -- ** InetPort+ , InetPort+ -- ** SocketAddress Inet+ , SocketAddress (SocketAddressInet, inetAddress, inetPort)+ -- * Special Addresses+ -- ** inetAllHostsGroup+ , inetAllHostsGroup+ -- ** inetAny+ , inetAny+ -- ** inetBroadcast+ , inetBroadcast+ -- ** inetLoopback+ , inetLoopback+ -- ** inetMaxLocalGroup+ , inetMaxLocalGroup+ -- ** inetNone+ , inetNone+ -- ** inetUnspecificGroup+ , inetUnspecificGroup ) where import Data.Word import Data.List-import qualified Data.ByteString as BS-import qualified Data.ByteString.Unsafe as BS -import Control.Applicative- import Foreign.Ptr import Foreign.Storable-import Foreign.Marshal.Utils -import System.Socket.Family+import System.Socket.Internal.Socket import System.Socket.Internal.Platform #include "hs_socket.h" #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +-- | The [Internet Protocol version 4](https://en.wikipedia.org/wiki/IPv4). data Inet instance Family Inet where- type SocketAddress Inet = SocketAddressInet familyNumber _ = (#const AF_INET) -data SocketAddressInet+-- | An [IPv4](https://en.wikipedia.org/wiki/IPv4) socket address.+--+-- The socket address contains a port number that may be used by transport+-- protocols like [TCP](https://en.wikipedia.org/wiki/Transmission_Control_Protocol).+--+-- > SocketAddressInet inetLoopback 8080+data instance SocketAddress Inet = SocketAddressInet- { address :: Address- , port :: Port+ { inetAddress :: InetAddress+ , inetPort :: InetPort } deriving (Eq, Show) -newtype Port- = Port Word16- deriving (Eq, Ord, Num)--instance Show Port where- show (Port p) = show p- -- | To avoid errors with endianess it was decided to keep this type abstract. -- -- Hint: Use the `Foreign.Storable.Storable` instance if you really need to access. It exposes it@@ -69,70 +74,96 @@ -- nameserver lookups: -- -- > > getAddressInfo (Just "127.0.0.1") Nothing aiNumericHost :: IO [AddressInfo Inet Stream TCP]--- > [AddressInfo {addressInfoFlags = AddressInfoFlags 4, socketAddress = SocketAddressInet { address = 127.0.0.1, port = 0}, canonicalName = Nothing}]-newtype Address- = Address BS.ByteString+-- > [AddressInfo {addressInfoFlags = AddressInfoFlags 4, socketAddress = SocketAddressInet {inetAddress = InetAddress 127.0.0.1, inetPort = InetPort 0}, canonicalName = Nothing}]+newtype InetAddress+ = InetAddress Word32 deriving (Eq) +newtype InetPort = InetPort Word16+ deriving (Eq, Ord, Show, Num)+ -- | @0.0.0.0@-any :: Address-any = Address $ BS.pack [ 0, 0, 0, 0]+inetAny :: InetAddress+inetAny = InetAddress $ 0 -- | @255.255.255.255@-broadcast :: Address-broadcast = Address $ BS.pack [255,255,255,255]+inetBroadcast :: InetAddress+inetBroadcast = InetAddress $ foldl1' (\x y->x*256+y) [255,255,255,255] -- | @255.255.255.255@-none :: Address-none = Address $ BS.pack [255,255,255,255]+inetNone :: InetAddress+inetNone = InetAddress $ foldl1' (\x y->x*256+y) [255,255,255,255] -- | @127.0.0.1@-loopback :: Address-loopback = Address $ BS.pack [127, 0, 0, 1]+inetLoopback :: InetAddress+inetLoopback = InetAddress $ foldl1' (\x y->x*256+y) [127, 0, 0, 1] -- | @224.0.0.0@-unspecificGroup :: Address-unspecificGroup = Address $ BS.pack [224, 0, 0, 0]+inetUnspecificGroup :: InetAddress+inetUnspecificGroup = InetAddress $ foldl1' (\x y->x*256+y) [224, 0, 0, 0] -- | @224.0.0.1@-allHostsGroup :: Address-allHostsGroup = Address $ BS.pack [224, 0, 0, 1]+inetAllHostsGroup :: InetAddress+inetAllHostsGroup = InetAddress $ foldl1' (\x y->x*256+y) [224, 0, 0, 1] -- | @224.0.0.255@-maxLocalGroup :: Address-maxLocalGroup = Address $ BS.pack [224, 0, 0,255]+inetMaxLocalGroup :: InetAddress+inetMaxLocalGroup = InetAddress $ foldl1' (\x y->x*256+y) [224, 0, 0,255] -instance Show Address where- show (Address a) =- concat $ intersperse "." $ map show $ BS.unpack a+instance Show InetAddress where+ show (InetAddress a) = ("InetAddress " ++)+ $ concat+ $ intersperse "."+ $ map (\p-> show $ a `div` 256^p `mod` 256) [3,2,1,0 :: Word32] -instance Storable Address where+instance Storable InetPort where+ sizeOf _ = (#size uint16_t)+ alignment _ = (#alignment uint16_t)+ peek ptr = do+ p0 <- peekByteOff ptr 0 :: IO Word8+ p1 <- peekByteOff ptr 1 :: IO Word8+ return $ InetPort (fromIntegral p0 * 256 + fromIntegral p1)+ poke ptr (InetPort w16) = do+ pokeByteOff ptr 0 (w16_0 w16)+ pokeByteOff ptr 1 (w16_1 w16)+ where+ w16_0, w16_1 :: Word16 -> Word8+ w16_0 x = fromIntegral $ rem (quot x 256) 256+ w16_1 x = fromIntegral $ rem x 256++instance Storable InetAddress where sizeOf _ = (#size uint32_t) alignment _ = (#alignment uint32_t)- peek ptr =- Address <$> BS.packCStringLen (castPtr ptr, 4)- poke ptr (Address a) =- BS.unsafeUseAsCString a $ \aPtr-> do- copyBytes ptr (castPtr aPtr) (min 4 $ BS.length a)+ peek ptr = do+ i0 <- peekByteOff ptr 0 :: IO Word8+ i1 <- peekByteOff ptr 1 :: IO Word8+ i2 <- peekByteOff ptr 2 :: IO Word8+ i3 <- peekByteOff ptr 3 :: IO Word8+ return $ InetAddress $ (((((f i0 * 256) + f i1) * 256) + f i2) * 256) + f i3+ where+ f = fromIntegral+ poke ptr (InetAddress a) = do+ pokeByteOff ptr 0 (fromIntegral $ rem (quot a $ 256*256*256) 256 :: Word8)+ pokeByteOff ptr 1 (fromIntegral $ rem (quot a $ 256*256) 256 :: Word8)+ pokeByteOff ptr 2 (fromIntegral $ rem (quot a $ 256) 256 :: Word8)+ pokeByteOff ptr 3 (fromIntegral $ rem a $ 256 :: Word8) -instance Storable SocketAddressInet where+instance Storable (SocketAddress Inet) where sizeOf _ = (#size struct sockaddr_in) alignment _ = (#alignment struct sockaddr_in) peek ptr = do- ph <- peekByteOff (sin_port ptr) 0 :: IO Word8- pl <- peekByteOff (sin_port ptr) 1 :: IO Word8- a <- peek (sin_addr ptr) :: IO Address- return (SocketAddressInet a (Port $ fromIntegral ph * 256 + fromIntegral pl))+ a <- peek (sin_addr ptr)+ p <- peek (sin_port ptr)+ return $ SocketAddressInet a p where- sin_port = (#ptr struct sockaddr_in, sin_port) sin_addr = (#ptr struct in_addr, s_addr) . (#ptr struct sockaddr_in, sin_addr)- poke ptr (SocketAddressInet a (Port p)) = do+ sin_port = (#ptr struct sockaddr_in, sin_port)+ poke ptr (SocketAddressInet a p) = do c_memset ptr 0 (#const sizeof(struct sockaddr_in)) poke (sin_family ptr) ((#const AF_INET) :: Word16)- pokeByteOff (sin_port ptr) 0 (fromIntegral $ rem (quot p 256) 256 :: Word8)- pokeByteOff (sin_port ptr) 1 (fromIntegral $ rem p 256 :: Word8) poke (sin_addr ptr) a+ poke (sin_port ptr) p where sin_family = (#ptr struct sockaddr_in, sin_family)- sin_port = (#ptr struct sockaddr_in, sin_port) sin_addr = (#ptr struct in_addr, s_addr) . (#ptr struct sockaddr_in, sin_addr)+ sin_port = (#ptr struct sockaddr_in, sin_port)
src/System/Socket/Family/Inet6.hsc view
@@ -1,66 +1,70 @@-{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving #-}+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Family.Inet6- ( Inet6- -- * Addresses- , SocketAddressInet6 (..)- , Address ()- , Port (..)- , FlowInfo (..)- , ScopeId (..)- -- ** Special Address Constants- -- *** any- , System.Socket.Family.Inet6.any- -- *** loopback- , loopback+ ( -- * Inet6+ Inet6+ -- ** Inet6Address+ , Inet6Address+ -- ** Inet6Port+ , Inet6Port+ -- ** Inet6FlowInfo+ , Inet6FlowInfo+ -- ** Inet6ScopeId+ , Inet6ScopeId+ -- ** SocketAddress Inet6+ , SocketAddress (SocketAddressInet6, inet6Address, inet6Port,+ inet6FlowInfo, inet6ScopeId)+ -- * Special Addresses+ -- ** inet6Any+ , inet6Any+ -- ** inet6Loopback+ , inet6Loopback -- * Socket Options -- ** V6Only , V6Only (..) ) where -import Data.Bits-import Data.Monoid import Data.Word-import qualified Data.ByteString as BS-import qualified Data.ByteString.Unsafe as BS--import Control.Applicative+import Control.Applicative as A import Foreign.Ptr import Foreign.C.Types import Foreign.Storable-import Foreign.Marshal.Utils -import System.Socket.Family import System.Socket.Internal.Socket import System.Socket.Internal.Platform #include "hs_socket.h" #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +-- | The [Internet Protocol version 4](https://en.wikipedia.org/wiki/IPv4). data Inet6 instance Family Inet6 where- type SocketAddress Inet6 = SocketAddressInet6 familyNumber _ = (#const AF_INET6) --- | Example:+-- | An [IPv6](https://en.wikipedia.org/wiki/IPv6) socket address. ----- > SocketAddressInet6 loopback 8080 mempty 0-data SocketAddressInet6+-- The socket address contains a port number that may be used by transport+-- protocols like [TCP](https://en.wikipedia.org/wiki/Transmission_Control_Protocol).+--+-- > SocketAddressInet6 inet6Loopback 8080 0 0+data instance SocketAddress Inet6 = SocketAddressInet6- { address :: Address- , port :: Port- , flowInfo :: FlowInfo- , scopeId :: ScopeId+ { inet6Address :: Inet6Address+ , inet6Port :: Inet6Port+ , inet6FlowInfo :: Inet6FlowInfo+ , inet6ScopeId :: Inet6ScopeId } deriving (Eq, Show) -newtype Port- = Port Word16- deriving (Eq, Ord, Num)--instance Show Port where- show (Port p) = show p- -- | To avoid errors with endianess it was decided to keep this type abstract. -- -- Hint: Use the `Foreign.Storable.Storable` instance if you really need to access. It exposes it@@ -72,99 +76,210 @@ -- -- > > getAddressInfo (Just "::1") Nothing aiNumericHost :: IO [AddressInfo SocketAddressInet6 Stream TCP] -- > [AddressInfo {--- > addressInfoFlags = AddressInfoFlags 4, --- > socketAddress = SocketAddressInet6 {address = 0000:0000:0000:0000:0000:0000:0000:0001, port = 0, flowInfo = mempty, scopeId = 0},+-- > addressInfoFlags = AddressInfoFlags 4,+-- > socketAddress = SocketAddressInet6 {inet6Address = Inet6Address 0000:0000:0000:0000:0000:0000:0000:0001, inet6Port = Inet6Port 0, inet6FlowInfo = Inet6FlowInfo 0, inet6ScopeId = Inet6ScopeId 0}, -- > canonicalName = Nothing }]-newtype Address- = Address BS.ByteString+data Inet6Address = Inet6Address {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Eq) -newtype FlowInfo- = FlowInfo Word32- deriving (Eq, Ord, Bits)--instance Show FlowInfo where- show (FlowInfo i) = show i--instance Monoid FlowInfo where- mempty = FlowInfo 0- mappend = (.|.)+newtype Inet6Port = Inet6Port Word16+ deriving (Eq, Ord, Show, Num) -newtype ScopeId- = ScopeId Word32- deriving (Eq, Ord, Num)+newtype Inet6FlowInfo = Inet6FlowInfo Word32+ deriving (Eq, Ord, Show, Num) -instance Show ScopeId where- show (ScopeId i) = show i+newtype Inet6ScopeId = Inet6ScopeId Word32+ deriving (Eq, Ord, Show, Num) -- | @::@-any :: Address-any = Address (BS.pack [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0])+inet6Any :: Inet6Address+inet6Any = Inet6Address 0 0 -- | @::1@-loopback :: Address-loopback = Address (BS.pack [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,1])+inet6Loopback :: Inet6Address+inet6Loopback = Inet6Address 0 1 -instance Show Address where- show (Address addr) = tail $ t $ BS.unpack addr+instance Show Inet6Address where+ show (Inet6Address high low) = "Inet6Address " +++ [ hex $ hn $ w64_0 high+ , hex $ ln $ w64_0 high+ , hex $ hn $ w64_1 high+ , hex $ ln $ w64_1 high+ , ':'+ , hex $ hn $ w64_2 high+ , hex $ ln $ w64_2 high+ , hex $ hn $ w64_3 high+ , hex $ ln $ w64_3 high+ , ':'+ , hex $ hn $ w64_4 high+ , hex $ ln $ w64_4 high+ , hex $ hn $ w64_5 high+ , hex $ ln $ w64_5 high+ , ':'+ , hex $ hn $ w64_6 high+ , hex $ ln $ w64_6 high+ , hex $ hn $ w64_7 high+ , hex $ ln $ w64_7 high+ , ':'+ , hex $ hn $ w64_0 low+ , hex $ ln $ w64_0 low+ , hex $ hn $ w64_1 low+ , hex $ ln $ w64_1 low+ , ':'+ , hex $ hn $ w64_2 low+ , hex $ ln $ w64_2 low+ , hex $ hn $ w64_3 low+ , hex $ ln $ w64_3 low+ , ':'+ , hex $ hn $ w64_4 low+ , hex $ ln $ w64_4 low+ , hex $ hn $ w64_5 low+ , hex $ ln $ w64_5 low+ , ':'+ , hex $ hn $ w64_6 low+ , hex $ ln $ w64_6 low+ , hex $ hn $ w64_7 low+ , hex $ ln $ w64_7 low+ ] where- t [] = []- t [x] = g x 0 []- t (x:y:xs) = g x y (t xs)- g x y s = let (a,b) = quotRem x 16- (c,d) = quotRem y 16- in ':':(h a):(h b):(h c):(h d):s- h :: Word8 -> Char- h 0 = '0'- h 1 = '1'- h 2 = '2'- h 3 = '3'- h 4 = '4'- h 5 = '5'- h 6 = '6'- h 7 = '7'- h 8 = '8'- h 9 = '9'- h 10 = 'a'- h 11 = 'b'- h 12 = 'c'- h 13 = 'd'- h 14 = 'e'- h 15 = 'f'- h _ = '_'+ hn, ln :: Word8 -> Word8+ hn x = div x 16+ ln x = mod x 16+ hex :: Word8 -> Char+ hex 0 = '0'+ hex 1 = '1'+ hex 2 = '2'+ hex 3 = '3'+ hex 4 = '4'+ hex 5 = '5'+ hex 6 = '6'+ hex 7 = '7'+ hex 8 = '8'+ hex 9 = '9'+ hex 10 = 'a'+ hex 11 = 'b'+ hex 12 = 'c'+ hex 13 = 'd'+ hex 14 = 'e'+ hex 15 = 'f'+ hex _ = '_' -instance Storable Address where+instance Storable Inet6Address where sizeOf _ = 16 alignment _ = 16- peek ptr =- Address <$> BS.packCStringLen (castPtr ptr, 16)- poke ptr (Address a) =- BS.unsafeUseAsCString a $ \aPtr-> do- copyBytes ptr (castPtr aPtr) (min 16 $ BS.length a)+ peek ptr = do+ h0 <- peekByteOff ptr 0 :: IO Word8+ h1 <- peekByteOff ptr 1 :: IO Word8+ h2 <- peekByteOff ptr 2 :: IO Word8+ h3 <- peekByteOff ptr 3 :: IO Word8+ h4 <- peekByteOff ptr 4 :: IO Word8+ h5 <- peekByteOff ptr 5 :: IO Word8+ h6 <- peekByteOff ptr 6 :: IO Word8+ h7 <- peekByteOff ptr 7 :: IO Word8+ l0 <- peekByteOff ptr 8 :: IO Word8+ l1 <- peekByteOff ptr 9 :: IO Word8+ l2 <- peekByteOff ptr 10 :: IO Word8+ l3 <- peekByteOff ptr 11 :: IO Word8+ l4 <- peekByteOff ptr 12 :: IO Word8+ l5 <- peekByteOff ptr 13 :: IO Word8+ l6 <- peekByteOff ptr 14 :: IO Word8+ l7 <- peekByteOff ptr 15 :: IO Word8+ return $ Inet6Address (((((((((((((( fromIntegral h0+ * 256) + fromIntegral h1 )+ * 256) + fromIntegral h2 )+ * 256) + fromIntegral h3 )+ * 256) + fromIntegral h4 )+ * 256) + fromIntegral h5 )+ * 256) + fromIntegral h6 )+ * 256) + fromIntegral h7 )+ (((((((((((((( fromIntegral l0+ * 256) + fromIntegral l1 )+ * 256) + fromIntegral l2 )+ * 256) + fromIntegral l3 )+ * 256) + fromIntegral l4 )+ * 256) + fromIntegral l5 )+ * 256) + fromIntegral l6 )+ * 256) + fromIntegral l7 )+ poke ptr (Inet6Address high low) = do+ pokeByteOff ptr 0 (w64_0 high)+ pokeByteOff ptr 1 (w64_1 high)+ pokeByteOff ptr 2 (w64_2 high)+ pokeByteOff ptr 3 (w64_3 high)+ pokeByteOff ptr 4 (w64_4 high)+ pokeByteOff ptr 5 (w64_5 high)+ pokeByteOff ptr 6 (w64_6 high)+ pokeByteOff ptr 7 (w64_7 high)+ pokeByteOff ptr 8 (w64_0 low)+ pokeByteOff ptr 9 (w64_1 low)+ pokeByteOff ptr 10 (w64_2 low)+ pokeByteOff ptr 11 (w64_3 low)+ pokeByteOff ptr 12 (w64_4 low)+ pokeByteOff ptr 13 (w64_5 low)+ pokeByteOff ptr 14 (w64_6 low)+ pokeByteOff ptr 15 (w64_7 low) -instance Storable SocketAddressInet6 where+instance Storable Inet6Port where+ sizeOf _ = (#size uint16_t)+ alignment _ = (#alignment uint16_t)+ peek ptr = do+ p0 <- peekByteOff ptr 0 :: IO Word8+ p1 <- peekByteOff ptr 1 :: IO Word8+ return $ Inet6Port (fromIntegral p0 * 256 + fromIntegral p1)+ poke ptr (Inet6Port w16) = do+ pokeByteOff ptr 0 (w16_0 w16)+ pokeByteOff ptr 1 (w16_1 w16)++instance Storable Inet6FlowInfo where+ sizeOf _ = (#size uint32_t)+ alignment _ = (#alignment uint32_t)+ peek ptr = do+ p0 <- peekByteOff ptr 0 :: IO Word8+ p1 <- peekByteOff ptr 1 :: IO Word8+ p2 <- peekByteOff ptr 2 :: IO Word8+ p3 <- peekByteOff ptr 3 :: IO Word8+ return $ Inet6FlowInfo $ ((((( fromIntegral p0 * 256) + fromIntegral p1) * 256)+ + fromIntegral p2) * 256) + fromIntegral p3+ poke ptr (Inet6FlowInfo w32) = do+ pokeByteOff ptr 0 (w32_0 w32)+ pokeByteOff ptr 1 (w32_1 w32)+ pokeByteOff ptr 2 (w32_2 w32)+ pokeByteOff ptr 3 (w32_3 w32)++instance Storable Inet6ScopeId where+ sizeOf _ = (#size uint32_t)+ alignment _ = (#alignment uint32_t)+ peek ptr = do+ p0 <- peekByteOff ptr 0 :: IO Word8+ p1 <- peekByteOff ptr 1 :: IO Word8+ p2 <- peekByteOff ptr 2 :: IO Word8+ p3 <- peekByteOff ptr 3 :: IO Word8+ return $ Inet6ScopeId $ ((((( fromIntegral p0 * 256) + fromIntegral p1) * 256)+ + fromIntegral p2) * 256) + fromIntegral p3+ poke ptr (Inet6ScopeId w32) = do+ pokeByteOff ptr 0 (w32_0 w32)+ pokeByteOff ptr 1 (w32_1 w32)+ pokeByteOff ptr 2 (w32_2 w32)+ pokeByteOff ptr 3 (w32_3 w32)++instance Storable (SocketAddress Inet6) where sizeOf _ = (#size struct sockaddr_in6) alignment _ = (#alignment struct sockaddr_in6)- peek ptr = do- f <- peek (sin6_flowinfo ptr) :: IO Word32- ph <- peekByteOff (sin6_port ptr) 0 :: IO Word8- pl <- peekByteOff (sin6_port ptr) 1 :: IO Word8- a <- peek (sin6_addr ptr) :: IO Address- s <- peek (sin6_scope_id ptr) :: IO Word32- return (SocketAddressInet6 a (Port $ fromIntegral ph * 256 + fromIntegral pl) (FlowInfo f) (ScopeId s))+ peek ptr = SocketAddressInet6 A.<$> peek (sin6_addr ptr)+ <*> peek (sin6_port ptr)+ <*> peek (sin6_flowinfo ptr)+ <*> peek (sin6_scope_id ptr) where sin6_flowinfo = (#ptr struct sockaddr_in6, sin6_flowinfo) sin6_scope_id = (#ptr struct sockaddr_in6, sin6_scope_id) sin6_port = (#ptr struct sockaddr_in6, sin6_port) sin6_addr = (#ptr struct in6_addr, s6_addr) . (#ptr struct sockaddr_in6, sin6_addr)- poke ptr (SocketAddressInet6 a (Port p) (FlowInfo f) (ScopeId s)) = do+ poke ptr (SocketAddressInet6 a p f s) = do c_memset ptr 0 (#const sizeof(struct sockaddr_in6))- poke (sin6_family ptr) ((#const AF_INET6) :: Word16)- poke (sin6_flowinfo ptr) f- poke (sin6_scope_id ptr) s- pokeByteOff (sin6_port ptr) 0 (fromIntegral $ rem (quot p 256) 256 :: Word8)- pokeByteOff (sin6_port ptr) 1 (fromIntegral $ rem p 256 :: Word8)- poke (sin6_addr ptr) a+ poke (sin6_family ptr) ((#const AF_INET6) :: Word16)+ poke (sin6_addr ptr) a+ poke (sin6_port ptr) p+ poke (sin6_flowinfo ptr) f+ poke (sin6_scope_id ptr) s where sin6_family = (#ptr struct sockaddr_in6, sin6_family) sin6_flowinfo = (#ptr struct sockaddr_in6, sin6_flowinfo)@@ -181,10 +296,28 @@ = V6Only Bool deriving (Eq, Ord, Show) -instance GetSocketOption V6Only where+instance SocketOption V6Only where getSocketOption s = V6Only . ((/=0) :: CInt -> Bool) <$> unsafeGetSocketOption s (#const IPPROTO_IPV6) (#const IPV6_V6ONLY)--instance SetSocketOption V6Only where setSocketOption s (V6Only o) = unsafeSetSocketOption s (#const IPPROTO_IPV6) (#const IPV6_V6ONLY) (if o then 1 else 0 :: CInt)++w64_0, w64_1, w64_2, w64_3, w64_4, w64_5, w64_6, w64_7 :: Word64 -> Word8+w64_0 x = fromIntegral $ rem (quot x $ 256*256*256*256*256*256*256) 256+w64_1 x = fromIntegral $ rem (quot x $ 256*256*256*256*256*256) 256+w64_2 x = fromIntegral $ rem (quot x $ 256*256*256*256*256) 256+w64_3 x = fromIntegral $ rem (quot x $ 256*256*256*256) 256+w64_4 x = fromIntegral $ rem (quot x $ 256*256*256) 256+w64_5 x = fromIntegral $ rem (quot x $ 256*256) 256+w64_6 x = fromIntegral $ rem (quot x $ 256) 256+w64_7 x = fromIntegral $ rem x 256++w32_0, w32_1, w32_2, w32_3 :: Word32 -> Word8+w32_0 x = fromIntegral $ rem (quot x $ 256*256*256) 256+w32_1 x = fromIntegral $ rem (quot x $ 256*256) 256+w32_2 x = fromIntegral $ rem (quot x $ 256) 256+w32_3 x = fromIntegral $ rem x 256++w16_0, w16_1 :: Word16 -> Word8+w16_0 x = fromIntegral $ rem (quot x $ 256) 256+w16_1 x = fromIntegral $ rem x 256
src/System/Socket/Internal/AddressInfo.hsc view
@@ -1,12 +1,20 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables,- StandaloneDeriving, FlexibleContexts, TypeFamilies,- GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, StandaloneDeriving,+ FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving #-}+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Internal.AddressInfo ( AddressInfo (..)- , GetAddressInfo (..)- , GetNameInfo (..)+ , HasAddressInfo (..)+ , NameInfo (..)+ , HasNameInfo (..) , AddressInfoException (..)- --, gaiStrerror , eaiAgain , eaiBadFlags , eaiFail@@ -35,8 +43,8 @@ import Control.Exception import Control.Monad -import Data.Bits import Data.Monoid+import Data.Bits import Data.Typeable import qualified Data.ByteString as BS @@ -48,11 +56,9 @@ import System.IO.Unsafe -import System.Socket.Family import System.Socket.Family.Inet import System.Socket.Family.Inet6-import System.Socket.Type-import System.Socket.Protocol+import System.Socket.Internal.Socket import System.Socket.Internal.Platform #include "hs_socket.h"@@ -130,7 +136,6 @@ eaiSystem :: AddressInfoException eaiSystem = AddressInfoException (#const EAI_SYSTEM) - -- | Use the `Data.Monoid.Monoid` instance to combine several flags: -- -- > mconcat [aiAddressConfig, aiV4Mapped]@@ -138,7 +143,7 @@ = AddressInfoFlags CInt deriving (Eq, Show, Bits) -instance Monoid AddressInfoFlags where+instance Data.Monoid.Monoid AddressInfoFlags where mempty = AddressInfoFlags 0 mappend (AddressInfoFlags a) (AddressInfoFlags b)@@ -151,29 +156,29 @@ -- | @AI_ALL@: Return both IPv4 (as mapped `SocketAddressInet6`) and IPv6 addresses when -- `aiV4Mapped` is set independent of whether IPv6 addresses exist for this -- name.-aiAll :: AddressInfoFlags-aiAll = AddressInfoFlags (#const AI_ALL)+aiAll :: AddressInfoFlags+aiAll = AddressInfoFlags (#const AI_ALL) -- | @AI_CANONNAME@: aiCanonicalName :: AddressInfoFlags aiCanonicalName = AddressInfoFlags (#const AI_CANONNAME) -- | @AI_NUMERICHOST@:-aiNumericHost :: AddressInfoFlags-aiNumericHost = AddressInfoFlags (#const AI_NUMERICHOST)+aiNumericHost :: AddressInfoFlags+aiNumericHost = AddressInfoFlags (#const AI_NUMERICHOST) -- | @AI_NUMERICSERV@:-aiNumericService :: AddressInfoFlags-aiNumericService = AddressInfoFlags (#const AI_NUMERICSERV)+aiNumericService :: AddressInfoFlags+aiNumericService = AddressInfoFlags (#const AI_NUMERICSERV) -- | @AI_PASSIVE@:-aiPassive :: AddressInfoFlags-aiPassive = AddressInfoFlags (#const AI_PASSIVE)+aiPassive :: AddressInfoFlags+aiPassive = AddressInfoFlags (#const AI_PASSIVE) -- | @AI_V4MAPPED@: Return mapped IPv4 addresses if no IPv6 addresses could be found -- or if `aiAll` flag is set.-aiV4Mapped :: AddressInfoFlags-aiV4Mapped = AddressInfoFlags (#const AI_V4MAPPED)+aiV4Mapped :: AddressInfoFlags+aiV4Mapped = AddressInfoFlags (#const AI_V4MAPPED) -- | Use the `Data.Monoid.Monoid` instance to combine several flags: --@@ -189,26 +194,26 @@ = NameInfoFlags (a .|. b) -- | @NI_NAMEREQD@: Throw an exception if the hostname cannot be determined.-niNameRequired :: NameInfoFlags-niNameRequired = NameInfoFlags (#const NI_NAMEREQD)+niNameRequired :: NameInfoFlags+niNameRequired = NameInfoFlags (#const NI_NAMEREQD) -- | @NI_DGRAM@: Service is datagram based (i.e. `System.Socket.Protocol.UDP.UDP`) rather than stream based (i.e. `System.Socket.Protocol.TCP.TCP`).-niDatagram :: NameInfoFlags-niDatagram = NameInfoFlags (#const NI_DGRAM)+niDatagram :: NameInfoFlags+niDatagram = NameInfoFlags (#const NI_DGRAM) -- | @NI_NOFQDN@: Return only the hostname part of the fully qualified domain name for local hosts.-niNoFullyQualifiedDomainName :: NameInfoFlags-niNoFullyQualifiedDomainName = NameInfoFlags (#const NI_NOFQDN)+niNoFullyQualifiedDomainName :: NameInfoFlags+niNoFullyQualifiedDomainName = NameInfoFlags (#const NI_NOFQDN) -- | @NI_NUMERICHOST@: Return the numeric form of the host address.-niNumericHost :: NameInfoFlags-niNumericHost = NameInfoFlags (#const NI_NUMERICHOST)+niNumericHost :: NameInfoFlags+niNumericHost = NameInfoFlags (#const NI_NUMERICHOST) -- | @NI_NUMERICSERV@: Return the numeric form of the service address.-niNumericService :: NameInfoFlags-niNumericService = NameInfoFlags (#const NI_NUMERICSERV)+niNumericService :: NameInfoFlags+niNumericService = NameInfoFlags (#const NI_NUMERICSERV) -class (Family f) => GetAddressInfo f where+class (Family f) => HasAddressInfo f where -- | Maps names to addresses (i.e. by DNS lookup). -- -- The operation throws `AddressInfoException`s.@@ -222,27 +227,31 @@ -- queries. If you want to connect to both IPv4 and IPV6 addresses use -- `aiV4Mapped` and use IPv6-sockets. --+-- > getAddressInfo (Just "www.haskell.org") (Just "https") mempty :: IO [AddressInfo Inet Stream TCP]+-- > > [AddressInfo {addressInfoFlags = AddressInfoFlags 0, socketAddress = SocketAddressInet {inetAddress = InetAddress 162.242.239.16, inetPort = InetPort 443}, canonicalName = Nothing}]+-- -- > > getAddressInfo (Just "www.haskell.org") (Just "80") aiV4Mapped :: IO [AddressInfo Inet6 Stream TCP] -- > [AddressInfo { -- > addressInfoFlags = AddressInfoFlags 8,--- > socketAddress = SocketAddressInet6 {address = 2400:cb00:2048:0001:0000:0000:6ca2:cc3c, port = 80, flowInfo = mempty, scopeId = 0},+-- > socketAddress = SocketAddressInet6 {inet6Address = Inet6Address 2400:cb00:2048:0001:0000:0000:6ca2:cc3c, inet6Port = Inet6Port 80, inet6FlowInfo = Inet6FlowInfo 0, inet6ScopeId = Inet6ScopeId 0}, -- > canonicalName = Nothing }]+-- -- > > getAddressInfo (Just "darcs.haskell.org") Nothing aiV4Mapped :: IO [AddressInfo Inet6 Stream TCP] -- > [AddressInfo {--- > addressInfoFlags = AddressInfoFlags 8, --- > socketAddress = SocketAddressInet6 {address = 0000:0000:0000:0000:0000:ffff:17fd:e1ad, port = 0, flowInfo = mempty, scopeId = 0},+-- > addressInfoFlags = AddressInfoFlags 8,+-- > socketAddress = SocketAddressInet6 {inet6Address = Inet6Address 0000:0000:0000:0000:0000:ffff:17fd:e1ad, inet6Port = Inet6Port 0, inet6FlowInfo = Inet6FlowInfo 0, inet6ScopeId = Inet6ScopeId 0}, -- > canonicalName = Nothing }] -- > > getAddressInfo (Just "darcs.haskell.org") Nothing mempty :: IO [AddressInfo Inet6 Stream TCP] -- > *** Exception: AddressInfoException "Name or service not known" getAddressInfo :: (Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddressInfoFlags -> IO [AddressInfo f t p] -instance GetAddressInfo Inet where+instance HasAddressInfo Inet where getAddressInfo = getAddressInfo' -instance GetAddressInfo Inet6 where+instance HasAddressInfo Inet6 where getAddressInfo = getAddressInfo' -getAddressInfo' :: forall f t p. (Family f, Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddressInfoFlags -> IO [AddressInfo f t p]+getAddressInfo' :: forall f t p. (Family f, Storable (SocketAddress f), Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddressInfoFlags -> IO [AddressInfo f t p] getAddressInfo' mnode mservice (AddressInfoFlags flags) = do alloca $ \resultPtrPtr-> do poke resultPtrPtr nullPtr@@ -280,7 +289,7 @@ fservice = case mservice of Just service -> BS.useAsCString service Nothing -> \f-> f nullPtr- peekAddressInfos ptr = + peekAddressInfos ptr = if ptr == nullPtr then return [] else do@@ -293,22 +302,29 @@ as <- peek (ai_next ptr) >>= peekAddressInfos return ((AddressInfo (AddressInfoFlags flag) addr cname):as) --- | Maps addresss to readable host- and service names.+-- | A `NameInfo` consists of host and service name.+data NameInfo+ = NameInfo+ { hostName :: BS.ByteString+ , serviceName :: BS.ByteString+ } deriving (Eq, Show)++-- | Maps addresses to readable host- and service names. -- -- The operation throws `AddressInfoException`s. ----- > > getNameInfo (SocketAddressInet loopback 80) mempty--- > ("localhost.localdomain","http")-class (Family f) => GetNameInfo f where- getNameInfo :: SocketAddress f -> NameInfoFlags -> IO (BS.ByteString, BS.ByteString)+-- > > getNameInfo (SocketAddressInet inetLoopback 80) mempty+-- > NameInfo {hostName = "localhost.localdomain", serviceName = "http"}+class (Family f) => HasNameInfo f where+ getNameInfo :: SocketAddress f -> NameInfoFlags -> IO NameInfo -instance GetNameInfo Inet where+instance HasNameInfo Inet where getNameInfo = getNameInfo' -instance GetNameInfo Inet6 where+instance HasNameInfo Inet6 where getNameInfo = getNameInfo' -getNameInfo' :: Storable a => a -> NameInfoFlags -> IO (BS.ByteString, BS.ByteString)+getNameInfo' :: Storable a => a -> NameInfoFlags -> IO NameInfo getNameInfo' addr (NameInfoFlags flags) = alloca $ \addrPtr-> allocaBytes (#const NI_MAXHOST) $ \hostPtr->@@ -321,6 +337,6 @@ if e == 0 then do host <- BS.packCString hostPtr serv <- BS.packCString servPtr- return (host,serv)+ return $ NameInfo host serv else do throwIO (AddressInfoException e)
src/System/Socket/Internal/Exception.hsc view
@@ -1,4 +1,13 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Internal.Exception where import Control.Exception@@ -15,68 +24,144 @@ instance Show SocketException where show e@(SocketException i)- | e == eOk = "eOk"- | e == eInterrupted = "eInterrupted"- | e == eAgain = "eAgain"- | e == eWouldBlock = "eWouldBlock"- | e == eBadFileDescriptor = "eBadFileDescriptor"- | e == eInProgress = "eInProgress"- | e == eProtocolNotSupported = "eProtocolNotSupported"- | e == eInvalid = "eInvalid"- | e == eConnectionRefused = "eConnectionRefused"- | e == eNetworkUnreachable = "eNetworkUnreachable"- | e == eNotConnected = "eNotConnected"- | e == eAlready = "eAlready"- | e == eIsConnected = "eIsConnected"- | e == eTimedOut = "eTimedOut"- | e == ePipe = "ePipe"- | e == eOperationNotSupported = "eOperationNotSupported"- | otherwise = "SocketException " ++ show i+ | e == eOk = "eOk"+ | e == eInterrupted = "eInterrupted"+ | e == eBadFileDescriptor = "eBadFileDescriptor"+ | e == eInvalid = "eInvalid"+ | e == ePipe = "ePipe"+ | e == eWouldBlock = "eWouldBlock"+ | e == eAgain = "eAgain"+ | e == eNotSocket = "eNotSocket"+ | e == eDestinationAddressRequired = "eDestinationAddressRequired"+ | e == eMessageSize = "eMessageSize"+ | e == eProtocolType = "eProtocolType"+ | e == eNoProtocolOption = "eNoProtocolOption"+ | e == eProtocolNotSupported = "eProtocolNotSupported"+ | e == eSocketTypeNotSupported = "eSocketTypeNotSupported"+ | e == eOperationNotSupported = "eOperationNotSupported"+ | e == eProtocolFamilyNotSupported = "eProtocolFamilyNotSupported"+ | e == eAddressFamilyNotSupported = "eAddressFamilyNotSupported"+ | e == eAddressInUse = "eAddressInUse"+ | e == eAddressNotAvailable = "eAddressNotAvailable"+ | e == eNetworkDown = "eNetworkDown"+ | e == eNetworkUnreachable = "eNetworkUnreachable"+ | e == eNetworkReset = "eNetworkReset"+ | e == eConnectionAborted = "eConnectionAborted"+ | e == eConnectionReset = "eConnectionReset"+ | e == eNoBufferSpace = "eNoBufferSpace"+ | e == eIsConnected = "eIsConnected"+ | e == eNotConnected = "eNotConnected"+ | e == eShutdown = "eShutdown"+ | e == eTooManyReferences = "eTooManyReferences"+ | e == eTimedOut = "eTimedOut"+ | e == eConnectionRefused = "eConnectionRefused"+ | e == eHostDown = "eHostDown"+ | e == eHostUnreachable = "eHostUnreachable"+ | e == eAlready = "eAlready"+ | e == eInProgress = "eInProgress"+ | otherwise = "SocketException " ++ show i -eOk :: SocketException-eOk = SocketException (#const SEOK)+eOk :: SocketException+eOk = SocketException (#const SEOK) -eInterrupted :: SocketException-eInterrupted = SocketException (#const SEINTR)+eInterrupted :: SocketException+eInterrupted = SocketException (#const SEINTR) -eAgain :: SocketException-eAgain = SocketException (#const SEAGAIN)+eBadFileDescriptor :: SocketException+eBadFileDescriptor = SocketException (#const SEBADF) -eWouldBlock :: SocketException-eWouldBlock = SocketException (#const SEWOULDBLOCK)+eInvalid :: SocketException+eInvalid = SocketException (#const SEINVAL) -eBadFileDescriptor :: SocketException-eBadFileDescriptor = SocketException (#const SEBADF)+ePipe :: SocketException+ePipe = SocketException (#const SEPIPE) -eInProgress :: SocketException-eInProgress = SocketException (#const SEINPROGRESS)+eWouldBlock :: SocketException+eWouldBlock = SocketException (#const SEWOULDBLOCK) -eProtocolNotSupported :: SocketException-eProtocolNotSupported = SocketException (#const SEPROTONOSUPPORT)+eAgain :: SocketException+eAgain = SocketException (#const SEAGAIN) -eInvalid :: SocketException-eInvalid = SocketException (#const SEINVAL)+eNotSocket :: SocketException+eNotSocket = SocketException (#const SENOTSOCK) -eConnectionRefused :: SocketException-eConnectionRefused = SocketException (#const SECONNREFUSED)+eDestinationAddressRequired :: SocketException+eDestinationAddressRequired = SocketException (#const SEDESTADDRREQ) -eNetworkUnreachable :: SocketException-eNetworkUnreachable = SocketException (#const SENETUNREACH)+eMessageSize :: SocketException+eMessageSize = SocketException (#const SEMSGSIZE) -eNotConnected :: SocketException-eNotConnected = SocketException (#const SENOTCONN)+eProtocolType :: SocketException+eProtocolType = SocketException (#const SEPROTOTYPE) -eAlready :: SocketException-eAlready = SocketException (#const SEALREADY)+eNoProtocolOption :: SocketException+eNoProtocolOption = SocketException (#const SENOPROTOOPT) -eIsConnected :: SocketException-eIsConnected = SocketException (#const SEISCONN)+eProtocolNotSupported :: SocketException+eProtocolNotSupported = SocketException (#const SEPROTONOSUPPORT) -eTimedOut :: SocketException-eTimedOut = SocketException (#const SETIMEDOUT)+eSocketTypeNotSupported :: SocketException+eSocketTypeNotSupported = SocketException (#const SESOCKTNOSUPPORT) -ePipe :: SocketException-ePipe = SocketException (#const SEPIPE)+eOperationNotSupported :: SocketException+eOperationNotSupported = SocketException (#const SEOPNOTSUPP) -eOperationNotSupported :: SocketException-eOperationNotSupported = SocketException (#const SEOPNOTSUPP)+eProtocolFamilyNotSupported :: SocketException+eProtocolFamilyNotSupported = SocketException (#const SEPFNOSUPPORT)++eAddressFamilyNotSupported :: SocketException+eAddressFamilyNotSupported = SocketException (#const SEAFNOSUPPORT)++eAddressInUse :: SocketException+eAddressInUse = SocketException (#const SEADDRINUSE)++eAddressNotAvailable :: SocketException+eAddressNotAvailable = SocketException (#const SEADDRNOTAVAIL)++eNetworkDown :: SocketException+eNetworkDown = SocketException (#const SENETDOWN)++eNetworkUnreachable :: SocketException+eNetworkUnreachable = SocketException (#const SENETUNREACH)++eNetworkReset :: SocketException+eNetworkReset = SocketException (#const SENETRESET)++eConnectionAborted :: SocketException+eConnectionAborted = SocketException (#const SECONNABORTED)++eConnectionReset :: SocketException+eConnectionReset = SocketException (#const SECONNRESET)++eNoBufferSpace :: SocketException+eNoBufferSpace = SocketException (#const SENOBUFS)++eIsConnected :: SocketException+eIsConnected = SocketException (#const SEISCONN)++eNotConnected :: SocketException+eNotConnected = SocketException (#const SENOTCONN)++eShutdown :: SocketException+eShutdown = SocketException (#const SESHUTDOWN)++eTooManyReferences :: SocketException+eTooManyReferences = SocketException (#const SETOOMANYREFS)++eTimedOut :: SocketException+eTimedOut = SocketException (#const SETIMEDOUT)++eConnectionRefused :: SocketException+eConnectionRefused = SocketException (#const SECONNREFUSED)++eHostDown :: SocketException+eHostDown = SocketException (#const SEHOSTDOWN)++eHostUnreachable :: SocketException+eHostUnreachable = SocketException (#const SEHOSTUNREACH)++eAlready :: SocketException+eAlready = SocketException (#const SEALREADY)++eInProgress :: SocketException+eInProgress = SocketException (#const SEINPROGRESS)
src/System/Socket/Internal/Message.hsc view
@@ -1,8 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Internal.Message ( MessageFlags (..) , Message- , IoVec , msgEndOfRecord , msgNoSignal , msgOutOfBand@@ -32,8 +40,6 @@ data Message a t p -data IoVec- instance Monoid MessageFlags where mempty = MessageFlags 0 mappend = (.|.)@@ -41,12 +47,12 @@ instance Show MessageFlags where show msg = "mconcat [" ++ y ++ "]" where- x = [ if msg .&. msgEndOfRecord /= mempty then Just "msgEndOfRecord" else Nothing- , if msg .&. msgNoSignal /= mempty then Just "msgNoSignal" else Nothing- , if msg .&. msgOutOfBand /= mempty then Just "msgOutOfBand" else Nothing- , if msg .&. msgWaitAll /= mempty then Just "msgWaitAll" else Nothing- , let (MessageFlags i) = msg `xor` (mconcat [msgEndOfRecord,msgNoSignal,msgOutOfBand,msgWaitAll] .&. msg)- in if i /= 0 then Just ("MessageFlags " ++ show i) else Nothing + x = [ if msg .&. msgEndOfRecord /= mempty then Just "msgEndOfRecord" else Nothing+ , if msg .&. msgNoSignal /= mempty then Just "msgNoSignal" else Nothing+ , if msg .&. msgOutOfBand /= mempty then Just "msgOutOfBand" else Nothing+ , if msg .&. msgWaitAll /= mempty then Just "msgWaitAll" else Nothing+ , let (MessageFlags i) = msg `xor` (Data.Monoid.mconcat [msgEndOfRecord,msgNoSignal,msgOutOfBand,msgWaitAll] .&. msg)+ in if i /= 0 then Just ("MessageFlags " ++ show i) else Nothing ] y = concat $ intersperse "," $ catMaybes x
src/System/Socket/Internal/Socket.hsc view
@@ -1,8 +1,21 @@+{-# LANGUAGE TypeFamilies #-}+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Internal.Socket ( Socket (..)- , GetSocketOption (..)+ , SocketAddress+ , Family (..)+ , Type (..)+ , Protocol (..)+ , SocketOption (..) , unsafeGetSocketOption- , SetSocketOption (..) , unsafeSetSocketOption , Error (..) , ReuseAddress (..)@@ -24,11 +37,12 @@ #include "hs_socket.h" --- | A generic socket type. Also see `socket` for details.+-- | A generic socket type. Use `System.Socket.socket` to create a new socket. -- -- The socket is just an `Control.Concurrent.MVar.MVar`-wrapped file descriptor.--- It is exposed in order to make this library easily extensible, but it is--- usually not necessary nor advised to work directly on the file descriptor.+-- The `System.Socket.Unsafe.Socket` constructor is exported trough the unsafe+-- module in order to make this library easily extensible, but it is usually+-- not necessary nor advised to work directly on the file descriptor. -- If you do, the following rules must be obeyed: -- -- - Make sure not to deadlock. Use `Control.Concurrent.MVar.withMVar` or similar.@@ -41,7 +55,7 @@ -- - The socket is non-blocking and all the code relies on that assumption. -- You need to use GHC's eventing mechanism primitives to block until -- something happens. The former rules forbid to use `GHC.Conc.threadWaitRead` as it--- does not seperate between registering the file descriptor (for which+-- does not separate between registering the file descriptor (for which -- the lock __must__ be held) and the actual waiting (for which you must -- __not__ hold the lock). -- Also see [this](https://mail.haskell.org/pipermail/haskell-cafe/2014-September/115823.html)@@ -49,10 +63,26 @@ newtype Socket f t p = Socket (MVar Fd) -class GetSocketOption o where- getSocketOption :: Socket f t p -> IO o+-- | The `SocketAddress` type is a [data family](https://wiki.haskell.org/GHC/Type_families#Detailed_definition_of_data_families).+-- This allows to provide different data constructors depending on the socket+-- family wihtout knowing all of them in advance or the need to patch this+-- core library.+--+-- > SocketAddressInet inetLoopback 8080 :: SocketAddress Inet+-- > SocketAddressInet6 inet6Loopback 8080 0 0 :: SocketAddress Inet6+data family SocketAddress f -class SetSocketOption o where+class Family f where+ familyNumber :: f -> CInt++class Type t where+ typeNumber :: t -> CInt++class Protocol p where+ protocolNumber :: p -> CInt++class SocketOption o where+ getSocketOption :: Socket f t p -> IO o setSocketOption :: Socket f t p -> o -> IO () -- | @SO_ERROR@@@ -60,20 +90,19 @@ = Error SocketException deriving (Eq, Ord, Show) -instance GetSocketOption Error where+instance SocketOption Error where getSocketOption s =- Error . SocketException <$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_ERROR)+ Error . SocketException Control.Applicative.<$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_ERROR)+ setSocketOption _ _ = throwIO eInvalid -- | @SO_REUSEADDR@ data ReuseAddress = ReuseAddress Bool deriving (Eq, Ord, Show) -instance GetSocketOption ReuseAddress where+instance SocketOption ReuseAddress where getSocketOption s = ReuseAddress . ((/=0) :: CInt -> Bool) <$> unsafeGetSocketOption s (#const SOL_SOCKET) (#const SO_REUSEADDR)--instance SetSocketOption ReuseAddress where setSocketOption s (ReuseAddress o) = unsafeSetSocketOption s (#const SOL_SOCKET) (#const SO_REUSEADDR) (if o then 1 else 0 :: CInt) @@ -86,7 +115,7 @@ withMVar mfd $ \fd-> alloca $ \vPtr-> do poke vPtr value- i <- c_setsockopt fd level name + i <- c_setsockopt fd level name vPtr (fromIntegral $ sizeOf value) when (i < 0) $ do
− src/System/Socket/Protocol.hs
@@ -1,12 +0,0 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}-module System.Socket.Protocol- ( Protocol (..)- ) where--import Foreign.C.Types--class Protocol p where- protocolNumber :: p -> CInt--instance Protocol () where- protocolNumber _ = 0
src/System/Socket/Protocol/TCP.hsc view
@@ -1,6 +1,15 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Protocol.TCP where -import System.Socket.Protocol+import System.Socket.Internal.Socket #include "hs_socket.h"
src/System/Socket/Protocol/UDP.hsc view
@@ -1,6 +1,15 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Protocol.UDP where -import System.Socket.Protocol+import System.Socket.Internal.Socket #include "hs_socket.h"
− src/System/Socket/Type.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}-module System.Socket.Type- ( Type (..)- ) where--import Foreign.C.Types--class Type t where- typeNumber :: t -> CInt
src/System/Socket/Type/Datagram.hsc view
@@ -1,6 +1,15 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Type.Datagram where -import System.Socket.Type+import System.Socket.Internal.Socket #include "hs_socket.h"
src/System/Socket/Type/Raw.hsc view
@@ -1,6 +1,15 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Type.Raw where -import System.Socket.Type+import System.Socket.Internal.Socket #include "hs_socket.h"
src/System/Socket/Type/SequentialPacket.hsc view
@@ -1,6 +1,15 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Type.SequentialPacket where -import System.Socket.Type+import System.Socket.Internal.Socket #include "hs_socket.h"
src/System/Socket/Type/Stream.hsc view
@@ -1,10 +1,77 @@-module System.Socket.Type.Stream where+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+--------------------------------------------------------------------------------+module System.Socket.Type.Stream (+ -- * Stream+ Stream+ -- * Convenience Operations+ -- ** sendAll, receiveAll+ , sendAll+ , receiveAll+ ) where -import System.Socket.Type+import Control.Monad (when)+import Data.Int+import Data.Monoid+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Builder.Extra as BB+import qualified Data.ByteString.Lazy as LBS +import System.Socket+ #include "hs_socket.h" data Stream instance Type Stream where typeNumber _ = (#const SOCK_STREAM)++-------------------------------------------------------------------------------+-- Convenience Operations+-------------------------------------------------------------------------------++-- | 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+ where+ sendAll' bs = do+ sent <- send s bs flags+ when (sent < BS.length bs) $ sendAll' (BS.drop sent bs)++-- | Like `receive`, but operates on lazy `Data.ByteString.Lazy.ByteString`s and+-- continues until either an empty part has been received (peer closed+-- the connection) or given buffer limit has been exceeded or an+-- exception occured.+--+-- - The `Data.Int.Int64` parameter is a soft limit on how many bytes to receive.+-- Collection is stopped if the limit has been exceeded. The result might+-- be up to one internal buffer size longer than the given limit.+-- If the returned `Data.ByteString.Lazy.ByteString`s length is lower or+-- eqal than the limit, the data has not been truncated and the+-- transmission is complete.+receiveAll :: Socket f Stream p -> Int64 -> MessageFlags -> IO LBS.ByteString+receiveAll sock maxLen flags = collect 0 Data.Monoid.mempty+ where+ collect len accum+ | len > maxLen = do+ build accum+ | otherwise = do+ bs <- receive sock BB.smallChunkSize flags+ if BS.null bs then do+ build accum+ else do+ collect (len + fromIntegral (BS.length bs))+ $! (accum `Data.Monoid.mappend` BB.byteString bs)+ build accum = do+ return (BB.toLazyByteString accum)
src/System/Socket/Unsafe.hsc view
@@ -1,11 +1,23 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Socket+-- Copyright : (c) Lars Petersen 2015+-- License : MIT+--+-- Maintainer : info@lars-petersen.net+-- Stability : experimental+-------------------------------------------------------------------------------- module System.Socket.Unsafe (- -- * unsafeSend- unsafeSend- -- * unsafeSendTo+ -- * Socket Constructor+ Socket (..)+ -- * Socket Operations+ -- ** unsafeSend+ , unsafeSend+ -- ** unsafeSendTo , unsafeSendTo- -- * unsafeReceive+ -- ** unsafeReceive , unsafeReceive- -- * unsafeReceiveFrom+ -- ** unsafeReceiveFrom , unsafeReceiveFrom -- * Socket Options -- ** unsafeGetSocketOption@@ -23,7 +35,6 @@ ) where import Data.Function-import Data.Monoid import Control.Monad import Control.Exception@@ -36,7 +47,6 @@ import System.Socket.Internal.Platform import System.Socket.Internal.Exception import System.Socket.Internal.Message-import System.Socket.Family import System.Posix.Types (Fd)
tests/AddrInfo.hs view
@@ -7,26 +7,30 @@ import Control.Exception import System.Socket import System.Socket.Family.Inet as Inet+import System.Socket.Family.Inet6 as Inet6+import System.Socket.Type.Stream+import System.Socket.Protocol.TCP import System.Exit main :: IO () main = do t0001 t0002+ t0003 t0001 :: IO () t0001 = do ais <- getAddressInfo (Just "127.0.0.1")- (Just "80")+ (Just "http") aiNumericHost `onException` p 0 :: IO [AddressInfo Inet Stream TCP] when (length ais /= 1) (e 1) let [ai] = ais when (canonicalName ai /= Nothing) (e 2) let sa = socketAddress ai- when (port sa /= 80) (e 3)- when (address sa /= Inet.loopback) (e 4)+ when (inetPort sa /= 80) (e 3)+ when (inetAddress sa /= inetLoopback) (e 4) where p i = print ("t0001." ++ show i) e i = error ("t0001." ++ show i)@@ -48,8 +52,6 @@ -- AI_V4MAPPEND and AI_ALL. Asking for localhost should -- yield an additional v4-mappend IPV6-Address in the second case, -- but not in the first one.-{---- TODO: Commented out due to issue #12. t0003 :: IO () t0003 = do x <- getAddressInfo@@ -66,4 +68,3 @@ where p i = print ("t0003." ++ show i) e i = error ("t0003." ++ show i)--}
tests/EOPNOTSUPP.hs view
@@ -6,12 +6,12 @@ import Control.Concurrent import Control.Concurrent.Async -import Data.Int-import Data.Monoid import qualified Data.ByteString.Lazy as LBS import System.Socket-import System.Socket.Family.Inet as Inet+import System.Socket.Family.Inet+import System.Socket.Type.Datagram+import System.Socket.Protocol.UDP main :: IO () main = do@@ -31,4 +31,4 @@ else throwIO e `onException` print "E09" ) where- addr = SocketAddressInet Inet.loopback 7777+ addr = SocketAddressInet inetLoopback 7777
tests/EPIPE.hs view
@@ -11,7 +11,9 @@ import qualified Data.ByteString.Lazy as LBS import System.Socket-import System.Socket.Family.Inet as Inet+import System.Socket.Family.Inet+import System.Socket.Type.Stream+import System.Socket.Protocol.TCP main :: IO () main = do@@ -53,4 +55,4 @@ else throwIO e `onException` print "E17" ) where- addr = SocketAddressInet Inet.loopback 7777+ addr = SocketAddressInet inetLoopback 7777
tests/IPV6_V6ONLY.hs view
@@ -8,17 +8,19 @@ import Control.Concurrent import Control.Concurrent.Async import System.Socket-import System.Socket.Family.Inet as Inet-import System.Socket.Family.Inet6 as Inet6+import System.Socket.Family.Inet+import System.Socket.Family.Inet6+import System.Socket.Type.Datagram+import System.Socket.Protocol.UDP import System.Exit main :: IO ()-main = do +main = do t0001 t0002 t0001 :: IO ()-t0001 = +t0001 = bracket ( do server <- socket `onException` p 0 :: IO (Socket Inet6 Datagram UDP)@@ -31,10 +33,10 @@ ) (\(server,client)-> do setSocketOption server (V6Only True) `onException` p 4- bind server (SocketAddressInet6 Inet6.any 7777 mempty 0) `onException` p 5+ bind server (SocketAddressInet6 inet6Any 7777 0 0) `onException` p 5 threadDelay 1000000 -- wait for the listening socket being set up- sendTo client "PING" mempty (SocketAddressInet Inet.loopback 7777)+ sendTo client "PING" mempty (SocketAddressInet inetLoopback 7777) `onException` p 6 eith <- race ( receiveFrom server 4096 mempty `onException` p 7 >> return () )@@ -48,7 +50,7 @@ p i = print ("t0001." ++ show i) t0002 :: IO ()-t0002 = +t0002 = bracket ( do server <- socket `onException` p 0 :: IO (Socket Inet6 Datagram UDP)@@ -61,10 +63,10 @@ ) (\(server,client)-> do setSocketOption server (V6Only False) `onException` p 4- bind server (SocketAddressInet6 Inet6.any 7778 mempty 0) `onException` p 5+ bind server (SocketAddressInet6 inet6Any 7778 0 0) `onException` p 5 threadDelay 1000000 -- wait for the listening socket being set up- sendTo client "PING" mempty (SocketAddressInet Inet.loopback 7778) `onException` p 6+ sendTo client "PING" mempty (SocketAddressInet inetLoopback 7778) `onException` p 6 eith <- race ( receiveFrom server 4096 mempty `onException` p 7 >> return ()) ( threadDelay 1000000 )
tests/NonBlockingIO.hs view
@@ -8,11 +8,13 @@ import Control.Concurrent import Control.Concurrent.Async import System.Socket-import System.Socket.Family.Inet as Inet+import System.Socket.Family.Inet+import System.Socket.Type.Stream+import System.Socket.Protocol.TCP import System.Exit main :: IO ()-main = do +main = do t0001 -- | This is to test interruptability of (blocking) calls like@@ -28,7 +30,7 @@ t0001 = do s <- socket `onException` e 0 :: IO (Socket Inet Stream TCP) setSocketOption s (ReuseAddress True) `onException` e 1- bind s (SocketAddressInet Inet.loopback 8080) `onException` e 2+ bind s (SocketAddressInet inetLoopback 8080) `onException` e 2 listen s 5 `onException` e 3 a <- async (accept s) `onException` e 4 threadDelay 1000000 -- make sure the async call really got enough time to start
tests/PingPong.hs view
@@ -8,11 +8,13 @@ import Control.Concurrent import Control.Concurrent.Async import System.Socket-import System.Socket.Family.Inet as Inet+import System.Socket.Family.Inet+import System.Socket.Type.Stream+import System.Socket.Protocol.TCP import System.Exit main :: IO ()-main = do +main = do t0001 t0001 :: IO ()@@ -24,7 +26,7 @@ listen server 5 `onException` e 4 connect client addr `onException` e 5 (peer,_) <- accept server `onException` e 6- + x <- async (loop client 0) y <- async (loop peer 0) @@ -39,7 +41,7 @@ when (i < 10000) (e 16) where- addr = SocketAddressInet Inet.loopback 8080+ addr = SocketAddressInet inetLoopback 8080 e i = print ("t0001." ++ show i) loop sock index = ( do ping <- receive sock 4096 mempty
tests/TCP-sendAndRecvAll.hs view
@@ -10,7 +10,9 @@ import qualified Data.ByteString.Lazy as LBS import System.Socket-import System.Socket.Family.Inet as Inet+import System.Socket.Family.Inet+import System.Socket.Type.Stream+import System.Socket.Protocol.TCP -- | This tries to send and receive an extremely huge message (currently 128MB). main :: IO ()@@ -42,4 +44,4 @@ where msgSize = 128*1024*1024 + 1 :: Int64 msg = LBS.replicate msgSize 23- addr = SocketAddressInet Inet.loopback 7777+ addr = SocketAddressInet inetLoopback 7777
tests/TCP.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies, FlexibleContexts #-} module Main where import Data.Monoid@@ -6,18 +6,21 @@ import Control.Exception import Control.Concurrent import Control.Concurrent.Async+import Foreign.Storable import System.Socket-import System.Socket.Family.Inet as Inet-import System.Socket.Family.Inet6 as Inet6+import System.Socket.Family.Inet+import System.Socket.Family.Inet6+import System.Socket.Type.Stream+import System.Socket.Protocol.TCP import System.Exit main :: IO ()-main = do +main = do test "test0001.01" $ test0001 (undefined :: Socket Inet Stream TCP) localhost test "test0001.02" $ test0001 (undefined :: Socket Inet6 Stream TCP) localhost6 -- Test send and receive on connection oriented sockets (i.e. TCP).-test0001 :: (Family f, Type t, Protocol p) => Socket f t p -> SocketAddress f -> IO (Either String String)+test0001 :: (Family f, Type t, Protocol p, Storable (SocketAddress f)) => Socket f t p -> SocketAddress f -> IO (Either String String) test0001 dummy addr = bracket ( do server <- socket `asTypeOf` return dummy `onException` print "E01"@@ -47,21 +50,12 @@ where helloWorld = "Hello world!" -localhost :: SocketAddressInet-localhost =- SocketAddressInet- { Inet.port = 7777- , Inet.address = Inet.loopback- }+localhost :: SocketAddress Inet+localhost = SocketAddressInet inetLoopback 7777 -localhost6 :: SocketAddressInet6-localhost6 =- SocketAddressInet6- { Inet6.port = 7777- , Inet6.address = Inet6.loopback- , Inet6.flowInfo = mempty- , Inet6.scopeId = 0- }+localhost6 :: SocketAddress Inet6+localhost6 = SocketAddressInet6 inet6Loopback 7777 0 0+ test :: String -> IO (Either String String) -> IO () test n t = do
tests/UDP.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Main where import Data.Monoid@@ -6,32 +6,35 @@ import Control.Exception import Control.Concurrent import Control.Concurrent.Async+import Foreign.Storable import System.Socket-import System.Socket.Family.Inet as Inet-import System.Socket.Family.Inet6 as Inet6+import System.Socket.Family.Inet+import System.Socket.Family.Inet6+import System.Socket.Type.Datagram+import System.Socket.Protocol.UDP import System.Exit main :: IO ()-main = do +main = do test "Inet" (undefined :: Socket Inet Datagram UDP) localhost test "Inet6" (undefined :: Socket Inet6 Datagram UDP) localhost6 -- Test stateless sockets (i.e. UDP).-test :: (Family f, Type t, Protocol p) => String -> Socket f t p -> SocketAddress f -> IO ()-test inet dummy addr = do +test :: (Family f, Type t, Protocol p, Storable (SocketAddress f)) => String -> Socket f t p -> SocketAddress f -> IO ()+test inet dummy addr = do server <- socket `asTypeOf` return dummy `onException` p 1 client <- socket `asTypeOf` return dummy `onException` p 2 bind server addr `onException` p 4 - ((msg,peeraddr),_) <- concurrently + ((msg,peeraddr),_) <- concurrently ( do receiveFrom server 4096 mempty `onException` p 5 )- ( do + ( do -- This is a race condition: -- The server must listen before the client sends his msg or the packt goes- -- to nirvana. Still, a second here should be enough. If not, there's + -- to nirvana. Still, a second here should be enough. If not, there's -- something wrong worth investigating. threadDelay 1000000 sendTo client helloWorld mempty addr `onException` p 6@@ -47,18 +50,8 @@ e i = error (inet ++ ": " ++ show i) p i = print (inet ++ ": " ++ show i) -localhost :: SocketAddressInet-localhost =- SocketAddressInet- { Inet.port = 7777- , Inet.address = Inet.loopback- }+localhost :: SocketAddress Inet+localhost = SocketAddressInet inetLoopback 7777 -localhost6 :: SocketAddressInet6-localhost6 =- SocketAddressInet6- { Inet6.port = 7777- , Inet6.address = Inet6.loopback- , Inet6.flowInfo = mempty- , Inet6.scopeId = 0- }+localhost6 :: SocketAddress Inet6+localhost6 = SocketAddressInet6 inet6Loopback 7777 0 0