network 3.1.1.1 → 3.1.2.0
raw patch · 43 files changed
+4258/−1862 lines, 43 filesdep +QuickCheckdep +temporarydep ~base
Dependencies added: QuickCheck, temporary
Dependency ranges changed: base
Files
- CHANGELOG.md +42/−0
- Network/Socket.hs +73/−13
- Network/Socket/Address.hs +3/−0
- Network/Socket/Buffer.hsc +130/−1
- Network/Socket/ByteString.hs +10/−8
- Network/Socket/ByteString/IO.hsc +106/−42
- Network/Socket/ByteString/IOVec.hsc +0/−29
- Network/Socket/ByteString/Internal.hs +32/−4
- Network/Socket/ByteString/Lazy.hs +5/−6
- Network/Socket/ByteString/Lazy/Posix.hs +4/−4
- Network/Socket/ByteString/MsgHdr.hsc +0/−45
- Network/Socket/Flag.hsc +99/−0
- Network/Socket/Handle.hs +5/−0
- Network/Socket/Imports.hs +0/−2
- Network/Socket/Info.hsc +63/−43
- Network/Socket/Internal.hs +48/−5
- Network/Socket/Options.hsc +322/−123
- Network/Socket/Posix/Cmsg.hsc +257/−0
- Network/Socket/Posix/CmsgHdr.hsc +102/−0
- Network/Socket/Posix/IOVec.hsc +47/−0
- Network/Socket/Posix/MsgHdr.hsc +51/−0
- Network/Socket/ReadShow.hs +136/−0
- Network/Socket/Shutdown.hs +5/−55
- Network/Socket/SockAddr.hs +53/−1
- Network/Socket/Syscall.hs +1/−1
- Network/Socket/Types.hsc +1427/−1233
- Network/Socket/Unix.hsc +39/−25
- Network/Socket/Win32/Cmsg.hsc +216/−0
- Network/Socket/Win32/CmsgHdr.hsc +104/−0
- Network/Socket/Win32/MsgHdr.hsc +55/−0
- Network/Socket/Win32/WSABuf.hsc +48/−0
- cbits/ancilData.c +0/−132
- cbits/cmsg.c +97/−0
- configure.ac +1/−1
- examples/EchoClient.hs +1/−2
- examples/EchoServer.hs +9/−6
- include/HsNet.h +48/−1
- include/alignment.h +3/−0
- include/win32defs.h +120/−0
- network.cabal +36/−19
- tests/Network/Socket/ByteStringSpec.hs +141/−24
- tests/Network/SocketSpec.hs +266/−11
- tests/Network/Test/Common.hs +53/−26
CHANGELOG.md view
@@ -1,3 +1,45 @@+## Unreleased++## Version 3.1.2.0++* Added `-f devel` for test cases that are known to fail.+ [#471](https://github.com/haskell/network/pull/471)+* Improved precedence-compliant Read/Show instances. Verified via QuickCheck.+ [#465](https://github.com/haskell/network/pull/465)+ [#466](https://github.com/haskell/network/pull/466)+* Removed the racing graceful close implementation to avoid issues with `CLOSE_WAIT`.+ [#460](https://github.com/haskell/network/pull/438)+* Gracefully handle binding of UNIX domain sockets.+ [#460](https://github.com/haskell/network/pull/460)+* Replace Socket type and family with extensible `CInt` pattern and synonyms.+ [#459](https://github.com/haskell/network/pull/459)+* Fixed race conditions in tests.+ [#458](https://github.com/haskell/network/pull/458)+* Removed many legacy uses of `undefined`.+ [#456](https://github.com/haskell/network/pull/456)+* Defined extensible `CustomSockOpt` via `ViewPatterns`.+ [#455](https://github.com/haskell/network/pull/455)+* Defined `openSocket` in terms of `AddrInfo`.+ [5b0987197fe2ed7beddd7b2096522d624e71151e](https://github.com/haskell/network/commit/5b0987197fe2ed7beddd7b2096522d624e71151e)+* Improved FreeBSD portability for Control Messages and tests+ [#452](https://github.com/haskell/network/pull/452)+* Support `sendMsg` and `recvMsg`+ [#433](https://github.com/haskell/network/pull/433)+ [#445](https://github.com/haskell/network/pull/445)+ [#451](https://github.com/haskell/network/pull/451)+ * Added `sendMsg` and `recvMsg` APIs+ * Redefined `SocketOption` as pattern synonym+* Implement total Show functions for SockAddr+ [#441](https://github.com/haskell/network/pull/441)+* Improve portability changing `u_int32_t` to `uint32_t`.+ [#442](https://github.com/haskell/network/pull/442)+* Removed obsolete CPP statements.+ [d1f4ee60ce6a4a85abb79532f64d4a4e71e2b1ce](https://github.com/haskell/network/commit/d1f4ee60ce6a4a85abb79532f64d4a4e71e2b1ce)+* Loads of improved test coverage.+ [cbd67cc50a37770432eb978ac8b8eb6da3664817](https://github.com/haskell/network/commit/cbd67cc50a37770432eb978ac8b8eb6da3664817)+ [fcc2d86d53a6bec793f6a979a9e8fdf7fe3f4c22](https://github.com/haskell/network/commit/fcc2d86d53a6bec793f6a979a9e8fdf7fe3f4c22)+ [6db96969b3e8974abbfd50a7f073baa57376fd5e](https://github.com/haskell/network/commit/6db96969b3e8974abbfd50a7f073baa57376fd5e)+ ## Version 3.1.1.1 * Fix for GHCJS.
Network/Socket.hs view
@@ -52,16 +52,19 @@ -- > , addrSocketType = Stream -- > } -- > head <$> getAddrInfo (Just hints) mhost (Just port)--- > open addr = do--- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+-- > open addr = E.bracketOnError (openSocket addr) close $ \sock -> do -- > setSocketOption sock ReuseAddr 1--- > withFdSocket sock $ setCloseOnExecIfNeeded+-- > withFdSocket sock setCloseOnExecIfNeeded -- > bind sock $ addrAddress addr -- > listen sock 1024 -- > return sock--- > loop sock = forever $ do--- > (conn, _peer) <- accept sock--- > void $ forkFinally (server conn) (const $ gracefulClose conn 5000)+-- > loop sock = forever $ E.bracketOnError (accept sock) (close . fst)+-- > $ \(conn, _peer) -> void $+-- > -- 'forkFinally' alone is unlikely to fail thus leaking @conn@,+-- > -- but 'E.bracketOnError' above will be necessary if some+-- > -- non-atomic setups (e.g. spawning a subprocess to handle+-- > -- @conn@) before proper cleanup of @conn@ is your case+-- > forkFinally (server conn) (const $ gracefulClose conn 5000) -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- Echo client program@@ -88,8 +91,7 @@ -- > resolve = do -- > let hints = defaultHints { addrSocketType = Stream } -- > head <$> getAddrInfo (Just hints) (Just host) (Just port)--- > open addr = do--- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+-- > open addr = E.bracketOnError (openSocket addr) close $ \sock -> do -- > connect sock $ addrAddress addr -- > return sock --@@ -131,14 +133,26 @@ , ShutdownCmd(..) -- * Socket options- , SocketOption(..)+ , SocketOption(SockOpt+ ,UnsupportedSocketOption+ ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute+ ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline+ ,TimeToLive,MaxSegment,NoDelay,Cork,Linger,ReusePort+ ,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut+ ,UseLoopBack,UserTimeout,IPv6Only+ ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo+ ,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo) , isSupportedSocketOption+ , whenSupported , getSocketOption , setSocketOption+ , getSockOpt+ , setSockOpt -- * Socket , Socket , socket+ , openSocket , withFdSocket , unsafeFdSocket , touchSocket@@ -147,11 +161,22 @@ , mkSocket , socketToHandle -- ** Types of Socket- , SocketType(..)+ , SocketType(GeneralSocketType, UnsupportedSocketType, NoSocketType+ , Stream, Datagram, Raw, RDM, SeqPacket) , isSupportedSocketType , getSocketType -- ** Family- , Family(..)+ , Family(GeneralFamily, UnsupportedFamily+ ,AF_UNSPEC,AF_UNIX,AF_INET,AF_INET6,AF_IMPLINK,AF_PUP,AF_CHAOS+ ,AF_NS,AF_NBS,AF_ECMA,AF_DATAKIT,AF_CCITT,AF_SNA,AF_DECnet+ ,AF_DLI,AF_LAT,AF_HYLINK,AF_APPLETALK,AF_ROUTE,AF_NETBIOS+ ,AF_NIT,AF_802,AF_ISO,AF_OSI,AF_NETMAN,AF_X25,AF_AX25,AF_OSINET+ ,AF_GOSSIP,AF_IPX,Pseudo_AF_XTP,AF_CTF,AF_WAN,AF_SDL,AF_NETWARE+ ,AF_NDD,AF_INTF,AF_COIP,AF_CNT,Pseudo_AF_RTIP,Pseudo_AF_PIP+ ,AF_SIP,AF_ISDN,Pseudo_AF_KEY,AF_NATM,AF_ARP,Pseudo_AF_HDRCMPLT+ ,AF_ENCAP,AF_LINK,AF_RAW,AF_RIF,AF_NETROM,AF_BRIDGE,AF_ATMPVC+ ,AF_ROSE,AF_NETBEUI,AF_SECURITY,AF_PACKET,AF_ASH,AF_ECONET+ ,AF_ATMSVC,AF_IRDA,AF_PPPOX,AF_WANPIPE,AF_BLUETOOTH,AF_CAN) , isSupportedFamily , packFamily , unpackFamily@@ -183,12 +208,14 @@ , socketPortSafe , socketPort +#if !defined(mingw32_HOST_OS) -- * UNIX-domain socket , isUnixDomainSocketAvailable , socketPair , sendFd , recvFd , getPeerCredential+#endif -- * Name information , getNameInfo@@ -205,14 +232,42 @@ , recvBuf , sendBufTo , recvBufFrom-+ -- ** Advanced IO+ , sendBufMsg+ , recvBufMsg+ , MsgFlag(MSG_OOB,MSG_DONTROUTE,MSG_PEEK,MSG_EOR,MSG_TRUNC,MSG_CTRUNC,MSG_WAITALL)+ -- ** Control message (ancillary data)+ , Cmsg(..)+ , CmsgId(CmsgId+ ,CmsgIdIPv4TTL+ ,CmsgIdIPv6HopLimit+ ,CmsgIdIPv4TOS+ ,CmsgIdIPv6TClass+ ,CmsgIdIPv4PktInfo+ ,CmsgIdIPv6PktInfo+ ,CmsgIdFd+ ,UnsupportedCmsgId)+ -- ** APIs for control message+ , lookupCmsg+ , filterCmsg+ , decodeCmsg+ , encodeCmsg+ -- ** Class and yypes for control message+ , ControlMessage(..)+ , IPv4TTL(..)+ , IPv6HopLimit(..)+ , IPv4TOS(..)+ , IPv6TClass(..)+ , IPv4PktInfo(..)+ , IPv6PktInfo(..) -- * Special constants , maxListenQueue ) where -import Network.Socket.Buffer hiding (sendBufTo, recvBufFrom)+import Network.Socket.Buffer hiding (sendBufTo, recvBufFrom, sendBufMsg, recvBufMsg) import Network.Socket.Cbits import Network.Socket.Fcntl+import Network.Socket.Flag import Network.Socket.Handle import Network.Socket.If import Network.Socket.Info@@ -223,4 +278,9 @@ import Network.Socket.SockAddr import Network.Socket.Syscall hiding (connect, bind, accept) import Network.Socket.Types+#if !defined(mingw32_HOST_OS)+import Network.Socket.Posix.Cmsg import Network.Socket.Unix+#else+import Network.Socket.Win32.Cmsg+#endif
Network/Socket/Address.hs view
@@ -16,6 +16,9 @@ -- * Sending and receiving data from a buffer , sendBufTo , recvBufFrom+ -- * Advanced IO+ , sendBufMsg+ , recvBufMsg ) where import Network.Socket.ByteString.IO
Network/Socket/Buffer.hsc view
@@ -11,24 +11,42 @@ , recvBufFrom , recvBuf , recvBufNoWait+ , sendBufMsg+ , recvBufMsg ) where #if !defined(mingw32_HOST_OS) import Foreign.C.Error (getErrno, eAGAIN, eWOULDBLOCK)+#else+import Foreign.Ptr (nullPtr) #endif-import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Alloc (alloca, allocaBytes)+import Foreign.Marshal.Utils (with) import GHC.IO.Exception (IOErrorType(InvalidArgument)) import System.IO.Error (mkIOError, ioeSetErrorString, catchIOError) #if defined(mingw32_HOST_OS) import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)+import Network.Socket.Win32.CmsgHdr+import Network.Socket.Win32.MsgHdr+import Network.Socket.Win32.WSABuf+#else+import Network.Socket.Posix.CmsgHdr+import Network.Socket.Posix.MsgHdr+import Network.Socket.Posix.IOVec #endif import Network.Socket.Imports import Network.Socket.Internal import Network.Socket.Name import Network.Socket.Types+import Network.Socket.Flag +#if defined(mingw32_HOST_OS)+type DWORD = Word32+type LPDWORD = Ptr DWORD+#endif+ -- | Send data to the socket. The recipient can be specified -- explicitly, so the socket need not be in a connected state. -- Returns the number of bytes sent. Applications are responsible for@@ -178,18 +196,129 @@ InvalidArgument loc Nothing Nothing) "non-positive length" +-- | Send data to the socket using sendmsg(2).+sendBufMsg :: SocketAddress sa+ => Socket -- ^ Socket+ -> sa -- ^ Destination address+ -> [(Ptr Word8,Int)] -- ^ Data to be sent+ -> [Cmsg] -- ^ Control messages+ -> MsgFlag -- ^ Message flags+ -> IO Int -- ^ The length actually sent+sendBufMsg s sa bufsizs cmsgs flags = do+ sz <- withSocketAddress sa $ \addrPtr addrSize -> #if !defined(mingw32_HOST_OS)+ withIOVec bufsizs $ \(iovsPtr, iovsLen) -> do+#else+ withWSABuf bufsizs $ \(wsaBPtr, wsaBLen) -> do+#endif+ withCmsgs cmsgs $ \ctrlPtr ctrlLen -> do+ let msgHdr = MsgHdr {+ msgName = addrPtr+ , msgNameLen = fromIntegral addrSize+#if !defined(mingw32_HOST_OS)+ , msgIov = iovsPtr+ , msgIovLen = fromIntegral iovsLen+#else+ , msgBuffer = wsaBPtr+ , msgBufferLen = fromIntegral wsaBLen+#endif+ , msgCtrl = castPtr ctrlPtr+ , msgCtrlLen = fromIntegral ctrlLen+ , msgFlags = 0+ }+ cflags = fromMsgFlag flags+ withFdSocket s $ \fd ->+ with msgHdr $ \msgHdrPtr ->+ throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $+#if !defined(mingw32_HOST_OS)+ c_sendmsg fd msgHdrPtr cflags+#else+ alloca $ \send_ptr ->+ c_sendmsg fd msgHdrPtr (fromIntegral cflags) send_ptr nullPtr nullPtr+#endif+ return $ fromIntegral sz++-- | Receive data from the socket using recvmsg(2). The supplied+-- buffers are filled in order, with subsequent buffers used only+-- after all the preceding buffers are full. If the message is short+-- enough some of the supplied buffers may remain unused.+recvBufMsg :: SocketAddress sa+ => Socket -- ^ Socket+ -> [(Ptr Word8,Int)] -- ^ A list of (buffer, buffer-length) pairs.+ -- If the total length is not large enough,+ -- 'MSG_TRUNC' is returned+ -> Int -- ^ The buffer size for control messages.+ -- If the length is not large enough,+ -- 'MSG_CTRUNC' is returned+ -> MsgFlag -- ^ Message flags+ -> IO (sa,Int,[Cmsg],MsgFlag) -- ^ Source address, total bytes received, control messages and message flags+recvBufMsg s bufsizs clen flags = do+ withNewSocketAddress $ \addrPtr addrSize ->+ allocaBytes clen $ \ctrlPtr ->+#if !defined(mingw32_HOST_OS)+ withIOVec bufsizs $ \(iovsPtr, iovsLen) -> do+ let msgHdr = MsgHdr {+ msgName = addrPtr+ , msgNameLen = fromIntegral addrSize+ , msgIov = iovsPtr+ , msgIovLen = fromIntegral iovsLen+ , msgCtrl = castPtr ctrlPtr+ , msgCtrlLen = fromIntegral clen+ , msgFlags = 0+#else+ withWSABuf bufsizs $ \(wsaBPtr, wsaBLen) -> do+ let msgHdr = MsgHdr {+ msgName = addrPtr+ , msgNameLen = fromIntegral addrSize+ , msgBuffer = wsaBPtr+ , msgBufferLen = fromIntegral wsaBLen+ , msgCtrl = if clen == 0 then nullPtr else castPtr ctrlPtr+ , msgCtrlLen = fromIntegral clen+ , msgFlags = fromIntegral $ fromMsgFlag flags+#endif+ }+ _cflags = fromMsgFlag flags+ withFdSocket s $ \fd -> do+ with msgHdr $ \msgHdrPtr -> do+ len <- (fmap fromIntegral) <$>+#if !defined(mingw32_HOST_OS)+ throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmg" $+ c_recvmsg fd msgHdrPtr _cflags+#else+ alloca $ \len_ptr -> do+ _ <- throwSocketErrorWaitReadBut (== #{const WSAEMSGSIZE}) s "Network.Socket.Buffer.recvmg" $+ c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr+ peek len_ptr+#endif+ sockaddr <- peekSocketAddress addrPtr `catchIOError` \_ -> getPeerName s+ hdr <- peek msgHdrPtr+ cmsgs <- parseCmsgs msgHdrPtr+ let flags' = MsgFlag $ fromIntegral $ msgFlags hdr+ return (sockaddr, len, cmsgs, flags')++#if !defined(mingw32_HOST_OS) foreign import ccall unsafe "send" c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt+foreign import ccall unsafe "sendmsg"+ c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> CInt -> IO CInt -- fixme CSsize+foreign import ccall unsafe "recvmsg"+ c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> CInt -> IO CInt #else foreign import CALLCONV SAFE_ON_WIN "ioctlsocket" c_ioctlsocket :: CInt -> CLong -> Ptr CULong -> IO CInt foreign import CALLCONV SAFE_ON_WIN "WSAGetLastError" c_WSAGetLastError :: IO CInt+foreign import CALLCONV SAFE_ON_WIN "WSASendMsg"+ -- fixme Handle for SOCKET, see #426+ c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt+foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"+ c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt #endif+ foreign import ccall unsafe "recv" c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt foreign import CALLCONV SAFE_ON_WIN "sendto" c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt foreign import CALLCONV SAFE_ON_WIN "recvfrom" c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt+
Network/Socket/ByteString.hs view
@@ -7,13 +7,12 @@ -- Stability : stable -- Portability : portable ----- This module provides access to the BSD /socket/ interface. This--- module is generally more efficient than the 'String' based network--- functions in 'Network.Socket'. For detailed documentation, consult--- your favorite POSIX socket reference. All functions communicate--- failures by converting the error number to 'System.IO.IOError'.+-- This module provides access to the BSD /socket/ interface. For detailed+-- documentation, consult your favorite POSIX socket reference. All functions+-- communicate failures by converting the error number to an+-- 'System.IO.Error.IOError'. ----- This module is made to be imported with 'Network.Socket' like so:+-- This module is made to be imported with "Network.Socket" like so: -- -- > import Network.Socket -- > import Network.Socket.ByteString@@ -34,12 +33,16 @@ -- * Receive data from a socket , recv , recvFrom++ -- * Advanced send and recv+ , sendMsg+ , recvMsg ) where import Data.ByteString (ByteString) -import Network.Socket.ByteString.IO hiding (sendTo, sendAllTo, recvFrom) import qualified Network.Socket.ByteString.IO as G+import Network.Socket.ByteString.IO hiding (sendTo, sendAllTo, recvFrom) import Network.Socket.Types -- ----------------------------------------------------------------------------@@ -86,4 +89,3 @@ -- 'SockAddr' representing the address of the sending socket. recvFrom :: Socket -> Int -> IO (ByteString, SockAddr) recvFrom = G.recvFrom-
Network/Socket/ByteString/IO.hsc view
@@ -1,10 +1,11 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} #include "HsNet.h" -- |--- Module : Network.Socket.ByteString+-- Module : Network.Socket.ByteString.IO -- Copyright : (c) Johan Tibell 2007-2010 -- License : BSD-style --@@ -12,17 +13,6 @@ -- Stability : stable -- Portability : portable ----- This module provides access to the BSD /socket/ interface. This--- module is generally more efficient than the 'String' based network--- functions in 'Network.Socket'. For detailed documentation, consult--- your favorite POSIX socket reference. All functions communicate--- failures by converting the error number to 'System.IO.IOError'.------ This module is made to be imported with 'Network.Socket' like so:------ > import Network.Socket hiding (send, sendTo, recv, recvFrom)--- > import Network.Socket.ByteString--- module Network.Socket.ByteString.IO ( -- * Send data to a socket@@ -40,6 +30,12 @@ , recv , recvFrom , waitWhen0++ -- * Advanced send and recv+ , sendMsg+ , recvMsg+ , MsgFlag(..)+ , Cmsg(..) ) where import Control.Concurrent (threadWaitWrite, rtsSupportsBoundThreads)@@ -48,23 +44,28 @@ import Data.ByteString.Internal (createAndTrim) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Ptr (castPtr) import Network.Socket.Buffer import Network.Socket.ByteString.Internal import Network.Socket.Imports import Network.Socket.Types -#if !defined(mingw32_HOST_OS)-import Control.Monad (zipWithM_)-import Foreign.Marshal.Array (allocaArray)+import Data.ByteString.Internal (create, ByteString(..))+import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Utils (with)-import Foreign.Ptr (Ptr, plusPtr)-import Foreign.Storable (Storable(..)) import Network.Socket.Internal -import Network.Socket.ByteString.IOVec (IOVec(..))-import Network.Socket.ByteString.MsgHdr (MsgHdr(..))+import Network.Socket.Flag++#if !defined(mingw32_HOST_OS)+import Network.Socket.Posix.Cmsg+import Network.Socket.Posix.IOVec+import Network.Socket.Posix.MsgHdr (MsgHdr(..))+#else+import Foreign.Marshal.Alloc (alloca)+import Network.Socket.Win32.Cmsg+import Network.Socket.Win32.WSABuf+import Network.Socket.Win32.MsgHdr (MsgHdr(..)) #endif -- ----------------------------------------------------------------------------@@ -136,7 +137,6 @@ sendMany :: Socket -- ^ Connected socket -> [ByteString] -- ^ Data to send -> IO ()-#if !defined(mingw32_HOST_OS) sendMany _ [] = return () sendMany s cs = do sent <- sendManyInner@@ -144,13 +144,20 @@ when (sent >= 0) $ sendMany s $ remainingChunks sent cs where sendManyInner =- fmap fromIntegral . withIOVec cs $ \(iovsPtr, iovsLen) ->+#if !defined(mingw32_HOST_OS)+ fmap fromIntegral . withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> withFdSocket s $ \fd -> do let len = fromIntegral $ min iovsLen (#const IOV_MAX) throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $ c_writev fd iovsPtr len #else-sendMany s = sendAll s . B.concat+ fmap fromIntegral . withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) ->+ withFdSocket s $ \fd -> do+ let len = fromIntegral wsabsLen+ alloca $ \send_ptr -> do+ _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $+ c_wsasend fd wsabsPtr len send_ptr 0 nullPtr nullPtr+ peek send_ptr #endif -- | Send data to the socket. The recipient can be specified@@ -163,7 +170,6 @@ -> [ByteString] -- ^ Data to send -> SockAddr -- ^ Recipient address -> IO ()-#if !defined(mingw32_HOST_OS) sendManyTo _ [] _ = return () sendManyTo s cs addr = do sent <- fromIntegral <$> sendManyToInner@@ -172,16 +178,38 @@ where sendManyToInner = withSockAddr addr $ \addrPtr addrSize ->- withIOVec cs $ \(iovsPtr, iovsLen) -> do- let msgHdr = MsgHdr- addrPtr (fromIntegral addrSize)- iovsPtr (fromIntegral iovsLen)+#if !defined(mingw32_HOST_OS)+ withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> do+ let msgHdr = MsgHdr {+ msgName = addrPtr+ , msgNameLen = fromIntegral addrSize+ , msgIov = iovsPtr+ , msgIovLen = fromIntegral iovsLen+ , msgCtrl = nullPtr+ , msgCtrlLen = 0+ , msgFlags = 0+ } withFdSocket s $ \fd -> with msgHdr $ \msgHdrPtr -> throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $ c_sendmsg fd msgHdrPtr 0 #else-sendManyTo s cs = sendAllTo s (B.concat cs)+ withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) -> do+ let msgHdr = MsgHdr {+ msgName = addrPtr+ , msgNameLen = fromIntegral addrSize+ , msgBuffer = wsabsPtr+ , msgBufferLen = fromIntegral wsabsLen+ , msgCtrl = nullPtr+ , msgCtrlLen = 0+ , msgFlags = 0+ }+ withFdSocket s $ \fd ->+ with msgHdr $ \msgHdrPtr ->+ alloca $ \send_ptr -> do+ _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $+ c_sendmsg fd msgHdrPtr 0 send_ptr nullPtr nullPtr+ peek send_ptr #endif -- ----------------------------------------------------------------------------@@ -224,7 +252,7 @@ -- ---------------------------------------------------------------------------- -- Not exported -#if !defined(mingw32_HOST_OS)+ -- | Suppose we try to transmit a list of chunks @cs@ via a gathering write -- operation and find that @n@ bytes were sent. Then @remainingChunks n cs@ is -- list of chunks remaining to be sent.@@ -236,19 +264,55 @@ where len = B.length x --- | @withIOVec cs f@ executes the computation @f@, passing as argument a pair+#if !defined(mingw32_HOST_OS)+-- | @withIOVecfromBS cs f@ executes the computation @f@, passing as argument a pair -- consisting of a pointer to a temporarily allocated array of pointers to -- IOVec made from @cs@ and the number of pointers (@length cs@). -- /Unix only/.-withIOVec :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a-withIOVec cs f =- allocaArray csLen $ \aPtr -> do- zipWithM_ pokeIov (ptrs aPtr) cs- f (aPtr, csLen)- where- csLen = length cs- ptrs = iterate (`plusPtr` sizeOf (undefined :: IOVec))- pokeIov ptr s =- unsafeUseAsCStringLen s $ \(sPtr, sLen) ->- poke ptr $ IOVec sPtr (fromIntegral sLen)+withIOVecfromBS :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a+withIOVecfromBS cs f = withBufSizs cs $ \bufsizs -> withIOVec bufsizs f+#else+-- | @withWSABuffromBS cs f@ executes the computation @f@, passing as argument a pair+-- consisting of a pointer to a temporarily allocated array of pointers to+-- WSABuf made from @cs@ and the number of pointers (@length cs@).+-- /Windows only/.+withWSABuffromBS :: [ByteString] -> ((Ptr WSABuf, Int) -> IO a) -> IO a+withWSABuffromBS cs f = withBufSizs cs $ \bufsizs -> withWSABuf bufsizs f #endif++withBufSizs :: [ByteString] -> ([(Ptr Word8, Int)] -> IO a) -> IO a+withBufSizs bss0 f = loop bss0 id+ where+ loop [] !build = f $ build []+ loop (PS fptr off len:bss) !build = withForeignPtr fptr $ \ptr -> do+ let !ptr' = ptr `plusPtr` off+ loop bss (build . ((ptr',len) :))++-- | Send data to the socket using sendmsg(2).+sendMsg :: Socket -- ^ Socket+ -> SockAddr -- ^ Destination address+ -> [ByteString] -- ^ Data to be sent+ -> [Cmsg] -- ^ Control messages+ -> MsgFlag -- ^ Message flags+ -> IO Int -- ^ The length actually sent+sendMsg _ _ [] _ _ = return 0+sendMsg s addr bss cmsgs flags = withBufSizs bss $ \bufsizs ->+ sendBufMsg s addr bufsizs cmsgs flags++-- | Receive data from the socket using recvmsg(2).+recvMsg :: Socket -- ^ Socket+ -> Int -- ^ The maximum length of data to be received+ -- If the total length is not large enough,+ -- 'MSG_TRUNC' is returned+ -> Int -- ^ The buffer size for control messages.+ -- If the length is not large enough,+ -- 'MSG_CTRUNC' is returned+ -> MsgFlag -- ^ Message flags+ -> IO (SockAddr, ByteString, [Cmsg], MsgFlag) -- ^ Source address, received data, control messages and message flags+recvMsg s siz clen flags = do+ bs@(PS fptr _ _) <- create siz $ \ptr -> zeroMemory ptr (fromIntegral siz)+ withForeignPtr fptr $ \ptr -> do+ (addr,len,cmsgs,flags') <- recvBufMsg s [(ptr,siz)] clen flags+ let bs' | len < siz = PS fptr 0 len+ | otherwise = bs+ return (addr, bs', cmsgs, flags')
− Network/Socket/ByteString/IOVec.hsc
@@ -1,29 +0,0 @@-{-# OPTIONS_GHC -funbox-strict-fields #-}---- | Support module for the POSIX writev system call.-module Network.Socket.ByteString.IOVec- ( IOVec(..)- ) where--import Network.Socket.Imports--#include <sys/types.h>-#include <sys/uio.h>--data IOVec = IOVec- { iovBase :: !(Ptr CChar)- , iovLen :: !CSize- }--instance Storable IOVec where- sizeOf _ = (#const sizeof(struct iovec))- alignment _ = alignment (undefined :: CInt)-- peek p = do- base <- (#peek struct iovec, iov_base) p- len <- (#peek struct iovec, iov_len) p- return $ IOVec base len-- poke p iov = do- (#poke struct iovec, iov_base) p (iovBase iov)- (#poke struct iovec, iov_len) p (iovLen iov)
Network/Socket/ByteString/Internal.hs view
@@ -14,10 +14,15 @@ mkInvalidRecvArgError #if !defined(mingw32_HOST_OS) , c_writev- , c_sendmsg+#else+ , c_wsasend #endif+ , c_sendmsg+ , c_recvmsg ) where +#include "HsNetDef.h"+ import GHC.IO.Exception (IOErrorType(..)) import System.IO.Error (ioeSetErrorString, mkIOError) @@ -25,8 +30,20 @@ import System.Posix.Types (CSsize(..)) import Network.Socket.Imports-import Network.Socket.ByteString.IOVec (IOVec)-import Network.Socket.ByteString.MsgHdr (MsgHdr)+import Network.Socket.Posix.IOVec (IOVec)+import Network.Socket.Posix.MsgHdr (MsgHdr)+import Network.Socket.Types+#else+import Data.Word+import Foreign.C.Types+import Foreign.Ptr++import Network.Socket.Win32.WSABuf (WSABuf)+import Network.Socket.Win32.MsgHdr (MsgHdr)+import Network.Socket.Types++type DWORD = Word32+type LPDWORD = Ptr DWORD #endif mkInvalidRecvArgError :: String -> IOError@@ -39,5 +56,16 @@ c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize foreign import ccall unsafe "sendmsg"- c_sendmsg :: CInt -> Ptr MsgHdr -> CInt -> IO CSsize+ c_sendmsg :: CInt -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize++foreign import ccall unsafe "recvmsg"+ c_recvmsg :: CInt -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize+#else+ -- fixme Handle for SOCKET, see #426+foreign import CALLCONV SAFE_ON_WIN "WSASend"+ c_wsasend :: CInt -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt+foreign import CALLCONV SAFE_ON_WIN "WSASendMsg"+ c_sendmsg :: CInt -> Ptr (MsgHdr SockAddr) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt+foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"+ c_recvmsg :: CInt -> Ptr (MsgHdr SockAddr) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt #endif
Network/Socket/ByteString/Lazy.hs view
@@ -8,13 +8,12 @@ -- Stability : experimental -- Portability : POSIX, GHC ----- This module provides access to the BSD /socket/ interface. This--- module is generally more efficient than the 'String' based network--- functions in 'Network.Socket'. For detailed documentation, consult--- your favorite POSIX socket reference. All functions communicate--- failures by converting the error number to 'System.IO.IOError'.+-- This module provides access to the BSD /socket/ interface. For detailed+-- documentation, consult your favorite POSIX socket reference. All functions+-- communicate failures by converting the error number to an+-- 'System.IO.Error.IOError'. ----- This module is made to be imported with 'Network.Socket' like so:+-- This module is made to be imported with "Network.Socket" like so: -- -- > import Network.Socket -- > import Network.Socket.ByteString.Lazy
Network/Socket/ByteString/Lazy/Posix.hs view
@@ -11,11 +11,11 @@ import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Foreign.Marshal.Array (allocaArray) -import Network.Socket.ByteString.Internal (c_writev) import Network.Socket.ByteString.IO (waitWhen0)-import Network.Socket.ByteString.IOVec (IOVec (IOVec))+import Network.Socket.ByteString.Internal (c_writev) import Network.Socket.Imports import Network.Socket.Internal+import Network.Socket.Posix.IOVec (IOVec (IOVec)) import Network.Socket.Types -- -----------------------------------------------------------------------------@@ -36,9 +36,9 @@ where loop (c:cs) q k !niovs | k < maxNumBytes = unsafeUseAsCStringLen c $ \(ptr, len) -> do- poke q $ IOVec ptr (fromIntegral len)+ poke q $ IOVec (castPtr ptr) (fromIntegral len) loop cs- (q `plusPtr` sizeOf (undefined :: IOVec))+ (q `plusPtr` sizeOf (IOVec nullPtr 0)) (k + fromIntegral len) (niovs + 1) | otherwise = f niovs
− Network/Socket/ByteString/MsgHdr.hsc
@@ -1,45 +0,0 @@-{-# OPTIONS_GHC -funbox-strict-fields #-}---- | Support module for the POSIX 'sendmsg' system call.-module Network.Socket.ByteString.MsgHdr- ( MsgHdr(..)- ) where--#include <sys/types.h>-#include <sys/socket.h>--import Network.Socket.Imports-import Network.Socket.Internal (zeroMemory)-import Network.Socket.Types (SockAddr)--import Network.Socket.ByteString.IOVec (IOVec)---- We don't use msg_control, msg_controllen, and msg_flags as these--- don't exist on OpenSolaris.-data MsgHdr = MsgHdr- { msgName :: !(Ptr SockAddr)- , msgNameLen :: !CUInt- , msgIov :: !(Ptr IOVec)- , msgIovLen :: !CSize- }--instance Storable MsgHdr where- sizeOf _ = (#const sizeof(struct msghdr))- alignment _ = alignment (undefined :: CInt)-- peek p = do- name <- (#peek struct msghdr, msg_name) p- nameLen <- (#peek struct msghdr, msg_namelen) p- iov <- (#peek struct msghdr, msg_iov) p- iovLen <- (#peek struct msghdr, msg_iovlen) p- return $ MsgHdr name nameLen iov iovLen-- poke p mh = do- -- We need to zero the msg_control, msg_controllen, and msg_flags- -- fields, but they only exist on some platforms (e.g. not on- -- Solaris). Instead of using CPP, we zero the entire struct.- zeroMemory p (#const sizeof(struct msghdr))- (#poke struct msghdr, msg_name) p (msgName mh)- (#poke struct msghdr, msg_namelen) p (msgNameLen mh)- (#poke struct msghdr, msg_iov) p (msgIov mh)- (#poke struct msghdr, msg_iovlen) p (msgIovLen mh)
+ Network/Socket/Flag.hsc view
@@ -0,0 +1,99 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}++#include "HsNet.h"++module Network.Socket.Flag where++import qualified Data.Semigroup as Sem++import Network.Socket.Imports++{-+import Network.Socket.ReadShow++import qualified Text.Read as P+-}++-- | Message flags. To combine flags, use '(<>)'.+newtype MsgFlag = MsgFlag { fromMsgFlag :: CInt }+ deriving (Show, Eq, Ord, Num, Bits)++instance Sem.Semigroup MsgFlag where+ (<>) = (.|.)++instance Monoid MsgFlag where+ mempty = MsgFlag 0+#if !(MIN_VERSION_base(4,11,0))+ mappend = (Sem.<>)+#endif++-- | Send or receive OOB(out-of-bound) data.+pattern MSG_OOB :: MsgFlag+#ifdef MSG_OOB+pattern MSG_OOB = MsgFlag (#const MSG_OOB)+#else+pattern MSG_OOB = MsgFlag 0+#endif++-- | Bypass routing table lookup.+pattern MSG_DONTROUTE :: MsgFlag+#ifdef MSG_DONTROUTE+pattern MSG_DONTROUTE = MsgFlag (#const MSG_DONTROUTE)+#else+pattern MSG_DONTROUTE = MsgFlag 0+#endif++-- | Peek at incoming message without removing it from the queue.+pattern MSG_PEEK :: MsgFlag+#ifdef MSG_PEEK+pattern MSG_PEEK = MsgFlag (#const MSG_PEEK)+#else+pattern MSG_PEEK = MsgFlag 0+#endif++-- | End of record.+pattern MSG_EOR :: MsgFlag+#ifdef MSG_EOR+pattern MSG_EOR = MsgFlag (#const MSG_EOR)+#else+pattern MSG_EOR = MsgFlag 0+#endif++-- | Received data is truncated. More data exist.+pattern MSG_TRUNC :: MsgFlag+#ifdef MSG_TRUNC+pattern MSG_TRUNC = MsgFlag (#const MSG_TRUNC)+#else+pattern MSG_TRUNC = MsgFlag 0+#endif++-- | Received control message is truncated. More control message exist.+pattern MSG_CTRUNC :: MsgFlag+#ifdef MSG_CTRUNC+pattern MSG_CTRUNC = MsgFlag (#const MSG_CTRUNC)+#else+pattern MSG_CTRUNC = MsgFlag 0+#endif++-- | Wait until the requested number of bytes have been read.+pattern MSG_WAITALL :: MsgFlag+#ifdef MSG_WAITALL+pattern MSG_WAITALL = MsgFlag (#const MSG_WAITALL)+#else+pattern MSG_WAITALL = MsgFlag 0+#endif++{-+msgFlagPairs :: [Pair MsgFlag String]+msgFlagPairs =+ [ (MSG_OOB, "MSG_OOB")+ , (MSG_DONTROUTE, "MSG_DONTROUTE")+ , (MSG_PEEK, "MSG_PEEK")+ , (MSG_EOR, "MSG_EOR")+ , (MSG_TRUNC, "MSG_TRUNC")+ , (MSG_CTRUNC, "MSG_CTRUNC")+ , (MSG_WAITALL, "MSG_WAITALL")+ ]+-}
Network/Socket/Handle.hs view
@@ -14,6 +14,11 @@ -- operations on the 'Socket' after calling 'socketToHandle'. To -- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose' -- on the 'Handle'.+--+-- Caveat 'Handle' is not recommended for network programming in +-- Haskell, e.g. merely performing 'hClose' on a TCP socket won't+-- cooperate with peer's 'gracefulClose', i.e. proper shutdown+-- sequence with appropriate handshakes specified by the protocol. socketToHandle :: Socket -> IOMode -> IO Handle socketToHandle s mode = invalidateSocket s err $ \oldfd -> do
Network/Socket/Imports.hs view
@@ -7,7 +7,6 @@ , module Data.Maybe , module Data.Monoid , module Data.Ord- , module Data.Typeable , module Data.Word , module Foreign.C.String , module Foreign.C.Types@@ -24,7 +23,6 @@ import Data.Maybe import Data.Monoid import Data.Ord-import Data.Typeable import Data.Word import Foreign.C.String import Foreign.C.Types
Network/Socket/Info.hsc view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -10,12 +9,12 @@ import Foreign.Marshal.Alloc (alloca, allocaBytes) import Foreign.Marshal.Utils (maybeWith, with)-import GHC.IO (unsafePerformIO) import GHC.IO.Exception (IOErrorType(NoSuchThing)) import System.IO.Error (ioeSetErrorString, mkIOError) import Network.Socket.Imports import Network.Socket.Internal+import Network.Socket.Syscall import Network.Socket.Types -----------------------------------------------------------------------------@@ -63,7 +62,7 @@ -- addresses are found, IPv6-mapped IPv4 addresses will be -- returned. (Only some platforms support this.) | AI_V4MAPPED- deriving (Eq, Read, Show, Typeable)+ deriving (Eq, Read, Show) aiFlagMapping :: [(AddrInfoFlag, CInt)] @@ -106,11 +105,11 @@ , addrProtocol :: ProtocolNumber , addrAddress :: SockAddr , addrCanonName :: Maybe String- } deriving (Eq, Show, Typeable)+ } deriving (Eq, Show) instance Storable AddrInfo where sizeOf _ = #const sizeof(struct addrinfo)- alignment _ = alignment (undefined :: CInt)+ alignment _ = alignment (0 :: CInt) peek p = do ai_flags <- (#peek struct addrinfo, ai_flags) p@@ -124,18 +123,17 @@ then return Nothing else Just <$> peekCString ai_canonname_ptr - socktype <- unpackSocketType' "AddrInfo.peek" ai_socktype return $ AddrInfo { addrFlags = unpackBits aiFlagMapping ai_flags , addrFamily = unpackFamily ai_family- , addrSocketType = socktype+ , addrSocketType = unpackSocketType ai_socktype , addrProtocol = ai_protocol , addrAddress = ai_addr , addrCanonName = ai_canonname } poke p (AddrInfo flags family sockType protocol _ _) = do- c_stype <- packSocketTypeOrThrow "AddrInfo.poke" sockType+ let c_stype = packSocketType sockType (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags) (#poke struct addrinfo, ai_family) p (packFamily family)@@ -171,7 +169,7 @@ -- looked up. Instead, a numeric representation of the -- service is returned. | NI_NUMERICSERV- deriving (Eq, Read, Show, Typeable)+ deriving (Eq, Read, Show) niFlagMapping :: [(NameInfoFlag, CInt)] @@ -181,9 +179,7 @@ (NI_NUMERICHOST, #const NI_NUMERICHOST), (NI_NUMERICSERV, #const NI_NUMERICSERV)] --- | Default hints for address lookup with 'getAddrInfo'. The values--- of the 'addrAddress' and 'addrCanonName' fields are 'undefined',--- and are never inspected by 'getAddrInfo'.+-- | Default hints for address lookup with 'getAddrInfo'. -- -- >>> addrFlags defaultHints -- []@@ -200,29 +196,10 @@ , addrFamily = AF_UNSPEC , addrSocketType = NoSocketType , addrProtocol = defaultProtocol- , addrAddress = undefined- , addrCanonName = undefined+ , addrAddress = SockAddrInet 0 0+ , addrCanonName = Nothing } --- | Shows the fields of 'defaultHints', without inspecting the by-default undefined fields 'addrAddress' and 'addrCanonName'.-showDefaultHints :: AddrInfo -> String-showDefaultHints AddrInfo{..} = concat [- "AddrInfo {"- , "addrFlags = "- , show addrFlags- , ", addrFamily = "- , show addrFamily- , ", addrSocketType = "- , show addrSocketType- , ", addrProtocol = "- , show addrProtocol- , ", addrAddress = "- , "<assumed to be undefined>"- , ", addrCanonName = "- , "<assumed to be undefined>"- , "}"- ]- ----------------------------------------------------------------------------- -- | Resolve a host or service name to one or more addresses. -- The 'AddrInfo' values that this function returns contain 'SockAddr'@@ -286,7 +263,7 @@ -- See: http://pubs.opengroup.org/onlinepubs/9699919799/functions/getaddrinfo.html case ais of [] -> ioError $ mkIOError NoSuchThing message Nothing Nothing- _ -> pure ais+ _ -> return ais else do err <- gai_strerror ret ioError $ ioeSetErrorString@@ -294,7 +271,7 @@ err message = concat [ "Network.Socket.getAddrInfo (called with preferred socket type/protocol: "- , maybe (show hints) showDefaultHints hints+ , maybe "Nothing" show hints , ", host name: " , show node , ", service name: "@@ -441,16 +418,59 @@ #else showsPrec _ SockAddrUnix{} = error "showsPrec: not supported" #endif- showsPrec _ addr@(SockAddrInet port _)- = showString (unsafePerformIO $- fst <$> getNameInfo [NI_NUMERICHOST] True False addr >>=- maybe (fail "showsPrec: impossible internal error") return)+ showsPrec _ (SockAddrInet port ha)+ = showHostAddress ha . showString ":" . shows port- showsPrec _ addr@(SockAddrInet6 port _ _ _)+ showsPrec _ (SockAddrInet6 port _ ha6 _) = showChar '['- . showString (unsafePerformIO $- fst <$> getNameInfo [NI_NUMERICHOST] True False addr >>=- maybe (fail "showsPrec: impossible internal error") return)+ . showHostAddress6 ha6 . showString "]:" . shows port+++-- Taken from on the implementation of showIPv4 in Data.IP.Addr+showHostAddress :: HostAddress -> ShowS+showHostAddress ip =+ let (u3, u2, u1, u0) = hostAddressToTuple ip in+ foldr1 (.) . intersperse (showChar '.') $ map showInt [u3, u2, u1, u0]++-- Taken from showIPv6 in Data.IP.Addr.++-- | Show an IPv6 address in the most appropriate notation, based on recommended+-- representation proposed by <http://tools.ietf.org/html/rfc5952 RFC 5952>.+--+-- /The implementation is completely compatible with the current implementation+-- of the `inet_ntop` function in glibc./+showHostAddress6 :: HostAddress6 -> ShowS+showHostAddress6 ha6@(a1, a2, a3, a4)+ -- IPv4-Mapped IPv6 Address+ | a1 == 0 && a2 == 0 && a3 == 0xffff =+ showString "::ffff:" . showHostAddress a4+ -- IPv4-Compatible IPv6 Address (exclude IPRange ::/112)+ | a1 == 0 && a2 == 0 && a3 == 0 && a4 >= 0x10000 =+ showString "::" . showHostAddress a4+ -- length of longest run > 1, replace it with "::"+ | end - begin > 1 =+ showFields prefix . showString "::" . showFields suffix+ | otherwise =+ showFields fields+ where+ fields =+ let (u7, u6, u5, u4, u3, u2, u1, u0) = hostAddress6ToTuple ha6 in+ [u7, u6, u5, u4, u3, u2, u1, u0]+ showFields = foldr (.) id . intersperse (showChar ':') . map showHex+ prefix = take begin fields -- fields before "::"+ suffix = drop end fields -- fields after "::"+ begin = end + diff -- the longest run of zeros+ (diff, end) = minimum $+ scanl (\c i -> if i == 0 then c - 1 else 0) 0 fields `zip` [0..]++-----------------------------------------------------------------------------++-- | A utility function to open a socket with `AddrInfo`.+-- This is a just wrapper for the following code:+--+-- > \addr -> socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+openSocket :: AddrInfo -> IO Socket+openSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
Network/Socket/Internal.hs view
@@ -13,8 +13,8 @@ -- Stability : provisional -- Portability : portable ----- A module containing semi-public 'Network.Socket' internals.--- Modules which extend the 'Network.Socket' module will need to use+-- A module containing semi-public "Network.Socket" internals.+-- Modules which extend the "Network.Socket" module will need to use -- this module while ideally most users will be able to make do with -- the public interface. --@@ -34,12 +34,15 @@ , throwSocketErrorIfMinus1Retry , throwSocketErrorIfMinus1Retry_ , throwSocketErrorIfMinus1RetryMayBlock-+#if defined(mingw32_HOST_OS)+ , throwSocketErrorIfMinus1ButRetry+#endif -- ** Guards that wait and retry if the operation would block -- | These guards are based on 'throwSocketErrorIfMinus1RetryMayBlock'. -- They wait for socket readiness if the action fails with @EWOULDBLOCK@ -- or similar. , throwSocketErrorWaitRead+ , throwSocketErrorWaitReadBut , throwSocketErrorWaitWrite -- * Initialization@@ -134,16 +137,39 @@ {-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock :: String -> IO b -> IO CInt -> IO CInt #-} ++-- | Throw an 'IOError' corresponding to the current socket error if+-- the IO action returns a result of @-1@, but retries in case of an+-- interrupted operation. Checks for operations that would block and+-- executes an alternative action before retrying in that case. If the error+-- is one handled by the exempt filter then ignore it and return the errorcode.+throwSocketErrorIfMinus1RetryMayBlockBut+ :: (Eq a, Num a)+ => (CInt -> Bool) -- ^ exception exempt filter+ -> String -- ^ textual description of the location+ -> IO b -- ^ action to execute before retrying if an+ -- immediate retry would block+ -> IO a -- ^ the 'IO' operation to be executed+ -> IO a++{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock+ :: String -> IO b -> IO CInt -> IO CInt #-}+ #if defined(mingw32_HOST_OS) throwSocketErrorIfMinus1RetryMayBlock name _ act = throwSocketErrorIfMinus1Retry name act +throwSocketErrorIfMinus1RetryMayBlockBut exempt name _ act+ = throwSocketErrorIfMinus1ButRetry exempt name act+ throwSocketErrorIfMinus1_ name act = do _ <- throwSocketErrorIfMinus1Retry name act return () -throwSocketErrorIfMinus1Retry name act = do+throwSocketErrorIfMinus1ButRetry :: (Eq a, Num a) =>+ (CInt -> Bool) -> String -> IO a -> IO a+throwSocketErrorIfMinus1ButRetry exempt name act = do r <- act if (r == -1) then do@@ -155,9 +181,14 @@ then throwSocketError name else return r' else- throwSocketError name+ if (exempt rc)+ then return r+ else throwSocketError name else return r +throwSocketErrorIfMinus1Retry+ = throwSocketErrorIfMinus1ButRetry (const False)+ throwSocketErrorCode name rc = do pstr <- c_getWSError rc str <- peekCString pstr@@ -177,6 +208,9 @@ throwSocketErrorIfMinus1RetryMayBlock name on_block act = throwErrnoIfMinus1RetryMayBlock name act on_block +throwSocketErrorIfMinus1RetryMayBlockBut _exempt name on_block act =+ throwErrnoIfMinus1RetryMayBlock name act on_block+ throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_@@ -194,6 +228,15 @@ throwSocketErrorWaitRead :: (Eq a, Num a) => Socket -> String -> IO a -> IO a throwSocketErrorWaitRead s name io = withFdSocket s $ \fd -> throwSocketErrorIfMinus1RetryMayBlock name+ (threadWaitRead $ fromIntegral fd) io++-- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with+-- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready,+-- and try again. If it fails with the error the user was expecting then+-- ignore the error+throwSocketErrorWaitReadBut :: (Eq a, Num a) => (CInt -> Bool) -> Socket -> String -> IO a -> IO a+throwSocketErrorWaitReadBut exempt s name io = withFdSocket s $ \fd ->+ throwSocketErrorIfMinus1RetryMayBlockBut exempt name (threadWaitRead $ fromIntegral fd) io -- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with
Network/Socket/Options.hsc view
@@ -1,25 +1,41 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-} #include "HsNet.h" ##include "HsNetDef.h" module Network.Socket.Options (- SocketOption(..)+ SocketOption(SockOpt+ ,UnsupportedSocketOption+ ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute+ ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline,TimeToLive+ ,MaxSegment,NoDelay,Cork,Linger,ReusePort+ ,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut+ ,UseLoopBack,UserTimeout,IPv6Only+ ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo+ ,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo+ ,CustomSockOpt) , isSupportedSocketOption+ , whenSupported , getSocketType , getSocketOption , setSocketOption- , c_getsockopt- , c_setsockopt+ , getSockOpt+ , setSockOpt ) where +import qualified Text.Read as P+ import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with) import Network.Socket.Imports import Network.Socket.Internal import Network.Socket.Types+import Network.Socket.ReadShow ----------------------------------------------------------------------------- -- Socket Properties@@ -28,155 +44,280 @@ -- -- The existence of a constructor does not imply that the relevant option -- is supported on your system: see 'isSupportedSocketOption'-data SocketOption- = Debug -- ^ SO_DEBUG- | ReuseAddr -- ^ SO_REUSEADDR- | Type -- ^ SO_TYPE- | SoError -- ^ SO_ERROR- | DontRoute -- ^ SO_DONTROUTE- | Broadcast -- ^ SO_BROADCAST- | SendBuffer -- ^ SO_SNDBUF- | RecvBuffer -- ^ SO_RCVBUF- | KeepAlive -- ^ SO_KEEPALIVE- | OOBInline -- ^ SO_OOBINLINE- | TimeToLive -- ^ IP_TTL- | MaxSegment -- ^ TCP_MAXSEG- | NoDelay -- ^ TCP_NODELAY- | Cork -- ^ TCP_CORK- | Linger -- ^ SO_LINGER: timeout in seconds, 0 means disabling/disabled.- | ReusePort -- ^ SO_REUSEPORT- | RecvLowWater -- ^ SO_RCVLOWAT- | SendLowWater -- ^ SO_SNDLOWAT- | RecvTimeOut -- ^ SO_RCVTIMEO: this does not work at this moment.- | SendTimeOut -- ^ SO_SNDTIMEO: this does not work at this moment.- | UseLoopBack -- ^ SO_USELOOPBACK- | UserTimeout -- ^ TCP_USER_TIMEOUT- | IPv6Only -- ^ IPV6_V6ONLY: don't use this on OpenBSD.- | CustomSockOpt (CInt, CInt)- deriving (Show, Typeable)+data SocketOption = SockOpt+#if __GLASGOW_HASKELL__ >= 806+ !CInt -- ^ Option Level+ !CInt -- ^ Option Name+#else+ !CInt -- Option Level+ !CInt -- Option Name+#endif+ deriving (Eq) -- | Does the 'SocketOption' exist on this system? isSupportedSocketOption :: SocketOption -> Bool-isSupportedSocketOption = isJust . packSocketOption+isSupportedSocketOption opt = opt /= SockOpt (-1) (-1) -- | Get the 'SocketType' of an active socket. -- -- Since: 3.0.1.0 getSocketType :: Socket -> IO SocketType-getSocketType s = (fromMaybe NoSocketType . unpackSocketType . fromIntegral)- <$> getSocketOption s Type+getSocketType s = unpackSocketType <$> getSockOpt s Type --- | For a socket option, return Just (level, value) where level is the--- corresponding C option level constant (e.g. SOL_SOCKET) and value is--- the option constant itself (e.g. SO_DEBUG)--- If either constant does not exist, return Nothing.-packSocketOption :: SocketOption -> Maybe (CInt, CInt)-packSocketOption so =- -- The Just here is a hack to disable GHC's overlapping pattern detection:- -- the problem is if all constants are present, the fallback pattern is- -- redundant, but if they aren't then it isn't. Hence we introduce an- -- extra pattern (Nothing) that can't possibly happen, so that the- -- fallback is always (in principle) necessary.- -- I feel a little bad for including this, but such are the sacrifices we- -- make while working with CPP - excluding the fallback pattern correctly- -- would be a serious nuisance.- -- (NB: comments elsewhere in this file refer to this one)- case Just so of+pattern UnsupportedSocketOption :: SocketOption+pattern UnsupportedSocketOption = SockOpt (-1) (-1)+ #ifdef SOL_SOCKET+-- | SO_DEBUG+pattern Debug :: SocketOption #ifdef SO_DEBUG- Just Debug -> Just ((#const SOL_SOCKET), (#const SO_DEBUG))+pattern Debug = SockOpt (#const SOL_SOCKET) (#const SO_DEBUG)+#else+pattern Debug = SockOpt (-1) (-1) #endif+-- | SO_REUSEADDR+pattern ReuseAddr :: SocketOption #ifdef SO_REUSEADDR- Just ReuseAddr -> Just ((#const SOL_SOCKET), (#const SO_REUSEADDR))+pattern ReuseAddr = SockOpt (#const SOL_SOCKET) (#const SO_REUSEADDR)+#else+pattern ReuseAddr = SockOpt (-1) (-1) #endif++-- | SO_DOMAIN, read-only+pattern SoDomain :: SocketOption+#ifdef SO_DOMAIN+pattern SoDomain = SockOpt (#const SOL_SOCKET) (#const SO_DOMAIN)+#else+pattern SoDomain = SockOpt (-1) (-1)+#endif++-- | SO_TYPE, read-only+pattern Type :: SocketOption #ifdef SO_TYPE- Just Type -> Just ((#const SOL_SOCKET), (#const SO_TYPE))+pattern Type = SockOpt (#const SOL_SOCKET) (#const SO_TYPE)+#else+pattern Type = SockOpt (-1) (-1) #endif++-- | SO_PROTOCOL, read-only+pattern SoProtocol :: SocketOption+#ifdef SO_PROTOCOL+pattern SoProtocol = SockOpt (#const SOL_SOCKET) (#const SO_PROTOCOL)+#else+pattern SoProtocol = SockOpt (-1) (-1)+#endif++-- | SO_ERROR+pattern SoError :: SocketOption #ifdef SO_ERROR- Just SoError -> Just ((#const SOL_SOCKET), (#const SO_ERROR))+pattern SoError = SockOpt (#const SOL_SOCKET) (#const SO_ERROR)+#else+pattern SoError = SockOpt (-1) (-1) #endif+-- | SO_DONTROUTE+pattern DontRoute :: SocketOption #ifdef SO_DONTROUTE- Just DontRoute -> Just ((#const SOL_SOCKET), (#const SO_DONTROUTE))+pattern DontRoute = SockOpt (#const SOL_SOCKET) (#const SO_DONTROUTE)+#else+pattern DontRoute = SockOpt (-1) (-1) #endif+-- | SO_BROADCAST+pattern Broadcast :: SocketOption #ifdef SO_BROADCAST- Just Broadcast -> Just ((#const SOL_SOCKET), (#const SO_BROADCAST))+pattern Broadcast = SockOpt (#const SOL_SOCKET) (#const SO_BROADCAST)+#else+pattern Broadcast = SockOpt (-1) (-1) #endif+-- | SO_SNDBUF+pattern SendBuffer :: SocketOption #ifdef SO_SNDBUF- Just SendBuffer -> Just ((#const SOL_SOCKET), (#const SO_SNDBUF))+pattern SendBuffer = SockOpt (#const SOL_SOCKET) (#const SO_SNDBUF)+#else+pattern SendBuffer = SockOpt (-1) (-1) #endif+-- | SO_RCVBUF+pattern RecvBuffer :: SocketOption #ifdef SO_RCVBUF- Just RecvBuffer -> Just ((#const SOL_SOCKET), (#const SO_RCVBUF))+pattern RecvBuffer = SockOpt (#const SOL_SOCKET) (#const SO_RCVBUF)+#else+pattern RecvBuffer = SockOpt (-1) (-1) #endif+-- | SO_KEEPALIVE+pattern KeepAlive :: SocketOption #ifdef SO_KEEPALIVE- Just KeepAlive -> Just ((#const SOL_SOCKET), (#const SO_KEEPALIVE))+pattern KeepAlive = SockOpt (#const SOL_SOCKET) (#const SO_KEEPALIVE)+#else+pattern KeepAlive = SockOpt (-1) (-1) #endif+-- | SO_OOBINLINE+pattern OOBInline :: SocketOption #ifdef SO_OOBINLINE- Just OOBInline -> Just ((#const SOL_SOCKET), (#const SO_OOBINLINE))+pattern OOBInline = SockOpt (#const SOL_SOCKET) (#const SO_OOBINLINE)+#else+pattern OOBInline = SockOpt (-1) (-1) #endif+-- | SO_LINGER: timeout in seconds, 0 means disabling/disabled.+pattern Linger :: SocketOption #ifdef SO_LINGER- Just Linger -> Just ((#const SOL_SOCKET), (#const SO_LINGER))+pattern Linger = SockOpt (#const SOL_SOCKET) (#const SO_LINGER)+#else+pattern Linger = SockOpt (-1) (-1) #endif+-- | SO_REUSEPORT+pattern ReusePort :: SocketOption #ifdef SO_REUSEPORT- Just ReusePort -> Just ((#const SOL_SOCKET), (#const SO_REUSEPORT))+pattern ReusePort = SockOpt (#const SOL_SOCKET) (#const SO_REUSEPORT)+#else+pattern ReusePort = SockOpt (-1) (-1) #endif+-- | SO_RCVLOWAT+pattern RecvLowWater :: SocketOption #ifdef SO_RCVLOWAT- Just RecvLowWater -> Just ((#const SOL_SOCKET), (#const SO_RCVLOWAT))+pattern RecvLowWater = SockOpt (#const SOL_SOCKET) (#const SO_RCVLOWAT)+#else+pattern RecvLowWater = SockOpt (-1) (-1) #endif+-- | SO_SNDLOWAT+pattern SendLowWater :: SocketOption #ifdef SO_SNDLOWAT- Just SendLowWater -> Just ((#const SOL_SOCKET), (#const SO_SNDLOWAT))+pattern SendLowWater = SockOpt (#const SOL_SOCKET) (#const SO_SNDLOWAT)+#else+pattern SendLowWater = SockOpt (-1) (-1) #endif+-- | SO_RCVTIMEO: this does not work at this moment.+pattern RecvTimeOut :: SocketOption #ifdef SO_RCVTIMEO- Just RecvTimeOut -> Just ((#const SOL_SOCKET), (#const SO_RCVTIMEO))+pattern RecvTimeOut = SockOpt (#const SOL_SOCKET) (#const SO_RCVTIMEO)+#else+pattern RecvTimeOut = SockOpt (-1) (-1) #endif+-- | SO_SNDTIMEO: this does not work at this moment.+pattern SendTimeOut :: SocketOption #ifdef SO_SNDTIMEO- Just SendTimeOut -> Just ((#const SOL_SOCKET), (#const SO_SNDTIMEO))+pattern SendTimeOut = SockOpt (#const SOL_SOCKET) (#const SO_SNDTIMEO)+#else+pattern SendTimeOut = SockOpt (-1) (-1) #endif+-- | SO_USELOOPBACK+pattern UseLoopBack :: SocketOption #ifdef SO_USELOOPBACK- Just UseLoopBack -> Just ((#const SOL_SOCKET), (#const SO_USELOOPBACK))+pattern UseLoopBack = SockOpt (#const SOL_SOCKET) (#const SO_USELOOPBACK)+#else+pattern UseLoopBack = SockOpt (-1) (-1) #endif #endif // SOL_SOCKET-#if HAVE_DECL_IPPROTO_IP-#ifdef IP_TTL- Just TimeToLive -> Just ((#const IPPROTO_IP), (#const IP_TTL))-#endif-#endif // HAVE_DECL_IPPROTO_IP+ #if HAVE_DECL_IPPROTO_TCP+-- | TCP_MAXSEG+pattern MaxSegment :: SocketOption #ifdef TCP_MAXSEG- Just MaxSegment -> Just ((#const IPPROTO_TCP), (#const TCP_MAXSEG))+pattern MaxSegment = SockOpt (#const IPPROTO_TCP) (#const TCP_MAXSEG)+#else+pattern MaxSegment = SockOpt (-1) (-1) #endif+-- | TCP_NODELAY+pattern NoDelay :: SocketOption #ifdef TCP_NODELAY- Just NoDelay -> Just ((#const IPPROTO_TCP), (#const TCP_NODELAY))+pattern NoDelay = SockOpt (#const IPPROTO_TCP) (#const TCP_NODELAY)+#else+pattern NoDelay = SockOpt (-1) (-1) #endif+-- | TCP_USER_TIMEOUT+pattern UserTimeout :: SocketOption #ifdef TCP_USER_TIMEOUT- Just UserTimeout -> Just ((#const IPPROTO_TCP), (#const TCP_USER_TIMEOUT))+pattern UserTimeout = SockOpt (#const IPPROTO_TCP) (#const TCP_USER_TIMEOUT)+#else+pattern UserTimeout = SockOpt (-1) (-1) #endif+-- | TCP_CORK+pattern Cork :: SocketOption #ifdef TCP_CORK- Just Cork -> Just ((#const IPPROTO_TCP), (#const TCP_CORK))+pattern Cork = SockOpt (#const IPPROTO_TCP) (#const TCP_CORK)+#else+pattern Cork = SockOpt (-1) (-1) #endif #endif // HAVE_DECL_IPPROTO_TCP++#if HAVE_DECL_IPPROTO_IP+-- | IP_TTL+pattern TimeToLive :: SocketOption+#ifdef IP_TTL+pattern TimeToLive = SockOpt (#const IPPROTO_IP) (#const IP_TTL)+#else+pattern TimeToLive = SockOpt (-1) (-1)+#endif+-- | Receiving IPv4 TTL.+pattern RecvIPv4TTL :: SocketOption+#ifdef IP_RECVTTL+pattern RecvIPv4TTL = SockOpt (#const IPPROTO_IP) (#const IP_RECVTTL)+#else+pattern RecvIPv4TTL = SockOpt (-1) (-1)+#endif+-- | Receiving IPv4 TOS.+pattern RecvIPv4TOS :: SocketOption+#ifdef IP_RECVTOS+pattern RecvIPv4TOS = SockOpt (#const IPPROTO_IP) (#const IP_RECVTOS)+#else+pattern RecvIPv4TOS = SockOpt (-1) (-1)+#endif+-- | Receiving IP_PKTINFO (struct in_pktinfo).+pattern RecvIPv4PktInfo :: SocketOption+#ifdef IP_RECVPKTINFO+pattern RecvIPv4PktInfo = SockOpt (#const IPPROTO_IP) (#const IP_RECVPKTINFO)+#elif defined(IP_PKTINFO)+pattern RecvIPv4PktInfo = SockOpt (#const IPPROTO_IP) (#const IP_PKTINFO)+#else+pattern RecvIPv4PktInfo = SockOpt (-1) (-1)+#endif+#endif // HAVE_DECL_IPPROTO_IP+ #if HAVE_DECL_IPPROTO_IPV6+-- | IPV6_V6ONLY: don't use this on OpenBSD.+pattern IPv6Only :: SocketOption #if HAVE_DECL_IPV6_V6ONLY- Just IPv6Only -> Just ((#const IPPROTO_IPV6), (#const IPV6_V6ONLY))+pattern IPv6Only = SockOpt (#const IPPROTO_IPV6) (#const IPV6_V6ONLY)+#else+pattern IPv6Only = SockOpt (-1) (-1) #endif+-- | Receiving IPv6 hop limit.+pattern RecvIPv6HopLimit :: SocketOption+#ifdef IPV6_RECVHOPLIMIT+pattern RecvIPv6HopLimit = SockOpt (#const IPPROTO_IPV6) (#const IPV6_RECVHOPLIMIT)+#else+pattern RecvIPv6HopLimit = SockOpt (-1) (-1)+#endif+-- | Receiving IPv6 traffic class.+pattern RecvIPv6TClass :: SocketOption+#ifdef IPV6_RECVTCLASS+pattern RecvIPv6TClass = SockOpt (#const IPPROTO_IPV6) (#const IPV6_RECVTCLASS)+#else+pattern RecvIPv6TClass = SockOpt (-1) (-1)+#endif+-- | Receiving IPV6_PKTINFO (struct in6_pktinfo).+pattern RecvIPv6PktInfo :: SocketOption+#ifdef IPV6_RECVPKTINFO+pattern RecvIPv6PktInfo = SockOpt (#const IPPROTO_IPV6) (#const IPV6_RECVPKTINFO)+#elif defined(IPV6_PKTINFO)+pattern RecvIPv6PktInfo = SockOpt (#const IPPROTO_IPV6) (#const IPV6_PKTINFO)+#else+pattern RecvIPv6PktInfo = SockOpt (-1) (-1)+#endif #endif // HAVE_DECL_IPPROTO_IPV6- Just (CustomSockOpt opt) -> Just opt- _ -> Nothing --- | Return the option level and option value if they exist,--- otherwise throw an error that begins "Network.Socket." ++ the String--- parameter-packSocketOption' :: String -> SocketOption -> IO (CInt, CInt)-packSocketOption' caller so = maybe err return (packSocketOption so)- where- err = ioError . userError . concat $ ["Network.Socket.", caller,- ": socket option ", show so, " unsupported on this system"]+pattern CustomSockOpt :: (CInt, CInt) -> SocketOption+pattern CustomSockOpt xy <- ((\(SockOpt x y) -> (x, y)) -> xy)+ where+ CustomSockOpt (x, y) = SockOpt x y +#if __GLASGOW_HASKELL__ >= 806+{-# COMPLETE CustomSockOpt #-}+#endif #ifdef SO_LINGER data StructLinger = StructLinger CInt CInt instance Storable StructLinger where- sizeOf _ = (#const sizeof(struct linger))- alignment _ = alignment (undefined :: CInt)+ sizeOf _ = (#const sizeof(struct linger))+ alignment _ = alignment (0 :: CInt) peek p = do onoff <- (#peek struct linger, l_onoff) p@@ -188,6 +329,13 @@ (#poke struct linger, l_linger) p linger #endif +-- | Execute the given action only when the specified socket option is+-- supported. Any return value is ignored.+whenSupported :: SocketOption -> IO a -> IO ()+whenSupported s action+ | isSupportedSocketOption s = action >> return ()+ | otherwise = return ()+ -- | Set a socket option that expects an Int value. -- There is currently no API to set e.g. the timeval socket options setSocketOption :: Socket@@ -195,51 +343,102 @@ -> Int -- Option Value -> IO () #ifdef SO_LINGER-setSocketOption s Linger v = do- (level, opt) <- packSocketOption' "setSocketOption" Linger- let arg = if v == 0 then StructLinger 0 0 else StructLinger 1 (fromIntegral v)- with arg $ \ptr_arg -> void $ do- let ptr = ptr_arg :: Ptr StructLinger- sz = fromIntegral $ sizeOf (undefined :: StructLinger)- withFdSocket s $ \fd ->- throwSocketErrorIfMinus1_ "Network.Socket.setSocketOption" $- c_setsockopt fd level opt ptr sz+setSocketOption s so@Linger v = do+ let arg = if v == 0 then StructLinger 0 0 else StructLinger 1 (fromIntegral v)+ setSockOpt s so arg #endif-setSocketOption s so v = do- (level, opt) <- packSocketOption' "setSocketOption" so- with (fromIntegral v) $ \ptr_v -> void $ do- let ptr = ptr_v :: Ptr CInt- sz = fromIntegral $ sizeOf (undefined :: CInt)- withFdSocket s $ \fd ->- throwSocketErrorIfMinus1_ "Network.Socket.setSocketOption" $- c_setsockopt fd level opt ptr sz+setSocketOption s sa v = setSockOpt s sa (fromIntegral v :: CInt) +-- | Set a socket option.+setSockOpt :: Storable a+ => Socket+ -> SocketOption+ -> a+ -> IO ()+setSockOpt s (SockOpt level opt) v = do+ with v $ \ptr -> void $ do+ let sz = fromIntegral $ sizeOf v+ withFdSocket s $ \fd ->+ throwSocketErrorIfMinus1_ "Network.Socket.setSockOpt" $+ c_setsockopt fd level opt ptr sz+ -- | Get a socket option that gives an Int value. -- There is currently no API to get e.g. the timeval socket options getSocketOption :: Socket -> SocketOption -- Option Name -> IO Int -- Option Value #ifdef SO_LINGER-getSocketOption s Linger = do- (level, opt) <- packSocketOption' "getSocketOption" Linger- alloca $ \ptr_v -> do- let ptr = ptr_v :: Ptr StructLinger- sz = fromIntegral $ sizeOf (undefined :: StructLinger)- withFdSocket s $ \fd -> with sz $ \ptr_sz -> do- throwSocketErrorIfMinus1Retry_ "Network.Socket.getSocketOption" $- c_getsockopt fd level opt ptr ptr_sz- StructLinger onoff linger <- peek ptr- return $ fromIntegral $ if onoff == 0 then 0 else linger+getSocketOption s so@Linger = do+ StructLinger onoff linger <- getSockOpt s so+ return $ fromIntegral $ if onoff == 0 then 0 else linger #endif getSocketOption s so = do- (level, opt) <- packSocketOption' "getSocketOption" so- alloca $ \ptr_v -> do- let ptr = ptr_v :: Ptr CInt- sz = fromIntegral $ sizeOf (undefined :: CInt)- withFdSocket s $ \fd -> with sz $ \ptr_sz -> do- throwSocketErrorIfMinus1Retry_ "Network.Socket.getSocketOption" $- c_getsockopt fd level opt ptr ptr_sz- fromIntegral <$> peek ptr+ n :: CInt <- getSockOpt s so+ return $ fromIntegral n++-- | Get a socket option.+getSockOpt :: forall a . Storable a+ => Socket+ -> SocketOption -- Option Name+ -> IO a -- Option Value+getSockOpt s (SockOpt level opt) = do+ alloca $ \ptr -> do+ let sz = fromIntegral $ sizeOf (undefined :: a)+ withFdSocket s $ \fd -> with sz $ \ptr_sz -> do+ throwSocketErrorIfMinus1Retry_ "Network.Socket.getSockOpt" $+ c_getsockopt fd level opt ptr ptr_sz+ peek ptr+++socketOptionBijection :: Bijection SocketOption String+socketOptionBijection =+ [ (UnsupportedSocketOption, "UnsupportedSocketOption")+ , (Debug, "Debug")+ , (ReuseAddr, "ReuseAddr")+ , (SoDomain, "SoDomain")+ , (Type, "Type")+ , (SoProtocol, "SoProtocol")+ , (SoError, "SoError")+ , (DontRoute, "DontRoute")+ , (Broadcast, "Broadcast")+ , (SendBuffer, "SendBuffer")+ , (RecvBuffer, "RecvBuffer")+ , (KeepAlive, "KeepAlive")+ , (OOBInline, "OOBInline")+ , (Linger, "Linger")+ , (ReusePort, "ReusePort")+ , (RecvLowWater, "RecvLowWater")+ , (SendLowWater, "SendLowWater")+ , (RecvTimeOut, "RecvTimeOut")+ , (SendTimeOut, "SendTimeOut")+ , (UseLoopBack, "UseLoopBack")+ , (MaxSegment, "MaxSegment")+ , (NoDelay, "NoDelay")+ , (UserTimeout, "UserTimeout")+ , (Cork, "Cork")+ , (TimeToLive, "TimeToLive")+ , (RecvIPv4TTL, "RecvIPv4TTL")+ , (RecvIPv4TOS, "RecvIPv4TOS")+ , (RecvIPv4PktInfo, "RecvIPv4PktInfo")+ , (IPv6Only, "IPv6Only")+ , (RecvIPv6HopLimit, "RecvIPv6HopLimit")+ , (RecvIPv6TClass, "RecvIPv6TClass")+ , (RecvIPv6PktInfo, "RecvIPv6PktInfo")+ ]++instance Show SocketOption where+ showsPrec = bijectiveShow socketOptionBijection def+ where+ defname = "SockOpt"+ unwrap = \(CustomSockOpt nm) -> nm+ def = defShow defname unwrap showIntInt+++instance Read SocketOption where+ readPrec = bijectiveRead socketOptionBijection def+ where+ defname = "SockOpt"+ def = defRead defname CustomSockOpt readIntInt foreign import CALLCONV unsafe "getsockopt" c_getsockopt :: CInt -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt
+ Network/Socket/Posix/Cmsg.hsc view
@@ -0,0 +1,257 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Network.Socket.Posix.Cmsg where++#include "HsNet.h"++#include <sys/types.h>+#include <sys/socket.h>++import Data.ByteString.Internal+import Foreign.ForeignPtr+import System.IO.Unsafe (unsafeDupablePerformIO)+import System.Posix.Types (Fd(..))++import Network.Socket.Imports+import Network.Socket.Types+import Network.Socket.ReadShow++import qualified Text.Read as P++-- | Control message (ancillary data) including a pair of level and type.+data Cmsg = Cmsg {+ cmsgId :: !CmsgId+ , cmsgData :: !ByteString+ } deriving (Eq, Show)++----------------------------------------------------------------++-- | Identifier of control message (ancillary data).+data CmsgId = CmsgId {+ cmsgLevel :: !CInt+ , cmsgType :: !CInt+ } deriving (Eq)++-- | Unsupported identifier+pattern UnsupportedCmsgId :: CmsgId+pattern UnsupportedCmsgId = CmsgId (-1) (-1)++-- | The identifier for 'IPv4TTL'.+pattern CmsgIdIPv4TTL :: CmsgId+#if defined(darwin_HOST_OS) || defined(freebsd_HOST_OS)+pattern CmsgIdIPv4TTL = CmsgId (#const IPPROTO_IP) (#const IP_RECVTTL)+#else+pattern CmsgIdIPv4TTL = CmsgId (#const IPPROTO_IP) (#const IP_TTL)+#endif++-- | The identifier for 'IPv6HopLimit'.+pattern CmsgIdIPv6HopLimit :: CmsgId+pattern CmsgIdIPv6HopLimit = CmsgId (#const IPPROTO_IPV6) (#const IPV6_HOPLIMIT)++-- | The identifier for 'IPv4TOS'.+pattern CmsgIdIPv4TOS :: CmsgId+#if defined(darwin_HOST_OS) || defined(freebsd_HOST_OS)+pattern CmsgIdIPv4TOS = CmsgId (#const IPPROTO_IP) (#const IP_RECVTOS)+#else+pattern CmsgIdIPv4TOS = CmsgId (#const IPPROTO_IP) (#const IP_TOS)+#endif++-- | The identifier for 'IPv6TClass'.+pattern CmsgIdIPv6TClass :: CmsgId+pattern CmsgIdIPv6TClass = CmsgId (#const IPPROTO_IPV6) (#const IPV6_TCLASS)++-- | The identifier for 'IPv4PktInfo'.+pattern CmsgIdIPv4PktInfo :: CmsgId+#if defined(IP_PKTINFO)+pattern CmsgIdIPv4PktInfo = CmsgId (#const IPPROTO_IP) (#const IP_PKTINFO)+#else+pattern CmsgIdIPv4PktInfo = CmsgId (-1) (-1)+#endif++-- | The identifier for 'IPv6PktInfo'.+pattern CmsgIdIPv6PktInfo :: CmsgId+#if defined(IPV6_PKTINFO)+pattern CmsgIdIPv6PktInfo = CmsgId (#const IPPROTO_IPV6) (#const IPV6_PKTINFO)+#else+pattern CmsgIdIPv6PktInfo = CmsgId (-1) (-1)+#endif++-- | The identifier for 'Fd'.+pattern CmsgIdFd :: CmsgId+pattern CmsgIdFd = CmsgId (#const SOL_SOCKET) (#const SCM_RIGHTS)++----------------------------------------------------------------++-- | Locate a control message of the given type in a list of control+-- messages. The following shows an example usage:+--+-- > (lookupCmsg CmsgIdIPv4TOS cmsgs >>= decodeCmsg) :: Maybe IPv4TOS+lookupCmsg :: CmsgId -> [Cmsg] -> Maybe Cmsg+lookupCmsg cid cmsgs = find (\cmsg -> cmsgId cmsg == cid) cmsgs++-- | Filtering control message.+filterCmsg :: CmsgId -> [Cmsg] -> [Cmsg]+filterCmsg cid cmsgs = filter (\cmsg -> cmsgId cmsg == cid) cmsgs++----------------------------------------------------------------++-- | Control message type class.+-- Each control message type has a numeric 'CmsgId' and a 'Storable'+-- data representation.+class Storable a => ControlMessage a where+ controlMessageId :: CmsgId++encodeCmsg :: forall a . ControlMessage a => a -> Cmsg+encodeCmsg x = unsafeDupablePerformIO $ do+ bs <- create siz $ \p0 -> do+ let p = castPtr p0+ poke p x+ let cmsid = controlMessageId @a+ return $ Cmsg cmsid bs+ where+ siz = sizeOf x++decodeCmsg :: forall a . (ControlMessage a, Storable a) => Cmsg -> Maybe a+decodeCmsg (Cmsg cmsid (PS fptr off len))+ | cid /= cmsid = Nothing+ | len < siz = Nothing+ | otherwise = unsafeDupablePerformIO $ withForeignPtr fptr $ \p0 -> do+ let p = castPtr (p0 `plusPtr` off)+ Just <$> peek p+ where+ cid = controlMessageId @a+ siz = sizeOf (undefined :: a)++----------------------------------------------------------------++-- | Time to live of IPv4.+#if defined(darwin_HOST_OS) || defined(freebsd_HOST_OS)+newtype IPv4TTL = IPv4TTL CChar deriving (Eq, Show, Storable)+#else+newtype IPv4TTL = IPv4TTL CInt deriving (Eq, Show, Storable)+#endif++instance ControlMessage IPv4TTL where+ controlMessageId = CmsgIdIPv4TTL++----------------------------------------------------------------++-- | Hop limit of IPv6.+newtype IPv6HopLimit = IPv6HopLimit CInt deriving (Eq, Show, Storable)++instance ControlMessage IPv6HopLimit where+ controlMessageId = CmsgIdIPv6HopLimit++----------------------------------------------------------------++-- | TOS of IPv4.+newtype IPv4TOS = IPv4TOS CChar deriving (Eq, Show, Storable)++instance ControlMessage IPv4TOS where+ controlMessageId = CmsgIdIPv4TOS++----------------------------------------------------------------++-- | Traffic class of IPv6.+newtype IPv6TClass = IPv6TClass CInt deriving (Eq, Show, Storable)++instance ControlMessage IPv6TClass where+ controlMessageId = CmsgIdIPv6TClass++----------------------------------------------------------------++-- | Network interface ID and local IPv4 address.+data IPv4PktInfo = IPv4PktInfo Int HostAddress HostAddress deriving (Eq)++instance Show IPv4PktInfo where+ show (IPv4PktInfo n sa ha) = "IPv4PktInfo " ++ show n ++ " " ++ show (hostAddressToTuple sa) ++ " " ++ show (hostAddressToTuple ha)++instance ControlMessage IPv4PktInfo where+ controlMessageId = CmsgIdIPv4PktInfo++instance Storable IPv4PktInfo where+#if defined (IP_PKTINFO)+ sizeOf _ = (#size struct in_pktinfo)+ alignment _ = alignment (0 :: CInt)+ poke p (IPv4PktInfo n sa ha) = do+ (#poke struct in_pktinfo, ipi_ifindex) p (fromIntegral n :: CInt)+ (#poke struct in_pktinfo, ipi_spec_dst) p sa+ (#poke struct in_pktinfo, ipi_addr) p ha+ peek p = do+ n <- (#peek struct in_pktinfo, ipi_ifindex) p+ sa <- (#peek struct in_pktinfo, ipi_spec_dst) p+ ha <- (#peek struct in_pktinfo, ipi_addr) p+ return $ IPv4PktInfo n sa ha+#else+ sizeOf _ = 0+ alignment _ = 1+ poke _ _ = error "Unsupported control message type"+ peek _ = error "Unsupported control message type"+#endif++----------------------------------------------------------------++-- | Network interface ID and local IPv4 address.+data IPv6PktInfo = IPv6PktInfo Int HostAddress6 deriving (Eq)++instance Show IPv6PktInfo where+ show (IPv6PktInfo n ha6) = "IPv6PktInfo " ++ show n ++ " " ++ show (hostAddress6ToTuple ha6)++instance ControlMessage IPv6PktInfo where+ controlMessageId = CmsgIdIPv6PktInfo++instance Storable IPv6PktInfo where+#if defined (IPV6_PKTINFO)+ sizeOf _ = (#size struct in6_pktinfo)+ alignment _ = alignment (0 :: CInt)+ poke p (IPv6PktInfo n ha6) = do+ (#poke struct in6_pktinfo, ipi6_ifindex) p (fromIntegral n :: CInt)+ (#poke struct in6_pktinfo, ipi6_addr) p (In6Addr ha6)+ peek p = do+ In6Addr ha6 <- (#peek struct in6_pktinfo, ipi6_addr) p+ n :: CInt <- (#peek struct in6_pktinfo, ipi6_ifindex) p+ return $ IPv6PktInfo (fromIntegral n) ha6+#else+ sizeOf _ = 0+ alignment _ = 1+ poke _ _ = error "Unsupported control message type"+ peek _ = error "Unsupported control message type"+#endif++----------------------------------------------------------------++instance ControlMessage Fd where+ controlMessageId = CmsgIdFd++cmsgIdBijection :: Bijection CmsgId String+cmsgIdBijection =+ [ (UnsupportedCmsgId, "UnsupportedCmsgId")+ , (CmsgIdIPv4TTL, "CmsgIdIPv4TTL")+ , (CmsgIdIPv6HopLimit, "CmsgIdIPv6HopLimit")+ , (CmsgIdIPv4TOS, "CmsgIdIPv4TOS")+ , (CmsgIdIPv6TClass, "CmsgIdIPv6TClass")+ , (CmsgIdIPv4PktInfo, "CmsgIdIPv4PktInfo")+ , (CmsgIdIPv6PktInfo, "CmsgIdIPv6PktInfo")+ , (CmsgIdFd, "CmsgIdFd")+ ]++instance Show CmsgId where+ showsPrec = bijectiveShow cmsgIdBijection def+ where+ defname = "CmsgId"+ unId = \(CmsgId l t) -> (l,t)+ def = defShow defname unId showIntInt++instance Read CmsgId where+ readPrec = bijectiveRead cmsgIdBijection def+ where+ defname = "CmsgId"+ def = defRead defname (uncurry CmsgId) readIntInt++
+ Network/Socket/Posix/CmsgHdr.hsc view
@@ -0,0 +1,102 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++#include "HsNet.h"++module Network.Socket.Posix.CmsgHdr (+ Cmsg(..)+ , withCmsgs+ , parseCmsgs+ ) where++#include <sys/types.h>+#include <sys/socket.h>++import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.ForeignPtr+import qualified Data.ByteString as B+import Data.ByteString.Internal++import Network.Socket.Imports+import Network.Socket.Posix.Cmsg+import Network.Socket.Posix.MsgHdr+import Network.Socket.Types++data CmsgHdr = CmsgHdr {+ cmsgHdrLen :: !CInt+ , cmsgHdrLevel :: !CInt+ , cmsgHdrType :: !CInt+ } deriving (Eq, Show)++instance Storable CmsgHdr where+ sizeOf _ = (#size struct cmsghdr)+ alignment _ = alignment (0 :: CInt)++ peek p = do+ len <- (#peek struct cmsghdr, cmsg_len) p+ lvl <- (#peek struct cmsghdr, cmsg_level) p+ typ <- (#peek struct cmsghdr, cmsg_type) p+ return $ CmsgHdr len lvl typ++ poke p (CmsgHdr len lvl typ) = do+ zeroMemory p (#size struct cmsghdr)+ (#poke struct cmsghdr, cmsg_len) p len+ (#poke struct cmsghdr, cmsg_level) p lvl+ (#poke struct cmsghdr, cmsg_type) p typ++withCmsgs :: [Cmsg] -> (Ptr CmsgHdr -> Int -> IO a) -> IO a+withCmsgs cmsgs0 action+ | total == 0 = action nullPtr 0+ | otherwise = allocaBytes total $ \ctrlPtr -> do+ loop ctrlPtr cmsgs0 spaces+ action ctrlPtr total+ where+ loop ctrlPtr (cmsg:cmsgs) (s:ss) = do+ toCmsgHdr cmsg ctrlPtr+ let nextPtr = ctrlPtr `plusPtr` s+ loop nextPtr cmsgs ss+ loop _ _ _ = return ()+ cmsg_space = fromIntegral . c_cmsg_space . fromIntegral+ spaces = map (cmsg_space . B.length . cmsgData) cmsgs0+ total = sum spaces++toCmsgHdr :: Cmsg -> Ptr CmsgHdr -> IO ()+toCmsgHdr (Cmsg (CmsgId lvl typ) (PS fptr off len)) ctrlPtr = do+ poke ctrlPtr $ CmsgHdr (c_cmsg_len (fromIntegral len)) lvl typ+ withForeignPtr fptr $ \src0 -> do+ let src = src0 `plusPtr` off+ dst <- c_cmsg_data ctrlPtr+ memcpy dst src len++parseCmsgs :: SocketAddress sa => Ptr (MsgHdr sa) -> IO [Cmsg]+parseCmsgs msgptr = do+ ptr <- c_cmsg_firsthdr msgptr+ loop ptr id+ where+ loop ptr build+ | ptr == nullPtr = return $ build []+ | otherwise = do+ cmsg <- fromCmsgHdr ptr+ nextPtr <- c_cmsg_nxthdr msgptr ptr+ loop nextPtr (build . (cmsg :))++fromCmsgHdr :: Ptr CmsgHdr -> IO Cmsg+fromCmsgHdr ptr = do+ CmsgHdr len lvl typ <- peek ptr+ src <- c_cmsg_data ptr+ let siz = fromIntegral len - (src `minusPtr` ptr)+ Cmsg (CmsgId lvl typ) <$> create (fromIntegral siz) (\dst -> memcpy dst src siz)++foreign import ccall unsafe "cmsg_firsthdr"+ c_cmsg_firsthdr :: Ptr (MsgHdr sa) -> IO (Ptr CmsgHdr)++foreign import ccall unsafe "cmsg_nxthdr"+ c_cmsg_nxthdr :: Ptr (MsgHdr sa) -> Ptr CmsgHdr -> IO (Ptr CmsgHdr)++foreign import ccall unsafe "cmsg_data"+ c_cmsg_data :: Ptr CmsgHdr -> IO (Ptr Word8)++foreign import ccall unsafe "cmsg_space"+ c_cmsg_space :: CInt -> CInt++foreign import ccall unsafe "cmsg_len"+ c_cmsg_len :: CInt -> CInt
+ Network/Socket/Posix/IOVec.hsc view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++-- | Support module for the POSIX writev system call.+module Network.Socket.Posix.IOVec+ ( IOVec(..)+ , withIOVec+ ) where++import Foreign.Marshal.Array (allocaArray)++import Network.Socket.Imports++#include <sys/types.h>+#include <sys/uio.h>++data IOVec = IOVec+ { iovBase :: !(Ptr Word8)+ , iovLen :: !CSize+ }++instance Storable IOVec where+ sizeOf _ = (#const sizeof(struct iovec))+ alignment _ = alignment (0 :: CInt)++ peek p = do+ base <- (#peek struct iovec, iov_base) p+ len <- (#peek struct iovec, iov_len) p+ return $ IOVec base len++ poke p iov = do+ (#poke struct iovec, iov_base) p (iovBase iov)+ (#poke struct iovec, iov_len) p (iovLen iov)++-- | @withIOVec cs f@ executes the computation @f@, passing as argument a pair+-- consisting of a pointer to a temporarily allocated array of pointers to+-- IOVec made from @cs@ and the number of pointers (@length cs@).+-- /Unix only/.+withIOVec :: [(Ptr Word8, Int)] -> ((Ptr IOVec, Int) -> IO a) -> IO a+withIOVec [] f = f (nullPtr, 0)+withIOVec cs f =+ allocaArray csLen $ \aPtr -> do+ zipWithM_ pokeIov (ptrs aPtr) cs+ f (aPtr, csLen)+ where+ csLen = length cs+ ptrs = iterate (`plusPtr` sizeOf (IOVec nullPtr 0))+ pokeIov ptr (sPtr, sLen) = poke ptr $ IOVec sPtr (fromIntegral sLen)
+ Network/Socket/Posix/MsgHdr.hsc view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++-- | Support module for the POSIX 'sendmsg' system call.+module Network.Socket.Posix.MsgHdr+ ( MsgHdr(..)+ ) where++#include <sys/types.h>+#include <sys/socket.h>++import Network.Socket.Imports+import Network.Socket.Internal (zeroMemory)++import Network.Socket.Posix.IOVec (IOVec)++data MsgHdr sa = MsgHdr+ { msgName :: !(Ptr sa)+ , msgNameLen :: !CUInt+ , msgIov :: !(Ptr IOVec)+ , msgIovLen :: !CSize+ , msgCtrl :: !(Ptr Word8)+ , msgCtrlLen :: !CInt+ , msgFlags :: !CInt+ }++instance Storable (MsgHdr sa) where+ sizeOf _ = (#const sizeof(struct msghdr))+ alignment _ = alignment (0 :: CInt)++ peek p = do+ name <- (#peek struct msghdr, msg_name) p+ nameLen <- (#peek struct msghdr, msg_namelen) p+ iov <- (#peek struct msghdr, msg_iov) p+ iovLen <- (#peek struct msghdr, msg_iovlen) p+ ctrl <- (#peek struct msghdr, msg_control) p+ ctrlLen <- (#peek struct msghdr, msg_controllen) p+ flags <- (#peek struct msghdr, msg_flags) p+ return $ MsgHdr name nameLen iov iovLen ctrl ctrlLen flags++ poke p mh = do+ -- We need to zero the msg_control, msg_controllen, and msg_flags+ -- fields, but they only exist on some platforms (e.g. not on+ -- Solaris). Instead of using CPP, we zero the entire struct.+ zeroMemory p (#const sizeof(struct msghdr))+ (#poke struct msghdr, msg_name) p (msgName mh)+ (#poke struct msghdr, msg_namelen) p (msgNameLen mh)+ (#poke struct msghdr, msg_iov) p (msgIov mh)+ (#poke struct msghdr, msg_iovlen) p (msgIovLen mh)+ (#poke struct msghdr, msg_control) p (msgCtrl mh)+ (#poke struct msghdr, msg_controllen) p (msgCtrlLen mh)+ (#poke struct msghdr, msg_flags) p (msgFlags mh)
+ Network/Socket/ReadShow.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+++module Network.Socket.ReadShow where++import Text.Read ((<++))+import qualified Text.Read as P+import qualified Text.Read.Lex as P+import Control.Monad (mzero)++-- type alias for individual correspondences of a (possibly partial) bijection+type Pair a b = (a, b)++-- | helper function for equality on first tuple element+{-# INLINE eqFst #-}+eqFst :: Eq a => a -> (a, b) -> Bool+eqFst x = \(x',_) -> x' == x++-- | helper function for equality on snd tuple element+{-# INLINE eqSnd #-}+eqSnd :: Eq b => b -> (a, b) -> Bool+eqSnd y = \(_,y') -> y' == y+++-- | Unified automorphic involution over @Either a b@ that converts between+-- LHS and RHS elements of a list of @Pair a b@ mappings and is the identity+-- function if no matching pair is found+--+-- If list contains duplicate matches, short-circuits to the first matching @Pair@+lookBetween :: (Eq a, Eq b) => [Pair a b] -> Either a b -> Either a b+lookBetween ps = \case+ Left x | (_,y):_ <- filter (eqFst x) ps -> Right y+ Right y | (x,_):_ <- filter (eqSnd y) ps -> Left x+ z -> z++-- Type alias for partial bijections between two types, consisting of a list+-- of individual correspondences that are checked in order and short-circuit+-- on first match+--+-- Depending on how this is used, may not actually be a true bijection over+-- the partial types, as no overlap-checking is currently implemented. If+-- overlaps are unavoidable, the canonical short-circuit pair should appear+-- first to avoid round-trip inconsistencies.+type Bijection a b = [Pair a b]++-- | Helper function for prefixing an optional constructor name before arbitrary values,+-- which only enforces high precedence on subsequent output if the constructor name is not+-- blank and space-separates for non-blank constructor names+namePrefix :: Int -> String -> (Int -> b -> ShowS) -> b -> ShowS+namePrefix i name f x+ | null name = f i x+ | otherwise = showParen (i > app_prec) $ showString name . showChar ' ' . f (app_prec+1) x+{-# INLINE namePrefix #-}++-- | Helper function for defining bijective Show instances that represents+-- a common use-case where a constructor (or constructor-like pattern) name+-- (optionally) precedes an internal value with a separate show function+defShow :: Eq a => String -> (a -> b) -> (Int -> b -> ShowS) -> (Int -> a -> ShowS)+defShow name unwrap shoPrec = \i x -> namePrefix i name shoPrec (unwrap x)+{-# INLINE defShow #-}++-- Helper function for stripping an optional constructor-name prefix before parsing+-- an arbitrary value, which only consumes an extra token and increases precedence+-- if the provided name prefix is non-blank+expectPrefix :: String -> P.ReadPrec a -> P.ReadPrec a+expectPrefix name pars+ | null name = pars+ | otherwise = do+ P.lift $ P.expect $ P.Ident name+ P.step pars+{-# INLINE expectPrefix #-}++-- | Helper function for defining bijective Read instances that represent a+-- common use case where a constructor (or constructor-like pattern) name+-- (optionally) precedes an internal value with a separate parse function+defRead :: Eq a => String -> (b -> a) -> P.ReadPrec b -> P.ReadPrec a+defRead name wrap redPrec = expectPrefix name $ wrap <$> redPrec+{-# INLINE defRead #-}++-- | Alias for showsPrec that pairs well with `_readInt`+_showInt :: (Show a) => Int -> a -> ShowS+_showInt = showsPrec+{-# INLINE _showInt #-}++-- | More descriptive alias for `safeInt`+_readInt :: (Bounded a, Integral a) => P.ReadPrec a+_readInt = safeInt+{-# INLINE _readInt #-}++-- | show two elements of a tuple separated by a space character+-- inverse function to readIntInt when used on integer-like values+showIntInt :: (Show a, Show b) => Int -> (a, b) -> ShowS+showIntInt i (x, y) = _showInt i x . showChar ' ' . _showInt i y+{-# INLINE showIntInt #-}++-- | consume and return two integer-like values from two consecutive lexical tokens+readIntInt :: (Bounded a, Integral a, Bounded b, Integral b) => P.ReadPrec (a, b)+readIntInt = do+ x <- _readInt+ y <- _readInt+ return (x, y)+{-# INLINE readIntInt #-}++bijectiveShow :: (Eq a) => Bijection a String -> (Int -> a -> ShowS) -> (Int -> a -> ShowS)+bijectiveShow bi def = \i x ->+ case lookBetween bi (Left x) of+ Right y -> showString y+ _ -> def i x++bijectiveRead :: (Eq a) => Bijection a String -> P.ReadPrec a -> P.ReadPrec a+bijectiveRead bi def = P.parens $ bijective <++ def+ where+ bijective = do+ (P.Ident y) <- P.lexP+ case lookBetween bi (Right y) of+ Left x -> return x+ _ -> mzero++app_prec :: Int+app_prec = 10+{-# INLINE app_prec #-}++-- Parse integral values with type-specific overflow and underflow bounds-checks+safeInt :: forall a. (Bounded a, Integral a) => P.ReadPrec a+safeInt = do+ i <- signed+ if (i >= fromIntegral (minBound :: a) && i <= fromIntegral (maxBound :: a))+ then return $ fromIntegral i+ else mzero+ where+ signed :: P.ReadPrec Integer+ signed = P.readPrec
Network/Socket/Shutdown.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} #include "HsNetDef.h" @@ -13,11 +12,6 @@ import Foreign.Marshal.Alloc (mallocBytes, free) import Control.Concurrent (threadDelay)-#if !defined(mingw32_HOST_OS)-import Control.Concurrent (putMVar, takeMVar, newEmptyMVar)-import qualified GHC.Event as Ev-import System.Posix.Types (Fd(..))-#endif import Network.Socket.Buffer import Network.Socket.Imports@@ -27,7 +21,6 @@ data ShutdownCmd = ShutdownReceive | ShutdownSend | ShutdownBoth- deriving Typeable sdownCmdToInt :: ShutdownCmd -> CInt sdownCmdToInt ShutdownReceive = 0@@ -47,10 +40,6 @@ foreign import CALLCONV unsafe "shutdown" c_shutdown :: CInt -> CInt -> IO CInt -#if !defined(mingw32_HOST_OS)-data Wait = MoreData | TimeoutTripped-#endif- -- | Closing a socket gracefully. -- This sends TCP FIN and check if TCP FIN is received from the peer. -- The second argument is time out to receive TCP FIN in millisecond.@@ -64,19 +53,13 @@ -- Sending TCP FIN. shutdown s ShutdownSend -- Waiting TCP FIN.-#if defined(mingw32_HOST_OS)- recvEOFloop-#else- mevmgr <- Ev.getSystemEventManager- case mevmgr of- Nothing -> recvEOFloop -- non-threaded RTS- Just evmgr -> recvEOFev evmgr-#endif+ E.bracket (mallocBytes bufSize) free $ \buf -> do+ {-# SCC "" #-} recvEOFloop buf -- milliseconds. Taken from BSD fast clock value. clock = 200- recvEOFloop = E.bracket (mallocBytes bufSize) free $ loop 0+ recvEOFloop buf = loop 0 where- loop delay buf = do+ loop delay = do -- We don't check the (positive) length. -- In normal case, it's 0. That is, only FIN is received. -- In error cases, data is available. But there is no@@ -86,40 +69,7 @@ let delay' = delay + clock when (r == -1 && delay' < tmout) $ do threadDelay (clock * 1000)- loop delay' buf-#if !defined(mingw32_HOST_OS)- recvEOFev evmgr = do- tmmgr <- Ev.getSystemTimerManager- mvar <- newEmptyMVar- E.bracket (register evmgr tmmgr mvar) (unregister evmgr tmmgr) $ \_ -> do- wait <- takeMVar mvar- case wait of- TimeoutTripped -> return ()- -- We don't check the (positive) length.- -- In normal case, it's 0. That is, only FIN is received.- -- In error cases, data is available. But there is no- -- application which can read it. So, let's stop receiving- -- to prevent attacks.- MoreData -> E.bracket (mallocBytes bufSize)- free- (\buf -> void $ recvBufNoWait s buf bufSize)- register evmgr tmmgr mvar = do- -- millisecond to microsecond- key1 <- Ev.registerTimeout tmmgr (tmout * 1000) $- putMVar mvar TimeoutTripped- key2 <- withFdSocket s $ \fd' -> do- let callback _ _ = putMVar mvar MoreData- fd = Fd fd'-#if __GLASGOW_HASKELL__ < 709- Ev.registerFd evmgr callback fd Ev.evtRead-#else- Ev.registerFd evmgr callback fd Ev.evtRead Ev.OneShot-#endif- return (key1, key2)- unregister evmgr tmmgr (key1,key2) = do- Ev.unregisterTimeout tmmgr key1- Ev.unregisterFd evmgr key2-#endif+ loop delay' -- Don't use 4092 here. The GHC runtime takes the global lock -- if the length is over 3276 bytes in 32bit or 3272 bytes in 64bit. bufSize = 1024
Network/Socket/SockAddr.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Network.Socket.SockAddr ( getPeerName , getSocketName@@ -6,12 +7,24 @@ , accept , sendBufTo , recvBufFrom+ , sendBufMsg+ , recvBufMsg ) where +import Control.Exception (try, throwIO, IOException)+import System.Directory (removeFile)+import System.IO.Error (isAlreadyInUseError, isDoesNotExistError)+ import qualified Network.Socket.Buffer as G import qualified Network.Socket.Name as G import qualified Network.Socket.Syscall as G+import Network.Socket.Flag import Network.Socket.Imports+#if !defined(mingw32_HOST_OS)+import Network.Socket.Posix.Cmsg+#else+import Network.Socket.Win32.Cmsg+#endif import Network.Socket.Types -- | Getting peer's 'SockAddr'.@@ -32,7 +45,25 @@ -- 'defaultPort' is passed then the system assigns the next available -- use port. bind :: Socket -> SockAddr -> IO ()-bind = G.bind+bind s a = case a of+ SockAddrUnix p -> do+ -- gracefully handle the fact that UNIX systems don't clean up closed UNIX+ -- domain sockets, inspired by https://stackoverflow.com/a/13719866+ res <- try (G.bind s a)+ case res of+ Right () -> return ()+ Left e | not (isAlreadyInUseError e) -> throwIO (e :: IOException)+ Left e | otherwise -> do+ -- socket might be in use, try to connect+ res2 <- try (G.connect s a)+ case res2 of+ Right () -> close s >> throwIO e+ Left e2 | not (isDoesNotExistError e2) -> throwIO (e2 :: IOException)+ _ -> do+ -- socket not actually in use, remove it and retry bind+ removeFile p+ G.bind s a+ _ -> G.bind s a -- | Accept a connection. The socket must be bound to an address and -- listening for connections. The return value is a pair @(conn,@@ -64,3 +95,24 @@ -- GHC ticket #1129) recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr) recvBufFrom = G.recvBufFrom++-- | Send data to the socket using sendmsg(2).+sendBufMsg :: Socket -- ^ Socket+ -> SockAddr -- ^ Destination address+ -> [(Ptr Word8,Int)] -- ^ Data to be sent+ -> [Cmsg] -- ^ Control messages+ -> MsgFlag -- ^ Message flags+ -> IO Int -- ^ The length actually sent+sendBufMsg = G.sendBufMsg++-- | Receive data from the socket using recvmsg(2).+recvBufMsg :: Socket -- ^ Socket+ -> [(Ptr Word8,Int)] -- ^ A list of a pair of buffer and its size.+ -- If the total length is not large enough,+ -- 'MSG_TRUNC' is returned+ -> Int -- ^ The buffer size for control messages.+ -- If the length is not large enough,+ -- 'MSG_CTRUNC' is returned+ -> MsgFlag -- ^ Message flags+ -> IO (SockAddr,Int,[Cmsg],MsgFlag) -- ^ Source address, received data, control messages and message flags+recvBufMsg = G.recvBufMsg
Network/Socket/Syscall.hs view
@@ -84,7 +84,7 @@ return s where create = do- c_stype <- modifyFlag <$> packSocketTypeOrThrow "socket" stype+ let c_stype = modifyFlag $ packSocketType stype throwSocketErrorIfMinus1Retry "Network.Socket.socket" $ c_socket (packFamily family) c_stype protocol
Network/Socket/Types.hsc view
@@ -1,1238 +1,1432 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash, UnboxedTuples #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--#include "HsNet.h"-##include "HsNetDef.h"--module Network.Socket.Types (- -- * Socket type- Socket- , withFdSocket- , unsafeFdSocket- , touchSocket- , socketToFd- , fdSocket- , mkSocket- , invalidateSocket- , close- , close'- , c_close- -- * Types of socket- , SocketType(..)- , isSupportedSocketType- , packSocketType- , packSocketType'- , packSocketTypeOrThrow- , unpackSocketType- , unpackSocketType'-- -- * Family- , Family(..)- , isSupportedFamily- , packFamily- , unpackFamily-- -- * Socket address typeclass- , SocketAddress(..)- , withSocketAddress- , withNewSocketAddress-- -- * Socket address type- , SockAddr(..)- , isSupportedSockAddr- , HostAddress- , hostAddressToTuple- , tupleToHostAddress- , HostAddress6- , hostAddress6ToTuple- , tupleToHostAddress6- , FlowInfo- , ScopeID- , peekSockAddr- , pokeSockAddr- , withSockAddr-- -- * Unsorted- , ProtocolNumber- , defaultProtocol- , PortNumber- , defaultPort-- -- * Low-level helpers- , zeroMemory- , htonl- , ntohl- ) where--import Control.Monad (when)-import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef', mkWeakIORef)-import Foreign.C.Error (throwErrno)-import Foreign.Marshal.Alloc-import GHC.Conc (closeFdWith)-import System.Posix.Types (Fd)-import Control.DeepSeq (NFData (..))-import GHC.Exts (touch##)-import GHC.IORef (IORef (..))-import GHC.STRef (STRef (..))-import GHC.IO (IO (..))--#if defined(DOMAIN_SOCKET_SUPPORT)-import Foreign.Marshal.Array-#endif--import Network.Socket.Imports----------------------------------------------------------------------------------- | Basic type for a socket.-data Socket = Socket !(IORef CInt) !CInt {- for Show -}--instance Show Socket where- show (Socket _ ofd) = "<socket: " ++ show ofd ++ ">"--instance Eq Socket where- Socket ref1 _ == Socket ref2 _ = ref1 == ref2--{-# DEPRECATED fdSocket "Use withFdSocket or unsafeFdSocket instead" #-}--- | Currently, this is an alias of `unsafeFdSocket`.-fdSocket :: Socket -> IO CInt-fdSocket = unsafeFdSocket---- | Getting a file descriptor from a socket.------ If a 'Socket' is shared with multiple threads and--- one uses 'unsafeFdSocket', unexpected issues may happen.--- Consider the following scenario:------ 1) Thread A acquires a 'Fd' from 'Socket' by 'unsafeFdSocket'.------ 2) Thread B close the 'Socket'.------ 3) Thread C opens a new 'Socket'. Unfortunately it gets the same 'Fd'--- number which thread A is holding.------ In this case, it is safer for Thread A to clone 'Fd' by--- 'System.Posix.IO.dup'. But this would still suffer from--- a race condition between 'unsafeFdSocket' and 'close'.------ If you use this function, you need to guarantee that the 'Socket' does not--- get garbage-collected until after you finish using the file descriptor.--- 'touchSocket' can be used for this purpose.------ A safer option is to use 'withFdSocket' instead.-unsafeFdSocket :: Socket -> IO CInt-unsafeFdSocket (Socket ref _) = readIORef ref---- | Ensure that the given 'Socket' stays alive (i.e. not garbage-collected)--- at the given place in the sequence of IO actions. This function can be--- used in conjunction with 'unsafeFdSocket' to guarantee that the file--- descriptor is not prematurely freed.------ > fd <- unsafeFdSocket sock--- > -- using fd with blocking operations such as accept(2)--- > touchSocket sock-touchSocket :: Socket -> IO ()-touchSocket (Socket ref _) = touch ref--touch :: IORef a -> IO ()-touch (IORef (STRef mutVar)) =- -- Thanks to a GHC issue, this touch# may not be quite guaranteed- -- to work. There's talk of replacing the touch# primop with one- -- that works better with the optimizer. But this seems to be the- -- "right" way to do it for now.- IO $ \s -> (## touch## mutVar s, () ##)---- | Get a file descriptor from a 'Socket'. The socket will never--- be closed automatically before @withFdSocket@ completes, but--- it may still be closed by an explicit call to 'close' or `close'`,--- either before or during the call.------ The file descriptor must not be used after @withFdSocket@ returns, because--- the 'Socket' may have been garbage-collected, invalidating the file--- descriptor.------ Since: 3.1.0.0-withFdSocket :: Socket -> (CInt -> IO r) -> IO r-withFdSocket (Socket ref _) f = do- fd <- readIORef ref- -- Should we throw an exception if the socket is already invalid?- -- That will catch some mistakes but certainly not all.-- r <- f fd-- touch ref- return r---- | Socket is closed and a duplicated file descriptor is returned.--- The duplicated descriptor is no longer subject to the possibility--- of unexpectedly being closed if the socket is finalized. It is--- now the caller's responsibility to ultimately close the--- duplicated file descriptor.-socketToFd :: Socket -> IO CInt-socketToFd s = do-#if defined(mingw32_HOST_OS)- fd <- unsafeFdSocket s- fd2 <- c_wsaDuplicate fd- -- FIXME: throw error no if -1- close s- return fd2--foreign import ccall unsafe "wsaDuplicate"- c_wsaDuplicate :: CInt -> IO CInt-#else- fd <- unsafeFdSocket s- -- FIXME: throw error no if -1- fd2 <- c_dup fd- close s- return fd2--foreign import ccall unsafe "dup"- c_dup :: CInt -> IO CInt-#endif---- | Creating a socket from a file descriptor.-mkSocket :: CInt -> IO Socket-mkSocket fd = do- ref <- newIORef fd- let s = Socket ref fd- void $ mkWeakIORef ref $ close s- return s--invalidSocket :: CInt-#if defined(mingw32_HOST_OS)-invalidSocket = #const INVALID_SOCKET-#else-invalidSocket = -1-#endif--invalidateSocket ::- Socket- -> (CInt -> IO a)- -> (CInt -> IO a)- -> IO a-invalidateSocket (Socket ref _) errorAction normalAction = do- oldfd <- atomicModifyIORef' ref $ \cur -> (invalidSocket, cur)- if oldfd == invalidSocket then errorAction oldfd else normalAction oldfd----------------------------------------------------------------------------------- | Close the socket. This function does not throw exceptions even if--- the underlying system call returns errors.------ If multiple threads use the same socket and one uses 'unsafeFdSocket' and--- the other use 'close', unexpected behavior may happen.--- For more information, please refer to the documentation of 'unsafeFdSocket'.-close :: Socket -> IO ()-close s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do- -- closeFdWith avoids the deadlock of IO manager.- closeFdWith closeFd (toFd oldfd)- where- toFd :: CInt -> Fd- toFd = fromIntegral- -- closeFd ignores the return value of c_close and- -- does not throw exceptions- closeFd :: Fd -> IO ()- closeFd = void . c_close . fromIntegral---- | Close the socket. This function throws exceptions if--- the underlying system call returns errors.-close' :: Socket -> IO ()-close' s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do- -- closeFdWith avoids the deadlock of IO manager.- closeFdWith closeFd (toFd oldfd)- where- toFd :: CInt -> Fd- toFd = fromIntegral- closeFd :: Fd -> IO ()- closeFd fd = do- ret <- c_close $ fromIntegral fd- when (ret == -1) $ throwErrno "Network.Socket.close'"--#if defined(mingw32_HOST_OS)-foreign import CALLCONV unsafe "closesocket"- c_close :: CInt -> IO CInt-#else-foreign import ccall unsafe "close"- c_close :: CInt -> IO CInt-#endif----------------------------------------------------------------------------------- | Protocol number.-type ProtocolNumber = CInt---- | This is the default protocol for a given service.------ >>> defaultProtocol--- 0-defaultProtocol :: ProtocolNumber-defaultProtocol = 0---------------------------------------------------------------------------------- Socket types---- There are a few possible ways to do this. The first is convert the--- structs used in the C library into an equivalent Haskell type. An--- other possible implementation is to keep all the internals in the C--- code and use an Int## and a status flag. The second method is used--- here since a lot of the C structures are not required to be--- manipulated.---- Originally the status was non-mutable so we had to return a new--- socket each time we changed the status. This version now uses--- mutable variables to avoid the need to do this. The result is a--- cleaner interface and better security since the application--- programmer now can't circumvent the status information to perform--- invalid operations on sockets.---- | Socket Types.------ The existence of a constructor does not necessarily imply that that--- socket type is supported on your system: see 'isSupportedSocketType'.-data SocketType- = NoSocketType -- ^ 0, used in getAddrInfo hints, for example- | Stream -- ^ SOCK_STREAM- | Datagram -- ^ SOCK_DGRAM- | Raw -- ^ SOCK_RAW- | RDM -- ^ SOCK_RDM- | SeqPacket -- ^ SOCK_SEQPACKET- deriving (Eq, Ord, Read, Show, Typeable)---- | Does the SOCK_ constant corresponding to the given SocketType exist on--- this system?-isSupportedSocketType :: SocketType -> Bool-isSupportedSocketType = isJust . packSocketType'---- | Find the SOCK_ constant corresponding to the SocketType value.-packSocketType' :: SocketType -> Maybe CInt-packSocketType' stype = case Just stype of- -- the Just above is to disable GHC's overlapping pattern- -- detection: see comments for packSocketOption- Just NoSocketType -> Just 0-#ifdef SOCK_STREAM- Just Stream -> Just #const SOCK_STREAM-#endif-#ifdef SOCK_DGRAM- Just Datagram -> Just #const SOCK_DGRAM-#endif-#ifdef SOCK_RAW- Just Raw -> Just #const SOCK_RAW-#endif-#ifdef SOCK_RDM- Just RDM -> Just #const SOCK_RDM-#endif-#ifdef SOCK_SEQPACKET- Just SeqPacket -> Just #const SOCK_SEQPACKET-#endif- _ -> Nothing--packSocketType :: SocketType -> CInt-packSocketType stype = fromMaybe (error errMsg) (packSocketType' stype)- where- errMsg = concat ["Network.Socket.packSocketType: ",- "socket type ", show stype, " unsupported on this system"]---- | Try packSocketType' on the SocketType, if it fails throw an error with--- message starting "Network.Socket." ++ the String parameter-packSocketTypeOrThrow :: String -> SocketType -> IO CInt-packSocketTypeOrThrow caller stype = maybe err return (packSocketType' stype)- where- err = ioError . userError . concat $ ["Network.Socket.", caller, ": ",- "socket type ", show stype, " unsupported on this system"]---unpackSocketType:: CInt -> Maybe SocketType-unpackSocketType t = case t of- 0 -> Just NoSocketType-#ifdef SOCK_STREAM- (#const SOCK_STREAM) -> Just Stream-#endif-#ifdef SOCK_DGRAM- (#const SOCK_DGRAM) -> Just Datagram-#endif-#ifdef SOCK_RAW- (#const SOCK_RAW) -> Just Raw-#endif-#ifdef SOCK_RDM- (#const SOCK_RDM) -> Just RDM-#endif-#ifdef SOCK_SEQPACKET- (#const SOCK_SEQPACKET) -> Just SeqPacket-#endif- _ -> Nothing---- | Try unpackSocketType on the CInt, if it fails throw an error with--- message starting "Network.Socket." ++ the String parameter-unpackSocketType' :: String -> CInt -> IO SocketType-unpackSocketType' caller ty = maybe err return (unpackSocketType ty)- where- err = ioError . userError . concat $ ["Network.Socket.", caller, ": ",- "socket type ", show ty, " unsupported on this system"]----------------------------------------------------------------------------- Protocol Families.---- | Address families.------ A constructor being present here does not mean it is supported by the--- operating system: see 'isSupportedFamily'.-data Family- = AF_UNSPEC -- ^ unspecified- | AF_UNIX -- ^ UNIX-domain- | AF_INET -- ^ Internet Protocol version 4- | AF_INET6 -- ^ Internet Protocol version 6- | AF_IMPLINK -- ^ Arpanet imp addresses- | AF_PUP -- ^ pup protocols: e.g. BSP- | AF_CHAOS -- ^ mit CHAOS protocols- | AF_NS -- ^ XEROX NS protocols- | AF_NBS -- ^ nbs protocols- | AF_ECMA -- ^ european computer manufacturers- | AF_DATAKIT -- ^ datakit protocols- | AF_CCITT -- ^ CCITT protocols, X.25 etc- | AF_SNA -- ^ IBM SNA- | AF_DECnet -- ^ DECnet- | AF_DLI -- ^ Direct data link interface- | AF_LAT -- ^ LAT- | AF_HYLINK -- ^ NSC Hyperchannel- | AF_APPLETALK -- ^ Apple Talk- | AF_ROUTE -- ^ Internal Routing Protocol (aka AF_NETLINK)- | AF_NETBIOS -- ^ NetBios-style addresses- | AF_NIT -- ^ Network Interface Tap- | AF_802 -- ^ IEEE 802.2, also ISO 8802- | AF_ISO -- ^ ISO protocols- | AF_OSI -- ^ umbrella of all families used by OSI- | AF_NETMAN -- ^ DNA Network Management- | AF_X25 -- ^ CCITT X.25- | AF_AX25 -- ^ AX25- | AF_OSINET -- ^ AFI- | AF_GOSSIP -- ^ US Government OSI- | AF_IPX -- ^ Novell Internet Protocol- | Pseudo_AF_XTP -- ^ eXpress Transfer Protocol (no AF)- | AF_CTF -- ^ Common Trace Facility- | AF_WAN -- ^ Wide Area Network protocols- | AF_SDL -- ^ SGI Data Link for DLPI- | AF_NETWARE -- ^ Netware- | AF_NDD -- ^ NDD- | AF_INTF -- ^ Debugging use only- | AF_COIP -- ^ connection-oriented IP, aka ST II- | AF_CNT -- ^ Computer Network Technology- | Pseudo_AF_RTIP -- ^ Help Identify RTIP packets- | Pseudo_AF_PIP -- ^ Help Identify PIP packets- | AF_SIP -- ^ Simple Internet Protocol- | AF_ISDN -- ^ Integrated Services Digital Network- | Pseudo_AF_KEY -- ^ Internal key-management function- | AF_NATM -- ^ native ATM access- | AF_ARP -- ^ ARP (RFC 826)- | Pseudo_AF_HDRCMPLT -- ^ Used by BPF to not rewrite hdrs in iface output- | AF_ENCAP -- ^ ENCAP- | AF_LINK -- ^ Link layer interface- | AF_RAW -- ^ Link layer interface- | AF_RIF -- ^ raw interface- | AF_NETROM -- ^ Amateur radio NetROM- | AF_BRIDGE -- ^ multiprotocol bridge- | AF_ATMPVC -- ^ ATM PVCs- | AF_ROSE -- ^ Amateur Radio X.25 PLP- | AF_NETBEUI -- ^ Netbeui 802.2LLC- | AF_SECURITY -- ^ Security callback pseudo AF- | AF_PACKET -- ^ Packet family- | AF_ASH -- ^ Ash- | AF_ECONET -- ^ Acorn Econet- | AF_ATMSVC -- ^ ATM SVCs- | AF_IRDA -- ^ IRDA sockets- | AF_PPPOX -- ^ PPPoX sockets- | AF_WANPIPE -- ^ Wanpipe API sockets- | AF_BLUETOOTH -- ^ bluetooth sockets- | AF_CAN -- ^ Controller Area Network- deriving (Eq, Ord, Read, Show)---- | Converting 'Family' to 'CInt'.-packFamily :: Family -> CInt-packFamily f = case packFamily' f of- Just fam -> fam- Nothing -> error $- "Network.Socket.packFamily: unsupported address family: " ++- show f---- | Does the AF_ constant corresponding to the given family exist on this--- system?-isSupportedFamily :: Family -> Bool-isSupportedFamily = isJust . packFamily'--packFamily' :: Family -> Maybe CInt-packFamily' f = case Just f of- -- the Just above is to disable GHC's overlapping pattern- -- detection: see comments for packSocketOption- Just AF_UNSPEC -> Just #const AF_UNSPEC-#ifdef AF_UNIX- Just AF_UNIX -> Just #const AF_UNIX-#endif-#ifdef AF_INET- Just AF_INET -> Just #const AF_INET-#endif-#ifdef AF_INET6- Just AF_INET6 -> Just #const AF_INET6-#endif-#ifdef AF_IMPLINK- Just AF_IMPLINK -> Just #const AF_IMPLINK-#endif-#ifdef AF_PUP- Just AF_PUP -> Just #const AF_PUP-#endif-#ifdef AF_CHAOS- Just AF_CHAOS -> Just #const AF_CHAOS-#endif-#ifdef AF_NS- Just AF_NS -> Just #const AF_NS-#endif-#ifdef AF_NBS- Just AF_NBS -> Just #const AF_NBS-#endif-#ifdef AF_ECMA- Just AF_ECMA -> Just #const AF_ECMA-#endif-#ifdef AF_DATAKIT- Just AF_DATAKIT -> Just #const AF_DATAKIT-#endif-#ifdef AF_CCITT- Just AF_CCITT -> Just #const AF_CCITT-#endif-#ifdef AF_SNA- Just AF_SNA -> Just #const AF_SNA-#endif-#ifdef AF_DECnet- Just AF_DECnet -> Just #const AF_DECnet-#endif-#ifdef AF_DLI- Just AF_DLI -> Just #const AF_DLI-#endif-#ifdef AF_LAT- Just AF_LAT -> Just #const AF_LAT-#endif-#ifdef AF_HYLINK- Just AF_HYLINK -> Just #const AF_HYLINK-#endif-#ifdef AF_APPLETALK- Just AF_APPLETALK -> Just #const AF_APPLETALK-#endif-#ifdef AF_ROUTE- Just AF_ROUTE -> Just #const AF_ROUTE-#endif-#ifdef AF_NETBIOS- Just AF_NETBIOS -> Just #const AF_NETBIOS-#endif-#ifdef AF_NIT- Just AF_NIT -> Just #const AF_NIT-#endif-#ifdef AF_802- Just AF_802 -> Just #const AF_802-#endif-#ifdef AF_ISO- Just AF_ISO -> Just #const AF_ISO-#endif-#ifdef AF_OSI- Just AF_OSI -> Just #const AF_OSI-#endif-#ifdef AF_NETMAN- Just AF_NETMAN -> Just #const AF_NETMAN-#endif-#ifdef AF_X25- Just AF_X25 -> Just #const AF_X25-#endif-#ifdef AF_AX25- Just AF_AX25 -> Just #const AF_AX25-#endif-#ifdef AF_OSINET- Just AF_OSINET -> Just #const AF_OSINET-#endif-#ifdef AF_GOSSIP- Just AF_GOSSIP -> Just #const AF_GOSSIP-#endif-#ifdef AF_IPX- Just AF_IPX -> Just #const AF_IPX-#endif-#ifdef Pseudo_AF_XTP- Just Pseudo_AF_XTP -> Just #const Pseudo_AF_XTP-#endif-#ifdef AF_CTF- Just AF_CTF -> Just #const AF_CTF-#endif-#ifdef AF_WAN- Just AF_WAN -> Just #const AF_WAN-#endif-#ifdef AF_SDL- Just AF_SDL -> Just #const AF_SDL-#endif-#ifdef AF_NETWARE- Just AF_NETWARE -> Just #const AF_NETWARE-#endif-#ifdef AF_NDD- Just AF_NDD -> Just #const AF_NDD-#endif-#ifdef AF_INTF- Just AF_INTF -> Just #const AF_INTF-#endif-#ifdef AF_COIP- Just AF_COIP -> Just #const AF_COIP-#endif-#ifdef AF_CNT- Just AF_CNT -> Just #const AF_CNT-#endif-#ifdef Pseudo_AF_RTIP- Just Pseudo_AF_RTIP -> Just #const Pseudo_AF_RTIP-#endif-#ifdef Pseudo_AF_PIP- Just Pseudo_AF_PIP -> Just #const Pseudo_AF_PIP-#endif-#ifdef AF_SIP- Just AF_SIP -> Just #const AF_SIP-#endif-#ifdef AF_ISDN- Just AF_ISDN -> Just #const AF_ISDN-#endif-#ifdef Pseudo_AF_KEY- Just Pseudo_AF_KEY -> Just #const Pseudo_AF_KEY-#endif-#ifdef AF_NATM- Just AF_NATM -> Just #const AF_NATM-#endif-#ifdef AF_ARP- Just AF_ARP -> Just #const AF_ARP-#endif-#ifdef Pseudo_AF_HDRCMPLT- Just Pseudo_AF_HDRCMPLT -> Just #const Pseudo_AF_HDRCMPLT-#endif-#ifdef AF_ENCAP- Just AF_ENCAP -> Just #const AF_ENCAP-#endif-#ifdef AF_LINK- Just AF_LINK -> Just #const AF_LINK-#endif-#ifdef AF_RAW- Just AF_RAW -> Just #const AF_RAW-#endif-#ifdef AF_RIF- Just AF_RIF -> Just #const AF_RIF-#endif-#ifdef AF_NETROM- Just AF_NETROM -> Just #const AF_NETROM-#endif-#ifdef AF_BRIDGE- Just AF_BRIDGE -> Just #const AF_BRIDGE-#endif-#ifdef AF_ATMPVC- Just AF_ATMPVC -> Just #const AF_ATMPVC-#endif-#ifdef AF_ROSE- Just AF_ROSE -> Just #const AF_ROSE-#endif-#ifdef AF_NETBEUI- Just AF_NETBEUI -> Just #const AF_NETBEUI-#endif-#ifdef AF_SECURITY- Just AF_SECURITY -> Just #const AF_SECURITY-#endif-#ifdef AF_PACKET- Just AF_PACKET -> Just #const AF_PACKET-#endif-#ifdef AF_ASH- Just AF_ASH -> Just #const AF_ASH-#endif-#ifdef AF_ECONET- Just AF_ECONET -> Just #const AF_ECONET-#endif-#ifdef AF_ATMSVC- Just AF_ATMSVC -> Just #const AF_ATMSVC-#endif-#ifdef AF_IRDA- Just AF_IRDA -> Just #const AF_IRDA-#endif-#ifdef AF_PPPOX- Just AF_PPPOX -> Just #const AF_PPPOX-#endif-#ifdef AF_WANPIPE- Just AF_WANPIPE -> Just #const AF_WANPIPE-#endif-#ifdef AF_BLUETOOTH- Just AF_BLUETOOTH -> Just #const AF_BLUETOOTH-#endif-#ifdef AF_CAN- Just AF_CAN -> Just #const AF_CAN-#endif- _ -> Nothing----------- -------------- | Converting 'CInt' to 'Family'.-unpackFamily :: CInt -> Family-unpackFamily f = case f of- (#const AF_UNSPEC) -> AF_UNSPEC-#ifdef AF_UNIX- (#const AF_UNIX) -> AF_UNIX-#endif-#ifdef AF_INET- (#const AF_INET) -> AF_INET-#endif-#ifdef AF_INET6- (#const AF_INET6) -> AF_INET6-#endif-#ifdef AF_IMPLINK- (#const AF_IMPLINK) -> AF_IMPLINK-#endif-#ifdef AF_PUP- (#const AF_PUP) -> AF_PUP-#endif-#ifdef AF_CHAOS- (#const AF_CHAOS) -> AF_CHAOS-#endif-#ifdef AF_NS- (#const AF_NS) -> AF_NS-#endif-#ifdef AF_NBS- (#const AF_NBS) -> AF_NBS-#endif-#ifdef AF_ECMA- (#const AF_ECMA) -> AF_ECMA-#endif-#ifdef AF_DATAKIT- (#const AF_DATAKIT) -> AF_DATAKIT-#endif-#ifdef AF_CCITT- (#const AF_CCITT) -> AF_CCITT-#endif-#ifdef AF_SNA- (#const AF_SNA) -> AF_SNA-#endif-#ifdef AF_DECnet- (#const AF_DECnet) -> AF_DECnet-#endif-#ifdef AF_DLI- (#const AF_DLI) -> AF_DLI-#endif-#ifdef AF_LAT- (#const AF_LAT) -> AF_LAT-#endif-#ifdef AF_HYLINK- (#const AF_HYLINK) -> AF_HYLINK-#endif-#ifdef AF_APPLETALK- (#const AF_APPLETALK) -> AF_APPLETALK-#endif-#ifdef AF_ROUTE- (#const AF_ROUTE) -> AF_ROUTE-#endif-#ifdef AF_NETBIOS- (#const AF_NETBIOS) -> AF_NETBIOS-#endif-#ifdef AF_NIT- (#const AF_NIT) -> AF_NIT-#endif-#ifdef AF_802- (#const AF_802) -> AF_802-#endif-#ifdef AF_ISO- (#const AF_ISO) -> AF_ISO-#endif-#ifdef AF_OSI-# if (!defined(AF_ISO)) || (defined(AF_ISO) && (AF_ISO != AF_OSI))- (#const AF_OSI) -> AF_OSI-# endif-#endif-#ifdef AF_NETMAN- (#const AF_NETMAN) -> AF_NETMAN-#endif-#ifdef AF_X25- (#const AF_X25) -> AF_X25-#endif-#ifdef AF_AX25- (#const AF_AX25) -> AF_AX25-#endif-#ifdef AF_OSINET- (#const AF_OSINET) -> AF_OSINET-#endif-#ifdef AF_GOSSIP- (#const AF_GOSSIP) -> AF_GOSSIP-#endif-#if defined(AF_IPX) && (!defined(AF_NS) || AF_NS != AF_IPX)- (#const AF_IPX) -> AF_IPX-#endif-#ifdef Pseudo_AF_XTP- (#const Pseudo_AF_XTP) -> Pseudo_AF_XTP-#endif-#ifdef AF_CTF- (#const AF_CTF) -> AF_CTF-#endif-#ifdef AF_WAN- (#const AF_WAN) -> AF_WAN-#endif-#ifdef AF_SDL- (#const AF_SDL) -> AF_SDL-#endif-#ifdef AF_NETWARE- (#const AF_NETWARE) -> AF_NETWARE-#endif-#ifdef AF_NDD- (#const AF_NDD) -> AF_NDD-#endif-#ifdef AF_INTF- (#const AF_INTF) -> AF_INTF-#endif-#ifdef AF_COIP- (#const AF_COIP) -> AF_COIP-#endif-#ifdef AF_CNT- (#const AF_CNT) -> AF_CNT-#endif-#ifdef Pseudo_AF_RTIP- (#const Pseudo_AF_RTIP) -> Pseudo_AF_RTIP-#endif-#ifdef Pseudo_AF_PIP- (#const Pseudo_AF_PIP) -> Pseudo_AF_PIP-#endif-#ifdef AF_SIP- (#const AF_SIP) -> AF_SIP-#endif-#ifdef AF_ISDN- (#const AF_ISDN) -> AF_ISDN-#endif-#ifdef Pseudo_AF_KEY- (#const Pseudo_AF_KEY) -> Pseudo_AF_KEY-#endif-#ifdef AF_NATM- (#const AF_NATM) -> AF_NATM-#endif-#ifdef AF_ARP- (#const AF_ARP) -> AF_ARP-#endif-#ifdef Pseudo_AF_HDRCMPLT- (#const Pseudo_AF_HDRCMPLT) -> Pseudo_AF_HDRCMPLT-#endif-#ifdef AF_ENCAP- (#const AF_ENCAP) -> AF_ENCAP-#endif-#ifdef AF_LINK- (#const AF_LINK) -> AF_LINK-#endif-#ifdef AF_RAW- (#const AF_RAW) -> AF_RAW-#endif-#ifdef AF_RIF- (#const AF_RIF) -> AF_RIF-#endif-#ifdef AF_NETROM- (#const AF_NETROM) -> AF_NETROM-#endif-#ifdef AF_BRIDGE- (#const AF_BRIDGE) -> AF_BRIDGE-#endif-#ifdef AF_ATMPVC- (#const AF_ATMPVC) -> AF_ATMPVC-#endif-#ifdef AF_ROSE- (#const AF_ROSE) -> AF_ROSE-#endif-#ifdef AF_NETBEUI- (#const AF_NETBEUI) -> AF_NETBEUI-#endif-#ifdef AF_SECURITY- (#const AF_SECURITY) -> AF_SECURITY-#endif-#ifdef AF_PACKET- (#const AF_PACKET) -> AF_PACKET-#endif-#ifdef AF_ASH- (#const AF_ASH) -> AF_ASH-#endif-#ifdef AF_ECONET- (#const AF_ECONET) -> AF_ECONET-#endif-#ifdef AF_ATMSVC- (#const AF_ATMSVC) -> AF_ATMSVC-#endif-#ifdef AF_IRDA- (#const AF_IRDA) -> AF_IRDA-#endif-#ifdef AF_PPPOX- (#const AF_PPPOX) -> AF_PPPOX-#endif-#ifdef AF_WANPIPE- (#const AF_WANPIPE) -> AF_WANPIPE-#endif-#ifdef AF_BLUETOOTH- (#const AF_BLUETOOTH) -> AF_BLUETOOTH-#endif-#ifdef AF_CAN- (#const AF_CAN) -> AF_CAN-#endif- unknown -> error $- "Network.Socket.Types.unpackFamily: unknown address family: " ++- show unknown----------------------------------------------------------------------------- Port Numbers---- | Port number.--- Use the @Num@ instance (i.e. use a literal) to create a--- @PortNumber@ value.------ >>> 1 :: PortNumber--- 1--- >>> read "1" :: PortNumber--- 1--- >>> show (12345 :: PortNumber)--- "12345"--- >>> 50000 < (51000 :: PortNumber)--- True--- >>> 50000 < (52000 :: PortNumber)--- True--- >>> 50000 + (10000 :: PortNumber)--- 60000-newtype PortNumber = PortNum Word16 deriving (Eq, Ord, Typeable, Num, Enum, Real, Integral)---- Print "n" instead of "PortNum n".-instance Show PortNumber where- showsPrec p (PortNum pn) = showsPrec p (fromIntegral pn :: Int)---- Read "n" instead of "PortNum n".-instance Read PortNumber where- readsPrec n = map (\(x,y) -> (fromIntegral (x :: Int), y)) . readsPrec n--foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16-foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16--- | Converts the from host byte order to network byte order.-foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32--- | Converts the from network byte order to host byte order.-foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32-{-# DEPRECATED htonl "Use getAddrInfo instead" #-}-{-# DEPRECATED ntohl "Use getAddrInfo instead" #-}--instance Storable PortNumber where- sizeOf _ = sizeOf (undefined :: Word16)- alignment _ = alignment (undefined :: Word16)- poke p (PortNum po) = poke (castPtr p) (htons po)- peek p = PortNum . ntohs <$> peek (castPtr p)---- | Default port number.------ >>> defaultPort--- 0-defaultPort :: PortNumber-defaultPort = 0------------------------------------------------------------------------------ | The core typeclass to unify socket addresses.-class SocketAddress sa where- sizeOfSocketAddress :: sa -> Int- peekSocketAddress :: Ptr sa -> IO sa- pokeSocketAddress :: Ptr a -> sa -> IO ()---- sizeof(struct sockaddr_storage) which has enough space to contain--- sockaddr_in, sockaddr_in6 and sockaddr_un.-sockaddrStorageLen :: Int-sockaddrStorageLen = 128--withSocketAddress :: SocketAddress sa => sa -> (Ptr sa -> Int -> IO a) -> IO a-withSocketAddress addr f = do- let sz = sizeOfSocketAddress addr- allocaBytes sz $ \p -> pokeSocketAddress p addr >> f (castPtr p) sz--withNewSocketAddress :: SocketAddress sa => (Ptr sa -> Int -> IO a) -> IO a-withNewSocketAddress f = allocaBytes sockaddrStorageLen $ \ptr -> do- zeroMemory ptr $ fromIntegral sockaddrStorageLen- f ptr sockaddrStorageLen----------------------------------------------------------------------------- Socket addresses---- The scheme used for addressing sockets is somewhat quirky. The--- calls in the BSD socket API that need to know the socket address--- all operate in terms of struct sockaddr, a `virtual' type of--- socket address.---- The Internet family of sockets are addressed as struct sockaddr_in,--- so when calling functions that operate on struct sockaddr, we have--- to type cast the Internet socket address into a struct sockaddr.--- Instances of the structure for different families might *not* be--- the same size. Same casting is required of other families of--- sockets such as Xerox NS. Similarly for UNIX-domain sockets.---- To represent these socket addresses in Haskell-land, we do what BSD--- didn't do, and use a union/algebraic type for the different--- families. Currently only UNIX-domain sockets and the Internet--- families are supported.---- | Flow information.-type FlowInfo = Word32--- | Scope identifier.-type ScopeID = Word32---- | Socket addresses.--- The existence of a constructor does not necessarily imply that--- that socket address type is supported on your system: see--- 'isSupportedSockAddr'.-data SockAddr- = SockAddrInet- !PortNumber -- sin_port- !HostAddress -- sin_addr (ditto)- | SockAddrInet6- !PortNumber -- sin6_port- !FlowInfo -- sin6_flowinfo (ditto)- !HostAddress6 -- sin6_addr (ditto)- !ScopeID -- sin6_scope_id (ditto)- -- | The path must have fewer than 104 characters. All of these characters must have code points less than 256.- | SockAddrUnix- String -- sun_path- deriving (Eq, Ord, Typeable)--instance NFData SockAddr where- rnf (SockAddrInet _ _) = ()- rnf (SockAddrInet6 _ _ _ _) = ()- rnf (SockAddrUnix str) = rnf str---- | Is the socket address type supported on this system?-isSupportedSockAddr :: SockAddr -> Bool-isSupportedSockAddr addr = case addr of- SockAddrInet{} -> True- SockAddrInet6{} -> True-#if defined(DOMAIN_SOCKET_SUPPORT)- SockAddrUnix{} -> True-#else- SockAddrUnix{} -> False-#endif--instance SocketAddress SockAddr where- sizeOfSocketAddress = sizeOfSockAddr- peekSocketAddress = peekSockAddr- pokeSocketAddress = pokeSockAddr--#if defined(mingw32_HOST_OS)-type CSaFamily = (#type unsigned short)-#elif defined(darwin_HOST_OS)-type CSaFamily = (#type u_char)-#else-type CSaFamily = (#type sa_family_t)-#endif---- | Computes the storage requirements (in bytes) of the given--- 'SockAddr'. This function differs from 'Foreign.Storable.sizeOf'--- in that the value of the argument /is/ used.-sizeOfSockAddr :: SockAddr -> Int-#if defined(DOMAIN_SOCKET_SUPPORT)-# ifdef linux_HOST_OS--- http://man7.org/linux/man-pages/man7/unix.7.html says:--- "an abstract socket address is distinguished (from a--- pathname socket) by the fact that sun_path[0] is a null byte--- ('\0'). The socket's address in this namespace is given by the--- additional bytes in sun_path that are covered by the specified--- length of the address structure. (Null bytes in the name have no--- special significance.) The name has no connection with filesystem--- pathnames. When the address of an abstract socket is returned,--- the returned addrlen is greater than sizeof(sa_family_t) (i.e.,--- greater than 2), and the name of the socket is contained in the--- first (addrlen - sizeof(sa_family_t)) bytes of sun_path."-sizeOfSockAddr (SockAddrUnix path) =- case path of- '\0':_ -> (#const sizeof(sa_family_t)) + length path- _ -> #const sizeof(struct sockaddr_un)-# else-sizeOfSockAddr SockAddrUnix{} = #const sizeof(struct sockaddr_un)-# endif-#else-sizeOfSockAddr SockAddrUnix{} = error "sizeOfSockAddr: not supported"-#endif-sizeOfSockAddr SockAddrInet{} = #const sizeof(struct sockaddr_in)-sizeOfSockAddr SockAddrInet6{} = #const sizeof(struct sockaddr_in6)---- | Use a 'SockAddr' with a function requiring a pointer to a--- 'SockAddr' and the length of that 'SockAddr'.-withSockAddr :: SockAddr -> (Ptr SockAddr -> Int -> IO a) -> IO a-withSockAddr addr f = do- let sz = sizeOfSockAddr addr- allocaBytes sz $ \p -> pokeSockAddr p addr >> f (castPtr p) sz---- We cannot bind sun_paths longer than than the space in the sockaddr_un--- structure, and attempting to do so could overflow the allocated storage--- space. This constant holds the maximum allowable path length.----#if defined(DOMAIN_SOCKET_SUPPORT)-unixPathMax :: Int-unixPathMax = #const sizeof(((struct sockaddr_un *)NULL)->sun_path)-#endif---- We can't write an instance of 'Storable' for 'SockAddr' because--- @sockaddr@ is a sum type of variable size but--- 'Foreign.Storable.sizeOf' is required to be constant.---- Note that on Darwin, the sockaddr structure must be zeroed before--- use.---- | Write the given 'SockAddr' to the given memory location.-pokeSockAddr :: Ptr a -> SockAddr -> IO ()-#if defined(DOMAIN_SOCKET_SUPPORT)-pokeSockAddr p sa@(SockAddrUnix path) = do- when (length path > unixPathMax) $ error "pokeSockAddr: path is too long"- zeroMemory p $ fromIntegral $ sizeOfSockAddr sa-# if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)- (#poke struct sockaddr_un, sun_len) p ((#const sizeof(struct sockaddr_un)) :: Word8)-# endif- (#poke struct sockaddr_un, sun_family) p ((#const AF_UNIX) :: CSaFamily)- let pathC = map castCharToCChar path- -- the buffer is already filled with nulls.- pokeArray ((#ptr struct sockaddr_un, sun_path) p) pathC-#else-pokeSockAddr _ SockAddrUnix{} = error "pokeSockAddr: not supported"-#endif-pokeSockAddr p (SockAddrInet port addr) = do- zeroMemory p (#const sizeof(struct sockaddr_in))-#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)- (#poke struct sockaddr_in, sin_len) p ((#const sizeof(struct sockaddr_in)) :: Word8)-#endif- (#poke struct sockaddr_in, sin_family) p ((#const AF_INET) :: CSaFamily)- (#poke struct sockaddr_in, sin_port) p port- (#poke struct sockaddr_in, sin_addr) p addr-pokeSockAddr p (SockAddrInet6 port flow addr scope) = do- zeroMemory p (#const sizeof(struct sockaddr_in6))-# if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)- (#poke struct sockaddr_in6, sin6_len) p ((#const sizeof(struct sockaddr_in6)) :: Word8)-# endif- (#poke struct sockaddr_in6, sin6_family) p ((#const AF_INET6) :: CSaFamily)- (#poke struct sockaddr_in6, sin6_port) p port- (#poke struct sockaddr_in6, sin6_flowinfo) p flow- (#poke struct sockaddr_in6, sin6_addr) p (In6Addr addr)- (#poke struct sockaddr_in6, sin6_scope_id) p scope---- | Read a 'SockAddr' from the given memory location.-peekSockAddr :: Ptr SockAddr -> IO SockAddr-peekSockAddr p = do- family <- (#peek struct sockaddr, sa_family) p- case family :: CSaFamily of-#if defined(DOMAIN_SOCKET_SUPPORT)- (#const AF_UNIX) -> do- str <- peekCAString ((#ptr struct sockaddr_un, sun_path) p)- return (SockAddrUnix str)-#endif- (#const AF_INET) -> do- addr <- (#peek struct sockaddr_in, sin_addr) p- port <- (#peek struct sockaddr_in, sin_port) p- return (SockAddrInet port addr)- (#const AF_INET6) -> do- port <- (#peek struct sockaddr_in6, sin6_port) p- flow <- (#peek struct sockaddr_in6, sin6_flowinfo) p- In6Addr addr <- (#peek struct sockaddr_in6, sin6_addr) p- scope <- (#peek struct sockaddr_in6, sin6_scope_id) p- return (SockAddrInet6 port flow addr scope)- _ -> ioError $ userError $- "Network.Socket.Types.peekSockAddr: address family '" ++- show family ++ "' not supported."------------------------------------------------------------------------------ | The raw network byte order number is read using host byte order.--- Therefore on little-endian architectures the byte order is swapped. For--- example @127.0.0.1@ is represented as @0x0100007f@ on little-endian hosts--- and as @0x7f000001@ on big-endian hosts.------ For direct manipulation prefer 'hostAddressToTuple' and--- 'tupleToHostAddress'.-type HostAddress = Word32---- | Converts 'HostAddress' to representation-independent IPv4 quadruple.--- For example for @127.0.0.1@ the function will return @(0x7f, 0, 0, 1)@--- regardless of host endianness.----{- -- prop> tow == hostAddressToTuple (tupleToHostAddress tow) -}-hostAddressToTuple :: HostAddress -> (Word8, Word8, Word8, Word8)-hostAddressToTuple ha' =- let ha = htonl ha'- byte i = fromIntegral (ha `shiftR` i) :: Word8- in (byte 24, byte 16, byte 8, byte 0)---- | Converts IPv4 quadruple to 'HostAddress'.-tupleToHostAddress :: (Word8, Word8, Word8, Word8) -> HostAddress-tupleToHostAddress (b3, b2, b1, b0) =- let x `sl` i = fromIntegral x `shiftL` i :: Word32- in ntohl $ (b3 `sl` 24) .|. (b2 `sl` 16) .|. (b1 `sl` 8) .|. (b0 `sl` 0)---- | Independent of endianness. For example @::1@ is stored as @(0, 0, 0, 1)@.------ For direct manipulation prefer 'hostAddress6ToTuple' and--- 'tupleToHostAddress6'.-type HostAddress6 = (Word32, Word32, Word32, Word32)---- | Converts 'HostAddress6' to representation-independent IPv6 octuple.----{- -- prop> (w1,w2,w3,w4,w5,w6,w7,w8) == hostAddress6ToTuple (tupleToHostAddress6 (w1,w2,w3,w4,w5,w6,w7,w8)) -}-hostAddress6ToTuple :: HostAddress6 -> (Word16, Word16, Word16, Word16,- Word16, Word16, Word16, Word16)-hostAddress6ToTuple (w3, w2, w1, w0) =- let high, low :: Word32 -> Word16- high w = fromIntegral (w `shiftR` 16)- low w = fromIntegral w- in (high w3, low w3, high w2, low w2, high w1, low w1, high w0, low w0)---- | Converts IPv6 octuple to 'HostAddress6'.-tupleToHostAddress6 :: (Word16, Word16, Word16, Word16,- Word16, Word16, Word16, Word16) -> HostAddress6-tupleToHostAddress6 (w7, w6, w5, w4, w3, w2, w1, w0) =- let add :: Word16 -> Word16 -> Word32- high `add` low = (fromIntegral high `shiftL` 16) .|. (fromIntegral low)- in (w7 `add` w6, w5 `add` w4, w3 `add` w2, w1 `add` w0)---- The peek32 and poke32 functions work around the fact that the RFCs--- don't require 32-bit-wide address fields to be present. We can--- only portably rely on an 8-bit field, s6_addr.--s6_addr_offset :: Int-s6_addr_offset = (#offset struct in6_addr, s6_addr)--peek32 :: Ptr a -> Int -> IO Word32-peek32 p i0 = do- let i' = i0 * 4- peekByte n = peekByteOff p (s6_addr_offset + i' + n) :: IO Word8- a `sl` i = fromIntegral a `shiftL` i- a0 <- peekByte 0- a1 <- peekByte 1- a2 <- peekByte 2- a3 <- peekByte 3- return ((a0 `sl` 24) .|. (a1 `sl` 16) .|. (a2 `sl` 8) .|. (a3 `sl` 0))--poke32 :: Ptr a -> Int -> Word32 -> IO ()-poke32 p i0 a = do- let i' = i0 * 4- pokeByte n = pokeByteOff p (s6_addr_offset + i' + n)- x `sr` i = fromIntegral (x `shiftR` i) :: Word8- pokeByte 0 (a `sr` 24)- pokeByte 1 (a `sr` 16)- pokeByte 2 (a `sr` 8)- pokeByte 3 (a `sr` 0)---- | Private newtype proxy for the Storable instance. To avoid orphan instances.-newtype In6Addr = In6Addr HostAddress6--#if __GLASGOW_HASKELL__ < 800-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)-#endif--instance Storable In6Addr where- sizeOf _ = #const sizeof(struct in6_addr)- alignment _ = #alignment struct in6_addr-- peek p = do- a <- peek32 p 0- b <- peek32 p 1- c <- peek32 p 2- d <- peek32 p 3- return $ In6Addr (a, b, c, d)-- poke p (In6Addr (a, b, c, d)) = do- poke32 p 0 a- poke32 p 1 b- poke32 p 2 c- poke32 p 3 d+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++#include "HsNet.h"+##include "HsNetDef.h"++module Network.Socket.Types (+ -- * Socket type+ Socket+ , withFdSocket+ , unsafeFdSocket+ , touchSocket+ , socketToFd+ , fdSocket+ , mkSocket+ , invalidateSocket+ , close+ , close'+ , c_close+ -- * Types of socket+ , SocketType(GeneralSocketType, UnsupportedSocketType, NoSocketType+ , Stream, Datagram, Raw, RDM, SeqPacket)+ , isSupportedSocketType+ , packSocketType+ , unpackSocketType++ -- * Family+ , Family(GeneralFamily, UnsupportedFamily+ ,AF_UNSPEC,AF_UNIX,AF_INET,AF_INET6,AF_IMPLINK,AF_PUP,AF_CHAOS+ ,AF_NS,AF_NBS,AF_ECMA,AF_DATAKIT,AF_CCITT,AF_SNA,AF_DECnet+ ,AF_DLI,AF_LAT,AF_HYLINK,AF_APPLETALK,AF_ROUTE,AF_NETBIOS+ ,AF_NIT,AF_802,AF_ISO,AF_OSI,AF_NETMAN,AF_X25,AF_AX25,AF_OSINET+ ,AF_GOSSIP,AF_IPX,Pseudo_AF_XTP,AF_CTF,AF_WAN,AF_SDL,AF_NETWARE+ ,AF_NDD,AF_INTF,AF_COIP,AF_CNT,Pseudo_AF_RTIP,Pseudo_AF_PIP+ ,AF_SIP,AF_ISDN,Pseudo_AF_KEY,AF_NATM,AF_ARP,Pseudo_AF_HDRCMPLT+ ,AF_ENCAP,AF_LINK,AF_RAW,AF_RIF,AF_NETROM,AF_BRIDGE,AF_ATMPVC+ ,AF_ROSE,AF_NETBEUI,AF_SECURITY,AF_PACKET,AF_ASH,AF_ECONET+ ,AF_ATMSVC,AF_IRDA,AF_PPPOX,AF_WANPIPE,AF_BLUETOOTH,AF_CAN)+ , isSupportedFamily+ , packFamily+ , unpackFamily++ -- * Socket address typeclass+ , SocketAddress(..)+ , withSocketAddress+ , withNewSocketAddress++ -- * Socket address type+ , SockAddr(..)+ , isSupportedSockAddr+ , HostAddress+ , hostAddressToTuple+ , tupleToHostAddress+ , HostAddress6+ , hostAddress6ToTuple+ , tupleToHostAddress6+ , FlowInfo+ , ScopeID+ , peekSockAddr+ , pokeSockAddr+ , withSockAddr++ -- * Unsorted+ , ProtocolNumber+ , defaultProtocol+ , PortNumber+ , defaultPort++ -- * Low-level helpers+ , zeroMemory+ , htonl+ , ntohl+ , In6Addr(..)+ ) where++import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef', mkWeakIORef)+import Foreign.C.Error (throwErrno)+import Foreign.Marshal.Alloc+import GHC.Conc (closeFdWith)+import System.Posix.Types (Fd)+import Control.DeepSeq (NFData (..))+import GHC.Exts (touch##)+import GHC.IORef (IORef (..))+import GHC.STRef (STRef (..))+import GHC.IO (IO (..))++import qualified Text.Read as P++#if defined(DOMAIN_SOCKET_SUPPORT)+import Foreign.Marshal.Array+#endif++import Network.Socket.Imports++----- readshow module import+import Network.Socket.ReadShow+++-----------------------------------------------------------------------------++-- | Basic type for a socket.+data Socket = Socket !(IORef CInt) !CInt {- for Show -}++instance Show Socket where+ show (Socket _ ofd) = "<socket: " ++ show ofd ++ ">"++instance Eq Socket where+ Socket ref1 _ == Socket ref2 _ = ref1 == ref2++{-# DEPRECATED fdSocket "Use withFdSocket or unsafeFdSocket instead" #-}+-- | Currently, this is an alias of `unsafeFdSocket`.+fdSocket :: Socket -> IO CInt+fdSocket = unsafeFdSocket++-- | Getting a file descriptor from a socket.+--+-- If a 'Socket' is shared with multiple threads and+-- one uses 'unsafeFdSocket', unexpected issues may happen.+-- Consider the following scenario:+--+-- 1) Thread A acquires a 'Fd' from 'Socket' by 'unsafeFdSocket'.+--+-- 2) Thread B close the 'Socket'.+--+-- 3) Thread C opens a new 'Socket'. Unfortunately it gets the same 'Fd'+-- number which thread A is holding.+--+-- In this case, it is safer for Thread A to clone 'Fd' by+-- 'System.Posix.IO.dup'. But this would still suffer from+-- a race condition between 'unsafeFdSocket' and 'close'.+--+-- If you use this function, you need to guarantee that the 'Socket' does not+-- get garbage-collected until after you finish using the file descriptor.+-- 'touchSocket' can be used for this purpose.+--+-- A safer option is to use 'withFdSocket' instead.+unsafeFdSocket :: Socket -> IO CInt+unsafeFdSocket (Socket ref _) = readIORef ref++-- | Ensure that the given 'Socket' stays alive (i.e. not garbage-collected)+-- at the given place in the sequence of IO actions. This function can be+-- used in conjunction with 'unsafeFdSocket' to guarantee that the file+-- descriptor is not prematurely freed.+--+-- > fd <- unsafeFdSocket sock+-- > -- using fd with blocking operations such as accept(2)+-- > touchSocket sock+touchSocket :: Socket -> IO ()+touchSocket (Socket ref _) = touch ref++touch :: IORef a -> IO ()+touch (IORef (STRef mutVar)) =+ -- Thanks to a GHC issue, this touch# may not be quite guaranteed+ -- to work. There's talk of replacing the touch# primop with one+ -- that works better with the optimizer. But this seems to be the+ -- "right" way to do it for now.+ IO $ \s -> (## touch## mutVar s, () ##)++-- | Get a file descriptor from a 'Socket'. The socket will never+-- be closed automatically before @withFdSocket@ completes, but+-- it may still be closed by an explicit call to 'close' or `close'`,+-- either before or during the call.+--+-- The file descriptor must not be used after @withFdSocket@ returns, because+-- the 'Socket' may have been garbage-collected, invalidating the file+-- descriptor.+--+-- Since: 3.1.0.0+withFdSocket :: Socket -> (CInt -> IO r) -> IO r+withFdSocket (Socket ref _) f = do+ fd <- readIORef ref+ -- Should we throw an exception if the socket is already invalid?+ -- That will catch some mistakes but certainly not all.++ r <- f fd++ touch ref+ return r++-- | Socket is closed and a duplicated file descriptor is returned.+-- The duplicated descriptor is no longer subject to the possibility+-- of unexpectedly being closed if the socket is finalized. It is+-- now the caller's responsibility to ultimately close the+-- duplicated file descriptor.+socketToFd :: Socket -> IO CInt+socketToFd s = do+#if defined(mingw32_HOST_OS)+ fd <- unsafeFdSocket s+ fd2 <- c_wsaDuplicate fd+ -- FIXME: throw error no if -1+ close s+ return fd2++foreign import ccall unsafe "wsaDuplicate"+ c_wsaDuplicate :: CInt -> IO CInt+#else+ fd <- unsafeFdSocket s+ -- FIXME: throw error no if -1+ fd2 <- c_dup fd+ close s+ return fd2++foreign import ccall unsafe "dup"+ c_dup :: CInt -> IO CInt+#endif++-- | Creating a socket from a file descriptor.+mkSocket :: CInt -> IO Socket+mkSocket fd = do+ ref <- newIORef fd+ let s = Socket ref fd+ void $ mkWeakIORef ref $ close s+ return s++invalidSocket :: CInt+#if defined(mingw32_HOST_OS)+invalidSocket = #const INVALID_SOCKET+#else+invalidSocket = -1+#endif++invalidateSocket ::+ Socket+ -> (CInt -> IO a)+ -> (CInt -> IO a)+ -> IO a+invalidateSocket (Socket ref _) errorAction normalAction = do+ oldfd <- atomicModifyIORef' ref $ \cur -> (invalidSocket, cur)+ if oldfd == invalidSocket then errorAction oldfd else normalAction oldfd++-----------------------------------------------------------------------------++-- | Close the socket. This function does not throw exceptions even if+-- the underlying system call returns errors.+--+-- If multiple threads use the same socket and one uses 'unsafeFdSocket' and+-- the other use 'close', unexpected behavior may happen.+-- For more information, please refer to the documentation of 'unsafeFdSocket'.+close :: Socket -> IO ()+close s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do+ -- closeFdWith avoids the deadlock of IO manager.+ closeFdWith closeFd (toFd oldfd)+ where+ toFd :: CInt -> Fd+ toFd = fromIntegral+ -- closeFd ignores the return value of c_close and+ -- does not throw exceptions+ closeFd :: Fd -> IO ()+ closeFd = void . c_close . fromIntegral++-- | Close the socket. This function throws exceptions if+-- the underlying system call returns errors.+close' :: Socket -> IO ()+close' s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do+ -- closeFdWith avoids the deadlock of IO manager.+ closeFdWith closeFd (toFd oldfd)+ where+ toFd :: CInt -> Fd+ toFd = fromIntegral+ closeFd :: Fd -> IO ()+ closeFd fd = do+ ret <- c_close $ fromIntegral fd+ when (ret == -1) $ throwErrno "Network.Socket.close'"++#if defined(mingw32_HOST_OS)+foreign import CALLCONV unsafe "closesocket"+ c_close :: CInt -> IO CInt+#else+foreign import ccall unsafe "close"+ c_close :: CInt -> IO CInt+#endif++-----------------------------------------------------------------------------++-- | Protocol number.+type ProtocolNumber = CInt++-- | This is the default protocol for a given service.+--+-- >>> defaultProtocol+-- 0+defaultProtocol :: ProtocolNumber+defaultProtocol = 0++-----------------------------------------------------------------------------+-- Socket types++-- There are a few possible ways to do this. The first is convert the+-- structs used in the C library into an equivalent Haskell type. An+-- other possible implementation is to keep all the internals in the C+-- code and use an Int## and a status flag. The second method is used+-- here since a lot of the C structures are not required to be+-- manipulated.++-- Originally the status was non-mutable so we had to return a new+-- socket each time we changed the status. This version now uses+-- mutable variables to avoid the need to do this. The result is a+-- cleaner interface and better security since the application+-- programmer now can't circumvent the status information to perform+-- invalid operations on sockets.++-- | Socket Types.+--+-- Some of the defined patterns may be unsupported on some systems:+-- see 'isSupportedSocketType'.+newtype SocketType = SocketType { packSocketType :: CInt }+ deriving (Eq, Ord)++unpackSocketType :: CInt -> SocketType+unpackSocketType = SocketType+{-# INLINE unpackSocketType #-}++-- | Is the @SOCK_xxxxx@ constant corresponding to the given SocketType known+-- on this system? 'GeneralSocketType' values, not equal to any of the named+-- patterns or 'UnsupportedSocketType', will return 'True' even when not+-- known on this system.+isSupportedSocketType :: SocketType -> Bool+isSupportedSocketType = (/= UnsupportedSocketType)++-- | Pattern for a general socket type.+pattern GeneralSocketType :: CInt -> SocketType+pattern GeneralSocketType n = SocketType n+#if __GLASGOW_HASKELL__ >= 806+{-# COMPLETE GeneralSocketType #-}+#endif+-- The actual constructor is not exported, which keeps the internal+-- representation private, but for all purposes other than 'coerce' the+-- above pattern is just as good.++-- | Unsupported socket type, equal to any other types not supported on this+-- system.+pattern UnsupportedSocketType :: SocketType+pattern UnsupportedSocketType = SocketType (-1)++-- | Used in getAddrInfo hints, for example.+pattern NoSocketType :: SocketType+pattern NoSocketType = SocketType 0++pattern Stream :: SocketType+#ifdef SOCK_STREAM+pattern Stream = SocketType (#const SOCK_STREAM)+#else+pattern Stream = (-1)+#endif++pattern Datagram :: SocketType+#ifdef SOCK_DGRAM+pattern Datagram = SocketType (#const SOCK_DGRAM)+#else+pattern Datagram = (-1)+#endif++pattern Raw :: SocketType+#ifdef SOCK_RAW+pattern Raw = SocketType (#const SOCK_RAW)+#else+pattern Raw = (-1)+#endif++pattern RDM :: SocketType+#ifdef SOCK_RDM+pattern RDM = SocketType (#const SOCK_RDM)+#else+pattern RDM = (-1)+#endif++pattern SeqPacket :: SocketType+#ifdef SOCK_SEQPACKET+pattern SeqPacket = SocketType (#const SOCK_SEQPACKET)+#else+pattern SeqPacket = (-1)+#endif++------------------------------------------------------------------------+-- Protocol Families.+++-- | Address families. The @AF_xxxxx@ constants are widely used as synonyms+-- for the corresponding @PF_xxxxx@ protocol family values, to which they are+-- numerically equal in mainstream socket API implementations.+--+-- Stictly correct usage would be to pass the @PF_xxxxx@ constants as the first+-- argument when creating a 'Socket', while the @AF_xxxxx@ constants should be+-- used as @addrFamily@ values with 'getAddrInfo'. For now only the @AF_xxxxx@+-- constants are provided.+--+-- Some of the defined patterns may be unsupported on some systems:+-- see 'isSupportedFamily'.+newtype Family = Family { packFamily :: CInt } deriving (Eq, Ord)+++-- | Does one of the AF_ constants correspond to a known address family on this+-- system. 'GeneralFamily' values, not equal to any of the named @AF_xxxxx@+-- patterns or 'UnsupportedFamily', will return 'True' even when not known on+-- this system.+isSupportedFamily :: Family -> Bool+isSupportedFamily f = case f of+ UnsupportedFamily -> False+ GeneralFamily _ -> True++-- | Convert 'CInt' to 'Family'.+unpackFamily :: CInt -> Family+unpackFamily = Family+{-# INLINE unpackFamily #-}++-- | Pattern for a general protocol family (a.k.a. address family).+--+-- @since 3.2.0.0+pattern GeneralFamily :: CInt -> Family+pattern GeneralFamily n = Family n+#if __GLASGOW_HASKELL__ >= 806+{-# COMPLETE GeneralFamily #-}+#endif+-- The actual constructor is not exported, which keeps the internal+-- representation private, but for all purposes other than 'coerce' the+-- above pattern is just as good.++-- | Unsupported address family, equal to any other families that are not+-- supported on the system.+--+-- @since 3.2.0.0+pattern UnsupportedFamily :: Family+pattern UnsupportedFamily = Family (-1)++-- | unspecified+pattern AF_UNSPEC :: Family+pattern AF_UNSPEC = Family (#const AF_UNSPEC)++-- | UNIX-domain+pattern AF_UNIX :: Family+#ifdef AF_UNIX+pattern AF_UNIX = Family (#const AF_UNIX)+#else+pattern AF_UNIX = Family (-1)+#endif++-- | Internet Protocol version 4+pattern AF_INET :: Family+#ifdef AF_INET+pattern AF_INET = Family (#const AF_INET)+#else+pattern AF_INET = Family (-1)+#endif++-- | Internet Protocol version 6+pattern AF_INET6 :: Family+#ifdef AF_INET6+pattern AF_INET6 = Family (#const AF_INET6)+#else+pattern AF_INET6 = Family (-1)+#endif++-- | Arpanet imp addresses+pattern AF_IMPLINK :: Family+#ifdef AF_IMPLINK+pattern AF_IMPLINK = Family (#const AF_IMPLINK)+#else+pattern AF_IMPLINK = Family (-1)+#endif++-- | pup protocols: e.g. BSP+pattern AF_PUP :: Family+#ifdef AF_PUP+pattern AF_PUP = Family (#const AF_PUP)+#else+pattern AF_PUP = Family (-1)+#endif++-- | mit CHAOS protocols+pattern AF_CHAOS :: Family+#ifdef AF_CHAOS+pattern AF_CHAOS = Family (#const AF_CHAOS)+#else+pattern AF_CHAOS = Family (-1)+#endif++-- | XEROX NS protocols+pattern AF_NS :: Family+#ifdef AF_NS+pattern AF_NS = Family (#const AF_NS)+#else+pattern AF_NS = Family (-1)+#endif++-- | nbs protocols+pattern AF_NBS :: Family+#ifdef AF_NBS+pattern AF_NBS = Family (#const AF_NBS)+#else+pattern AF_NBS = Family (-1)+#endif++-- | european computer manufacturers+pattern AF_ECMA :: Family+#ifdef AF_ECMA+pattern AF_ECMA = Family (#const AF_ECMA)+#else+pattern AF_ECMA = Family (-1)+#endif++-- | datakit protocols+pattern AF_DATAKIT :: Family+#ifdef AF_DATAKIT+pattern AF_DATAKIT = Family (#const AF_DATAKIT)+#else+pattern AF_DATAKIT = Family (-1)+#endif++-- | CCITT protocols, X.25 etc+pattern AF_CCITT :: Family+#ifdef AF_CCITT+pattern AF_CCITT = Family (#const AF_CCITT)+#else+pattern AF_CCITT = Family (-1)+#endif++-- | IBM SNA+pattern AF_SNA :: Family+#ifdef AF_SNA+pattern AF_SNA = Family (#const AF_SNA)+#else+pattern AF_SNA = Family (-1)+#endif++-- | DECnet+pattern AF_DECnet :: Family+#ifdef AF_DECnet+pattern AF_DECnet = Family (#const AF_DECnet)+#else+pattern AF_DECnet = Family (-1)+#endif++-- | Direct data link interface+pattern AF_DLI :: Family+#ifdef AF_DLI+pattern AF_DLI = Family (#const AF_DLI)+#else+pattern AF_DLI = Family (-1)+#endif++-- | LAT+pattern AF_LAT :: Family+#ifdef AF_LAT+pattern AF_LAT = Family (#const AF_LAT)+#else+pattern AF_LAT = Family (-1)+#endif++-- | NSC Hyperchannel+pattern AF_HYLINK :: Family+#ifdef AF_HYLINK+pattern AF_HYLINK = Family (#const AF_HYLINK)+#else+pattern AF_HYLINK = Family (-1)+#endif++-- | Apple Talk+pattern AF_APPLETALK :: Family+#ifdef AF_APPLETALK+pattern AF_APPLETALK = Family (#const AF_APPLETALK)+#else+pattern AF_APPLETALK = Family (-1)+#endif++-- | Internal Routing Protocol (aka AF_NETLINK)+pattern AF_ROUTE :: Family+#ifdef AF_ROUTE+pattern AF_ROUTE = Family (#const AF_ROUTE)+#else+pattern AF_ROUTE = Family (-1)+#endif++-- | NetBios-style addresses+pattern AF_NETBIOS :: Family+#ifdef AF_NETBIOS+pattern AF_NETBIOS = Family (#const AF_NETBIOS)+#else+pattern AF_NETBIOS = Family (-1)+#endif++-- | Network Interface Tap+pattern AF_NIT :: Family+#ifdef AF_NIT+pattern AF_NIT = Family (#const AF_NIT)+#else+pattern AF_NIT = Family (-1)+#endif++-- | IEEE 802.2, also ISO 8802+pattern AF_802 :: Family+#ifdef AF_802+pattern AF_802 = Family (#const AF_802)+#else+pattern AF_802 = Family (-1)+#endif++-- | ISO protocols+pattern AF_ISO :: Family+#ifdef AF_ISO+pattern AF_ISO = Family (#const AF_ISO)+#else+pattern AF_ISO = Family (-1)+#endif++-- | umbrella of all families used by OSI+pattern AF_OSI :: Family+#ifdef AF_OSI+pattern AF_OSI = Family (#const AF_OSI)+#else+pattern AF_OSI = Family (-1)+#endif++-- | DNA Network Management+pattern AF_NETMAN :: Family+#ifdef AF_NETMAN+pattern AF_NETMAN = Family (#const AF_NETMAN)+#else+pattern AF_NETMAN = Family (-1)+#endif++-- | CCITT X.25+pattern AF_X25 :: Family+#ifdef AF_X25+pattern AF_X25 = Family (#const AF_X25)+#else+pattern AF_X25 = Family (-1)+#endif++-- | AX25+pattern AF_AX25 :: Family+#ifdef AF_AX25+pattern AF_AX25 = Family (#const AF_AX25)+#else+pattern AF_AX25 = Family (-1)+#endif++-- | AFI+pattern AF_OSINET :: Family+#ifdef AF_OSINET+pattern AF_OSINET = Family (#const AF_OSINET)+#else+pattern AF_OSINET = Family (-1)+#endif++-- | US Government OSI+pattern AF_GOSSIP :: Family+#ifdef AF_GOSSIP+pattern AF_GOSSIP = Family (#const AF_GOSSIP)+#else+pattern AF_GOSSIP = Family (-1)+#endif++-- | Novell Internet Protocol+pattern AF_IPX :: Family+#ifdef AF_IPX+pattern AF_IPX = Family (#const AF_IPX)+#else+pattern AF_IPX = Family (-1)+#endif++-- | eXpress Transfer Protocol (no AF)+pattern Pseudo_AF_XTP :: Family+#ifdef Pseudo_AF_XTP+pattern Pseudo_AF_XTP = Family (#const Pseudo_AF_XTP)+#else+pattern Pseudo_AF_XTP = Family (-1)+#endif++-- | Common Trace Facility+pattern AF_CTF :: Family+#ifdef AF_CTF+pattern AF_CTF = Family (#const AF_CTF)+#else+pattern AF_CTF = Family (-1)+#endif++-- | Wide Area Network protocols+pattern AF_WAN :: Family+#ifdef AF_WAN+pattern AF_WAN = Family (#const AF_WAN)+#else+pattern AF_WAN = Family (-1)+#endif++-- | SGI Data Link for DLPI+pattern AF_SDL :: Family+#ifdef AF_SDL+pattern AF_SDL = Family (#const AF_SDL)+#else+pattern AF_SDL = Family (-1)+#endif++-- | Netware+pattern AF_NETWARE :: Family+#ifdef AF_NETWARE+pattern AF_NETWARE = Family (#const AF_NETWARE)+#else+pattern AF_NETWARE = Family (-1)+#endif++-- | NDD+pattern AF_NDD :: Family+#ifdef AF_NDD+pattern AF_NDD = Family (#const AF_NDD)+#else+pattern AF_NDD = Family (-1)+#endif++-- | Debugging use only+pattern AF_INTF :: Family+#ifdef AF_INTF+pattern AF_INTF = Family (#const AF_INTF)+#else+pattern AF_INTF = Family (-1)+#endif++-- | connection-oriented IP, aka ST II+pattern AF_COIP :: Family+#ifdef AF_COIP+pattern AF_COIP = Family (#const AF_COIP)+#else+pattern AF_COIP = Family (-1)+#endif++-- | Computer Network Technology+pattern AF_CNT :: Family+#ifdef AF_CNT+pattern AF_CNT = Family (#const AF_CNT)+#else+pattern AF_CNT = Family (-1)+#endif++-- | Help Identify RTIP packets+pattern Pseudo_AF_RTIP :: Family+#ifdef Pseudo_AF_RTIP+pattern Pseudo_AF_RTIP = Family (#const Pseudo_AF_RTIP)+#else+pattern Pseudo_AF_RTIP = Family (-1)+#endif++-- | Help Identify PIP packets+pattern Pseudo_AF_PIP :: Family+#ifdef Pseudo_AF_PIP+pattern Pseudo_AF_PIP = Family (#const Pseudo_AF_PIP)+#else+pattern Pseudo_AF_PIP = Family (-1)+#endif++-- | Simple Internet Protocol+pattern AF_SIP :: Family+#ifdef AF_SIP+pattern AF_SIP = Family (#const AF_SIP)+#else+pattern AF_SIP = Family (-1)+#endif++-- | Integrated Services Digital Network+pattern AF_ISDN :: Family+#ifdef AF_ISDN+pattern AF_ISDN = Family (#const AF_ISDN)+#else+pattern AF_ISDN = Family (-1)+#endif++-- | Internal key-management function+pattern Pseudo_AF_KEY :: Family+#ifdef Pseudo_AF_KEY+pattern Pseudo_AF_KEY = Family (#const Pseudo_AF_KEY)+#else+pattern Pseudo_AF_KEY = Family (-1)+#endif++-- | native ATM access+pattern AF_NATM :: Family+#ifdef AF_NATM+pattern AF_NATM = Family (#const AF_NATM)+#else+pattern AF_NATM = Family (-1)+#endif++-- | ARP (RFC 826)+pattern AF_ARP :: Family+#ifdef AF_ARP+pattern AF_ARP = Family (#const AF_ARP)+#else+pattern AF_ARP = Family (-1)+#endif++-- | Used by BPF to not rewrite hdrs in iface output+pattern Pseudo_AF_HDRCMPLT :: Family+#ifdef Pseudo_AF_HDRCMPLT+pattern Pseudo_AF_HDRCMPLT = Family (#const Pseudo_AF_HDRCMPLT)+#else+pattern Pseudo_AF_HDRCMPLT = Family (-1)+#endif++-- | ENCAP+pattern AF_ENCAP :: Family+#ifdef AF_ENCAP+pattern AF_ENCAP = Family (#const AF_ENCAP)+#else+pattern AF_ENCAP = Family (-1)+#endif++-- | Link layer interface+pattern AF_LINK :: Family+#ifdef AF_LINK+pattern AF_LINK = Family (#const AF_LINK)+#else+pattern AF_LINK = Family (-1)+#endif++-- | Link layer interface+pattern AF_RAW :: Family+#ifdef AF_RAW+pattern AF_RAW = Family (#const AF_RAW)+#else+pattern AF_RAW = Family (-1)+#endif++-- | raw interface+pattern AF_RIF :: Family+#ifdef AF_RIF+pattern AF_RIF = Family (#const AF_RIF)+#else+pattern AF_RIF = Family (-1)+#endif++-- | Amateur radio NetROM+pattern AF_NETROM :: Family+#ifdef AF_NETROM+pattern AF_NETROM = Family (#const AF_NETROM)+#else+pattern AF_NETROM = Family (-1)+#endif++-- | multiprotocol bridge+pattern AF_BRIDGE :: Family+#ifdef AF_BRIDGE+pattern AF_BRIDGE = Family (#const AF_BRIDGE)+#else+pattern AF_BRIDGE = Family (-1)+#endif++-- | ATM PVCs+pattern AF_ATMPVC :: Family+#ifdef AF_ATMPVC+pattern AF_ATMPVC = Family (#const AF_ATMPVC)+#else+pattern AF_ATMPVC = Family (-1)+#endif++-- | Amateur Radio X.25 PLP+pattern AF_ROSE :: Family+#ifdef AF_ROSE+pattern AF_ROSE = Family (#const AF_ROSE)+#else+pattern AF_ROSE = Family (-1)+#endif++-- | Netbeui 802.2LLC+pattern AF_NETBEUI :: Family+#ifdef AF_NETBEUI+pattern AF_NETBEUI = Family (#const AF_NETBEUI)+#else+pattern AF_NETBEUI = Family (-1)+#endif++-- | Security callback pseudo AF+pattern AF_SECURITY :: Family+#ifdef AF_SECURITY+pattern AF_SECURITY = Family (#const AF_SECURITY)+#else+pattern AF_SECURITY = Family (-1)+#endif++-- | Packet family+pattern AF_PACKET :: Family+#ifdef AF_PACKET+pattern AF_PACKET = Family (#const AF_PACKET)+#else+pattern AF_PACKET = Family (-1)+#endif++-- | Ash+pattern AF_ASH :: Family+#ifdef AF_ASH+pattern AF_ASH = Family (#const AF_ASH)+#else+pattern AF_ASH = Family (-1)+#endif++-- | Acorn Econet+pattern AF_ECONET :: Family+#ifdef AF_ECONET+pattern AF_ECONET = Family (#const AF_ECONET)+#else+pattern AF_ECONET = Family (-1)+#endif++-- | ATM SVCs+pattern AF_ATMSVC :: Family+#ifdef AF_ATMSVC+pattern AF_ATMSVC = Family (#const AF_ATMSVC)+#else+pattern AF_ATMSVC = Family (-1)+#endif++-- | IRDA sockets+pattern AF_IRDA :: Family+#ifdef AF_IRDA+pattern AF_IRDA = Family (#const AF_IRDA)+#else+pattern AF_IRDA = Family (-1)+#endif++-- | PPPoX sockets+pattern AF_PPPOX :: Family+#ifdef AF_PPPOX+pattern AF_PPPOX = Family (#const AF_PPPOX)+#else+pattern AF_PPPOX = Family (-1)+#endif++-- | Wanpipe API sockets+pattern AF_WANPIPE :: Family+#ifdef AF_WANPIPE+pattern AF_WANPIPE = Family (#const AF_WANPIPE)+#else+pattern AF_WANPIPE = Family (-1)+#endif++-- | bluetooth sockets+pattern AF_BLUETOOTH :: Family+#ifdef AF_BLUETOOTH+pattern AF_BLUETOOTH = Family (#const AF_BLUETOOTH)+#else+pattern AF_BLUETOOTH = Family (-1)+#endif++-- | Controller Area Network+pattern AF_CAN :: Family+#ifdef AF_CAN+pattern AF_CAN = Family (#const AF_CAN)+#else+pattern AF_CAN = Family (-1)+#endif++------------------------------------------------------------------------+-- Port Numbers++-- | Port number.+-- Use the @Num@ instance (i.e. use a literal) to create a+-- @PortNumber@ value.+--+-- >>> 1 :: PortNumber+-- 1+-- >>> read "1" :: PortNumber+-- 1+-- >>> show (12345 :: PortNumber)+-- "12345"+-- >>> 50000 < (51000 :: PortNumber)+-- True+-- >>> 50000 < (52000 :: PortNumber)+-- True+-- >>> 50000 + (10000 :: PortNumber)+-- 60000+newtype PortNumber = PortNum Word16 deriving (Eq, Ord, Num, Enum, Bounded, Real, Integral)++foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16+foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16+-- | Converts the from host byte order to network byte order.+foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32+-- | Converts the from network byte order to host byte order.+foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32+{-# DEPRECATED htonl "Use getAddrInfo instead" #-}+{-# DEPRECATED ntohl "Use getAddrInfo instead" #-}++instance Storable PortNumber where+ sizeOf _ = sizeOf (0 :: Word16)+ alignment _ = alignment (0 :: Word16)+ poke p (PortNum po) = poke (castPtr p) (htons po)+ peek p = PortNum . ntohs <$> peek (castPtr p)++-- | Default port number.+--+-- >>> defaultPort+-- 0+defaultPort :: PortNumber+defaultPort = 0++------------------------------------------------------------------------++-- | The core typeclass to unify socket addresses.+class SocketAddress sa where+ sizeOfSocketAddress :: sa -> Int+ peekSocketAddress :: Ptr sa -> IO sa+ pokeSocketAddress :: Ptr a -> sa -> IO ()++-- sizeof(struct sockaddr_storage) which has enough space to contain+-- sockaddr_in, sockaddr_in6 and sockaddr_un.+sockaddrStorageLen :: Int+sockaddrStorageLen = 128++withSocketAddress :: SocketAddress sa => sa -> (Ptr sa -> Int -> IO a) -> IO a+withSocketAddress addr f = do+ let sz = sizeOfSocketAddress addr+ if sz == 0 then+ f nullPtr 0+ else+ allocaBytes sz $ \p -> pokeSocketAddress p addr >> f (castPtr p) sz++withNewSocketAddress :: SocketAddress sa => (Ptr sa -> Int -> IO a) -> IO a+withNewSocketAddress f = allocaBytes sockaddrStorageLen $ \ptr -> do+ zeroMemory ptr $ fromIntegral sockaddrStorageLen+ f ptr sockaddrStorageLen++------------------------------------------------------------------------+-- Socket addresses++-- The scheme used for addressing sockets is somewhat quirky. The+-- calls in the BSD socket API that need to know the socket address+-- all operate in terms of struct sockaddr, a `virtual' type of+-- socket address.++-- The Internet family of sockets are addressed as struct sockaddr_in,+-- so when calling functions that operate on struct sockaddr, we have+-- to type cast the Internet socket address into a struct sockaddr.+-- Instances of the structure for different families might *not* be+-- the same size. Same casting is required of other families of+-- sockets such as Xerox NS. Similarly for UNIX-domain sockets.++-- To represent these socket addresses in Haskell-land, we do what BSD+-- didn't do, and use a union/algebraic type for the different+-- families. Currently only UNIX-domain sockets and the Internet+-- families are supported.++-- | Flow information.+type FlowInfo = Word32+-- | Scope identifier.+type ScopeID = Word32++-- | Socket addresses.+-- The existence of a constructor does not necessarily imply that+-- that socket address type is supported on your system: see+-- 'isSupportedSockAddr'.+data SockAddr+ = SockAddrInet+ !PortNumber -- sin_port+ !HostAddress -- sin_addr (ditto)+ | SockAddrInet6+ !PortNumber -- sin6_port+ !FlowInfo -- sin6_flowinfo (ditto)+ !HostAddress6 -- sin6_addr (ditto)+ !ScopeID -- sin6_scope_id (ditto)+ -- | The path must have fewer than 104 characters. All of these characters must have code points less than 256.+ | SockAddrUnix+ String -- sun_path+ deriving (Eq, Ord)++instance NFData SockAddr where+ rnf (SockAddrInet _ _) = ()+ rnf (SockAddrInet6 _ _ _ _) = ()+ rnf (SockAddrUnix str) = rnf str++-- | Is the socket address type supported on this system?+isSupportedSockAddr :: SockAddr -> Bool+isSupportedSockAddr addr = case addr of+ SockAddrInet{} -> True+ SockAddrInet6{} -> True+#if defined(DOMAIN_SOCKET_SUPPORT)+ SockAddrUnix{} -> True+#else+ SockAddrUnix{} -> False+#endif++instance SocketAddress SockAddr where+ sizeOfSocketAddress = sizeOfSockAddr+ peekSocketAddress = peekSockAddr+ pokeSocketAddress = pokeSockAddr++#if defined(mingw32_HOST_OS)+type CSaFamily = (#type unsigned short)+#elif defined(darwin_HOST_OS)+type CSaFamily = (#type u_char)+#else+type CSaFamily = (#type sa_family_t)+#endif++-- | Computes the storage requirements (in bytes) of the given+-- 'SockAddr'. This function differs from 'Foreign.Storable.sizeOf'+-- in that the value of the argument /is/ used.+sizeOfSockAddr :: SockAddr -> Int+#if defined(DOMAIN_SOCKET_SUPPORT)+# ifdef linux_HOST_OS+-- http://man7.org/linux/man-pages/man7/unix.7.html says:+-- "an abstract socket address is distinguished (from a+-- pathname socket) by the fact that sun_path[0] is a null byte+-- ('\0'). The socket's address in this namespace is given by the+-- additional bytes in sun_path that are covered by the specified+-- length of the address structure. (Null bytes in the name have no+-- special significance.) The name has no connection with filesystem+-- pathnames. When the address of an abstract socket is returned,+-- the returned addrlen is greater than sizeof(sa_family_t) (i.e.,+-- greater than 2), and the name of the socket is contained in the+-- first (addrlen - sizeof(sa_family_t)) bytes of sun_path."+sizeOfSockAddr (SockAddrUnix path) =+ case path of+ '\0':_ -> (#const sizeof(sa_family_t)) + length path+ _ -> #const sizeof(struct sockaddr_un)+# else+sizeOfSockAddr SockAddrUnix{} = #const sizeof(struct sockaddr_un)+# endif+#else+sizeOfSockAddr SockAddrUnix{} = error "sizeOfSockAddr: not supported"+#endif+sizeOfSockAddr SockAddrInet{} = #const sizeof(struct sockaddr_in)+sizeOfSockAddr SockAddrInet6{} = #const sizeof(struct sockaddr_in6)++-- | Use a 'SockAddr' with a function requiring a pointer to a+-- 'SockAddr' and the length of that 'SockAddr'.+withSockAddr :: SockAddr -> (Ptr SockAddr -> Int -> IO a) -> IO a+withSockAddr addr f = do+ let sz = sizeOfSockAddr addr+ allocaBytes sz $ \p -> pokeSockAddr p addr >> f (castPtr p) sz++-- We cannot bind sun_paths longer than than the space in the sockaddr_un+-- structure, and attempting to do so could overflow the allocated storage+-- space. This constant holds the maximum allowable path length.+--+#if defined(DOMAIN_SOCKET_SUPPORT)+unixPathMax :: Int+unixPathMax = #const sizeof(((struct sockaddr_un *)NULL)->sun_path)+#endif++-- We can't write an instance of 'Storable' for 'SockAddr' because+-- @sockaddr@ is a sum type of variable size but+-- 'Foreign.Storable.sizeOf' is required to be constant.++-- Note that on Darwin, the sockaddr structure must be zeroed before+-- use.++-- | Write the given 'SockAddr' to the given memory location.+pokeSockAddr :: Ptr a -> SockAddr -> IO ()+#if defined(DOMAIN_SOCKET_SUPPORT)+pokeSockAddr p sa@(SockAddrUnix path) = do+ when (length path > unixPathMax) $ error "pokeSockAddr: path is too long"+ zeroMemory p $ fromIntegral $ sizeOfSockAddr sa+# if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)+ (#poke struct sockaddr_un, sun_len) p ((#const sizeof(struct sockaddr_un)) :: Word8)+# endif+ (#poke struct sockaddr_un, sun_family) p ((#const AF_UNIX) :: CSaFamily)+ let pathC = map castCharToCChar path+ -- the buffer is already filled with nulls.+ pokeArray ((#ptr struct sockaddr_un, sun_path) p) pathC+#else+pokeSockAddr _ SockAddrUnix{} = error "pokeSockAddr: not supported"+#endif+pokeSockAddr p (SockAddrInet port addr) = do+ zeroMemory p (#const sizeof(struct sockaddr_in))+#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)+ (#poke struct sockaddr_in, sin_len) p ((#const sizeof(struct sockaddr_in)) :: Word8)+#endif+ (#poke struct sockaddr_in, sin_family) p ((#const AF_INET) :: CSaFamily)+ (#poke struct sockaddr_in, sin_port) p port+ (#poke struct sockaddr_in, sin_addr) p addr+pokeSockAddr p (SockAddrInet6 port flow addr scope) = do+ zeroMemory p (#const sizeof(struct sockaddr_in6))+# if defined(HAVE_STRUCT_SOCKADDR_SA_LEN)+ (#poke struct sockaddr_in6, sin6_len) p ((#const sizeof(struct sockaddr_in6)) :: Word8)+# endif+ (#poke struct sockaddr_in6, sin6_family) p ((#const AF_INET6) :: CSaFamily)+ (#poke struct sockaddr_in6, sin6_port) p port+ (#poke struct sockaddr_in6, sin6_flowinfo) p flow+ (#poke struct sockaddr_in6, sin6_addr) p (In6Addr addr)+ (#poke struct sockaddr_in6, sin6_scope_id) p scope++-- | Read a 'SockAddr' from the given memory location.+peekSockAddr :: Ptr SockAddr -> IO SockAddr+peekSockAddr p = do+ family <- (#peek struct sockaddr, sa_family) p+ case family :: CSaFamily of+#if defined(DOMAIN_SOCKET_SUPPORT)+ (#const AF_UNIX) -> do+ str <- peekCAString ((#ptr struct sockaddr_un, sun_path) p)+ return (SockAddrUnix str)+#endif+ (#const AF_INET) -> do+ addr <- (#peek struct sockaddr_in, sin_addr) p+ port <- (#peek struct sockaddr_in, sin_port) p+ return (SockAddrInet port addr)+ (#const AF_INET6) -> do+ port <- (#peek struct sockaddr_in6, sin6_port) p+ flow <- (#peek struct sockaddr_in6, sin6_flowinfo) p+ In6Addr addr <- (#peek struct sockaddr_in6, sin6_addr) p+ scope <- (#peek struct sockaddr_in6, sin6_scope_id) p+ return (SockAddrInet6 port flow addr scope)+ _ -> ioError $ userError $+ "Network.Socket.Types.peekSockAddr: address family '" +++ show family ++ "' not supported."++------------------------------------------------------------------------++-- | The raw network byte order number is read using host byte order.+-- Therefore on little-endian architectures the byte order is swapped. For+-- example @127.0.0.1@ is represented as @0x0100007f@ on little-endian hosts+-- and as @0x7f000001@ on big-endian hosts.+--+-- For direct manipulation prefer 'hostAddressToTuple' and+-- 'tupleToHostAddress'.+type HostAddress = Word32++-- | Converts 'HostAddress' to representation-independent IPv4 quadruple.+-- For example for @127.0.0.1@ the function will return @(0x7f, 0, 0, 1)@+-- regardless of host endianness.+--+{- -- prop> tow == hostAddressToTuple (tupleToHostAddress tow) -}+hostAddressToTuple :: HostAddress -> (Word8, Word8, Word8, Word8)+hostAddressToTuple ha' =+ let ha = htonl ha'+ byte i = fromIntegral (ha `shiftR` i) :: Word8+ in (byte 24, byte 16, byte 8, byte 0)++-- | Converts IPv4 quadruple to 'HostAddress'.+tupleToHostAddress :: (Word8, Word8, Word8, Word8) -> HostAddress+tupleToHostAddress (b3, b2, b1, b0) =+ let x `sl` i = fromIntegral x `shiftL` i :: Word32+ in ntohl $ (b3 `sl` 24) .|. (b2 `sl` 16) .|. (b1 `sl` 8) .|. (b0 `sl` 0)++-- | Independent of endianness. For example @::1@ is stored as @(0, 0, 0, 1)@.+--+-- For direct manipulation prefer 'hostAddress6ToTuple' and+-- 'tupleToHostAddress6'.+type HostAddress6 = (Word32, Word32, Word32, Word32)++-- | Converts 'HostAddress6' to representation-independent IPv6 octuple.+--+{- -- prop> (w1,w2,w3,w4,w5,w6,w7,w8) == hostAddress6ToTuple (tupleToHostAddress6 (w1,w2,w3,w4,w5,w6,w7,w8)) -}+hostAddress6ToTuple :: HostAddress6 -> (Word16, Word16, Word16, Word16,+ Word16, Word16, Word16, Word16)+hostAddress6ToTuple (w3, w2, w1, w0) =+ let high, low :: Word32 -> Word16+ high w = fromIntegral (w `shiftR` 16)+ low w = fromIntegral w+ in (high w3, low w3, high w2, low w2, high w1, low w1, high w0, low w0)++-- | Converts IPv6 octuple to 'HostAddress6'.+tupleToHostAddress6 :: (Word16, Word16, Word16, Word16,+ Word16, Word16, Word16, Word16) -> HostAddress6+tupleToHostAddress6 (w7, w6, w5, w4, w3, w2, w1, w0) =+ let add :: Word16 -> Word16 -> Word32+ high `add` low = (fromIntegral high `shiftL` 16) .|. (fromIntegral low)+ in (w7 `add` w6, w5 `add` w4, w3 `add` w2, w1 `add` w0)++-- The peek32 and poke32 functions work around the fact that the RFCs+-- don't require 32-bit-wide address fields to be present. We can+-- only portably rely on an 8-bit field, s6_addr.++s6_addr_offset :: Int+s6_addr_offset = (#offset struct in6_addr, s6_addr)++peek32 :: Ptr a -> Int -> IO Word32+peek32 p i0 = do+ let i' = i0 * 4+ peekByte n = peekByteOff p (s6_addr_offset + i' + n) :: IO Word8+ a `sl` i = fromIntegral a `shiftL` i+ a0 <- peekByte 0+ a1 <- peekByte 1+ a2 <- peekByte 2+ a3 <- peekByte 3+ return ((a0 `sl` 24) .|. (a1 `sl` 16) .|. (a2 `sl` 8) .|. (a3 `sl` 0))++poke32 :: Ptr a -> Int -> Word32 -> IO ()+poke32 p i0 a = do+ let i' = i0 * 4+ pokeByte n = pokeByteOff p (s6_addr_offset + i' + n)+ x `sr` i = fromIntegral (x `shiftR` i) :: Word8+ pokeByte 0 (a `sr` 24)+ pokeByte 1 (a `sr` 16)+ pokeByte 2 (a `sr` 8)+ pokeByte 3 (a `sr` 0)++-- | Private newtype proxy for the Storable instance. To avoid orphan instances.+newtype In6Addr = In6Addr HostAddress6++#if __GLASGOW_HASKELL__ < 800+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#endif++instance Storable In6Addr where+ sizeOf _ = #const sizeof(struct in6_addr)+ alignment _ = #alignment struct in6_addr++ peek p = do+ a <- peek32 p 0+ b <- peek32 p 1+ c <- peek32 p 2+ d <- peek32 p 3+ return $ In6Addr (a, b, c, d)++ poke p (In6Addr (a, b, c, d)) = do+ poke32 p 0 a+ poke32 p 1 b+ poke32 p 2 c+ poke32 p 3 d++------------------------------------------------------------------------+-- Read and Show instance for pattern-based integral newtypes++socktypeBijection :: Bijection SocketType String+socktypeBijection =+ [ (UnsupportedSocketType, "UnsupportedSocketType")+ , (Stream, "Stream")+ , (Datagram, "Datagram") + , (Raw, "Raw")+ , (RDM, "RDM")+ , (SeqPacket, "SeqPacket")+ , (NoSocketType, "NoSocketType")+ ]++instance Show SocketType where+ showsPrec = bijectiveShow socktypeBijection def+ where+ gst = "GeneralSocketType"+ def = defShow gst packSocketType _showInt++instance Read SocketType where+ readPrec = bijectiveRead socktypeBijection def+ where+ gst = "GeneralSocketType"+ def = defRead gst unpackSocketType _readInt++familyBijection :: Bijection Family String+familyBijection =+ [ (UnsupportedFamily, "UnsupportedFamily")+ , (AF_UNSPEC, "AF_UNSPEC")+ , (AF_UNIX, "AF_UNIX")+ , (AF_INET, "AF_INET")+ , (AF_INET6, "AF_INET6")+ , (AF_IMPLINK, "AF_IMPLINK")+ , (AF_PUP, "AF_PUP")+ , (AF_CHAOS, "AF_CHAOS")+ , (AF_NS, "AF_NS")+ , (AF_NBS, "AF_NBS")+ , (AF_ECMA, "AF_ECMA")+ , (AF_DATAKIT, "AF_DATAKIT")+ , (AF_CCITT, "AF_CCITT")+ , (AF_SNA, "AF_SNA")+ , (AF_DECnet, "AF_DECnet")+ , (AF_DLI, "AF_DLI")+ , (AF_LAT, "AF_LAT")+ , (AF_HYLINK, "AF_HYLINK")+ , (AF_APPLETALK, "AF_APPLETALK")+ , (AF_ROUTE, "AF_ROUTE")+ , (AF_NETBIOS, "AF_NETBIOS")+ , (AF_NIT, "AF_NIT")+ , (AF_802, "AF_802")+ , (AF_ISO, "AF_ISO")+ , (AF_OSI, "AF_OSI")+ , (AF_NETMAN, "AF_NETMAN")+ , (AF_X25, "AF_X25")+ , (AF_AX25, "AF_AX25")+ , (AF_OSINET, "AF_OSINET")+ , (AF_GOSSIP, "AF_GOSSIP")+ , (AF_IPX, "AF_IPX")+ , (Pseudo_AF_XTP, "Pseudo_AF_XTP")+ , (AF_CTF, "AF_CTF")+ , (AF_WAN, "AF_WAN")+ , (AF_SDL, "AF_SDL")+ , (AF_NETWARE, "AF_NETWARE")+ , (AF_NDD, "AF_NDD")+ , (AF_INTF, "AF_INTF")+ , (AF_COIP, "AF_COIP")+ , (AF_CNT, "AF_CNT")+ , (Pseudo_AF_RTIP, "Pseudo_AF_RTIP")+ , (Pseudo_AF_PIP, "Pseudo_AF_PIP")+ , (AF_SIP, "AF_SIP")+ , (AF_ISDN, "AF_ISDN")+ , (Pseudo_AF_KEY, "Pseudo_AF_KEY")+ , (AF_NATM, "AF_NATM")+ , (AF_ARP, "AF_ARP")+ , (Pseudo_AF_HDRCMPLT, "Pseudo_AF_HDRCMPLT")+ , (AF_ENCAP, "AF_ENCAP")+ , (AF_LINK, "AF_LINK")+ , (AF_RAW, "AF_RAW")+ , (AF_RIF, "AF_RIF")+ , (AF_NETROM, "AF_NETROM")+ , (AF_BRIDGE, "AF_BRIDGE")+ , (AF_ATMPVC, "AF_ATMPVC")+ , (AF_ROSE, "AF_ROSE")+ , (AF_NETBEUI, "AF_NETBEUI")+ , (AF_SECURITY, "AF_SECURITY")+ , (AF_PACKET, "AF_PACKET")+ , (AF_ASH, "AF_ASH")+ , (AF_ECONET, "AF_ECONET")+ , (AF_ATMSVC, "AF_ATMSVC")+ , (AF_IRDA, "AF_IRDA")+ , (AF_PPPOX, "AF_PPPOX")+ , (AF_WANPIPE, "AF_WANPIPE")+ , (AF_BLUETOOTH, "AF_BLUETOOTH")+ , (AF_CAN, "AF_CAN")+ ]++instance Show Family where+ showsPrec = bijectiveShow familyBijection def+ where+ gf = "GeneralFamily"+ def = defShow gf packFamily _showInt++instance Read Family where+ readPrec = bijectiveRead familyBijection def+ where+ gf = "GeneralFamily"+ def = defRead gf unpackFamily _readInt++-- Print "n" instead of "PortNum n".+instance Show PortNumber where+ showsPrec p (PortNum pn) = showsPrec p pn++-- Read "n" instead of "PortNum n".+instance Read PortNumber where+ readPrec = safeInt ------------------------------------------------------------------------ -- Helper functions
Network/Socket/Unix.hsc view
@@ -13,30 +13,28 @@ , getPeerEid ) where +import System.Posix.Types (Fd(..))++import Network.Socket.Buffer import Network.Socket.Imports+import Network.Socket.Posix.Cmsg import Network.Socket.Types #if defined(HAVE_GETPEEREID) import System.IO.Error (catchIOError) #endif-#ifdef HAVE_STRUCT_UCRED_SO_PEERCRED-import Foreign.Marshal.Utils (with)-#endif #ifdef HAVE_GETPEEREID import Foreign.Marshal.Alloc (alloca) #endif #ifdef DOMAIN_SOCKET_SUPPORT-import Control.Monad (void) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Array (peekArray)-import Foreign.Ptr (Ptr)-import Foreign.Storable (Storable(..)) import Network.Socket.Fcntl import Network.Socket.Internal #endif #ifdef HAVE_STRUCT_UCRED_SO_PEERCRED-import Network.Socket.Options (c_getsockopt)+import Network.Socket.Options #endif -- | Getting process ID, user ID and group ID for UNIX-domain sockets.@@ -77,15 +75,20 @@ getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt) #ifdef HAVE_STRUCT_UCRED_SO_PEERCRED getPeerCred s = do- let sz = (#const sizeof(struct ucred))- withFdSocket s $ \fd -> allocaBytes sz $ \ ptr_cr ->- with (fromIntegral sz) $ \ ptr_sz -> do- _ <- ($) throwSocketErrorIfMinus1Retry "Network.Socket.getPeerCred" $- c_getsockopt fd (#const SOL_SOCKET) (#const SO_PEERCRED) ptr_cr ptr_sz- pid <- (#peek struct ucred, pid) ptr_cr- uid <- (#peek struct ucred, uid) ptr_cr- gid <- (#peek struct ucred, gid) ptr_cr- return (pid, uid, gid)+ let opt = SockOpt (#const SOL_SOCKET) (#const SO_PEERCRED)+ PeerCred cred <- getSockOpt s opt+ return cred++newtype PeerCred = PeerCred (CUInt, CUInt, CUInt)+instance Storable PeerCred where+ sizeOf _ = (#const sizeof(struct ucred))+ alignment _ = alignment (0 :: CInt)+ poke _ _ = return ()+ peek p = do+ pid <- (#peek struct ucred, pid) p+ uid <- (#peek struct ucred, uid) p+ gid <- (#peek struct ucred, gid) p+ return $ PeerCred (pid, uid, gid) #else getPeerCred _ = return (0, 0, 0) #endif@@ -125,15 +128,23 @@ isUnixDomainSocketAvailable = False #endif +data NullSockAddr = NullSockAddr++instance SocketAddress NullSockAddr where+ sizeOfSocketAddress _ = 0+ peekSocketAddress _ = return NullSockAddr+ pokeSocketAddress _ _ = return ()+ -- | Send a file descriptor over a UNIX-domain socket. -- Use this function in the case where 'isUnixDomainSocketAvailable' is -- 'True'. sendFd :: Socket -> CInt -> IO () #if defined(DOMAIN_SOCKET_SUPPORT)-sendFd s outfd = void $ do- withFdSocket s $ \fd ->- throwSocketErrorWaitWrite s "Network.Socket.sendFd" $ c_sendFd fd outfd-foreign import ccall SAFE_ON_WIN "sendFd" c_sendFd :: CInt -> CInt -> IO CInt+sendFd s outfd = void $ allocaBytes dummyBufSize $ \buf -> do+ let cmsg = encodeCmsg $ Fd outfd+ sendBufMsg s NullSockAddr [(buf,dummyBufSize)] [cmsg] mempty+ where+ dummyBufSize = 1 #else sendFd _ _ = error "Network.Socket.sendFd" #endif@@ -145,10 +156,13 @@ -- 'True'. recvFd :: Socket -> IO CInt #if defined(DOMAIN_SOCKET_SUPPORT)-recvFd s = do- withFdSocket s $ \fd ->- throwSocketErrorWaitRead s "Network.Socket.recvFd" $ c_recvFd fd-foreign import ccall SAFE_ON_WIN "recvFd" c_recvFd :: CInt -> IO CInt+recvFd s = allocaBytes dummyBufSize $ \buf -> do+ (NullSockAddr, _, cmsgs, _) <- recvBufMsg s [(buf,dummyBufSize)] 32 mempty+ case (lookupCmsg CmsgIdFd cmsgs >>= decodeCmsg) :: Maybe Fd of+ Nothing -> return (-1)+ Just (Fd fd) -> return fd+ where+ dummyBufSize = 16 #else recvFd _ = error "Network.Socket.recvFd" #endif@@ -164,7 +178,7 @@ #if defined(DOMAIN_SOCKET_SUPPORT) socketPair family stype protocol = allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do- c_stype <- packSocketTypeOrThrow "socketPair" stype+ let c_stype = packSocketType stype _rc <- throwSocketErrorIfMinus1Retry "Network.Socket.socketpair" $ c_socketpair (packFamily family) c_stype protocol fdArr [fd1,fd2] <- peekArray 2 fdArr
+ Network/Socket/Win32/Cmsg.hsc view
@@ -0,0 +1,216 @@++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Network.Socket.Win32.Cmsg where++#include "HsNet.h"++import Data.ByteString.Internal+import Foreign.ForeignPtr+import System.IO.Unsafe (unsafeDupablePerformIO)++import Network.Socket.Imports+import Network.Socket.Types+import Network.Socket.ReadShow++import qualified Text.Read as P++type DWORD = Word32+type ULONG = Word32++-- | Control message (ancillary data) including a pair of level and type.+data Cmsg = Cmsg {+ cmsgId :: !CmsgId+ , cmsgData :: !ByteString+ } deriving (Eq, Show)++----------------------------------------------------------------++-- | Identifier of control message (ancillary data).+data CmsgId = CmsgId {+ cmsgLevel :: !CInt+ , cmsgType :: !CInt+ } deriving (Eq)++-- | Unsupported identifier+pattern UnsupportedCmsgId :: CmsgId+pattern UnsupportedCmsgId = CmsgId (-1) (-1)++-- | The identifier for 'IPv4TTL'.+pattern CmsgIdIPv4TTL :: CmsgId+pattern CmsgIdIPv4TTL = CmsgId (#const IPPROTO_IP) (#const IP_TTL)++-- | The identifier for 'IPv6HopLimit'.+pattern CmsgIdIPv6HopLimit :: CmsgId+pattern CmsgIdIPv6HopLimit = CmsgId (#const IPPROTO_IPV6) (#const IPV6_HOPLIMIT)++-- | The identifier for 'IPv4TOS'.+pattern CmsgIdIPv4TOS :: CmsgId+pattern CmsgIdIPv4TOS = CmsgId (#const IPPROTO_IP) (#const IP_TOS)++-- | The identifier for 'IPv6TClass'.+pattern CmsgIdIPv6TClass :: CmsgId+pattern CmsgIdIPv6TClass = CmsgId (#const IPPROTO_IPV6) (#const IPV6_TCLASS)++-- | The identifier for 'IPv4PktInfo'.+pattern CmsgIdIPv4PktInfo :: CmsgId+pattern CmsgIdIPv4PktInfo = CmsgId (#const IPPROTO_IP) (#const IP_PKTINFO)++-- | The identifier for 'IPv6PktInfo'.+pattern CmsgIdIPv6PktInfo :: CmsgId+pattern CmsgIdIPv6PktInfo = CmsgId (#const IPPROTO_IPV6) (#const IPV6_PKTINFO)++-- | Control message ID for POSIX file-descriptor passing.+--+-- Not supported on Windows; use WSADuplicateSocket instead+pattern CmsgIdFd :: CmsgId+pattern CmsgIdFd = CmsgId (-1) (-1)++----------------------------------------------------------------++-- | Looking up control message. The following shows an example usage:+--+-- > (lookupCmsg CmsgIdIPv4TOS cmsgs >>= decodeCmsg) :: Maybe IPv4TOS+lookupCmsg :: CmsgId -> [Cmsg] -> Maybe Cmsg+lookupCmsg _ [] = Nothing+lookupCmsg cid (cmsg:cmsgs)+ | cmsgId cmsg == cid = Just cmsg+ | otherwise = lookupCmsg cid cmsgs++-- | Filtering control message.+filterCmsg :: CmsgId -> [Cmsg] -> [Cmsg]+filterCmsg cid cmsgs = filter (\cmsg -> cmsgId cmsg == cid) cmsgs++----------------------------------------------------------------++-- | A class to encode and decode control message.+class Storable a => ControlMessage a where+ controlMessageId :: CmsgId++encodeCmsg :: forall a. ControlMessage a => a -> Cmsg+encodeCmsg x = unsafeDupablePerformIO $ do+ bs <- create siz $ \p0 -> do+ let p = castPtr p0+ poke p x+ let cmsid = controlMessageId @a+ return $ Cmsg cmsid bs+ where+ siz = sizeOf x++decodeCmsg :: forall a . (ControlMessage a, Storable a) => Cmsg -> Maybe a+decodeCmsg (Cmsg cmsid (PS fptr off len))+ | cid /= cmsid = Nothing+ | len < siz = Nothing+ | otherwise = unsafeDupablePerformIO $ withForeignPtr fptr $ \p0 -> do+ let p = castPtr (p0 `plusPtr` off)+ Just <$> peek p+ where+ cid = controlMessageId @a+ siz = sizeOf (undefined :: a)++----------------------------------------------------------------++-- | Time to live of IPv4.+newtype IPv4TTL = IPv4TTL DWORD deriving (Eq, Show, Storable)++instance ControlMessage IPv4TTL where+ controlMessageId = CmsgIdIPv4TTL++----------------------------------------------------------------++-- | Hop limit of IPv6.+newtype IPv6HopLimit = IPv6HopLimit DWORD deriving (Eq, Show, Storable)++instance ControlMessage IPv6HopLimit where+ controlMessageId = CmsgIdIPv6HopLimit++----------------------------------------------------------------++-- | TOS of IPv4.+newtype IPv4TOS = IPv4TOS DWORD deriving (Eq, Show, Storable)++instance ControlMessage IPv4TOS where+ controlMessageId = CmsgIdIPv4TOS++----------------------------------------------------------------++-- | Traffic class of IPv6.+newtype IPv6TClass = IPv6TClass DWORD deriving (Eq, Show, Storable)++instance ControlMessage IPv6TClass where+ controlMessageId = CmsgIdIPv6TClass++----------------------------------------------------------------++-- | Network interface ID and local IPv4 address.+data IPv4PktInfo = IPv4PktInfo ULONG HostAddress deriving (Eq)++instance Show IPv4PktInfo where+ show (IPv4PktInfo n ha) = "IPv4PktInfo " ++ show n ++ " " ++ show (hostAddressToTuple ha)++instance ControlMessage IPv4PktInfo where+ controlMessageId = CmsgIdIPv4PktInfo++instance Storable IPv4PktInfo where+ sizeOf _ = #{size IN_PKTINFO}+ alignment _ = #alignment IN_PKTINFO+ poke p (IPv4PktInfo n ha) = do+ (#poke IN_PKTINFO, ipi_ifindex) p (fromIntegral n :: CInt)+ (#poke IN_PKTINFO, ipi_addr) p ha+ peek p = do+ n <- (#peek IN_PKTINFO, ipi_ifindex) p+ ha <- (#peek IN_PKTINFO, ipi_addr) p+ return $ IPv4PktInfo n ha++----------------------------------------------------------------++-- | Network interface ID and local IPv4 address.+data IPv6PktInfo = IPv6PktInfo Int HostAddress6 deriving (Eq)++instance Show IPv6PktInfo where+ show (IPv6PktInfo n ha6) = "IPv6PktInfo " ++ show n ++ " " ++ show (hostAddress6ToTuple ha6)++instance ControlMessage IPv6PktInfo where+ controlMessageId = CmsgIdIPv6PktInfo++instance Storable IPv6PktInfo where+ sizeOf _ = #{size IN6_PKTINFO}+ alignment _ = #alignment IN6_PKTINFO+ poke p (IPv6PktInfo n ha6) = do+ (#poke IN6_PKTINFO, ipi6_ifindex) p (fromIntegral n :: CInt)+ (#poke IN6_PKTINFO, ipi6_addr) p (In6Addr ha6)+ peek p = do+ In6Addr ha6 <- (#peek IN6_PKTINFO, ipi6_addr) p+ n :: ULONG <- (#peek IN6_PKTINFO, ipi6_ifindex) p+ return $ IPv6PktInfo (fromIntegral n) ha6++cmsgIdBijection :: Bijection CmsgId String+cmsgIdBijection =+ [ (UnsupportedCmsgId, "UnsupportedCmsgId")+ , (CmsgIdIPv4TTL, "CmsgIdIPv4TTL")+ , (CmsgIdIPv6HopLimit, "CmsgIdIPv6HopLimit")+ , (CmsgIdIPv4TOS, "CmsgIdIPv4TOS")+ , (CmsgIdIPv6TClass, "CmsgIdIPv6TClass")+ , (CmsgIdIPv4PktInfo, "CmsgIdIPv4PktInfo")+ , (CmsgIdIPv6PktInfo, "CmsgIdIPv6PktInfo")+ , (CmsgIdFd, "CmsgIdFd")+ ]++instance Show CmsgId where+ showsPrec = bijectiveShow cmsgIdBijection def+ where+ defname = "CmsgId"+ unId = \(CmsgId l t) -> (l,t)+ def = defShow defname unId showIntInt++instance Read CmsgId where+ readPrec = bijectiveRead cmsgIdBijection def+ where+ defname = "CmsgId"+ def = defRead defname (uncurry CmsgId) readIntInt
+ Network/Socket/Win32/CmsgHdr.hsc view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++#include "HsNet.h"++module Network.Socket.Win32.CmsgHdr (+ Cmsg(..)+ , withCmsgs+ , parseCmsgs+ ) where++import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.ForeignPtr+import qualified Data.ByteString as B+import Data.ByteString.Internal++import Network.Socket.Imports+import Network.Socket.Win32.Cmsg+import Network.Socket.Win32.MsgHdr+import Network.Socket.Types++data CmsgHdr = CmsgHdr {+ cmsgHdrLen :: !CUInt+ , cmsgHdrLevel :: !CInt+ , cmsgHdrType :: !CInt+ } deriving (Eq, Show)++instance Storable CmsgHdr where+ sizeOf _ = #{size WSACMSGHDR}+ alignment _ = #alignment WSACMSGHDR++ peek p = do+ len <- (#peek WSACMSGHDR, cmsg_len) p+ lvl <- (#peek WSACMSGHDR, cmsg_level) p+ typ <- (#peek WSACMSGHDR, cmsg_type) p+ return $ CmsgHdr len lvl typ++ poke p (CmsgHdr len lvl typ) = do+ zeroMemory p (#size WSACMSGHDR)+ (#poke WSACMSGHDR, cmsg_len) p len+ (#poke WSACMSGHDR, cmsg_level) p lvl+ (#poke WSACMSGHDR, cmsg_type) p typ++withCmsgs :: [Cmsg] -> (Ptr CmsgHdr -> Int -> IO a) -> IO a+withCmsgs cmsgs0 action+ | total == 0 = action nullPtr 0+ | otherwise = allocaBytes total $ \ctrlPtr -> do+ loop ctrlPtr cmsgs0 spaces+ action ctrlPtr total+ where+ loop ctrlPtr (cmsg:cmsgs) (s:ss) = do+ toCmsgHdr cmsg ctrlPtr+ let nextPtr = ctrlPtr `plusPtr` s+ loop nextPtr cmsgs ss+ loop _ _ _ = return ()+ cmsg_space = fromIntegral . c_cmsg_space . fromIntegral+ spaces = map (cmsg_space . B.length . cmsgData) cmsgs0+ total = sum spaces++toCmsgHdr :: Cmsg -> Ptr CmsgHdr -> IO ()+toCmsgHdr (Cmsg (CmsgId lvl typ) (PS fptr off len)) ctrlPtr = do+ poke ctrlPtr $ CmsgHdr (c_cmsg_len (fromIntegral len)) lvl typ+ withForeignPtr fptr $ \src0 -> do+ let src = src0 `plusPtr` off+ dst <- c_cmsg_data ctrlPtr+ memcpy dst src len++parseCmsgs :: SocketAddress sa => Ptr (MsgHdr sa) -> IO [Cmsg]+parseCmsgs msgptr = do+ ptr <- c_cmsg_firsthdr msgptr+ loop ptr id+ where+ loop ptr build+ | ptr == nullPtr = return $ build []+ | otherwise = do+ val <- fromCmsgHdr ptr+ case val of+ Nothing -> return $ build []+ Just cmsg -> do+ nextPtr <- c_cmsg_nxthdr msgptr ptr+ loop nextPtr (build . (cmsg :))++fromCmsgHdr :: Ptr CmsgHdr -> IO (Maybe Cmsg)+fromCmsgHdr ptr = do+ CmsgHdr len lvl typ <- peek ptr+ src <- c_cmsg_data ptr+ let siz = fromIntegral len - (src `minusPtr` ptr)+ if siz < 0+ then return Nothing+ else Just . Cmsg (CmsgId lvl typ) <$> create (fromIntegral siz) (\dst -> memcpy dst src siz)++foreign import ccall unsafe "cmsg_firsthdr"+ c_cmsg_firsthdr :: Ptr (MsgHdr sa) -> IO (Ptr CmsgHdr)++foreign import ccall unsafe "cmsg_nxthdr"+ c_cmsg_nxthdr :: Ptr (MsgHdr sa) -> Ptr CmsgHdr -> IO (Ptr CmsgHdr)++foreign import ccall unsafe "cmsg_data"+ c_cmsg_data :: Ptr CmsgHdr -> IO (Ptr Word8)++foreign import ccall unsafe "cmsg_space"+ c_cmsg_space :: CUInt -> CUInt++foreign import ccall unsafe "cmsg_len"+ c_cmsg_len :: CUInt -> CUInt
+ Network/Socket/Win32/MsgHdr.hsc view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# LANGUAGE CPP #-}++-- | Support module for the Windows 'WSASendMsg' system call.+module Network.Socket.Win32.MsgHdr+ ( MsgHdr(..)+ ) where++#include "HsNet.h"++import Network.Socket.Imports+import Network.Socket.Internal (zeroMemory)+import Network.Socket.Win32.WSABuf++type DWORD = Word32+type ULONG = Word32++-- The size of BufferLen is different on pre-vista compilers.+-- But since those platforms are out of support anyway we ignore that.+data MsgHdr sa = MsgHdr+ { msgName :: !(Ptr sa)+ , msgNameLen :: !CInt+ , msgBuffer :: !(Ptr WSABuf)+ , msgBufferLen :: !DWORD+ , msgCtrl :: !(Ptr Word8)+ , msgCtrlLen :: !ULONG+ , msgFlags :: !DWORD+ } deriving Show++instance Storable (MsgHdr sa) where+ sizeOf _ = #{size WSAMSG}+ alignment _ = #alignment WSAMSG++ peek p = do+ name <- (#peek WSAMSG, name) p+ nameLen <- (#peek WSAMSG, namelen) p+ buffer <- (#peek WSAMSG, lpBuffers) p+ bufferLen <- (#peek WSAMSG, dwBufferCount) p+ ctrl <- (#peek WSAMSG, Control.buf) p+ ctrlLen <- (#peek WSAMSG, Control.len) p+ flags <- (#peek WSAMSG, dwFlags) p+ return $ MsgHdr name nameLen buffer bufferLen ctrl ctrlLen flags++ poke p mh = do+ -- We need to zero the msg_control, msg_controllen, and msg_flags+ -- fields, but they only exist on some platforms (e.g. not on+ -- Solaris). Instead of using CPP, we zero the entire struct.+ zeroMemory p (#const sizeof(WSAMSG))+ (#poke WSAMSG, name) p (msgName mh)+ (#poke WSAMSG, namelen) p (msgNameLen mh)+ (#poke WSAMSG, lpBuffers) p (msgBuffer mh)+ (#poke WSAMSG, dwBufferCount) p (msgBufferLen mh)+ (#poke WSAMSG, Control.buf) p (msgCtrl mh)+ (#poke WSAMSG, Control.len) p (msgCtrlLen mh)+ (#poke WSAMSG, dwFlags) p (msgFlags mh)
+ Network/Socket/Win32/WSABuf.hsc view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++-- | Support module for the Windows winsock system calls.+module Network.Socket.Win32.WSABuf+ ( WSABuf(..)+ , withWSABuf+ ) where++#include "HsNet.h"++import Foreign.Marshal.Array (allocaArray)++import Network.Socket.Imports++type ULONG = Word32++data WSABuf = WSABuf+ { wsaBufPtr :: !(Ptr Word8)+ , wsaBufLen :: !ULONG+ }++instance Storable WSABuf where+ sizeOf _ = #{size WSABUF}+ alignment _ = #alignment WSABUF++ peek p = do+ base <- (#peek WSABUF, buf) p+ len <- (#peek WSABUF, len) p+ return $ WSABuf base len++ poke p iov = do+ (#poke WSABUF, buf) p (wsaBufPtr iov)+ (#poke WSABUF, len) p (wsaBufLen iov)++-- | @withWSABuf cs f@ executes the computation @f@, passing as argument a pair+-- consisting of a pointer to a temporarily allocated array of pointers to+-- WSABBUF made from @cs@ and the number of pointers (@length cs@).+-- /Windows only/.+withWSABuf :: [(Ptr Word8, Int)] -> ((Ptr WSABuf, Int) -> IO a) -> IO a+withWSABuf [] f = f (nullPtr, 0)+withWSABuf cs f =+ allocaArray csLen $ \aPtr -> do+ zipWithM_ pokeWsaBuf (ptrs aPtr) cs+ f (aPtr, csLen)+ where+ csLen = length cs+ ptrs = iterate (`plusPtr` sizeOf (WSABuf nullPtr 0))+ pokeWsaBuf ptr (sPtr, sLen) = poke ptr $ WSABuf sPtr (fromIntegral sLen)
− cbits/ancilData.c
@@ -1,132 +0,0 @@-/*- * Copyright(c), 2002 The GHC Team.- */--#ifdef aix_HOST_OS-#define _LINUX_SOURCE_COMPAT -// Required to get CMSG_SPACE/CMSG_LEN macros. See #265.-// Alternative is to #define COMPAT_43 and use the -// HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS code instead, but that means-// fiddling with the configure script too.-#endif--#include "HsNet.h"-#include <string.h>--#if HAVE_STRUCT_MSGHDR_MSG_CONTROL || HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS /* until end */--/* - * Support for transmitting file descriptors.- *- * - */- --/*- * sendmsg() and recvmsg() wrappers for transmitting- * ancillary socket data.- *- * Doesn't provide the full generality of either, specifically:- *- * - no support for scattered read/writes.- * - only possible to send one ancillary chunk of data at a time.- */--int-sendFd(int sock,- int outfd)-{- struct msghdr msg = {0};- struct iovec iov[1];- char buf[2];-#if HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS- msg.msg_accrights = (void*)&outfd;- msg.msg_accrightslen = sizeof(int);-#else- struct cmsghdr *cmsg;- char ancBuffer[CMSG_SPACE(sizeof(int))];- char* dPtr;- - msg.msg_control = ancBuffer;- msg.msg_controllen = sizeof(ancBuffer);-- cmsg = CMSG_FIRSTHDR(&msg);- cmsg->cmsg_level = SOL_SOCKET;- cmsg->cmsg_type = SCM_RIGHTS;- cmsg->cmsg_len = CMSG_LEN(sizeof(int));- dPtr = (char*)CMSG_DATA(cmsg);- - *(int*)dPtr = outfd;- msg.msg_controllen = cmsg->cmsg_len;-#endif-- buf[0] = 0; buf[1] = '\0';- iov[0].iov_base = buf;- iov[0].iov_len = 2;-- msg.msg_iov = iov;- msg.msg_iovlen = 1;- - return sendmsg(sock,&msg,0);-}--int-recvFd(int sock)-{- struct msghdr msg = {0};- char duffBuf[10];- int rc;- int len = sizeof(int);- struct iovec iov[1];-#if HAVE_STRUCT_MSGHDR_MSG_CONTROL- struct cmsghdr *cmsg = NULL;- struct cmsghdr *cptr;-#else- int* fdBuffer;-#endif- int fd;-- iov[0].iov_base = duffBuf;- iov[0].iov_len = sizeof(duffBuf);- msg.msg_iov = iov;- msg.msg_iovlen = 1;--#if HAVE_STRUCT_MSGHDR_MSG_CONTROL- cmsg = (struct cmsghdr*)malloc(CMSG_SPACE(len));- if (cmsg==NULL) {- return -1;- }- - msg.msg_control = (void *)cmsg;- msg.msg_controllen = CMSG_LEN(len);-#else- fdBuffer = (int*)malloc(len);- if (fdBuffer) {- msg.msg_accrights = (void *)fdBuffer;- } else {- return -1;- }- msg.msg_accrightslen = len;-#endif-- if ((rc = recvmsg(sock,&msg,0)) < 0) {-#if HAVE_STRUCT_MSGHDR_MSG_CONTROL- free(cmsg);-#else- free(fdBuffer);-#endif- return rc;- }- -#if HAVE_STRUCT_MSGHDR_MSG_CONTROL- cptr = (struct cmsghdr*)CMSG_FIRSTHDR(&msg);- fd = *(int*)CMSG_DATA(cptr);- free(cmsg);-#else- fd = *(int*)fdBuffer;- free(fdBuffer);-#endif- return fd;-}--#endif
+ cbits/cmsg.c view
@@ -0,0 +1,97 @@+#include "HsNet.h"+#include <string.h>++#ifdef _WIN32++LPWSACMSGHDR cmsg_firsthdr(LPWSAMSG mhdr) {+ return (WSA_CMSG_FIRSTHDR(mhdr));+}++LPWSACMSGHDR cmsg_nxthdr(LPWSAMSG mhdr, LPWSACMSGHDR cmsg) {+ return (WSA_CMSG_NXTHDR(mhdr, cmsg));+}++unsigned char *cmsg_data(LPWSACMSGHDR cmsg) {+ return (WSA_CMSG_DATA(cmsg));+}++unsigned int cmsg_space(unsigned int l) {+ return (WSA_CMSG_SPACE(l));+}++unsigned int cmsg_len(unsigned int l) {+ return (WSA_CMSG_LEN(l));+}++static LPFN_WSASENDMSG ptr_SendMsg;+static LPFN_WSARECVMSG ptr_RecvMsg;+/* GUIDS to lookup WSASend/RecvMsg */+static GUID WSARecvMsgGUID = WSAID_WSARECVMSG;+static GUID WSASendMsgGUID = WSAID_WSASENDMSG;++int WINAPI+WSASendMsg (SOCKET s, LPWSAMSG lpMsg, DWORD flags,+ LPDWORD lpdwNumberOfBytesRecvd, LPWSAOVERLAPPED lpOverlapped,+ LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine) {++ if (!ptr_SendMsg) {+ DWORD len;+ if (WSAIoctl(s, SIO_GET_EXTENSION_FUNCTION_POINTER,+ &WSASendMsgGUID, sizeof(WSASendMsgGUID), &ptr_SendMsg,+ sizeof(ptr_SendMsg), &len, NULL, NULL) != 0)+ return -1;+ }++ return ptr_SendMsg (s, lpMsg, flags, lpdwNumberOfBytesRecvd, lpOverlapped,+ lpCompletionRoutine);+}++/**+ * WSARecvMsg function+ */+int WINAPI+WSARecvMsg (SOCKET s, LPWSAMSG lpMsg, LPDWORD lpdwNumberOfBytesRecvd,+ LPWSAOVERLAPPED lpOverlapped,+ LPWSAOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine) {++ if (!ptr_RecvMsg) {+ DWORD len;+ if (WSAIoctl(s, SIO_GET_EXTENSION_FUNCTION_POINTER,+ &WSARecvMsgGUID, sizeof(WSARecvMsgGUID), &ptr_RecvMsg,+ sizeof(ptr_RecvMsg), &len, NULL, NULL) != 0)+ return -1;+ }++ int res = ptr_RecvMsg (s, lpMsg, lpdwNumberOfBytesRecvd, lpOverlapped,+ lpCompletionRoutine);++ /* If the msg was truncated then this pointer can be garbage. */+ if (res == SOCKET_ERROR && GetLastError () == WSAEMSGSIZE)+ {+ lpMsg->Control.len = 0;+ lpMsg->Control.buf = NULL;+ }++ return res;+}+#else+struct cmsghdr *cmsg_firsthdr(struct msghdr *mhdr) {+ return (CMSG_FIRSTHDR(mhdr));+}++struct cmsghdr *cmsg_nxthdr(struct msghdr *mhdr, struct cmsghdr *cmsg) {+ return (CMSG_NXTHDR(mhdr, cmsg));+}++unsigned char *cmsg_data(struct cmsghdr *cmsg) {+ return (CMSG_DATA(cmsg));+}++int cmsg_space(int l) {+ return (CMSG_SPACE(l));+}++int cmsg_len(int l) {+ return (CMSG_LEN(l));+}+#endif /* _WIN32 */
configure.ac view
@@ -1,5 +1,5 @@ AC_INIT([Haskell network package],- [3.1.1.1],+ [3.1.2.0], [libraries@haskell.org], [network])
examples/EchoClient.hs view
@@ -23,7 +23,6 @@ resolve = do let hints = defaultHints { addrSocketType = Stream } head <$> getAddrInfo (Just hints) (Just host) (Just port)- open addr = do- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ open addr = E.bracketOnError (openSocket addr) close $ \sock -> do connect sock $ addrAddress addr return sock
examples/EchoServer.hs view
@@ -29,13 +29,16 @@ , addrSocketType = Stream } head <$> getAddrInfo (Just hints) mhost (Just port)- open addr = do- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ open addr = E.bracketOnError (openSocket addr) close $ \sock -> do setSocketOption sock ReuseAddr 1- withFdSocket sock $ setCloseOnExecIfNeeded+ withFdSocket sock setCloseOnExecIfNeeded bind sock $ addrAddress addr listen sock 1024 return sock- loop sock = forever $ do- (conn, _peer) <- accept sock- void $ forkFinally (server conn) (const $ gracefulClose conn 5000)+ loop sock = forever $ E.bracketOnError (accept sock) (close . fst)+ $ \(conn, _peer) -> void $+ -- 'forkFinally' alone is unlikely to fail thus leaking @conn@,+ -- but 'E.bracketOnError' above will be necessary if some+ -- non-atomic setups (e.g. spawning a subprocess to handle+ -- @conn@) before proper cleanup of @conn@ is your case+ forkFinally (server conn) (const $ gracefulClose conn 5000)
include/HsNet.h view
@@ -20,10 +20,13 @@ #endif #define _GNU_SOURCE 1 /* for struct ucred on Linux */+#define __APPLE_USE_RFC_3542 1 /* for IPV6_RECVPKTINFO */ #ifdef _WIN32 # include <winsock2.h> # include <ws2tcpip.h>+# include <mswsock.h>+# include "win32defs.h" # define IPV6_V6ONLY 27 #endif @@ -78,12 +81,56 @@ void* sockaddr); extern int acceptNewSock(void* d); extern int acceptDoProc(void* param);++extern LPWSACMSGHDR+cmsg_firsthdr(LPWSAMSG mhdr);++extern LPWSACMSGHDR+cmsg_nxthdr(LPWSAMSG mhdr, LPWSACMSGHDR cmsg);++extern unsigned char *+cmsg_data(LPWSACMSGHDR cmsg);++extern unsigned int+cmsg_space(unsigned int l);++extern unsigned int+cmsg_len(unsigned int l);++/**+ * WSASendMsg function+ */+extern WINAPI int+WSASendMsg (SOCKET, LPWSAMSG, DWORD, LPDWORD,+ LPWSAOVERLAPPED, LPWSAOVERLAPPED_COMPLETION_ROUTINE);++/**+ * WSARecvMsg function+ */+extern WINAPI int+WSARecvMsg (SOCKET, LPWSAMSG, LPDWORD,+ LPWSAOVERLAPPED, LPWSAOVERLAPPED_COMPLETION_ROUTINE); #else /* _WIN32 */ extern int sendFd(int sock, int outfd); extern int recvFd(int sock);++extern struct cmsghdr *+cmsg_firsthdr(struct msghdr *mhdr);++extern struct cmsghdr *+cmsg_nxthdr(struct msghdr *mhdr, struct cmsghdr *cmsg);++extern unsigned char *+cmsg_data(struct cmsghdr *cmsg);++extern int+cmsg_space(int l);++extern int+cmsg_len(int l); #endif /* _WIN32 */ INLINE char *@@ -93,7 +140,7 @@ #elif defined(HAVE_IN_ADDR_T) in_addr_t addr #elif defined(HAVE_INTTYPES_H)- u_int32_t addr+ uint32_t addr #else unsigned long addr #endif
+ include/alignment.h view
@@ -0,0 +1,3 @@+#if __GLASGOW_HASKELL__ < 711 +#define hsc_alignment(t ) hsc_printf ( "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__)); +#endif
+ include/win32defs.h view
@@ -0,0 +1,120 @@+#ifndef IP_OPTIONS +#define IP_OPTIONS 1 // Set/get IP options. +#endif +#ifndef IP_HDRINCL +#define IP_HDRINCL 2 // Header is included with data. +#endif +#ifndef IP_TOS +#define IP_TOS 3 // IP type of service. +#endif +#ifndef IP_TTL +#define IP_TTL 4 // IP TTL (hop limit). +#endif +#ifndef IP_MULTICAST_IF +#define IP_MULTICAST_IF 9 // IP multicast interface. +#endif +#ifndef IP_MULTICAST_TTL +#define IP_MULTICAST_TTL 10 // IP multicast TTL (hop limit). +#endif +#ifndef IP_MULTICAST_LOOP +#define IP_MULTICAST_LOOP 11 // IP multicast loopback. +#endif +#ifndef IP_ADD_MEMBERSHIP +#define IP_ADD_MEMBERSHIP 12 // Add an IP group membership. +#endif +#ifndef IP_DROP_MEMBERSHIP +#define IP_DROP_MEMBERSHIP 13 // Drop an IP group membership. +#endif +#ifndef IP_DONTFRAGMENT +#define IP_DONTFRAGMENT 14 // Don't fragment IP datagrams. +#endif +#ifndef IP_ADD_SOURCE_MEMBERSHIP +#define IP_ADD_SOURCE_MEMBERSHIP 15 // Join IP group/source. +#endif +#ifndef IP_DROP_SOURCE_MEMBERSHIP +#define IP_DROP_SOURCE_MEMBERSHIP 16 // Leave IP group/source. +#endif +#ifndef IP_BLOCK_SOURCE +#define IP_BLOCK_SOURCE 17 // Block IP group/source. +#endif +#ifndef IP_UNBLOCK_SOURCE +#define IP_UNBLOCK_SOURCE 18 // Unblock IP group/source. +#endif +#ifndef IP_PKTINFO +#define IP_PKTINFO 19 // Receive packet information. +#endif +#ifndef IP_HOPLIMIT +#define IP_HOPLIMIT 21 // Receive packet hop limit. +#endif +#ifndef IP_RECVTTL +#define IP_RECVTTL 21 // Receive packet Time To Live (TTL). +#endif +#ifndef IP_RECEIVE_BROADCAST +#define IP_RECEIVE_BROADCAST 22 // Allow/block broadcast reception. +#endif +#ifndef IP_RECVIF +#define IP_RECVIF 24 // Receive arrival interface. +#endif +#ifndef IP_RECVDSTADDR +#define IP_RECVDSTADDR 25 // Receive destination address. +#endif +#ifndef IP_IFLIST +#define IP_IFLIST 28 // Enable/Disable an interface list. +#endif +#ifndef IP_ADD_IFLIST +#define IP_ADD_IFLIST 29 // Add an interface list entry. +#endif +#ifndef IP_DEL_IFLIST +#define IP_DEL_IFLIST 30 // Delete an interface list entry. +#endif +#ifndef IP_UNICAST_IF +#define IP_UNICAST_IF 31 // IP unicast interface. +#endif +#ifndef IP_RTHDR +#define IP_RTHDR 32 // Set/get IPv6 routing header. +#endif +#ifndef IP_GET_IFLIST +#define IP_GET_IFLIST 33 // Get an interface list. +#endif +#ifndef IP_RECVRTHDR +#define IP_RECVRTHDR 38 // Receive the routing header. +#endif +#ifndef IP_TCLASS +#define IP_TCLASS 39 // Packet traffic class. +#endif +#ifndef IP_RECVTCLASS +#define IP_RECVTCLASS 40 // Receive packet traffic class. +#endif +#ifndef IP_RECVTOS +#define IP_RECVTOS 40 // Receive packet Type Of Service (TOS). +#endif +#ifndef IP_ORIGINAL_ARRIVAL_IF +#define IP_ORIGINAL_ARRIVAL_IF 47 // Original Arrival Interface Index. +#endif +#ifndef IP_ECN +#define IP_ECN 50 // Receive ECN codepoints in the IP header. +#endif +#ifndef IP_PKTINFO_EX +#define IP_PKTINFO_EX 51 // Receive extended packet information. +#endif +#ifndef IP_WFP_REDIRECT_RECORDS +#define IP_WFP_REDIRECT_RECORDS 60 // WFP's Connection Redirect Records. +#endif +#ifndef IP_WFP_REDIRECT_CONTEXT +#define IP_WFP_REDIRECT_CONTEXT 70 // WFP's Connection Redirect Context. +#endif +#ifndef IP_MTU_DISCOVER +#define IP_MTU_DISCOVER 71 // Set/get path MTU discover state. +#endif +#ifndef IP_MTU +#define IP_MTU 73 // Get path MTU. +#endif +#ifndef IP_NRT_INTERFACE +#define IP_NRT_INTERFACE 74 // Set NRT interface constraint (outbound). +#endif +#ifndef IP_RECVERR +#define IP_RECVERR 75 // Receive ICMP errors. +#endif +#ifndef IPV6_TCLASS +#define IPV6_TCLASS 39 +#endif
network.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: network-version: 3.1.1.1+version: 3.1.2.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Evan Borden@@ -43,17 +43,21 @@ configure.ac configure include/HsNetworkConfig.h.in include/HsNet.h include/HsNetDef.h -- C sources only used on some systems- cbits/ancilData.c cbits/asyncAccept.c cbits/initWinSock.c- cbits/winSockErr.c+ cbits/asyncAccept.c cbits/initWinSock.c+ cbits/winSockErr.c cbits/cmsg.c homepage: https://github.com/haskell/network bug-reports: https://github.com/haskell/network/issues-tested-with: GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2+tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4- , GHC == 8.6.2+ , GHC == 8.6.5+ , GHC == 8.8.3+ , GHC == 8.10.1 +flag devel+ description: using tests for developers+ default: False+ library default-language: Haskell2010 exposed-modules:@@ -64,31 +68,33 @@ Network.Socket.Internal other-modules: Network.Socket.Buffer- Network.Socket.ByteString.Internal Network.Socket.ByteString.IO+ Network.Socket.ByteString.Internal Network.Socket.Cbits Network.Socket.Fcntl+ Network.Socket.Flag Network.Socket.Handle- Network.Socket.Imports Network.Socket.If+ Network.Socket.Imports Network.Socket.Info Network.Socket.Name Network.Socket.Options+ Network.Socket.ReadShow Network.Socket.Shutdown Network.Socket.SockAddr Network.Socket.Syscall Network.Socket.Types- Network.Socket.Unix build-depends: base >= 4.7 && < 5, bytestring == 0.10.*,- deepseq+ deepseq,+ directory include-dirs: include- includes: HsNet.h HsNetDef.h- install-includes: HsNet.h HsNetDef.h- c-sources: cbits/HsNet.c+ includes: HsNet.h HsNetDef.h alignment.h win32defs.h+ install-includes: HsNet.h HsNetDef.h alignment.h win32defs.h+ c-sources: cbits/HsNet.c cbits/cmsg.c ghc-options: -Wall -fwarn-tabs build-tools: hsc2hs @@ -96,10 +102,12 @@ -- Add some platform specific stuff if !os(windows) other-modules:- Network.Socket.ByteString.IOVec Network.Socket.ByteString.Lazy.Posix- Network.Socket.ByteString.MsgHdr- c-sources: cbits/ancilData.c+ Network.Socket.Posix.Cmsg+ Network.Socket.Posix.CmsgHdr+ Network.Socket.Posix.IOVec+ Network.Socket.Posix.MsgHdr+ Network.Socket.Unix if os(solaris) extra-libraries: nsl, socket@@ -107,16 +115,23 @@ if os(windows) other-modules: Network.Socket.ByteString.Lazy.Windows+ Network.Socket.Win32.Cmsg+ Network.Socket.Win32.CmsgHdr+ Network.Socket.Win32.WSABuf+ Network.Socket.Win32.MsgHdr c-sources: cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c- extra-libraries: ws2_32, iphlpapi+ extra-libraries: ws2_32, iphlpapi, mswsock -- See https://github.com/haskell/network/pull/362 if impl(ghc >= 7.10) cpp-options: -D_WIN32_WINNT=0x0600+ cc-options: -D_WIN32_WINNT=0x0600 test-suite spec default-language: Haskell2010 hs-source-dirs: tests main-is: Spec.hs+ if flag(devel)+ cpp-options: -DDEVELOPMENT other-modules: Network.Test.Common Network.SocketSpec@@ -134,7 +149,9 @@ directory, HUnit, network,- hspec >= 2.6+ temporary,+ hspec >= 2.6,+ QuickCheck test-suite doctests buildable: False
tests/Network/Socket/ByteStringSpec.hs view
@@ -2,12 +2,18 @@ module Network.Socket.ByteStringSpec (main, spec) where +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Data.Bits+import Data.Maybe+import Control.Monad import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C import Network.Socket import Network.Socket.ByteString import Network.Test.Common +import System.Environment+ import Test.Hspec main :: IO ()@@ -48,37 +54,27 @@ describe "sendTo" $ do it "works well" $ do let server sock = recv sock 1024 `shouldReturn` testMsg- client sock serverPort = do- let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)- sendTo sock testMsg $ addrAddress addr+ client sock addr = sendTo sock testMsg addr udpTest client server it "throws when closed" $ do let server _ = return ()- client sock serverPort = do- let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)+ client sock addr = do close sock- sendTo sock testMsg (addrAddress addr) `shouldThrow` anyException+ sendTo sock testMsg addr `shouldThrow` anyException udpTest client server describe "sendAllTo" $ do it "works well" $ do let server sock = recv sock 1024 `shouldReturn` testMsg- client sock serverPort = do- let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)- sendAllTo sock testMsg $ addrAddress addr+ client sock addr = sendAllTo sock testMsg addr udpTest client server it "throws when closed" $ do let server _ = return ()- client sock serverPort = do- let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)+ client sock addr = do close sock- sendAllTo sock testMsg (addrAddress addr) `shouldThrow` anyException+ sendAllTo sock testMsg addr `shouldThrow` anyException udpTest client server describe "sendMany" $ do@@ -103,10 +99,7 @@ describe "sendManyTo" $ do it "works well" $ do let server sock = recv sock 1024 `shouldReturn` S.append seg1 seg2- client sock serverPort = do- let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)- sendManyTo sock [seg1, seg2] $ addrAddress addr+ client sock addr = sendManyTo sock [seg1, seg2] addr seg1 = C.pack "This is a " seg2 = C.pack "test message."@@ -114,11 +107,9 @@ it "throws when closed" $ do let server _ = return ()- client sock serverPort = do- let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)+ client sock addr = do close sock- sendManyTo sock [seg1, seg2] (addrAddress addr) `shouldThrow` anyException+ sendManyTo sock [seg1, seg2] addr `shouldThrow` anyException seg1 = C.pack "This is a " seg2 = C.pack "test message."@@ -189,3 +180,129 @@ seg1 `shouldBe` S.empty client sock = shutdown sock ShutdownSend tcpTest client server++ describe "sendMsg" $ do+ it "works well" $ do+ let server sock = recv sock 1024 `shouldReturn` S.append seg1 seg2+ client sock addr = sendMsg sock addr [seg1, seg2] [] mempty++ seg1 = C.pack "This is a "+ seg2 = C.pack "test message."+ udpTest client server++ it "throws when closed" $ do+ let server _ = return ()+ client sock addr = do+ close sock+ sendMsg sock addr [seg1, seg2] [] mempty `shouldThrow` anyException++ seg1 = C.pack "This is a "+ seg2 = C.pack "test message."+ udpTest client server++ describe "recvMsg" $ do+ it "works well" $ do+ let server sock = do+ (_, msg, cmsgs, flags) <- recvMsg sock 1024 0 mempty+ msg `shouldBe` seg+ cmsgs `shouldBe` []+ flags `shouldBe` mempty+ client sock addr = sendTo sock seg addr++ seg = C.pack "This is a test message"+ udpTest client server++ it "receives truncated flag" $ do+ let server sock = do+ (_, _, _, flags) <- recvMsg sock (S.length seg - 2) 0 mempty+ flags .&. MSG_TRUNC `shouldBe` MSG_TRUNC+ client sock addr = sendTo sock seg addr++ seg = C.pack "This is a test message"+ udpTest client server++ it "peek" $ do+ let server sock = do+ (_, msgs, _, _flags) <- recvMsg sock 1024 0 MSG_PEEK+ -- flags .&. MSG_PEEK `shouldBe` MSG_PEEK -- Mac only+ (_, msgs', _, _) <- recvMsg sock 1024 0 mempty+ msgs `shouldBe` msgs'+ client sock addr = sendTo sock seg addr++ seg = C.pack "This is a test message"+ udpTest client server++ it "receives control messages for IPv4" $ do+ -- This test behaves strange on AppVeyor and I don't know why so skip+ -- TOS for now.+ isAppVeyor <- isJust <$> lookupEnv "APPVEYOR"++ -- Avoid race condition between the client sending the message and+ -- the server finishing its socket configuration. Otherwise the+ -- message may be received with default socket options!+ serverReady <- newEmptyMVar++ let server sock = do+ whenSupported RecvIPv4TTL $ setSocketOption sock RecvIPv4TTL 1+ whenSupported RecvIPv4PktInfo $ setSocketOption sock RecvIPv4PktInfo 1+ whenSupported RecvIPv4TOS $ setSocketOption sock RecvIPv4TOS 1+ putMVar serverReady ()++ (_, _, cmsgs, _) <- recvMsg sock 1024 128 mempty++ whenSupported RecvIPv4PktInfo $+ ((lookupCmsg CmsgIdIPv4PktInfo cmsgs >>= decodeCmsg) :: Maybe IPv4PktInfo) `shouldNotBe` Nothing+ when (not isAppVeyor) $ do+ whenSupported RecvIPv4TTL $+ ((lookupCmsg CmsgIdIPv4TTL cmsgs >>= decodeCmsg) :: Maybe IPv4TTL) `shouldNotBe` Nothing+ whenSupported RecvIPv4TOS $+ ((lookupCmsg CmsgIdIPv4TOS cmsgs >>= decodeCmsg) :: Maybe IPv4TOS) `shouldNotBe` Nothing+ client sock addr = takeMVar serverReady >> sendTo sock seg addr++ seg = C.pack "This is a test message"+ udpTest client server++ it "receives control messages for IPv6" $ do+ -- Avoid race condition between the client sending the message and+ -- the server finishing its socket configuration. Otherwise the+ -- message may be received with default socket options!+ serverReady <- newEmptyMVar++ let server sock = do+ whenSupported RecvIPv6HopLimit $ setSocketOption sock RecvIPv6HopLimit 1+ whenSupported RecvIPv6TClass $ setSocketOption sock RecvIPv6TClass 1+ whenSupported RecvIPv6PktInfo $ setSocketOption sock RecvIPv6PktInfo 1+ putMVar serverReady ()++ (_, _, cmsgs, _) <- recvMsg sock 1024 128 mempty++ whenSupported RecvIPv6HopLimit $+ ((lookupCmsg CmsgIdIPv6HopLimit cmsgs >>= decodeCmsg) :: Maybe IPv6HopLimit) `shouldNotBe` Nothing+ whenSupported RecvIPv6TClass $+ ((lookupCmsg CmsgIdIPv6TClass cmsgs >>= decodeCmsg) :: Maybe IPv6TClass) `shouldNotBe` Nothing+ whenSupported RecvIPv6PktInfo $+ ((lookupCmsg CmsgIdIPv6PktInfo cmsgs >>= decodeCmsg) :: Maybe IPv6PktInfo) `shouldNotBe` Nothing+ client sock addr = takeMVar serverReady >> sendTo sock seg addr++ seg = C.pack "This is a test message"+ udpTest6 client server++ it "receives truncated control messages" $ do+ -- Avoid race condition between the client sending the message and+ -- the server finishing its socket configuration. Otherwise the+ -- message may be received with default socket options!+ serverReady <- newEmptyMVar++ let server sock = do+ whenSupported RecvIPv4TTL $ setSocketOption sock RecvIPv4TTL 1+ whenSupported RecvIPv4TOS $ setSocketOption sock RecvIPv4TOS 1+ whenSupported RecvIPv4PktInfo $ setSocketOption sock RecvIPv4PktInfo 1+ putMVar serverReady ()++ (_, _, _, flags) <- recvMsg sock 1024 10 mempty+ flags .&. MSG_CTRUNC `shouldBe` MSG_CTRUNC++ client sock addr = takeMVar serverReady >> sendTo sock seg addr++ seg = C.pack "This is a test message"+ udpTest client server
tests/Network/SocketSpec.hs view
@@ -6,12 +6,18 @@ import Control.Concurrent (threadDelay, forkIO) import Control.Concurrent.MVar (readMVar) import Control.Monad+import Data.Maybe (fromJust)+import Data.List (nub) import Network.Socket import Network.Socket.ByteString import Network.Test.Common import System.Mem (performGC)+import System.IO.Error (tryIOError, isAlreadyInUseError)+import System.IO.Temp (withSystemTempDirectory)+import Foreign.C.Types () import Test.Hspec+import Test.QuickCheck main :: IO () main = hspec spec@@ -31,7 +37,7 @@ connect' (8080 :: Int) `shouldThrow` anyIOException it "successfully connects to a socket with no exception" $ do- withPort $ \portVar -> test (tcp return portVar)+ withPort $ \portVar -> test (tcp serverAddr return portVar) { clientSetup = readMVar portVar >>= connect' } @@ -40,6 +46,19 @@ { addrFlags = [AI_PASSIVE] , addrSocketType = Stream }+ it "successfully binds to an ipv4 socket" $ do+ addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ bind sock $ addrAddress addr++{- This does not work on Windows and Linux.+ it "fails to bind to unknown ipv4 socket" $ do+ addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.3") Nothing+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ bind sock (addrAddress addr) `shouldThrow` anyIOException+-}++#ifdef DEVELOPMENT it "successfully binds to an ipv6 socket" $ do addr:_ <- getAddrInfo (Just hints) (Just serverAddr6) Nothing sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)@@ -49,7 +68,38 @@ addr:_ <- getAddrInfo (Just hints) (Just "::6") Nothing sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) bind sock (addrAddress addr) `shouldThrow` anyIOException+#endif + it "successfully binds to a unix socket, twice" $ do+ withSystemTempDirectory "haskell-network" $ \path -> do+ let sfile = path ++ "/socket-file"+ let addr = SockAddrUnix sfile+ when (isSupportedSockAddr addr) $ do+ sock0 <- socket AF_UNIX Stream defaultProtocol+ bind sock0 addr+ listen sock0 1++ sock1 <- socket AF_UNIX Stream defaultProtocol+ tryIOError (bind sock1 addr) >>= \o -> case o of+ Right () -> error "bind should have failed but succeeded"+ Left e | not (isAlreadyInUseError e) -> ioError e+ _ -> return ()++ close sock0++ -- Unix systems tend to leave the file existing, which is+ -- why our `bind` does its workaround. however if any+ -- system in the future does fix this issue, we don't want+ -- this test to fail, since that would defeat the purpose+ -- of our workaround. but you can uncomment the below lines+ -- if you want to play with this on your own system.+ --import System.Directory (doesPathExist)+ --ex <- doesPathExist sfile+ --unless ex $ error "socket file was deleted unexpectedly"++ sock2 <- socket AF_UNIX Stream defaultProtocol+ bind sock2 addr+ describe "UserTimeout" $ do it "can be set" $ do when (isSupportedSocketOption UserTimeout) $ do@@ -67,7 +117,6 @@ getAddrInfo (Just hints) (Just "127.128.129.130") Nothing hostAddressToTuple hostAddr `shouldBe` (0x7f, 0x80, 0x81, 0x82) -#if defined(IPV6_SOCKET_SUPPORT) it "works for IPv6 address" $ do let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } host = "2001:0db8:85a3:0000:0000:8a2e:0370:7334"@@ -75,7 +124,6 @@ getAddrInfo (Just hints) (Just host) Nothing hostAddress6ToTuple hostAddr `shouldBe` (0x2001, 0x0db8, 0x85a3, 0x0000, 0x0000, 0x8a2e, 0x0370, 0x7334)-#endif it "does not cause segfault on macOS 10.8.2 due to AI_NUMERICSERV" $ do let hints = defaultHints { addrFlags = [AI_NUMERICSERV] }@@ -83,19 +131,18 @@ #if defined(mingw32_HOST_OS) let lpdevname = "loopback_0"-#elif defined(darwin_HOST_OS)+#elif defined(darwin_HOST_OS) || defined(freebsd_HOST_OS) let lpdevname = "lo0" #else let lpdevname = "lo" #endif - describe "ifNameToIndex" $ do- it "converts a name to an index" $- ifNameToIndex lpdevname `shouldReturn` Just 1-- describe "ifIndexToName" $ do- it "converts an index to a name" $- ifIndexToName 1 `shouldReturn` Just lpdevname+ describe "ifNameToIndex and ifIndexToName" $ do+ it "convert a name to an index and back" $+ do+ n <- ifNameToIndex lpdevname+ n `shouldNotBe` Nothing+ ifIndexToName (fromJust n) `shouldReturn` Just lpdevname describe "socket" $ do let gc = do@@ -116,6 +163,7 @@ -- check if an exception is not thrown. isSupportedSockAddr addr `shouldBe` True +#if !defined(mingw32_HOST_OS) when isUnixDomainSocketAvailable $ do context "unix sockets" $ do it "basic unix sockets end-to-end" $ do@@ -124,6 +172,7 @@ recv sock 1024 `shouldReturn` testMsg addr `shouldBe` (SockAddrUnix "") test . setClientAction client $ unixWithUnlink unixAddr server+#endif #ifdef linux_HOST_OS it "can end-to-end with an abstract socket" $ do@@ -142,6 +191,7 @@ bind sock (SockAddrUnix abstractAddress) `shouldThrow` anyErrorCall #endif +#if !defined(mingw32_HOST_OS) describe "socketPair" $ do it "can send and recieve bi-directionally" $ do (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol@@ -196,6 +246,7 @@ cred1 <- getPeerCredential s cred1 `shouldBe` (Nothing,Nothing,Nothing) -}+#endif describe "gracefulClose" $ do it "does not send TCP RST back" $ do@@ -219,3 +270,207 @@ s <- mkSocket fd sendAll s "HELLO WORLD" tcpTest client server++ describe "getNameInfo" $ do+ it "works for IPv4 address" $ do+ let addr = SockAddrInet 80 (tupleToHostAddress (127, 0, 0, 1))+ (hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr++ hn_m `shouldBe` (Just "127.0.0.1")+ sn_m `shouldBe` (Just "80")++ it "works for IPv6 address" $ do+ let addr = SockAddrInet6 80 0+ (tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0+ (hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr+ hn_m `shouldBe`(Just "2001:db8:2:3:4:5:6:7")+ sn_m `shouldBe` (Just "80")++ it "works for IPv6 address" $ do+ let addr = SockAddrInet6 80 0+ (tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0+ (hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr+ hn_m `shouldBe`(Just "2001:db8:2:3:4:5:6:7")+ sn_m `shouldBe` (Just "80")++ it "works for global multicast IPv6 address" $ do+ let addr = SockAddrInet6 80 0+ (tupleToHostAddress6 (0xfe01, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0+ (hn_m, sn_m) <- getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True addr+ hn_m `shouldBe`(Just "fe01:db8:2:3:4:5:6:7")+ sn_m `shouldBe` (Just "80")++ describe "show SocketAddr" $ do+ it "works for IPv4 address" $+ let addr = SockAddrInet 80 (tupleToHostAddress (127, 0, 0, 1)) in+ show addr `shouldBe` "127.0.0.1:80"++ it "works for IPv6 address" $+ let addr = SockAddrInet6 80 0+ (tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0 in+ show addr `shouldBe` "[2001:db8:2:3:4:5:6:7]:80"++ it "works for IPv6 address with zeros" $+ let addr = SockAddrInet6 80 0+ (tupleToHostAddress6 (0x2001, 0x0db8, 0x2, 0x3, 0x0, 0x0, 0x0, 0x7)) 0 in+ show addr `shouldBe` "[2001:db8:2:3::7]:80"++ it "works for multicast IPv6 address with reserved scope" $ do+ let addr = SockAddrInet6 80 0+ (tupleToHostAddress6 (0xff01, 0x1234, 0x2, 0x3, 0x4, 0x5, 0x6, 0x7)) 0+ show addr `shouldBe` "[ff01:1234:2:3:4:5:6:7]:80"++ describe "show Family" $ do+ it "works for pattern synonyms" $+ let fam = AF_UNSPEC in+ show fam `shouldBe` "AF_UNSPEC"++ it "works for unsupported" $+ let fam = GeneralFamily (-1) in+ show fam `shouldBe` "UnsupportedFamily"++ it "works for positive values" $+ let fam = GeneralFamily 300 in+ show fam `shouldBe` "GeneralFamily 300"++ it "works for negative values" $+ let fam = GeneralFamily (-300) in+ show fam `shouldBe` "GeneralFamily (-300)"++ describe "show SocketType" $ do+ it "works for pattern synonyms" $+ let socktype = NoSocketType in+ show socktype `shouldBe` "NoSocketType"++ it "works for unsupported" $+ let socktype = GeneralSocketType (-1) in+ show socktype `shouldBe` "UnsupportedSocketType"++ it "works for positive values" $+ let socktype = GeneralSocketType 300 in+ show socktype `shouldBe` "GeneralSocketType 300"++ it "works for negative values" $+ let socktype = GeneralSocketType (-300) in+ show socktype `shouldBe` "GeneralSocketType (-300)"++ describe "show SocketOptions" $ do+ it "works for pattern synonyms" $+ let opt = ReuseAddr in+ show opt `shouldBe` "ReuseAddr"++ it "works for unsupported" $+ let opt = SockOpt (-1) (-1) in+ show opt `shouldBe` "UnsupportedSocketOption"++ it "works for positive values" $+ let opt = SockOpt 300 300 in+ show opt `shouldBe` "SockOpt 300 300"++ it "works for negative values" $+ let opt = SockOpt (-300) (-300) in+ show opt `shouldBe` "SockOpt (-300) (-300)"++ describe "show CmsgId" $ do+ it "works for pattern synonyms" $+ let msgid = CmsgIdIPv6HopLimit in+ show msgid `shouldBe` "CmsgIdIPv6HopLimit"++ it "works for unsupported" $+ let msgid = CmsgId (-1) (-1) in+ show msgid `shouldBe` "UnsupportedCmsgId"++ it "works for positive values" $+ let msgid = CmsgId 300 300 in+ show msgid `shouldBe` "CmsgId 300 300"++ it "works for negative values" $+ let msgid = CmsgId (-300) (-300) in+ show msgid `shouldBe` "CmsgId (-300) (-300)"++ describe "bijective read-show roundtrip equality" $ do+ it "holds for Family" $ forAll familyGen $+ \x -> (read . show $ x) == (x :: Family)++ it "holds for SocketType" $ forAll socktypeGen $+ \x -> (read . show $ x) == (x :: SocketType)++ it "holds for SocketOption" $ forAll sockoptGen $+ \x -> (read . show $ x) == (x :: SocketOption)++ it "holds for CmsgId" $ forAll cmsgidGen $+ \x -> (read . show $ x) == (x :: CmsgId)+++-- Type-specific generators with strong bias towards pattern synonyms++-- Generator combinator that biases elements of a given list and otherwise+-- applies a function to a given generator+biasedGen :: (Gen a -> Gen b) -> [b] -> Gen a -> Gen b+biasedGen f xs g = do+ useBias <- (arbitrary :: Gen Bool)+ if useBias+ then elements xs+ else f g++familyGen :: Gen Family+familyGen = biasedGen (fmap GeneralFamily) familyPatterns arbitrary++socktypeGen :: Gen SocketType+socktypeGen = biasedGen (fmap GeneralSocketType) socktypePatterns arbitrary++sockoptGen :: Gen SocketOption+sockoptGen = biasedGen (\g -> SockOpt <$> g <*> g) sockoptPatterns arbitrary++cmsgidGen :: Gen CmsgId+cmsgidGen = biasedGen (\g -> CmsgId <$> g <*> g) cmsgidPatterns arbitrary++-- pruned lists of pattern synonym values for each type to generate values from++familyPatterns :: [Family]+familyPatterns = nub+ [UnsupportedFamily+ ,AF_UNSPEC,AF_UNIX,AF_INET,AF_INET6,AF_IMPLINK,AF_PUP,AF_CHAOS+ ,AF_NS,AF_NBS,AF_ECMA,AF_DATAKIT,AF_CCITT,AF_SNA,AF_DECnet+ ,AF_DLI,AF_LAT,AF_HYLINK,AF_APPLETALK,AF_ROUTE,AF_NETBIOS+ ,AF_NIT,AF_802,AF_ISO,AF_OSI,AF_NETMAN,AF_X25,AF_AX25,AF_OSINET+ ,AF_GOSSIP,AF_IPX,Pseudo_AF_XTP,AF_CTF,AF_WAN,AF_SDL,AF_NETWARE+ ,AF_NDD,AF_INTF,AF_COIP,AF_CNT,Pseudo_AF_RTIP,Pseudo_AF_PIP+ ,AF_SIP,AF_ISDN,Pseudo_AF_KEY,AF_NATM,AF_ARP,Pseudo_AF_HDRCMPLT+ ,AF_ENCAP,AF_LINK,AF_RAW,AF_RIF,AF_NETROM,AF_BRIDGE,AF_ATMPVC+ ,AF_ROSE,AF_NETBEUI,AF_SECURITY,AF_PACKET,AF_ASH,AF_ECONET+ ,AF_ATMSVC,AF_IRDA,AF_PPPOX,AF_WANPIPE,AF_BLUETOOTH,AF_CAN]++socktypePatterns :: [SocketType]+socktypePatterns = nub+ [ UnsupportedSocketType+ , NoSocketType+ , Stream+ , Datagram+ , Raw+ , RDM+ , SeqPacket+ ]++sockoptPatterns :: [SocketOption]+sockoptPatterns = nub+ [UnsupportedSocketOption+ ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute+ ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline,TimeToLive+ ,MaxSegment,NoDelay,Cork,Linger,ReusePort+ ,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut+ ,UseLoopBack,UserTimeout,IPv6Only+ ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo+ ,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo]++cmsgidPatterns :: [CmsgId]+cmsgidPatterns = nub+ [ UnsupportedCmsgId+ , CmsgIdIPv4TTL+ , CmsgIdIPv6HopLimit+ , CmsgIdIPv4TOS+ , CmsgIdIPv6TClass+ , CmsgIdIPv4PktInfo+ , CmsgIdIPv6PktInfo+ , CmsgIdFd+ ]
tests/Network/Test/Common.hs view
@@ -15,7 +15,9 @@ -- * Run a ClientServer configuration , test , tcpTest+ , tcpTest6 , udpTest+ , udpTest6 -- * Common constants , serverAddr , serverAddr6@@ -24,16 +26,18 @@ , lazyTestMsg ) where +#if __GLASGOW_HASKELL__ < 709+import Control.Applicative ((<$>))+#endif import Control.Concurrent (ThreadId, forkIO, myThreadId) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar) import qualified Control.Exception as E import Control.Monad import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L import Network.Socket import System.Directory-import qualified Data.ByteString.Lazy as L import System.Timeout (timeout)- import Test.Hspec serverAddr :: String@@ -94,15 +98,17 @@ -- client and server. 'tcpTest' makes sure that the 'Socket' is -- closed after the actions have run. tcpTest :: (Socket -> IO a) -> (Socket -> IO b) -> IO ()-tcpTest client server = withPort $ test . setClientAction client . tcp server+tcpTest client server = withPort $ test . setClientAction client . tcp serverAddr server -tcp :: (Socket -> IO b) -> MVar PortNumber -> ClientServer Socket ()-tcp serverAct portVar = defaultClientServer+tcpTest6 :: (Socket -> IO a) -> (Socket -> IO b) -> IO ()+tcpTest6 client server = withPort $ test . setClientAction client . tcp serverAddr6 server++tcp :: HostName -> (Socket -> IO b) -> MVar PortNumber -> ClientServer Socket ()+tcp serverAddress serverAct portVar = defaultClientServer { clientSetup = do- let hints = defaultHints { addrSocketType = Stream } serverPort <- readMVar portVar- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ addr <- resolveClient Stream serverAddress serverPort+ sock <- socketWithAddrInfo addr #if !defined(mingw32_HOST_OS) withFdSocket sock $ \fd -> do getNonBlock fd `shouldReturn` True@@ -111,12 +117,8 @@ connect sock $ addrAddress addr return sock , serverSetup = do- let hints = defaultHints {- addrFlags = [AI_PASSIVE]- , addrSocketType = Stream- }- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ addr <- resolveServer Stream serverAddress+ sock <- socketWithAddrInfo addr withFdSocket sock $ \fd -> do #if !defined(mingw32_HOST_OS) getNonBlock fd `shouldReturn` True@@ -145,26 +147,30 @@ -- | Create an unconnected 'Socket' for sending UDP and receiving -- datagrams and then run 'clientAct' and 'serverAct'.-udpTest :: (Socket -> PortNumber -> IO a) -> (Socket -> IO b) -> IO ()+udpTest :: (Socket -> SockAddr -> IO a) -> (Socket -> IO b) -> IO () udpTest client server =- withPort $ test . setServerAction server . udp client+ withPort $ test . setServerAction server . udp serverAddr client +udpTest6 :: (Socket -> SockAddr -> IO a) -> (Socket -> IO b) -> IO ()+udpTest6 client server =+ withPort $ test . setServerAction server . udp serverAddr6 client+ udp- :: (Socket -> PortNumber -> IO a)+ :: HostName+ -> (Socket -> SockAddr -> IO a) -> MVar PortNumber -> ClientServer a Socket-udp clientAct portVar = defaultClientServer- { clientSetup = socket AF_INET Datagram defaultProtocol+udp serverAddress clientAct portVar = defaultClientServer+ { clientSetup = do+ addr <- resolveClient Datagram serverAddress 8000 -- dummy port+ socketWithAddrInfo addr , clientAction = \sock -> do serverPort <- readMVar portVar- clientAct sock serverPort+ addr <- resolveClient Datagram serverAddress serverPort+ clientAct sock $ addrAddress addr , serverSetup = do- let hints = defaultHints {- addrFlags = [AI_PASSIVE]- , addrSocketType = Datagram- }- addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ addr <- resolveServer Datagram serverAddress+ sock <- socketWithAddrInfo addr setSocketOption sock ReuseAddr 1 bind sock $ addrAddress addr serverPort <- socketPort sock@@ -235,3 +241,24 @@ bracketWithReraise tid setup teardown thing = E.bracket setup teardown thing `E.catch` \ (e :: E.SomeException) -> E.throwTo tid e++resolveClient :: SocketType -> HostName -> PortNumber -> IO AddrInfo+resolveClient socketType host port =+ head <$> getAddrInfo (Just hints) (Just host) (Just $ show port)+ where+ hints = defaultHints {+ addrSocketType = socketType+ , addrFlags = [AI_NUMERICHOST]+ }++resolveServer :: SocketType -> HostName -> IO AddrInfo+resolveServer socketType host =+ head <$> getAddrInfo (Just hints) (Just host) Nothing+ where+ hints = defaultHints {+ addrSocketType = socketType+ , addrFlags = [AI_PASSIVE]+ }++socketWithAddrInfo :: AddrInfo -> IO Socket+socketWithAddrInfo addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)