diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/Network/Socket.hs b/Network/Socket.hs --- a/Network/Socket.hs +++ b/Network/Socket.hs @@ -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 diff --git a/Network/Socket/Address.hs b/Network/Socket/Address.hs --- a/Network/Socket/Address.hs +++ b/Network/Socket/Address.hs @@ -16,6 +16,9 @@ -- * Sending and receiving data from a buffer , sendBufTo , recvBufFrom + -- * Advanced IO + , sendBufMsg + , recvBufMsg ) where import Network.Socket.ByteString.IO diff --git a/Network/Socket/Buffer.hsc b/Network/Socket/Buffer.hsc --- a/Network/Socket/Buffer.hsc +++ b/Network/Socket/Buffer.hsc @@ -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 + diff --git a/Network/Socket/ByteString.hs b/Network/Socket/ByteString.hs --- a/Network/Socket/ByteString.hs +++ b/Network/Socket/ByteString.hs @@ -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 - diff --git a/Network/Socket/ByteString/IO.hsc b/Network/Socket/ByteString/IO.hsc --- a/Network/Socket/ByteString/IO.hsc +++ b/Network/Socket/ByteString/IO.hsc @@ -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') diff --git a/Network/Socket/ByteString/IOVec.hsc b/Network/Socket/ByteString/IOVec.hsc deleted file mode 100644 --- a/Network/Socket/ByteString/IOVec.hsc +++ /dev/null @@ -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 -#include - -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) diff --git a/Network/Socket/ByteString/Internal.hs b/Network/Socket/ByteString/Internal.hs --- a/Network/Socket/ByteString/Internal.hs +++ b/Network/Socket/ByteString/Internal.hs @@ -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 diff --git a/Network/Socket/ByteString/Lazy.hs b/Network/Socket/ByteString/Lazy.hs --- a/Network/Socket/ByteString/Lazy.hs +++ b/Network/Socket/ByteString/Lazy.hs @@ -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 diff --git a/Network/Socket/ByteString/Lazy/Posix.hs b/Network/Socket/ByteString/Lazy/Posix.hs --- a/Network/Socket/ByteString/Lazy/Posix.hs +++ b/Network/Socket/ByteString/Lazy/Posix.hs @@ -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 diff --git a/Network/Socket/ByteString/MsgHdr.hsc b/Network/Socket/ByteString/MsgHdr.hsc deleted file mode 100644 --- a/Network/Socket/ByteString/MsgHdr.hsc +++ /dev/null @@ -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 -#include - -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) diff --git a/Network/Socket/Flag.hsc b/Network/Socket/Flag.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Flag.hsc @@ -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") + ] +-} diff --git a/Network/Socket/Handle.hs b/Network/Socket/Handle.hs --- a/Network/Socket/Handle.hs +++ b/Network/Socket/Handle.hs @@ -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 diff --git a/Network/Socket/Imports.hs b/Network/Socket/Imports.hs --- a/Network/Socket/Imports.hs +++ b/Network/Socket/Imports.hs @@ -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 diff --git a/Network/Socket/Info.hsc b/Network/Socket/Info.hsc --- a/Network/Socket/Info.hsc +++ b/Network/Socket/Info.hsc @@ -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 = " - , "" - , ", addrCanonName = " - , "" - , "}" - ] - ----------------------------------------------------------------------------- -- | 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 . +-- +-- /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) diff --git a/Network/Socket/Internal.hs b/Network/Socket/Internal.hs --- a/Network/Socket/Internal.hs +++ b/Network/Socket/Internal.hs @@ -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 diff --git a/Network/Socket/Options.hsc b/Network/Socket/Options.hsc --- a/Network/Socket/Options.hsc +++ b/Network/Socket/Options.hsc @@ -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 diff --git a/Network/Socket/Posix/Cmsg.hsc b/Network/Socket/Posix/Cmsg.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Posix/Cmsg.hsc @@ -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 +#include + +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 + + diff --git a/Network/Socket/Posix/CmsgHdr.hsc b/Network/Socket/Posix/CmsgHdr.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Posix/CmsgHdr.hsc @@ -0,0 +1,102 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} + +#include "HsNet.h" + +module Network.Socket.Posix.CmsgHdr ( + Cmsg(..) + , withCmsgs + , parseCmsgs + ) where + +#include +#include + +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 diff --git a/Network/Socket/Posix/IOVec.hsc b/Network/Socket/Posix/IOVec.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Posix/IOVec.hsc @@ -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 +#include + +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) diff --git a/Network/Socket/Posix/MsgHdr.hsc b/Network/Socket/Posix/MsgHdr.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Posix/MsgHdr.hsc @@ -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 +#include + +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) diff --git a/Network/Socket/ReadShow.hs b/Network/Socket/ReadShow.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/ReadShow.hs @@ -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 diff --git a/Network/Socket/Shutdown.hs b/Network/Socket/Shutdown.hs --- a/Network/Socket/Shutdown.hs +++ b/Network/Socket/Shutdown.hs @@ -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 diff --git a/Network/Socket/SockAddr.hs b/Network/Socket/SockAddr.hs --- a/Network/Socket/SockAddr.hs +++ b/Network/Socket/SockAddr.hs @@ -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 diff --git a/Network/Socket/Syscall.hs b/Network/Socket/Syscall.hs --- a/Network/Socket/Syscall.hs +++ b/Network/Socket/Syscall.hs @@ -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 diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -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) = "" - -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) = "" + +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 diff --git a/Network/Socket/Unix.hsc b/Network/Socket/Unix.hsc --- a/Network/Socket/Unix.hsc +++ b/Network/Socket/Unix.hsc @@ -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 diff --git a/Network/Socket/Win32/Cmsg.hsc b/Network/Socket/Win32/Cmsg.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Win32/Cmsg.hsc @@ -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 diff --git a/Network/Socket/Win32/CmsgHdr.hsc b/Network/Socket/Win32/CmsgHdr.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Win32/CmsgHdr.hsc @@ -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 diff --git a/Network/Socket/Win32/MsgHdr.hsc b/Network/Socket/Win32/MsgHdr.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Win32/MsgHdr.hsc @@ -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) diff --git a/Network/Socket/Win32/WSABuf.hsc b/Network/Socket/Win32/WSABuf.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Win32/WSABuf.hsc @@ -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) diff --git a/cbits/ancilData.c b/cbits/ancilData.c deleted file mode 100644 --- a/cbits/ancilData.c +++ /dev/null @@ -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 - -#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 diff --git a/cbits/cmsg.c b/cbits/cmsg.c new file mode 100644 --- /dev/null +++ b/cbits/cmsg.c @@ -0,0 +1,97 @@ +#include "HsNet.h" +#include + +#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 */ diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([Haskell network package], - [3.1.1.1], + [3.1.2.0], [libraries@haskell.org], [network]) diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -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 diff --git a/examples/EchoServer.hs b/examples/EchoServer.hs --- a/examples/EchoServer.hs +++ b/examples/EchoServer.hs @@ -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) diff --git a/include/HsNet.h b/include/HsNet.h --- a/include/HsNet.h +++ b/include/HsNet.h @@ -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 # include +# include +# 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 diff --git a/include/alignment.h b/include/alignment.h new file mode 100644 --- /dev/null +++ b/include/alignment.h @@ -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 diff --git a/include/win32defs.h b/include/win32defs.h new file mode 100644 --- /dev/null +++ b/include/win32defs.h @@ -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 diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -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 diff --git a/tests/Network/Socket/ByteStringSpec.hs b/tests/Network/Socket/ByteStringSpec.hs --- a/tests/Network/Socket/ByteStringSpec.hs +++ b/tests/Network/Socket/ByteStringSpec.hs @@ -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 diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs --- a/tests/Network/SocketSpec.hs +++ b/tests/Network/SocketSpec.hs @@ -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 + ] diff --git a/tests/Network/Test/Common.hs b/tests/Network/Test/Common.hs --- a/tests/Network/Test/Common.hs +++ b/tests/Network/Test/Common.hs @@ -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)