Merge PR #433.

Author: kazu-yamamoto

.gitignore

@@ -19,3 +19,4 @@ cabal.sandbox.config
 .cabal-sandbox
 .stack-work/
 .ghc.*
+.vscode

.travis.yml

@@ -26,12 +26,6 @@ before_cache:
 
 matrix:
   include:
-    - compiler: "ghc-7.8.4"
-    # env: TEST=--disable-tests BENCH=--disable-benchmarks
-      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.8.4], sources: [hvr-ghc]}}
-    - compiler: "ghc-7.10.3"
-    # env: TEST=--disable-tests BENCH=--disable-benchmarks
-      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}}
     - compiler: "ghc-8.0.2"
     # env: TEST=--disable-tests BENCH=--disable-benchmarks
       addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}}
@@ -44,7 +38,7 @@ matrix:
     - compiler: "ghc-8.6.5"
     # env: TEST=--disable-tests BENCH=--disable-benchmarks
       addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}
-    - compiler: "ghc-8.8.1"
+    - compiler: "ghc-8.8.3"
     # env: TEST=--disable-tests BENCH=--disable-benchmarks
       addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.8.1], sources: [hvr-ghc]}}
     - compiler: "ghc-head"

Network/Socket.hs

@@ -131,10 +131,20 @@ module Network.Socket
     , ShutdownCmd(..)
 
     -- * Socket options
-    , SocketOption(..)
+    , SocketOption(SockOpt
+                  ,Debug,ReuseAddr,Type,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
@@ -183,12 +193,14 @@ module Network.Socket
     , socketPortSafe
     , socketPort
 
+#if !defined(mingw32_HOST_OS)
     -- * UNIX-domain socket
     , isUnixDomainSocketAvailable
     , socketPair
     , sendFd
     , recvFd
     , getPeerCredential
+#endif
 
     -- * Name information
     , getNameInfo
@@ -205,14 +217,40 @@ module Network.Socket
     , 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)
+    -- ** 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 +261,9 @@ import Network.Socket.Shutdown
 import Network.Socket.SockAddr
 import Network.Socket.Syscall hiding (connect, bind, accept)
 import Network.Socket.Types
+#if !defined(mingw32_HOST_OS)
+import Network.Socket.Posix.Cmsg
 import Network.Socket.Unix
+#else
+import Network.Socket.Win32.Cmsg
+#endif

Network/Socket/Address.hs

@@ -16,6 +16,9 @@ module Network.Socket.Address (
     -- * Sending and receiving data from a buffer
     , sendBufTo
     , recvBufFrom
+    -- * Advanced IO
+    , sendBufMsg
+    , recvBufMsg
     ) where
 
 import Network.Socket.ByteString.IO

Network/Socket/Buffer.hsc

@@ -11,23 +11,41 @@ module Network.Socket.Buffer (
   , 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.
@@ -178,18 +196,134 @@ mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError
                                     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
+#else
+      withWSABuf bufsizs $ \(wsaBPtr, wsaBLen) -> do
+#endif
+        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
+#if !defined(mingw32_HOST_OS)
+              , msgCtrl    = castPtr ctrlPtr
+#else
+              , msgCtrl    = if clen == 0 then nullPtr else castPtr ctrlPtr
+#endif
+              , msgCtrlLen = fromIntegral clen
+#if !defined(mingw32_HOST_OS)
+              , msgFlags   = 0
+#else
+              , msgFlags   = fromIntegral $ fromMsgFlag flags
+#endif
+              }
+            _cflags = fromMsgFlag flags
+        withFdSocket s $ \fd -> do
+          with msgHdr $ \msgHdrPtr -> do
+            len <- (fmap fromIntegral) <$>
+#if !defined(mingw32_HOST_OS)
+                throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmg" $
+                      c_recvmsg fd msgHdrPtr _cflags
+#else
+                alloca $ \len_ptr -> do
+                    _ <- throwSocketErrorWaitReadBut (== #{const WSAEMSGSIZE}) s "Network.Socket.Buffer.recvmg" $
+                            c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr
+                    peek len_ptr
+#endif
+            sockaddr <- peekSocketAddress addrPtr `catchIOError` \_ -> getPeerName s
+            hdr <- peek msgHdrPtr
+            cmsgs <- parseCmsgs msgHdrPtr
+            let flags' = MsgFlag $ fromIntegral $ msgFlags hdr
+            return (sockaddr, len, cmsgs, flags')
+
 #if !defined(mingw32_HOST_OS)
 foreign import ccall unsafe "send"
   c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt
+foreign import ccall unsafe "sendmsg"
+  c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> CInt -> IO CInt -- fixme CSsize
+foreign import ccall unsafe "recvmsg"
+  c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> CInt -> IO CInt
 #else
 foreign import CALLCONV SAFE_ON_WIN "ioctlsocket"
   c_ioctlsocket :: CInt -> CLong -> Ptr CULong -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "WSAGetLastError"
   c_WSAGetLastError :: IO CInt
+foreign import CALLCONV SAFE_ON_WIN "WSASendMsg"
+  -- fixme Handle for SOCKET, see #426
+  c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr ()  -> IO CInt
+foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"
+  c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
 #endif
+
 foreign import ccall unsafe "recv"
   c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "sendto"
   c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "recvfrom"
   c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt
+

Network/Socket/ByteString.hs

@@ -33,12 +33,16 @@ module Network.Socket.ByteString
     -- * 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
 
 -- ----------------------------------------------------------------------------