diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,26 @@ -## Version 2.8.0.1 +## Version 3.0.0.0 -* Eensuring that accept returns a correct sockaddr for unix domain. - [#400](https://github.com/haskell/network/pull/400) -* Avoid out of bounds writes in pokeSockAddr. - [#400](https://github.com/haskell/network/pull/400) +* Breaking change: the Network and Network.BSD are removed. + Network.BSD is provided a new package: network-bsd. +* Breaking change: the signatures are changed: +``` +old fdSocket :: Socket -> CInt +new fdSocket :: Socket -> IO CInt +old mkSocket :: CInt -> Family -> SocketType -> ProtocolNumber -> SocketStatus -> IO Socket +new mkSocket :: CInt Socket +``` +* Breaking change: the deprecated APIs are removed: send, sendTo, recv, recvFrom, recvLen, htonl, ntohl, inet_addr, int_ntoa, bindSocket, sClose, SocketStatus, isConnected, isBound, isListening, isReadable, isWritable, sIsConnected, sIsBound, sIsListening, sIsReadable, sIsWritable, aNY_PORT, iNADDR_ANY, iN6ADDR_ANY, sOMAXCONN, sOL_SOCKET, sCM_RIGHTS, packSocketType, getPeerCred. +* Breaking chage: SockAddrCan is removed from SockAddr. +* Socket addresses are extendable with Network.Socket.Address. +* "socket" is now asynchronous-exception-safe. + [#336](https://github.com/haskell/network/pull/336) +* "recvFrom" returns (0, addr) instead of throwing an error on EOF. + [#360](https://github.com/haskell/network/pull/360) +* All APIs are available on any platforms. +* Build system is simplified. +* Bug fixes. + ## Version 2.8.0.0 * Breaking change: PortNumber originally contained Word16 in network @@ -51,7 +67,7 @@ aNY_PORT, iNADDR_ANY, iN6ADDR_ANY, sOMAXCONN, sOL_SOCKET, sCM_RIGHTS, packFamily, unpackFamily, packSocketType - * Do not closeFd within sendFd. + * Breaking change: do not closeFd within sendFd. [#271](https://github.com/haskell/network/pull/271) * Exporting ifNameToIndex and ifIndexToName from Network.Socket. * New APIs: setCloseOnExecIfNeeded, getCloseOnExec and getNonBlock @@ -74,10 +90,9 @@ ## Version 2.6.3.3 * Adds a function to show the defaultHints without reading their undefined fields - [#291](https://github.com/haskell/network/pull/291) + [#291](https://github.com/haskell/network/pull/292) * Improve exception error messages for getAddrInfo and getNameInfo [#289](https://github.com/haskell/network/pull/289) - * Deprecating SockAddrCan. ## Version 2.6.3.2 @@ -142,15 +157,15 @@ ## Version 2.6.2.1 - * Regenerate configure and HsNetworkConfig.h.in. + * Regenerate configure and `HsNetworkConfig.h.in`. * Better detection of CAN sockets. ## Version 2.6.2.0 - * Add support for TCP_USER_TIMEOUT. + * Add support for `TCP_USER_TIMEOUT`. - * Don't conditionally export the SockAddr constructors. + * Don't conditionally export the `SockAddr` constructors. - * Add isSupportSockAddr to allow checking for supported address types + * Add `isSupportSockAddr` to allow checking for supported address types at runtime. diff --git a/Network.hs b/Network.hs deleted file mode 100644 --- a/Network.hs +++ /dev/null @@ -1,480 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : Network --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/network/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- This module is kept for backwards-compatibility. New users are --- encouraged to use "Network.Socket" instead. --- --- "Network" was intended as a \"higher-level\" interface to networking --- facilities, and only supports TCP. --- ------------------------------------------------------------------------------ - -#include "HsNetworkConfig.h" - -#ifdef HAVE_GETADDRINFO --- Use IPv6-capable function definitions if the OS supports it. -#define IPV6_SOCKET_SUPPORT 1 -#endif - -module Network {-# DEPRECATED "The high level Network interface is no longer supported. Please use Network.Socket." #-} - ( - -- * Basic data types - Socket - , PortID(..) - , HostName - , PortNumber - - -- * Initialisation - , withSocketsDo - - -- * Server-side connections - , listenOn - , accept - , sClose - - -- * Client-side connections - , connectTo - - -- * Simple sending and receiving - {-$sendrecv-} - , sendTo - , recvFrom - - -- * Miscellaneous - , socketPort - - -- * Networking Issues - -- ** Buffering - {-$buffering-} - - -- ** Improving I\/O Performance over sockets - {-$performance-} - ) where - -import Control.Monad (liftM) -import Data.Maybe (fromJust) -import Network.BSD -import Network.Socket hiding (accept, socketPort, recvFrom, - sendTo, PortNumber, sClose) -import qualified Network.Socket as Socket (accept) -import System.IO -import Prelude -import qualified Control.Exception as Exception - --- --------------------------------------------------------------------------- --- High Level ``Setup'' functions - --- If the @PortID@ specifies a unix family socket and the @Hostname@ --- differs from that returned by @getHostname@ then an error is --- raised. Alternatively an empty string may be given to @connectTo@ --- signalling that the current hostname applies. - -data PortID = - Service String -- Service Name eg "ftp" - | PortNumber PortNumber -- User defined Port Number -#if !defined(mingw32_HOST_OS) - | UnixSocket String -- Unix family socket in file system -#endif - deriving (Show, Eq) - --- | Calling 'connectTo' creates a client side socket which is --- connected to the given host and port. The Protocol and socket type is --- derived from the given port identifier. If a port number is given --- then the result is always an internet family 'Stream' socket. - -connectTo :: HostName -- Hostname - -> PortID -- Port Identifier - -> IO Handle -- Connected Socket - -#if defined(IPV6_SOCKET_SUPPORT) --- IPv6 and IPv4. - -connectTo hostname (Service serv) = connect' "Network.connectTo" hostname serv - -connectTo hostname (PortNumber port) = connect' "Network.connectTo" hostname (show port) -#else --- IPv4 only. - -connectTo hostname (Service serv) = do - proto <- getProtocolNumber "tcp" - bracketOnError - (socket AF_INET Stream proto) - (sClose) -- only done if there's an error - (\sock -> do - port <- getServicePortNumber serv - he <- getHostByName hostname - connect sock (SockAddrInet port (hostAddress he)) - socketToHandle sock ReadWriteMode - ) - -connectTo hostname (PortNumber port) = do - proto <- getProtocolNumber "tcp" - bracketOnError - (socket AF_INET Stream proto) - (sClose) -- only done if there's an error - (\sock -> do - he <- getHostByName hostname - connect sock (SockAddrInet port (hostAddress he)) - socketToHandle sock ReadWriteMode - ) -#endif - -#if !defined(mingw32_HOST_OS) -connectTo _ (UnixSocket path) = do - bracketOnError - (socket AF_UNIX Stream 0) - (sClose) - (\sock -> do - connect sock (SockAddrUnix path) - socketToHandle sock ReadWriteMode - ) -#endif - -#if defined(IPV6_SOCKET_SUPPORT) -connect' :: String -> HostName -> ServiceName -> IO Handle - -connect' caller host serv = do - proto <- getProtocolNumber "tcp" - let hints = defaultHints { addrFlags = [AI_ADDRCONFIG] - , addrProtocol = proto - , addrSocketType = Stream } - addrs <- getAddrInfo (Just hints) (Just host) (Just serv) - firstSuccessful caller $ map tryToConnect addrs - where - tryToConnect addr = - bracketOnError - (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) - (sClose) -- only done if there's an error - (\sock -> do - connect sock (addrAddress addr) - socketToHandle sock ReadWriteMode - ) -#endif - --- | Creates the server side socket which has been bound to the --- specified port. --- --- 'maxListenQueue' (typically 128) is specified to the listen queue. --- This is good enough for normal network servers but is too small --- for high performance servers. --- --- To avoid the \"Address already in use\" problems, --- the 'ReuseAddr' socket option is set on the listening socket. --- --- If available, the 'IPv6Only' socket option is set to 0 --- so that both IPv4 and IPv6 can be accepted with this socket. --- --- If you don't like the behavior above, please use the lower level --- 'Network.Socket.listen' instead. - -listenOn :: PortID -- ^ Port Identifier - -> IO Socket -- ^ Listening Socket - -#if defined(IPV6_SOCKET_SUPPORT) --- IPv6 and IPv4. - -listenOn (Service serv) = listen' serv - -listenOn (PortNumber port) = listen' (show port) -#else --- IPv4 only. - -listenOn (Service serv) = do - proto <- getProtocolNumber "tcp" - bracketOnError - (socket AF_INET Stream proto) - (sClose) - (\sock -> do - port <- getServicePortNumber serv - setSocketOption sock ReuseAddr 1 - bind sock (SockAddrInet port iNADDR_ANY) - listen sock maxListenQueue - return sock - ) - -listenOn (PortNumber port) = do - proto <- getProtocolNumber "tcp" - bracketOnError - (socket AF_INET Stream proto) - (sClose) - (\sock -> do - setSocketOption sock ReuseAddr 1 - bind sock (SockAddrInet port iNADDR_ANY) - listen sock maxListenQueue - return sock - ) -#endif - -#if !defined(mingw32_HOST_OS) -listenOn (UnixSocket path) = - bracketOnError - (socket AF_UNIX Stream 0) - (sClose) - (\sock -> do - setSocketOption sock ReuseAddr 1 - bind sock (SockAddrUnix path) - listen sock maxListenQueue - return sock - ) -#endif - -#if defined(IPV6_SOCKET_SUPPORT) -listen' :: ServiceName -> IO Socket - -listen' serv = do - proto <- getProtocolNumber "tcp" - -- We should probably specify addrFamily = AF_INET6 and the filter - -- code below should be removed. AI_ADDRCONFIG is probably not - -- necessary. But this code is well-tested. So, let's keep it. - let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE] - , addrSocketType = Stream - , addrProtocol = proto } - addrs <- getAddrInfo (Just hints) Nothing (Just serv) - -- Choose an IPv6 socket if exists. This ensures the socket can - -- handle both IPv4 and IPv6 if v6only is false. - let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs - addr = if null addrs' then head addrs else head addrs' - bracketOnError - (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) - (sClose) - (\sock -> do - setSocketOption sock ReuseAddr 1 - bind sock (addrAddress addr) - listen sock maxListenQueue - return sock - ) -#endif - --- ----------------------------------------------------------------------------- --- accept - --- | Accept a connection on a socket created by 'listenOn'. Normal --- I\/O operations (see "System.IO") can be used on the 'Handle' --- returned to communicate with the client. --- Notice that although you can pass any Socket to Network.accept, --- only sockets of either AF_UNIX, AF_INET, or AF_INET6 will work --- (this shouldn't be a problem, though). When using AF_UNIX, HostName --- will be set to the path of the socket and PortNumber to -1. --- -accept :: Socket -- ^ Listening Socket - -> IO (Handle, - HostName, - PortNumber) -- ^ Triple of: read\/write 'Handle' for - -- communicating with the client, - -- the 'HostName' of the peer socket, and - -- the 'PortNumber' of the remote connection. -accept sock@(MkSocket _ AF_INET _ _ _) = do - ~(sock', (SockAddrInet port haddr)) <- Socket.accept sock - peer <- catchIO - (do - (HostEntry peer _ _ _) <- getHostByAddr AF_INET haddr - return peer - ) - (\_e -> inet_ntoa haddr) - -- if getHostByName fails, we fall back to the IP address - handle <- socketToHandle sock' ReadWriteMode - return (handle, peer, port) -#if defined(IPV6_SOCKET_SUPPORT) -accept sock@(MkSocket _ AF_INET6 _ _ _) = do - (sock', addr) <- Socket.accept sock - peer <- catchIO ((fromJust . fst) `liftM` getNameInfo [] True False addr) $ - \_ -> case addr of - SockAddrInet _ a -> inet_ntoa a - SockAddrInet6 _ _ a _ -> return (show a) -#if defined(mingw32_HOST_OS) - SockAddrUnix {} -> ioError $ userError "Network.accept: peer socket address 'SockAddrUnix' not supported on this platform." -#else - SockAddrUnix a -> return a -#endif -#if defined(CAN_SOCKET_SUPPORT) - SockAddrCan {} -> ioError $ userError "Network.accept: peer socket address 'SockAddrCan' not supported." -#else - SockAddrCan {} -> ioError $ userError "Network.accept: peer socket address 'SockAddrCan' not supported on this platform." -#endif - handle <- socketToHandle sock' ReadWriteMode - let port = case addr of - SockAddrInet p _ -> p - SockAddrInet6 p _ _ _ -> p - _ -> -1 - return (handle, peer, port) -#endif -#if !defined(mingw32_HOST_OS) -accept sock@(MkSocket _ AF_UNIX _ _ _) = do - ~(sock', (SockAddrUnix path)) <- Socket.accept sock - handle <- socketToHandle sock' ReadWriteMode - return (handle, path, -1) -#endif -accept (MkSocket _ family _ _ _) = - ioError $ userError $ "Network.accept: address family '" ++ - show family ++ "' not supported." - - --- | Close the socket. Sending data to or receiving data from closed socket --- may lead to undefined behaviour. -sClose :: Socket -> IO () -sClose = close -- Explicit redefinition because Network.sClose is deprecated, - -- hence the re-export would also be marked as such. - --- ----------------------------------------------------------------------------- --- sendTo/recvFrom - -{-$sendrecv -Send and receive data from\/to the given host and port number. These -should normally only be used where the socket will not be required for -further calls. Also, note that due to the use of 'hGetContents' in 'recvFrom' -the socket will remain open (i.e. not available) even if the function already -returned. Their use is strongly discouraged except for small test-applications -or invocations from the command line. --} - -sendTo :: HostName -- Hostname - -> PortID -- Port Number - -> String -- Message to send - -> IO () -sendTo h p msg = do - s <- connectTo h p - hPutStr s msg - hClose s - -recvFrom :: HostName -- Hostname - -> PortID -- Port Number - -> IO String -- Received Data - -#if defined(IPV6_SOCKET_SUPPORT) -recvFrom host port = do - proto <- getProtocolNumber "tcp" - let hints = defaultHints { addrFlags = [AI_ADDRCONFIG] - , addrProtocol = proto - , addrSocketType = Stream } - allowed <- map addrAddress `liftM` getAddrInfo (Just hints) (Just host) - Nothing - s <- listenOn port - let waiting = do - (s', addr) <- Socket.accept s - if not (addr `oneOf` allowed) - then sClose s' >> waiting - else socketToHandle s' ReadMode >>= hGetContents - waiting - where - a@(SockAddrInet _ ha) `oneOf` ((SockAddrInet _ hb):bs) - | ha == hb = True - | otherwise = a `oneOf` bs - a@(SockAddrInet6 _ _ ha _) `oneOf` ((SockAddrInet6 _ _ hb _):bs) - | ha == hb = True - | otherwise = a `oneOf` bs - _ `oneOf` _ = False -#else -recvFrom host port = do - ip <- getHostByName host - let ipHs = hostAddresses ip - s <- listenOn port - let - waiting = do - ~(s', SockAddrInet _ haddr) <- Socket.accept s - he <- getHostByAddr AF_INET haddr - if not (any (`elem` ipHs) (hostAddresses he)) - then do - sClose s' - waiting - else do - h <- socketToHandle s' ReadMode - msg <- hGetContents h - return msg - - message <- waiting - return message -#endif - --- --------------------------------------------------------------------------- --- Access function returning the port type/id of socket. - --- | Returns the 'PortID' associated with a given socket. -socketPort :: Socket -> IO PortID -socketPort s = do - sockaddr <- getSocketName s - case sockaddr of - SockAddrInet port _ -> return $ PortNumber port -#if defined(IPV6_SOCKET_SUPPORT) - SockAddrInet6 port _ _ _ -> return $ PortNumber port -#else - SockAddrInet6 {} -> ioError $ userError "Network.socketPort: socket address 'SockAddrInet6' not supported on this platform." -#endif -#if defined(mingw32_HOST_OS) - SockAddrUnix {} -> ioError $ userError "Network.socketPort: socket address 'SockAddrUnix' not supported on this platform." -#else - SockAddrUnix path -> return $ UnixSocket path -#endif - SockAddrCan {} -> ioError $ userError "Network.socketPort: socket address 'SockAddrCan' not supported." - --- --------------------------------------------------------------------------- --- Utils - --- Like bracket, but only performs the final action if there was an --- exception raised by the middle bit. -bracketOnError - :: IO a -- ^ computation to run first (\"acquire resource\") - -> (a -> IO b) -- ^ computation to run last (\"release resource\") - -> (a -> IO c) -- ^ computation to run in-between - -> IO c -- returns the value from the in-between computation -bracketOnError = Exception.bracketOnError - ------------------------------------------------------------------------------ --- Extra documentation - -{-$buffering - -The 'Handle' returned by 'connectTo' and 'accept' is 'NoBuffering' by -default. For an interactive application you may want to set the -buffering mode on the 'Handle' to -'LineBuffering' or 'BlockBuffering', like so: - -> h <- connectTo host port -> hSetBuffering h LineBuffering --} - -{-$performance - -For really fast I\/O, it might be worth looking at the 'hGetBuf' and -'hPutBuf' family of functions in "System.IO". --} - -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#if MIN_VERSION_base(4,0,0) -catchIO = Exception.catch -#else -catchIO = Exception.catchJust Exception.ioErrors -#endif - --- Version of try implemented in terms of the locally defined catchIO -tryIO :: IO a -> IO (Either Exception.IOException a) -tryIO m = catchIO (liftM Right m) (return . Left) - --- Returns the first action from a list which does not throw an exception. --- If all the actions throw exceptions (and the list of actions is not empty), --- the last exception is thrown. --- The operations are run outside of the catchIO cleanup handler because --- catchIO masks asynchronous exceptions in the cleanup handler. --- In the case of complete failure, the last exception is actually thrown. -firstSuccessful :: String -> [IO a] -> IO a -firstSuccessful caller = go Nothing - where - -- Attempt the next operation, remember exception on failure - go _ (p:ps) = - do r <- tryIO p - case r of - Right x -> return x - Left e -> go (Just e) ps - - -- All operations failed, throw error if one exists - go Nothing [] = ioError $ userError $ caller ++ ": firstSuccessful: empty list" - go (Just e) [] = Exception.throwIO e diff --git a/Network/BSD.hsc b/Network/BSD.hsc deleted file mode 100644 --- a/Network/BSD.hsc +++ /dev/null @@ -1,574 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_HADDOCK hide #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} ------------------------------------------------------------------------------ --- | --- Module : Network.BSD --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/network/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable --- --- The "Network.BSD" module defines Haskell bindings to network --- programming functionality provided by BSD Unix derivatives. --- ------------------------------------------------------------------------------ - -#include "HsNet.h" -##include "HsNetDef.h" - -module Network.BSD {-# DEPRECATED "This platform dependent module is no longer supported." #-} - ( - -- * Host names - HostName - , getHostName - - , HostEntry(..) - , getHostByName - , getHostByAddr - , hostAddress - -#if defined(HAVE_GETHOSTENT) && !defined(mingw32_HOST_OS) - , getHostEntries - - -- ** Low level functionality - , setHostEntry - , getHostEntry - , endHostEntry -#endif - - -- * Service names - , ServiceEntry(..) - , ServiceName - , getServiceByName - , getServiceByPort - , getServicePortNumber - -#if !defined(mingw32_HOST_OS) - , getServiceEntries - - -- ** Low level functionality - , getServiceEntry - , setServiceEntry - , endServiceEntry -#endif - - -- * Protocol names - , ProtocolName - , ProtocolNumber - , ProtocolEntry(..) - , getProtocolByName - , getProtocolByNumber - , getProtocolNumber - , defaultProtocol - -#if !defined(mingw32_HOST_OS) - , getProtocolEntries - -- ** Low level functionality - , setProtocolEntry - , getProtocolEntry - , endProtocolEntry -#endif - - -- * Port numbers - , PortNumber - - -- * Network names - , NetworkName - , NetworkAddr - , NetworkEntry(..) - -#if !defined(mingw32_HOST_OS) - , getNetworkByName - , getNetworkByAddr - , getNetworkEntries - -- ** Low level functionality - , setNetworkEntry - , getNetworkEntry - , endNetworkEntry -#endif - -#if defined(HAVE_IF_NAMETOINDEX) - -- * Interface names - , ifNameToIndex -#endif - - ) where - -import Network.Socket - -import Control.Concurrent (MVar, newMVar, withMVar) -import qualified Control.Exception as E -import Foreign.C.String (CString, peekCString, withCString) -#if defined(HAVE_WINSOCK2_H) -import Foreign.C.Types ( CShort ) -#endif -import Foreign.C.Types ( CInt(..), CULong(..), CSize(..) ) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Array (allocaArray0, peekArray0) -import Foreign.Marshal.Utils (with, fromBool) -import Data.Typeable -import System.IO.Error (ioeSetErrorString, mkIOError) -import System.IO.Unsafe (unsafePerformIO) - -import GHC.IO.Exception - -import Control.Monad (liftM) - -import Network.Socket.Internal (throwSocketErrorIfMinus1_) - --- --------------------------------------------------------------------------- --- Basic Types - -type ProtocolName = String - --- --------------------------------------------------------------------------- --- Service Database Access - --- Calling getServiceByName for a given service and protocol returns --- the systems service entry. This should be used to find the port --- numbers for standard protocols such as SMTP and FTP. The remaining --- three functions should be used for browsing the service database --- sequentially. - --- Calling setServiceEntry with True indicates that the service --- database should be left open between calls to getServiceEntry. To --- close the database a call to endServiceEntry is required. This --- database file is usually stored in the file /etc/services. - -data ServiceEntry = - ServiceEntry { - serviceName :: ServiceName, -- Official Name - serviceAliases :: [ServiceName], -- aliases - servicePort :: PortNumber, -- Port Number ( network byte order ) - serviceProtocol :: ProtocolName -- Protocol - } deriving (Show, Typeable) - -instance Storable ServiceEntry where - sizeOf _ = #const sizeof(struct servent) - alignment _ = alignment (undefined :: CInt) -- ??? - - peek p = do - s_name <- (#peek struct servent, s_name) p >>= peekCString - s_aliases <- (#peek struct servent, s_aliases) p - >>= peekArray0 nullPtr - >>= mapM peekCString - s_port <- (#peek struct servent, s_port) p - s_proto <- (#peek struct servent, s_proto) p >>= peekCString - return (ServiceEntry { - serviceName = s_name, - serviceAliases = s_aliases, -#if defined(HAVE_WINSOCK2_H) - servicePort = (fromIntegral (s_port :: CShort)), -#else - -- s_port is already in network byte order, but it - -- might be the wrong size. - servicePort = (fromIntegral (s_port :: CInt)), -#endif - serviceProtocol = s_proto - }) - - poke = throwUnsupportedOperationPoke "ServiceEntry" - - --- | Get service by name. -getServiceByName :: ServiceName -- Service Name - -> ProtocolName -- Protocol Name - -> IO ServiceEntry -- Service Entry -getServiceByName name proto = withLock $ do - withCString name $ \ cstr_name -> do - withCString proto $ \ cstr_proto -> do - throwNoSuchThingIfNull "Network.BSD.getServiceByName" "no such service entry" - $ c_getservbyname cstr_name cstr_proto - >>= peek - -foreign import CALLCONV unsafe "getservbyname" - c_getservbyname :: CString -> CString -> IO (Ptr ServiceEntry) - --- | Get the service given a 'PortNumber' and 'ProtocolName'. -getServiceByPort :: PortNumber -> ProtocolName -> IO ServiceEntry -getServiceByPort port proto = withLock $ do - withCString proto $ \ cstr_proto -> do - throwNoSuchThingIfNull "Network.BSD.getServiceByPort" "no such service entry" - $ c_getservbyport (fromIntegral port) cstr_proto - >>= peek - -foreign import CALLCONV unsafe "getservbyport" - c_getservbyport :: CInt -> CString -> IO (Ptr ServiceEntry) - --- | Get the 'PortNumber' corresponding to the 'ServiceName'. -getServicePortNumber :: ServiceName -> IO PortNumber -getServicePortNumber name = do - (ServiceEntry _ _ port _) <- getServiceByName name "tcp" - return port - -#if !defined(mingw32_HOST_OS) -getServiceEntry :: IO ServiceEntry -getServiceEntry = withLock $ do - throwNoSuchThingIfNull "Network.BSD.getServiceEntry" "no such service entry" - $ c_getservent - >>= peek - -foreign import ccall unsafe "getservent" c_getservent :: IO (Ptr ServiceEntry) - -setServiceEntry :: Bool -> IO () -setServiceEntry flg = withLock $ c_setservent (fromBool flg) - -foreign import ccall unsafe "setservent" c_setservent :: CInt -> IO () - -endServiceEntry :: IO () -endServiceEntry = withLock $ c_endservent - -foreign import ccall unsafe "endservent" c_endservent :: IO () - -getServiceEntries :: Bool -> IO [ServiceEntry] -getServiceEntries stayOpen = do - setServiceEntry stayOpen - getEntries (getServiceEntry) (endServiceEntry) -#endif - --- --------------------------------------------------------------------------- --- Protocol Entries - --- The following relate directly to the corresponding UNIX C --- calls for returning the protocol entries. The protocol entry is --- represented by the Haskell type ProtocolEntry. - --- As for setServiceEntry above, calling setProtocolEntry. --- determines whether or not the protocol database file, usually --- @/etc/protocols@, is to be kept open between calls of --- getProtocolEntry. Similarly, - -data ProtocolEntry = - ProtocolEntry { - protoName :: ProtocolName, -- Official Name - protoAliases :: [ProtocolName], -- aliases - protoNumber :: ProtocolNumber -- Protocol Number - } deriving (Read, Show, Typeable) - -instance Storable ProtocolEntry where - sizeOf _ = #const sizeof(struct protoent) - alignment _ = alignment (undefined :: CInt) -- ??? - - peek p = do - p_name <- (#peek struct protoent, p_name) p >>= peekCString - p_aliases <- (#peek struct protoent, p_aliases) p - >>= peekArray0 nullPtr - >>= mapM peekCString -#if defined(HAVE_WINSOCK2_H) - -- With WinSock, the protocol number is only a short; - -- hoist it in as such, but represent it on the Haskell side - -- as a CInt. - p_proto_short <- (#peek struct protoent, p_proto) p - let p_proto = fromIntegral (p_proto_short :: CShort) -#else - p_proto <- (#peek struct protoent, p_proto) p -#endif - return (ProtocolEntry { - protoName = p_name, - protoAliases = p_aliases, - protoNumber = p_proto - }) - - poke = throwUnsupportedOperationPoke "ProtocolEntry" - - -getProtocolByName :: ProtocolName -> IO ProtocolEntry -getProtocolByName name = withLock $ do - withCString name $ \ name_cstr -> do - throwNoSuchThingIfNull "Network.BSD.getProtocolByName" ("no such protocol name: " ++ name) - $ c_getprotobyname name_cstr - >>= peek - -foreign import CALLCONV unsafe "getprotobyname" - c_getprotobyname :: CString -> IO (Ptr ProtocolEntry) - - -getProtocolByNumber :: ProtocolNumber -> IO ProtocolEntry -getProtocolByNumber num = withLock $ do - throwNoSuchThingIfNull "Network.BSD.getProtocolByNumber" ("no such protocol number: " ++ show num) - $ c_getprotobynumber (fromIntegral num) - >>= peek - -foreign import CALLCONV unsafe "getprotobynumber" - c_getprotobynumber :: CInt -> IO (Ptr ProtocolEntry) - - -getProtocolNumber :: ProtocolName -> IO ProtocolNumber -getProtocolNumber proto = do - (ProtocolEntry _ _ num) <- getProtocolByName proto - return num - -#if !defined(mingw32_HOST_OS) -getProtocolEntry :: IO ProtocolEntry -- Next Protocol Entry from DB -getProtocolEntry = withLock $ do - ent <- throwNoSuchThingIfNull "Network.BSD.getProtocolEntry" "no such protocol entry" - $ c_getprotoent - peek ent - -foreign import ccall unsafe "getprotoent" c_getprotoent :: IO (Ptr ProtocolEntry) - -setProtocolEntry :: Bool -> IO () -- Keep DB Open ? -setProtocolEntry flg = withLock $ c_setprotoent (fromBool flg) - -foreign import ccall unsafe "setprotoent" c_setprotoent :: CInt -> IO () - -endProtocolEntry :: IO () -endProtocolEntry = withLock $ c_endprotoent - -foreign import ccall unsafe "endprotoent" c_endprotoent :: IO () - -getProtocolEntries :: Bool -> IO [ProtocolEntry] -getProtocolEntries stayOpen = withLock $ do - setProtocolEntry stayOpen - getEntries (getProtocolEntry) (endProtocolEntry) -#endif - --- --------------------------------------------------------------------------- --- Host lookups - -data HostEntry = - HostEntry { - hostName :: HostName, -- Official Name - hostAliases :: [HostName], -- aliases - hostFamily :: Family, -- Host Type (currently AF_INET) - hostAddresses :: [HostAddress] -- Set of Network Addresses (in network byte order) - } deriving (Read, Show, Typeable) - -instance Storable HostEntry where - sizeOf _ = #const sizeof(struct hostent) - alignment _ = alignment (undefined :: CInt) -- ??? - - peek p = do - h_name <- (#peek struct hostent, h_name) p >>= peekCString - h_aliases <- (#peek struct hostent, h_aliases) p - >>= peekArray0 nullPtr - >>= mapM peekCString - h_addrtype <- (#peek struct hostent, h_addrtype) p - -- h_length <- (#peek struct hostent, h_length) p - h_addr_list <- (#peek struct hostent, h_addr_list) p - >>= peekArray0 nullPtr - >>= mapM peek - return (HostEntry { - hostName = h_name, - hostAliases = h_aliases, -#if defined(HAVE_WINSOCK2_H) - hostFamily = unpackFamily (fromIntegral (h_addrtype :: CShort)), -#else - hostFamily = unpackFamily h_addrtype, -#endif - hostAddresses = h_addr_list - }) - - poke = throwUnsupportedOperationPoke "HostEntry" - - --- convenience function: -hostAddress :: HostEntry -> HostAddress -hostAddress (HostEntry nm _ _ ls) = - case ls of - [] -> error $ "Network.BSD.hostAddress: empty network address list for " ++ nm - (x:_) -> x - --- getHostByName must use the same lock as the *hostent functions --- may cause problems if called concurrently. - --- | Resolve a 'HostName' to IPv4 address. -getHostByName :: HostName -> IO HostEntry -getHostByName name = withLock $ do - withCString name $ \ name_cstr -> do - ent <- throwNoSuchThingIfNull "Network.BSD.getHostByName" "no such host entry" - $ c_gethostbyname name_cstr - peek ent - -foreign import CALLCONV safe "gethostbyname" - c_gethostbyname :: CString -> IO (Ptr HostEntry) - - --- The locking of gethostbyaddr is similar to gethostbyname. --- | Get a 'HostEntry' corresponding to the given address and family. --- Note that only IPv4 is currently supported. -getHostByAddr :: Family -> HostAddress -> IO HostEntry -getHostByAddr family addr = do - with addr $ \ ptr_addr -> withLock $ do - throwNoSuchThingIfNull "Network.BSD.getHostByAddr" "no such host entry" - $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family) - >>= peek - -foreign import CALLCONV safe "gethostbyaddr" - c_gethostbyaddr :: Ptr HostAddress -> CInt -> CInt -> IO (Ptr HostEntry) - -#if defined(HAVE_GETHOSTENT) && !defined(mingw32_HOST_OS) -getHostEntry :: IO HostEntry -getHostEntry = withLock $ do - throwNoSuchThingIfNull "Network.BSD.getHostEntry" "unable to retrieve host entry" - $ c_gethostent - >>= peek - -foreign import ccall unsafe "gethostent" c_gethostent :: IO (Ptr HostEntry) - -setHostEntry :: Bool -> IO () -setHostEntry flg = withLock $ c_sethostent (fromBool flg) - -foreign import ccall unsafe "sethostent" c_sethostent :: CInt -> IO () - -endHostEntry :: IO () -endHostEntry = withLock $ c_endhostent - -foreign import ccall unsafe "endhostent" c_endhostent :: IO () - -getHostEntries :: Bool -> IO [HostEntry] -getHostEntries stayOpen = do - setHostEntry stayOpen - getEntries (getHostEntry) (endHostEntry) -#endif - --- --------------------------------------------------------------------------- --- Accessing network information - --- Same set of access functions as for accessing host,protocol and --- service system info, this time for the types of networks supported. - --- network addresses are represented in host byte order. -type NetworkAddr = CULong - -type NetworkName = String - -data NetworkEntry = - NetworkEntry { - networkName :: NetworkName, -- official name - networkAliases :: [NetworkName], -- aliases - networkFamily :: Family, -- type - networkAddress :: NetworkAddr - } deriving (Read, Show, Typeable) - -instance Storable NetworkEntry where - sizeOf _ = #const sizeof(struct hostent) - alignment _ = alignment (undefined :: CInt) -- ??? - - peek p = do - n_name <- (#peek struct netent, n_name) p >>= peekCString - n_aliases <- (#peek struct netent, n_aliases) p - >>= peekArray0 nullPtr - >>= mapM peekCString - n_addrtype <- (#peek struct netent, n_addrtype) p - n_net <- (#peek struct netent, n_net) p - return (NetworkEntry { - networkName = n_name, - networkAliases = n_aliases, - networkFamily = unpackFamily (fromIntegral - (n_addrtype :: CInt)), - networkAddress = n_net - }) - - poke = throwUnsupportedOperationPoke "NetworkEntry" - - -#if !defined(mingw32_HOST_OS) -getNetworkByName :: NetworkName -> IO NetworkEntry -getNetworkByName name = withLock $ do - withCString name $ \ name_cstr -> do - throwNoSuchThingIfNull "Network.BSD.getNetworkByName" "no such network entry" - $ c_getnetbyname name_cstr - >>= peek - -foreign import ccall unsafe "getnetbyname" - c_getnetbyname :: CString -> IO (Ptr NetworkEntry) - -getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry -getNetworkByAddr addr family = withLock $ do - throwNoSuchThingIfNull "Network.BSD.getNetworkByAddr" "no such network entry" - $ c_getnetbyaddr addr (packFamily family) - >>= peek - -foreign import ccall unsafe "getnetbyaddr" - c_getnetbyaddr :: NetworkAddr -> CInt -> IO (Ptr NetworkEntry) - -getNetworkEntry :: IO NetworkEntry -getNetworkEntry = withLock $ do - throwNoSuchThingIfNull "Network.BSD.getNetworkEntry" "no more network entries" - $ c_getnetent - >>= peek - -foreign import ccall unsafe "getnetent" c_getnetent :: IO (Ptr NetworkEntry) - --- | Open the network name database. The parameter specifies --- whether a connection is maintained open between various --- networkEntry calls -setNetworkEntry :: Bool -> IO () -setNetworkEntry flg = withLock $ c_setnetent (fromBool flg) - -foreign import ccall unsafe "setnetent" c_setnetent :: CInt -> IO () - --- | Close the connection to the network name database. -endNetworkEntry :: IO () -endNetworkEntry = withLock $ c_endnetent - -foreign import ccall unsafe "endnetent" c_endnetent :: IO () - --- | Get the list of network entries. -getNetworkEntries :: Bool -> IO [NetworkEntry] -getNetworkEntries stayOpen = do - setNetworkEntry stayOpen - getEntries (getNetworkEntry) (endNetworkEntry) -#endif - --- Mutex for name service lockdown - -{-# NOINLINE lock #-} -lock :: MVar () -lock = unsafePerformIO $ withSocketsDo $ newMVar () - -withLock :: IO a -> IO a -withLock act = withMVar lock (\_ -> act) - --- --------------------------------------------------------------------------- --- Miscellaneous Functions - --- | Calling getHostName returns the standard host name for the current --- processor, as set at boot time. - -getHostName :: IO HostName -getHostName = do - let size = 256 - allocaArray0 size $ \ cstr -> do - throwSocketErrorIfMinus1_ "Network.BSD.getHostName" $ c_gethostname cstr (fromIntegral size) - peekCString cstr - -foreign import CALLCONV unsafe "gethostname" - c_gethostname :: CString -> CSize -> IO CInt - --- Helper function used by the exported functions that provides a --- Haskellised view of the enumerator functions: - -getEntries :: IO a -- read - -> IO () -- at end - -> IO [a] -getEntries getOne atEnd = loop - where - loop = do - vv <- E.catch (liftM Just getOne) - (\ e -> let _types = e :: IOException in return Nothing) - case vv of - Nothing -> return [] - Just v -> loop >>= \ vs -> atEnd >> return (v:vs) - - -throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a) -throwNoSuchThingIfNull loc desc act = do - ptr <- act - if (ptr == nullPtr) - then ioError (ioeSetErrorString (mkIOError NoSuchThing loc Nothing Nothing) desc) - else return ptr - -throwUnsupportedOperationPoke :: String -> Ptr a -> a -> IO () -throwUnsupportedOperationPoke typ _ _ = - ioError $ ioeSetErrorString ioe "Operation not implemented" - where - ioe = mkIOError UnsupportedOperation - ("Network.BSD: instance Storable " ++ typ ++ ": poke") - Nothing - Nothing diff --git a/Network/Socket.hs b/Network/Socket.hs new file mode 100644 --- /dev/null +++ b/Network/Socket.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP #-} + +#include "HsNetDef.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Network.Socket +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/network/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- This is the main module of the network package supposed to be +-- used with either "Network.Socket.ByteString" or +-- "Network.Socket.ByteString.Lazy" for sending/receiving. +-- +-- Here are two minimal example programs using the TCP/IP protocol: a +-- server that echoes all data that it receives back (servicing only +-- one client) and a client using it. +-- +-- > -- Echo server program +-- > module Main (main) where +-- > +-- > import Control.Concurrent (forkFinally) +-- > import qualified Control.Exception as E +-- > import Control.Monad (unless, forever, void) +-- > import qualified Data.ByteString as S +-- > import Network.Socket +-- > import Network.Socket.ByteString (recv, sendAll) +-- > +-- > main :: IO () +-- > main = withSocketsDo $ do +-- > addr <- resolve "3000" +-- > E.bracket (open addr) close loop +-- > where +-- > resolve port = do +-- > let hints = defaultHints { +-- > addrFlags = [AI_PASSIVE] +-- > , addrSocketType = Stream +-- > } +-- > addr:_ <- getAddrInfo (Just hints) Nothing (Just port) +-- > return addr +-- > open addr = do +-- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +-- > setSocketOption sock ReuseAddr 1 +-- > -- If the prefork technique is not used, +-- > -- set CloseOnExec for the security reasons. +-- > fd <- fdSocket sock +-- > setCloseOnExecIfNeeded fd +-- > bind sock (addrAddress addr) +-- > listen sock 10 +-- > return sock +-- > loop sock = forever $ do +-- > (conn, peer) <- accept sock +-- > putStrLn $ "Connection from " ++ show peer +-- > void $ forkFinally (talk conn) (\_ -> close conn) +-- > talk conn = do +-- > msg <- recv conn 1024 +-- > unless (S.null msg) $ do +-- > sendAll conn msg +-- > talk conn +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > -- Echo client program +-- > module Main (main) where +-- > +-- > import qualified Control.Exception as E +-- > import qualified Data.ByteString.Char8 as C +-- > import Network.Socket +-- > import Network.Socket.ByteString (recv, sendAll) +-- > +-- > main :: IO () +-- > main = withSocketsDo $ do +-- > addr <- resolve "127.0.0.1" "3000" +-- > E.bracket (open addr) close talk +-- > where +-- > resolve host port = do +-- > let hints = defaultHints { addrSocketType = Stream } +-- > addr:_ <- getAddrInfo (Just hints) (Just host) (Just port) +-- > return addr +-- > open addr = do +-- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +-- > connect sock $ addrAddress addr +-- > return sock +-- > talk sock = do +-- > sendAll sock "Hello, world!" +-- > msg <- recv sock 1024 +-- > putStr "Received: " +-- > C.putStrLn msg +-- +-- The proper programming model is that one 'Socket' is handled by +-- a single thread. If multiple threads use one 'Socket' concurrently, +-- unexpected things would happen. There is one exception for multiple +-- threads vs a single 'Socket': one thread reads data from a 'Socket' +-- only and the other thread writes data to the 'Socket' only. +----------------------------------------------------------------------------- + +-- In order to process this file, you need to have CALLCONV defined. + +module Network.Socket + ( + -- * Initialisation + withSocketsDo + + -- * Address information + , getAddrInfo + -- ** Types + , HostName + , ServiceName + , AddrInfo(..) + , defaultHints + -- ** Flags + , AddrInfoFlag(..) + , addrInfoFlagImplemented + + -- * Socket operations + , connect + , bind + , listen + , accept + -- ** Closing + , close + , close' + , shutdown + , ShutdownCmd(..) + + -- * Socket options + , SocketOption(..) + , isSupportedSocketOption + , getSocketOption + , setSocketOption + + -- * Socket + , Socket + , socket + , fdSocket + , mkSocket + , socketToHandle + -- ** Types of Socket + , SocketType(..) + , isSupportedSocketType + -- ** Family + , Family(..) + , isSupportedFamily + , packFamily + , unpackFamily + -- ** Protocol number + , ProtocolNumber + , defaultProtocol + -- * Basic socket address type + , SockAddr(..) + , isSupportedSockAddr + , getPeerName + , getSocketName + -- ** Host address + , HostAddress + , hostAddressToTuple + , tupleToHostAddress + -- ** Host address6 + , HostAddress6 + , hostAddress6ToTuple + , tupleToHostAddress6 + -- ** Flow Info + , FlowInfo + -- ** Scope ID + , ScopeID + , ifNameToIndex + , ifIndexToName + -- ** Port number + , PortNumber + , defaultPort + , socketPortSafe + , socketPort + + -- * UNIX-domain socket + , isUnixDomainSocketAvailable + , socketPair + , sendFd + , recvFd + , getPeerCredential + + -- * Name information + , getNameInfo + , NameInfoFlag(..) + + -- * Low level + -- ** socket operations + , setCloseOnExecIfNeeded + , getCloseOnExec + , setNonBlockIfNeeded + , getNonBlock + -- ** Sending and receiving data + , sendBuf + , recvBuf + , sendBufTo + , recvBufFrom + + -- * Special constants + , maxListenQueue + ) where + +import Network.Socket.Buffer hiding (sendBufTo, recvBufFrom) +import Network.Socket.Cbits +import Network.Socket.Fcntl +import Network.Socket.Handle +import Network.Socket.If +import Network.Socket.Info +import Network.Socket.Internal +import Network.Socket.Name hiding (getPeerName, getSocketName) +import Network.Socket.Options +import Network.Socket.Shutdown +import Network.Socket.SockAddr +import Network.Socket.Syscall hiding (connect, bind, accept) +import Network.Socket.Types +import Network.Socket.Unix diff --git a/Network/Socket.hsc b/Network/Socket.hsc deleted file mode 100644 --- a/Network/Socket.hsc +++ /dev/null @@ -1,1966 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} ------------------------------------------------------------------------------ --- | --- Module : Network.Socket --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/network/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- This is the main module of the network package supposed to be --- used with either "Network.Socket.ByteString" or --- "Network.Socket.ByteString.Lazy" for sending/receiving. --- --- Here are two minimal example programs using the TCP/IP protocol: a --- server that echoes all data that it receives back (servicing only --- one client) and a client using it. --- --- > -- Echo server program --- > module Main (main) where --- > --- > import Control.Concurrent (forkFinally) --- > import qualified Control.Exception as E --- > import Control.Monad (unless, forever, void) --- > import qualified Data.ByteString as S --- > import Network.Socket hiding (recv) --- > import Network.Socket.ByteString (recv, sendAll) --- > --- > main :: IO () --- > main = withSocketsDo $ do --- > addr <- resolve "3000" --- > E.bracket (open addr) close loop --- > where --- > resolve port = do --- > let hints = defaultHints { --- > addrFlags = [AI_PASSIVE] --- > , addrSocketType = Stream --- > } --- > addr:_ <- getAddrInfo (Just hints) Nothing (Just port) --- > return addr --- > open addr = do --- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) --- > setSocketOption sock ReuseAddr 1 --- > bind sock (addrAddress addr) --- > -- If the prefork technique is not used, --- > -- set CloseOnExec for the security reasons. --- > let fd = fdSocket sock --- > setCloseOnExecIfNeeded fd --- > listen sock 10 --- > return sock --- > loop sock = forever $ do --- > (conn, peer) <- accept sock --- > putStrLn $ "Connection from " ++ show peer --- > void $ forkFinally (talk conn) (\_ -> close conn) --- > talk conn = do --- > msg <- recv conn 1024 --- > unless (S.null msg) $ do --- > sendAll conn msg --- > talk conn --- --- > {-# LANGUAGE OverloadedStrings #-} --- > -- Echo client program --- > module Main (main) where --- > --- > import qualified Control.Exception as E --- > import qualified Data.ByteString.Char8 as C --- > import Network.Socket hiding (recv) --- > import Network.Socket.ByteString (recv, sendAll) --- > --- > main :: IO () --- > main = withSocketsDo $ do --- > addr <- resolve "127.0.0.1" "3000" --- > E.bracket (open addr) close talk --- > where --- > resolve host port = do --- > let hints = defaultHints { addrSocketType = Stream } --- > addr:_ <- getAddrInfo (Just hints) (Just host) (Just port) --- > return addr --- > open addr = do --- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) --- > connect sock $ addrAddress addr --- > return sock --- > talk sock = do --- > sendAll sock "Hello, world!" --- > msg <- recv sock 1024 --- > putStr "Received: " --- > C.putStrLn msg --- --- The proper programming model is that one 'Socket' is handled by --- a single thread. If multiple threads use one 'Socket' concurrently, --- unexpected things would happen. There is one exception for multiple --- threads vs a single 'Socket': one thread reads data from a 'Socket' --- only and the other thread writes data to the 'Socket' only. ------------------------------------------------------------------------------ - -#include "HsNet.h" -##include "HsNetDef.h" - -module Network.Socket - ( - -- * Initialisation - withSocketsDo - -- * Address information - , getAddrInfo - -- ** Types - , HostName - , ServiceName - , AddrInfo(..) - , defaultHints - -- ** Flags - , AddrInfoFlag(..) - , addrInfoFlagImplemented - -- * Socket operations - , connect - , bind - , listen - , accept - -- ** Closing - , close - , close' - , shutdown - , ShutdownCmd(..) - -- * Socket options - , SocketOption(..) - , isSupportedSocketOption - , getSocketOption - , setSocketOption - -- * Socket - , Socket(..) - , socket - , fdSocket - , mkSocket - , socketToHandle - -- ** Types of Socket - , SocketType(..) - , isSupportedSocketType - -- ** Family - , Family(..) - , isSupportedFamily - -- ** Protocol number - , ProtocolNumber - , defaultProtocol - -- * Socket address - , SockAddr(..) - , isSupportedSockAddr - , getPeerName - , getSocketName - -- ** Host address - , HostAddress - , hostAddressToTuple - , tupleToHostAddress -#if defined(IPV6_SOCKET_SUPPORT) - -- ** Host address6 - , HostAddress6 - , hostAddress6ToTuple - , tupleToHostAddress6 - -- ** Flow Info - , FlowInfo - -- ** Scope ID - , ScopeID -# if defined(HAVE_IF_NAMETOINDEX) - , ifNameToIndex - , ifIndexToName -# endif -#endif - -- ** Port number - , PortNumber - , defaultPort - , socketPortSafe - , socketPort - -- * UNIX-domain socket - , isUnixDomainSocketAvailable - , socketPair - , sendFd - , recvFd - , getPeerCredential -#if defined(IPV6_SOCKET_SUPPORT) - -- * Name information - , NameInfoFlag(..) - , getNameInfo -#endif - -- * Low level operations - , setCloseOnExecIfNeeded - , getCloseOnExec - , setNonBlockIfNeeded - , getNonBlock - -- * Sending and receiving data - , sendBuf - , recvBuf - , sendBufTo - , recvBufFrom - -- * Special constants - , maxListenQueue - -- * Deprecated - -- ** Deprecated sending and receiving - , send - , sendTo - , recv - , recvFrom - , recvLen - -- ** Deprecated address functions - , htonl - , ntohl - , inet_addr - , inet_ntoa - -- ** Deprecated socket operations - , bindSocket - , sClose - -- ** Deprecated socket status - , SocketStatus(..) -- fixme - , isConnected - , isBound - , isListening - , isReadable - , isWritable - , sIsConnected - , sIsBound - , sIsListening - , sIsReadable - , sIsWritable - -- ** Deprecated special constants - , aNY_PORT - , iNADDR_ANY -#if defined(IPV6_SOCKET_SUPPORT) - , iN6ADDR_ANY -#endif - , sOMAXCONN - , sOL_SOCKET -#ifdef SCM_RIGHTS - , sCM_RIGHTS -#endif - -- ** Decrecated internal functions - , packFamily - , unpackFamily - , packSocketType - -- ** Decrecated UNIX-domain functions -#if defined(HAVE_STRUCT_UCRED) || defined(HAVE_GETPEEREID) - -- get the credentials of our domain socket peer. - , getPeerCred -#if defined(HAVE_GETPEEREID) - , getPeerEid -#endif -#endif - ) where - -import Data.Bits -import Data.Functor -import Data.List (foldl') -import Data.Maybe (isJust) -import Data.Word (Word8, Word32) -import Foreign.Ptr (Ptr, castPtr, nullPtr) -import Foreign.Storable (Storable(..)) -import Foreign.C.Error -import Foreign.C.String (CString, withCString, withCStringLen, peekCString, peekCStringLen) -import Foreign.C.Types (CUInt(..), CChar) -import Foreign.C.Types (CInt(..), CSize(..)) -import Foreign.Marshal.Alloc ( alloca, allocaBytes ) -import Foreign.Marshal.Array ( peekArray ) -import Foreign.Marshal.Utils ( maybeWith, with ) - -import System.IO -import Control.Monad (liftM, when, void) - -import qualified Control.Exception as E -import Control.Concurrent.MVar -import Data.Typeable -import System.IO.Error - -import GHC.Conc (threadWaitWrite) -# ifdef HAVE_ACCEPT4 -import GHC.Conc (threadWaitRead) -# endif -##if MIN_VERSION_base(4,3,1) -import GHC.Conc (closeFdWith) -##endif -# if defined(mingw32_HOST_OS) -import GHC.Conc (asyncDoProc) -import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr) -import Foreign (FunPtr) -# endif -# if defined(darwin_HOST_OS) -import Data.List (delete) -# endif -import qualified GHC.IO.Device -import GHC.IO.Handle.FD -import GHC.IO.Exception -import GHC.IO -import qualified System.Posix.Internals - -import Network.Socket.Internal -import Network.Socket.Types - -import Prelude -- Silence AMP warnings - --- | Either a host name e.g., @\"haskell.org\"@ or a numeric host --- address string consisting of a dotted decimal IPv4 address or an --- IPv6 address e.g., @\"192.168.0.1\"@. -type HostName = String -type ServiceName = String - --- ---------------------------------------------------------------------------- --- On Windows, our sockets are not put in non-blocking mode (non-blocking --- is not supported for regular file descriptors on Windows, and it would --- be a pain to support it only for sockets). So there are two cases: --- --- - the threaded RTS uses safe calls for socket operations to get --- non-blocking I/O, just like the rest of the I/O library --- --- - with the non-threaded RTS, only some operations on sockets will be --- non-blocking. Reads and writes go through the normal async I/O --- system. accept() uses asyncDoProc so is non-blocking. A handful --- of others (recvFrom, sendFd, recvFd) will block all threads - if this --- is a problem, -threaded is the workaround. --- -##if defined(mingw32_HOST_OS) -##define SAFE_ON_WIN safe -##else -##define SAFE_ON_WIN unsafe -##endif - ------------------------------------------------------------------------------ --- Socket types - -#if defined(mingw32_HOST_OS) -socket2FD (MkSocket fd _ _ _ _) = - -- HACK, 1 means True - FD{fdFD = fd,fdIsSocket_ = 1} -#endif - --- | Smart constructor for constructing a 'Socket'. It should only be --- called once for every new file descriptor. The caller must make --- sure that the socket is in non-blocking mode. See --- 'setNonBlockIfNeeded'. -mkSocket :: CInt - -> Family - -> SocketType - -> ProtocolNumber - -> SocketStatus - -> IO Socket -mkSocket fd fam sType pNum stat = do - mStat <- newMVar stat - withSocketsDo $ return () - return $ MkSocket fd fam sType pNum mStat - --- | This is the default protocol for a given service. -defaultProtocol :: ProtocolNumber -defaultProtocol = 0 - ------------------------------------------------------------------------------ --- SockAddr - -instance Show SockAddr where -#if defined(DOMAIN_SOCKET_SUPPORT) - showsPrec _ (SockAddrUnix str) = showString str -#endif - showsPrec _ (SockAddrInet port ha) - = showString (unsafePerformIO (inet_ntoa ha)) - . showString ":" - . shows port -#if defined(IPV6_SOCKET_SUPPORT) - showsPrec _ addr@(SockAddrInet6 port _ _ _) - = showChar '[' - . showString (unsafePerformIO $ - fst `liftM` getNameInfo [NI_NUMERICHOST] True False addr >>= - maybe (fail "showsPrec: impossible internal error") return) - . showString "]:" - . shows port -#endif -#if defined(CAN_SOCKET_SUPPORT) - showsPrec _ (SockAddrCan ifidx) = shows ifidx -#endif -#if !(defined(IPV6_SOCKET_SUPPORT) \ - && defined(DOMAIN_SOCKET_SUPPORT) && defined(CAN_SOCKET_SUPPORT)) - showsPrec _ _ = error "showsPrec: not supported" -#endif - ------------------------------------------------------------------------------ --- Connection Functions - --- In the following connection and binding primitives. The names of --- the equivalent C functions have been preserved where possible. It --- should be noted that some of these names used in the C library, --- \tr{bind} in particular, have a different meaning to many Haskell --- programmers and have thus been renamed by appending the prefix --- Socket. - --- | Create a new socket using the given address family, socket type --- and protocol number. The address family is usually 'AF_INET', --- 'AF_INET6', or 'AF_UNIX'. The socket type is usually 'Stream' or --- 'Datagram'. The protocol number is usually 'defaultProtocol'. --- If 'AF_INET6' is used and the socket type is 'Stream' or 'Datagram', --- the 'IPv6Only' socket option is set to 0 so that both IPv4 and IPv6 --- can be handled with one socket. --- --- >>> let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } --- >>> addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just "5000") --- >>> sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) --- >>> bind sock (addrAddress addr) --- >>> getSocketName sock --- 127.0.0.1:5000 -socket :: Family -- Family Name (usually AF_INET) - -> SocketType -- Socket Type (usually Stream) - -> ProtocolNumber -- Protocol Number (getProtocolByName to find value) - -> IO Socket -- Unconnected Socket -socket family stype protocol = do - c_stype <- packSocketTypeOrThrow "socket" stype - fd <- throwSocketErrorIfMinus1Retry "Network.Socket.socket" $ - c_socket (packFamily family) c_stype protocol - setNonBlockIfNeeded fd - sock <- mkSocket fd family stype protocol NotConnected -#if HAVE_DECL_IPV6_V6ONLY - -- The default value of the IPv6Only option is platform specific, - -- so we explicitly set it to 0 to provide a common default. -# if defined(mingw32_HOST_OS) - -- The IPv6Only option is only supported on Windows Vista and later, - -- so trying to change it might throw an error. - when (family == AF_INET6 && (stype == Stream || stype == Datagram)) $ - E.catch (setSocketOption sock IPv6Only 0) $ (\(_ :: E.IOException) -> return ()) -# elif !defined(__OpenBSD__) - when (family == AF_INET6 && (stype == Stream || stype == Datagram)) $ - setSocketOption sock IPv6Only 0 `onException` close sock -# endif -#endif - return sock - --- | Build a pair of connected socket objects using the given address --- family, socket type, and protocol number. Address family, socket --- type, and protocol number are as for the 'socket' function above. --- Availability: Unix. -socketPair :: Family -- Family Name (usually AF_INET or AF_INET6) - -> SocketType -- Socket Type (usually Stream) - -> ProtocolNumber -- Protocol Number - -> IO (Socket, Socket) -- unnamed and connected. -#if defined(DOMAIN_SOCKET_SUPPORT) -socketPair family stype protocol = do - allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do - c_stype <- packSocketTypeOrThrow "socketPair" stype - _rc <- throwSocketErrorIfMinus1Retry "Network.Socket.socketpair" $ - c_socketpair (packFamily family) c_stype protocol fdArr - [fd1,fd2] <- peekArray 2 fdArr - s1 <- mkNonBlockingSocket fd1 - s2 <- mkNonBlockingSocket fd2 - return (s1,s2) - where - mkNonBlockingSocket fd = do - setNonBlockIfNeeded fd - mkSocket fd family stype protocol Connected - -foreign import ccall unsafe "socketpair" - c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt -#else -socketPair _ _ _ = error "Network.Socket.socketPair" -#endif - ------------------------------------------------------------------------------ - -#if defined(mingw32_HOST_OS) -#else -fGetFd :: CInt -fGetFd = #const F_GETFD -fGetFl :: CInt -fGetFl = #const F_GETFL -fdCloexec :: CInt -fdCloexec = #const FD_CLOEXEC -oNonBlock :: CInt -oNonBlock = #const O_NONBLOCK -# if defined(HAVE_ACCEPT4) -sockNonBlock :: CInt -sockNonBlock = #const SOCK_NONBLOCK -sockCloexec :: CInt -sockCloexec = #const SOCK_CLOEXEC -# endif -#endif - --- | Set the nonblocking flag on Unix. --- On Windows, nothing is done. -setNonBlockIfNeeded :: CInt -> IO () -setNonBlockIfNeeded fd = - System.Posix.Internals.setNonBlockingFD fd True - --- | Set the close_on_exec flag on Unix. --- On Windows, nothing is done. --- --- Since 2.7.0.0. -setCloseOnExecIfNeeded :: CInt -> IO () -#if defined(mingw32_HOST_OS) -setCloseOnExecIfNeeded _ = return () -#else -setCloseOnExecIfNeeded fd = System.Posix.Internals.setCloseOnExec fd -#endif - -#if !defined(mingw32_HOST_OS) -foreign import ccall unsafe "fcntl" - c_fcntl_read :: CInt -> CInt -> CInt -> IO CInt -#endif - --- | Get the nonblocking flag. --- On Windows, this function always returns 'False'. --- --- Since 2.7.0.0. -getCloseOnExec :: CInt -> IO Bool -#if defined(mingw32_HOST_OS) -getCloseOnExec _ = return False -#else -getCloseOnExec fd = do - flags <- c_fcntl_read fd fGetFd 0 - let ret = flags .&. fdCloexec - return (ret /= 0) -#endif - --- | Get the close_on_exec flag. --- On Windows, this function always returns 'False'. --- --- Since 2.7.0.0. -getNonBlock :: CInt -> IO Bool -#if defined(mingw32_HOST_OS) -getNonBlock _ = return False -#else -getNonBlock fd = do - flags <- c_fcntl_read fd fGetFl 0 - let ret = flags .&. oNonBlock - return (ret /= 0) -#endif - ------------------------------------------------------------------------------ --- Binding a socket - --- | Bind the socket to an address. The socket must not already be --- bound. The 'Family' passed to @bind@ must be the --- same as that passed to 'socket'. If the special port number --- 'defaultPort' is passed then the system assigns the next available --- use port. -bind :: Socket -- Unconnected Socket - -> SockAddr -- Address to Bind to - -> IO () -bind (MkSocket s _family _stype _protocol socketStatus) addr = do - modifyMVar_ socketStatus $ \ status -> do - if status /= NotConnected - then - ioError $ userError $ - "Network.Socket.bind: can't bind to socket with status " ++ show status - else do - withSockAddr addr $ \p_addr sz -> do - _status <- throwSocketErrorIfMinus1Retry "Network.Socket.bind" $ - c_bind s p_addr (fromIntegral sz) - return Bound - ------------------------------------------------------------------------------ --- Connecting a socket - --- | Connect to a remote socket at address. -connect :: Socket -- Unconnected Socket - -> SockAddr -- Socket address stuff - -> IO () -connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = withSocketsDo $ do - modifyMVar_ socketStatus $ \currentStatus -> do - if currentStatus /= NotConnected && currentStatus /= Bound - then - ioError $ userError $ - errLoc ++ ": can't connect to socket with status " ++ show currentStatus - else do - withSockAddr addr $ \p_addr sz -> do - - let connectLoop = do - r <- c_connect s p_addr (fromIntegral sz) - if r == -1 - then do -#if !(defined(HAVE_WINSOCK2_H)) - err <- getErrno - case () of - _ | err == eINTR -> connectLoop - _ | err == eINPROGRESS -> connectBlocked --- _ | err == eAGAIN -> connectBlocked - _otherwise -> throwSocketError errLoc -#else - throwSocketError errLoc -#endif - else return () - - connectBlocked = do - threadWaitWrite (fromIntegral s) - err <- getSocketOption sock SoError - if (err == 0) - then return () - else throwSocketErrorCode errLoc (fromIntegral err) - - connectLoop - return Connected - where - errLoc = "Network.Socket.connect: " ++ show sock - ------------------------------------------------------------------------------ --- Listen - --- | Listen for connections made to the socket. The second argument --- specifies the maximum number of queued connections and should be at --- least 1; the maximum value is system-dependent (usually 5). -listen :: Socket -- Connected & Bound Socket - -> Int -- Queue Length - -> IO () -listen (MkSocket s _family _stype _protocol socketStatus) backlog = do - modifyMVar_ socketStatus $ \ status -> do - if status /= Bound - then - ioError $ userError $ - "Network.Socket.listen: can't listen on socket with status " ++ show status - else do - throwSocketErrorIfMinus1Retry_ "Network.Socket.listen" $ - c_listen s (fromIntegral backlog) - return Listening - ------------------------------------------------------------------------------ --- Accept --- --- A call to `accept' only returns when data is available on the given --- socket, unless the socket has been set to non-blocking. It will --- return a new socket which should be used to read the incoming data and --- should then be closed. Using the socket returned by `accept' allows --- incoming requests to be queued on the original socket. - --- | Accept a connection. The socket must be bound to an address and --- listening for connections. The return value is a pair @(conn, --- address)@ where @conn@ is a new socket object usable to send and --- receive data on the connection, and @address@ is the address bound --- to the socket on the other end of the connection. -accept :: Socket -- Queue Socket - -> IO (Socket, -- Readable Socket - SockAddr) -- Peer details - -accept sock@(MkSocket s family stype protocol status) = do - currentStatus <- readMVar status - if not $ isAcceptable family stype currentStatus - then - ioError $ userError $ - "Network.Socket.accept: can't accept socket (" ++ - show (family, stype, protocol) ++ ") with status " ++ - show currentStatus - else do - let sz = sizeOfSockAddrByFamily family - allocaBytes sz $ \ sockaddr -> do - zeroMemory sockaddr $ fromIntegral sz -#if defined(mingw32_HOST_OS) - new_sock <- - if threaded - then with (fromIntegral sz) $ \ ptr_len -> - throwSocketErrorIfMinus1Retry "Network.Socket.accept" $ - c_accept_safe s sockaddr ptr_len - else do - paramData <- c_newAcceptParams s (fromIntegral sz) sockaddr - rc <- asyncDoProc c_acceptDoProc paramData - new_sock <- c_acceptNewSock paramData - c_free paramData - when (rc /= 0) $ - throwSocketErrorCode "Network.Socket.accept" (fromIntegral rc) - return new_sock -#else - with (fromIntegral sz) $ \ ptr_len -> do -# ifdef HAVE_ACCEPT4 - new_sock <- throwSocketErrorIfMinus1RetryMayBlock "Network.Socket.accept" - (threadWaitRead (fromIntegral s)) - (c_accept4 s sockaddr ptr_len (sockNonBlock .|. sockCloexec)) -# else - new_sock <- throwSocketErrorWaitRead sock "Network.Socket.accept" - (c_accept s sockaddr ptr_len) - setNonBlockIfNeeded new_sock - setCloseOnExecIfNeeded new_sock -# endif /* HAVE_ACCEPT4 */ -#endif - addr <- peekSockAddr sockaddr - sock' <- mkSocket new_sock family stype protocol Connected - return (sock', addr) - -#if defined(mingw32_HOST_OS) -foreign import ccall unsafe "HsNet.h acceptNewSock" - c_acceptNewSock :: Ptr () -> IO CInt -foreign import ccall unsafe "HsNet.h newAcceptParams" - c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ()) -foreign import ccall unsafe "HsNet.h &acceptDoProc" - c_acceptDoProc :: FunPtr (Ptr () -> IO Int) -foreign import ccall unsafe "free" - c_free:: Ptr a -> IO () -#endif - ------------------------------------------------------------------------------ --- ** Sending and receiving data - --- $sendrecv --- --- Do not use the @send@ and @recv@ functions defined in this section --- in new code, as they incorrectly represent binary data as a Unicode --- string. As a result, these functions are inefficient and may lead --- to bugs in the program. Instead use the @send@ and @recv@ --- functions defined in the "Network.Socket.ByteString" module. - ------------------------------------------------------------------------------ --- sendTo & recvFrom - --- | 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 --- ensuring that all data has been sent. --- --- NOTE: blocking on Windows unless you compile with -threaded (see --- GHC ticket #1129) -{-# DEPRECATED sendTo "Use sendTo defined in \"Network.Socket.ByteString\"" #-} -sendTo :: Socket -- (possibly) bound/connected Socket - -> String -- Data to send - -> SockAddr - -> IO Int -- Number of Bytes sent -sendTo sock xs addr = do - withCStringLen xs $ \(str, len) -> do - sendBufTo sock str len addr - --- | 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 --- ensuring that all data has been sent. -sendBufTo :: Socket -- (possibly) bound/connected Socket - -> Ptr a -> Int -- Data to send - -> SockAddr - -> IO Int -- Number of Bytes sent -sendBufTo sock@(MkSocket s _family _stype _protocol _status) ptr nbytes addr = do - withSockAddr addr $ \p_addr sz -> do - liftM fromIntegral $ - throwSocketErrorWaitWrite sock "Network.Socket.sendBufTo" $ - c_sendto s ptr (fromIntegral $ nbytes) 0{-flags-} - p_addr (fromIntegral sz) - --- | Receive data from the socket. The socket need not be in a --- connected state. Returns @(bytes, nbytes, address)@ where @bytes@ --- is a @String@ of length @nbytes@ representing the data received and --- @address@ is a 'SockAddr' representing the address of the sending --- socket. --- --- NOTE: blocking on Windows unless you compile with -threaded (see --- GHC ticket #1129) -{-# DEPRECATED recvFrom "Use recvFrom defined in \"Network.Socket.ByteString\"" #-} -recvFrom :: Socket -> Int -> IO (String, Int, SockAddr) -recvFrom sock nbytes = - allocaBytes nbytes $ \ptr -> do - (len, sockaddr) <- recvBufFrom sock ptr nbytes - str <- peekCStringLen (ptr, len) - return (str, len, sockaddr) - --- | Receive data from the socket, writing it into buffer instead of --- creating a new string. The socket need not be in a connected --- state. Returns @(nbytes, address)@ where @nbytes@ is the number of --- bytes received and @address@ is a 'SockAddr' representing the --- address of the sending socket. --- --- NOTE: blocking on Windows unless you compile with -threaded (see --- GHC ticket #1129) -recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr) -recvBufFrom sock@(MkSocket s family _stype _protocol _status) ptr nbytes - | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom") - | otherwise = - withNewSockAddr family $ \ptr_addr sz -> do - alloca $ \ptr_len -> do - poke ptr_len (fromIntegral sz) - len <- throwSocketErrorWaitRead sock "Network.Socket.recvBufFrom" $ - c_recvfrom s ptr (fromIntegral nbytes) 0{-flags-} - ptr_addr ptr_len - let len' = fromIntegral len - if len' == 0 - then ioError (mkEOFError "Network.Socket.recvFrom") - else do - flg <- isConnected sock - -- For at least one implementation (WinSock 2), recvfrom() ignores - -- filling in the sockaddr for connected TCP sockets. Cope with - -- this by using getPeerName instead. - sockaddr <- - if flg then - getPeerName sock - else - peekSockAddr ptr_addr - return (len', sockaddr) - ------------------------------------------------------------------------------ --- send & recv - --- | Send data to the socket. The socket must be connected to a remote --- socket. Returns the number of bytes sent. Applications are --- responsible for ensuring that all data has been sent. --- --- Sending data to closed socket may lead to undefined behaviour. -{-# DEPRECATED send "Use send defined in \"Network.Socket.ByteString\"" #-} -send :: Socket -- Bound/Connected Socket - -> String -- Data to send - -> IO Int -- Number of Bytes sent -send sock xs = withCStringLen xs $ \(str, len) -> - sendBuf sock (castPtr str) len - --- | Send data to the socket. The socket must be connected to a remote --- socket. Returns the number of bytes sent. Applications are --- responsible for ensuring that all data has been sent. --- --- Sending data to closed socket may lead to undefined behaviour. -sendBuf :: Socket -- Bound/Connected Socket - -> Ptr Word8 -- Pointer to the data to send - -> Int -- Length of the buffer - -> IO Int -- Number of Bytes sent -sendBuf sock@(MkSocket s _family _stype _protocol _status) str len = do - liftM fromIntegral $ -#if defined(mingw32_HOST_OS) --- writeRawBufferPtr is supposed to handle checking for errors, but it's broken --- on x86_64 because of GHC bug #12010 so we duplicate the check here. The call --- to throwSocketErrorIfMinus1Retry can be removed when no GHC version with the --- bug is supported. - throwSocketErrorIfMinus1Retry "Network.Socket.sendBuf" $ writeRawBufferPtr - "Network.Socket.sendBuf" - (socket2FD sock) - (castPtr str) - 0 - (fromIntegral len) -#else - throwSocketErrorWaitWrite sock "Network.Socket.sendBuf" $ - c_send s str (fromIntegral len) 0{-flags-} -#endif - - --- | Receive data from the socket. The socket must be in a connected --- state. This function may return fewer bytes than specified. If the --- message is longer than the specified length, it may be discarded --- depending on the type of socket. This function may block until a --- message arrives. --- --- Considering hardware and network realities, the maximum number of --- bytes to receive should be a small power of 2, e.g., 4096. --- --- For TCP sockets, a zero length return value means the peer has --- closed its half side of the connection. --- --- Receiving data from closed socket may lead to undefined behaviour. -{-# DEPRECATED recv "Use recv defined in \"Network.Socket.ByteString\"" #-} -recv :: Socket -> Int -> IO String -recv sock l = fst <$> recvLen sock l - -{-# DEPRECATED recvLen "Use recv defined in \"Network.Socket.ByteString\" with \"Data.Bytestring.length\"" #-} -recvLen :: Socket -> Int -> IO (String, Int) -recvLen sock nbytes = - allocaBytes nbytes $ \ptr -> do - len <- recvBuf sock ptr nbytes - s <- peekCStringLen (castPtr ptr,len) - return (s, len) - --- | Receive data from the socket. The socket must be in a connected --- state. This function may return fewer bytes than specified. If the --- message is longer than the specified length, it may be discarded --- depending on the type of socket. This function may block until a --- message arrives. --- --- Considering hardware and network realities, the maximum number of --- bytes to receive should be a small power of 2, e.g., 4096. --- --- For TCP sockets, a zero length return value means the peer has --- closed its half side of the connection. --- --- Receiving data from closed socket may lead to undefined behaviour. -recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int -recvBuf sock@(MkSocket s _family _stype _protocol _status) ptr nbytes - | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf") - | otherwise = do - len <- -#if defined(mingw32_HOST_OS) --- see comment in sendBuf above. - throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $ - readRawBufferPtr "Network.Socket.recvBuf" - (socket2FD sock) ptr 0 (fromIntegral nbytes) -#else - throwSocketErrorWaitRead sock "Network.Socket.recvBuf" $ - c_recv s (castPtr ptr) (fromIntegral nbytes) 0{-flags-} -#endif - let len' = fromIntegral len - if len' == 0 - then ioError (mkEOFError "Network.Socket.recvBuf") - else return len' - - --- --------------------------------------------------------------------------- --- socketPort --- --- The port number the given socket is currently connected to can be --- determined by calling $port$, is generally only useful when bind --- was given $aNY\_PORT$. - --- | Getting the port of socket. --- `IOError` is thrown if a port is not available. -socketPort :: Socket -- Connected & Bound Socket - -> IO PortNumber -- Port Number of Socket -socketPort sock@(MkSocket _ AF_INET _ _ _) = do - (SockAddrInet port _) <- getSocketName sock - return port -#if defined(IPV6_SOCKET_SUPPORT) -socketPort sock@(MkSocket _ AF_INET6 _ _ _) = do - (SockAddrInet6 port _ _ _) <- getSocketName sock - return port -#endif -socketPort (MkSocket _ family _ _ _) = - ioError $ userError $ - "Network.Socket.socketPort: address family '" ++ show family ++ - "' not supported." - - --- --------------------------------------------------------------------------- --- socketPortSafe --- | Getting the port of socket. -socketPortSafe :: Socket -- Connected & Bound Socket - -> IO (Maybe PortNumber) -- Port Number of Socket -socketPortSafe s = do - sa <- getSocketName s - return $ case sa of - SockAddrInet port _ -> Just port -#if defined(IPV6_SOCKET_SUPPORT) - SockAddrInet6 port _ _ _ -> Just port -#endif - _ -> Nothing - --- --------------------------------------------------------------------------- --- getPeerName - --- Calling $getPeerName$ returns the address details of the machine, --- other than the local one, which is connected to the socket. This is --- used in programs such as FTP to determine where to send the --- returning data. The corresponding call to get the details of the --- local machine is $getSocketName$. - -getPeerName :: Socket -> IO SockAddr -getPeerName (MkSocket s family _ _ _) = do - withNewSockAddr family $ \ptr sz -> do - with (fromIntegral sz) $ \int_star -> do - throwSocketErrorIfMinus1Retry_ "Network.Socket.getPeerName" $ - c_getpeername s ptr int_star - _sz <- peek int_star - peekSockAddr ptr - -getSocketName :: Socket -> IO SockAddr -getSocketName (MkSocket s family _ _ _) = do - withNewSockAddr family $ \ptr sz -> do - with (fromIntegral sz) $ \int_star -> do - throwSocketErrorIfMinus1Retry_ "Network.Socket.getSocketName" $ - c_getsockname s ptr int_star - peekSockAddr ptr - ------------------------------------------------------------------------------ --- Socket Properties - --- | Socket options for use with 'setSocketOption' and 'getSocketOption'. --- --- 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 - | ReusePort -- ^ SO_REUSEPORT - | RecvLowWater -- ^ SO_RCVLOWAT - | SendLowWater -- ^ SO_SNDLOWAT - | RecvTimeOut -- ^ SO_RCVTIMEO - | SendTimeOut -- ^ SO_SNDTIMEO - | UseLoopBack -- ^ SO_USELOOPBACK - | UserTimeout -- ^ TCP_USER_TIMEOUT - | IPv6Only -- ^ IPV6_V6ONLY - | CustomSockOpt (CInt, CInt) - deriving (Show, Typeable) - --- | Does the 'SocketOption' exist on this system? -isSupportedSocketOption :: SocketOption -> Bool -isSupportedSocketOption = isJust . packSocketOption - --- | 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 -#ifdef SOL_SOCKET -#ifdef SO_DEBUG - Just Debug -> Just ((#const SOL_SOCKET), (#const SO_DEBUG)) -#endif -#ifdef SO_REUSEADDR - Just ReuseAddr -> Just ((#const SOL_SOCKET), (#const SO_REUSEADDR)) -#endif -#ifdef SO_TYPE - Just Type -> Just ((#const SOL_SOCKET), (#const SO_TYPE)) -#endif -#ifdef SO_ERROR - Just SoError -> Just ((#const SOL_SOCKET), (#const SO_ERROR)) -#endif -#ifdef SO_DONTROUTE - Just DontRoute -> Just ((#const SOL_SOCKET), (#const SO_DONTROUTE)) -#endif -#ifdef SO_BROADCAST - Just Broadcast -> Just ((#const SOL_SOCKET), (#const SO_BROADCAST)) -#endif -#ifdef SO_SNDBUF - Just SendBuffer -> Just ((#const SOL_SOCKET), (#const SO_SNDBUF)) -#endif -#ifdef SO_RCVBUF - Just RecvBuffer -> Just ((#const SOL_SOCKET), (#const SO_RCVBUF)) -#endif -#ifdef SO_KEEPALIVE - Just KeepAlive -> Just ((#const SOL_SOCKET), (#const SO_KEEPALIVE)) -#endif -#ifdef SO_OOBINLINE - Just OOBInline -> Just ((#const SOL_SOCKET), (#const SO_OOBINLINE)) -#endif -#ifdef SO_LINGER - Just Linger -> Just ((#const SOL_SOCKET), (#const SO_LINGER)) -#endif -#ifdef SO_REUSEPORT - Just ReusePort -> Just ((#const SOL_SOCKET), (#const SO_REUSEPORT)) -#endif -#ifdef SO_RCVLOWAT - Just RecvLowWater -> Just ((#const SOL_SOCKET), (#const SO_RCVLOWAT)) -#endif -#ifdef SO_SNDLOWAT - Just SendLowWater -> Just ((#const SOL_SOCKET), (#const SO_SNDLOWAT)) -#endif -#ifdef SO_RCVTIMEO - Just RecvTimeOut -> Just ((#const SOL_SOCKET), (#const SO_RCVTIMEO)) -#endif -#ifdef SO_SNDTIMEO - Just SendTimeOut -> Just ((#const SOL_SOCKET), (#const SO_SNDTIMEO)) -#endif -#ifdef SO_USELOOPBACK - Just UseLoopBack -> Just ((#const SOL_SOCKET), (#const SO_USELOOPBACK)) -#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 -#ifdef TCP_MAXSEG - Just MaxSegment -> Just ((#const IPPROTO_TCP), (#const TCP_MAXSEG)) -#endif -#ifdef TCP_NODELAY - Just NoDelay -> Just ((#const IPPROTO_TCP), (#const TCP_NODELAY)) -#endif -#ifdef TCP_USER_TIMEOUT - Just UserTimeout -> Just ((#const IPPROTO_TCP), (#const TCP_USER_TIMEOUT)) -#endif -#ifdef TCP_CORK - Just Cork -> Just ((#const IPPROTO_TCP), (#const TCP_CORK)) -#endif -#endif // HAVE_DECL_IPPROTO_TCP -#if HAVE_DECL_IPPROTO_IPV6 -#if HAVE_DECL_IPV6_V6ONLY - Just IPv6Only -> Just ((#const IPPROTO_IPV6), (#const IPV6_V6ONLY)) -#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"] - --- | Set a socket option that expects an Int value. --- There is currently no API to set e.g. the timeval socket options -setSocketOption :: Socket - -> SocketOption -- Option Name - -> Int -- Option Value - -> IO () -setSocketOption (MkSocket s _ _ _ _) so v = do - (level, opt) <- packSocketOption' "setSocketOption" so - with (fromIntegral v) $ \ptr_v -> do - throwSocketErrorIfMinus1_ "Network.Socket.setSocketOption" $ - c_setsockopt s level opt ptr_v - (fromIntegral (sizeOf (undefined :: CInt))) - return () - - --- | 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 -getSocketOption (MkSocket s _ _ _ _) so = do - (level, opt) <- packSocketOption' "getSocketOption" so - alloca $ \ptr_v -> - with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do - throwSocketErrorIfMinus1Retry_ "Network.Socket.getSocketOption" $ - c_getsockopt s level opt ptr_v ptr_sz - fromIntegral `liftM` peek ptr_v - - --- | Getting process ID, user ID and group ID for UNIX-domain sockets. --- --- This is implemented with SO_PEERCRED on Linux and getpeereid() --- on BSD variants. Unfortunately, on some BSD variants --- getpeereid() returns unexpected results, rather than an error, --- for AF_INET sockets. It is the user's responsibility to make sure --- that the socket is a UNIX-domain socket. --- Also, on some BSD variants, getpeereid() does not return credentials --- for sockets created via 'socketPair', only separately created and then --- explicitly connected UNIX-domain sockets work on such systems. --- --- Since 2.7.0.0. -getPeerCredential :: Socket -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt) -#ifdef HAVE_STRUCT_UCRED -getPeerCredential sock = do - (pid, uid, gid) <- getPeerCred sock - if uid == maxBound then - return (Nothing, Nothing, Nothing) - else - return (Just pid, Just uid, Just gid) -#elif defined(HAVE_GETPEEREID) -getPeerCredential sock = E.handle (\(E.SomeException _) -> return (Nothing,Nothing,Nothing)) $ do - (uid, gid) <- getPeerEid sock - return (Nothing, Just uid, Just gid) -#else -getPeerCredential _ = return (Nothing, Nothing, Nothing) -#endif - -#if defined(HAVE_STRUCT_UCRED) || defined(HAVE_GETPEEREID) -{-# DEPRECATED getPeerCred "Use getPeerCredential instead" #-} --- | Returns the processID, userID and groupID of the socket's peer. --- --- Only available on platforms that support SO_PEERCRED or GETPEEREID(3) --- on domain sockets. --- GETPEEREID(3) returns userID and groupID. processID is always 0. -getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt) -getPeerCred sock = do -#ifdef HAVE_STRUCT_UCRED - let fd = fdSocket sock - let sz = (#const sizeof(struct ucred)) - 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) -#else - (uid,gid) <- getPeerEid sock - return (0,uid,gid) -#endif - -#ifdef HAVE_GETPEEREID -{-# DEPRECATED getPeerEid "Use getPeerCredential instead" #-} --- | The getpeereid() function returns the effective user and group IDs of the --- peer connected to a UNIX-domain socket -getPeerEid :: Socket -> IO (CUInt, CUInt) -getPeerEid sock = do - let fd = fdSocket sock - alloca $ \ ptr_uid -> - alloca $ \ ptr_gid -> do - throwSocketErrorIfMinus1Retry_ "Network.Socket.getPeerEid" $ - c_getpeereid fd ptr_uid ptr_gid - uid <- peek ptr_uid - gid <- peek ptr_gid - return (uid, gid) -#endif -#endif - --- | Whether or not UNIX-domain sockets are available. --- --- Since 3.0.0.0. -isUnixDomainSocketAvailable :: Bool -#if defined(DOMAIN_SOCKET_SUPPORT) -isUnixDomainSocketAvailable = True -#else -isUnixDomainSocketAvailable = False -#endif - -##if !(MIN_VERSION_base(4,3,1)) -closeFdWith closer fd = closer fd -##endif - --- sending/receiving ancillary socket data; low-level mechanism --- for transmitting file descriptors, mainly. -sendFd :: Socket -> CInt -> IO () -#if defined(DOMAIN_SOCKET_SUPPORT) -sendFd sock outfd = do - _ <- throwSocketErrorWaitWrite sock "Network.Socket.sendFd" $ c_sendFd (fdSocket sock) outfd - return () -foreign import ccall SAFE_ON_WIN "sendFd" c_sendFd :: CInt -> CInt -> IO CInt -#else -sendFd _ _ = error "Network.Socket.sendFd" -#endif - --- | Receive a file descriptor over a domain socket. Note that the resulting --- file descriptor may have to be put into non-blocking mode in order to be --- used safely. See 'setNonBlockIfNeeded'. -recvFd :: Socket -> IO CInt -#if defined(DOMAIN_SOCKET_SUPPORT) -recvFd sock = do - theFd <- throwSocketErrorWaitRead sock "Network.Socket.recvFd" $ - c_recvFd (fdSocket sock) - return theFd -foreign import ccall SAFE_ON_WIN "recvFd" c_recvFd :: CInt -> IO CInt -#else -recvFd _ = error "Network.Socket.recvFd" -#endif - --- --------------------------------------------------------------------------- --- Utility Functions - -{-# DEPRECATED aNY_PORT "Use defaultPort instead" #-} -aNY_PORT :: PortNumber -aNY_PORT = 0 - -defaultPort :: PortNumber -defaultPort = 0 - --- | The IPv4 wild card address. - -{-# DEPRECATED iNADDR_ANY "Use getAddrInfo instead" #-} -iNADDR_ANY :: HostAddress -iNADDR_ANY = htonl (#const INADDR_ANY) - --- | 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" #-} - -#if defined(IPV6_SOCKET_SUPPORT) --- | The IPv6 wild card address. - -{-# DEPRECATED iN6ADDR_ANY "Use getAddrInfo instead" #-} -iN6ADDR_ANY :: HostAddress6 -iN6ADDR_ANY = (0, 0, 0, 0) -#endif - -{-# DEPRECATED sOMAXCONN "Use maxListenQueue instead" #-} -sOMAXCONN :: Int -sOMAXCONN = #const SOMAXCONN - -{-# DEPRECATED sOL_SOCKET "This is not necessary anymore" #-} -sOL_SOCKET :: Int -sOL_SOCKET = #const SOL_SOCKET - -#ifdef SCM_RIGHTS -{-# DEPRECATED sCM_RIGHTS "This is not necessary anymore" #-} -sCM_RIGHTS :: Int -sCM_RIGHTS = #const SCM_RIGHTS -#endif - --- | This is the value of SOMAXCONN, typically 128. --- 128 is good enough for normal network servers but --- is too small for high performance servers. -maxListenQueue :: Int -maxListenQueue = sOMAXCONN - --- ----------------------------------------------------------------------------- - -data ShutdownCmd - = ShutdownReceive - | ShutdownSend - | ShutdownBoth - deriving Typeable - -sdownCmdToInt :: ShutdownCmd -> CInt -sdownCmdToInt ShutdownReceive = 0 -sdownCmdToInt ShutdownSend = 1 -sdownCmdToInt ShutdownBoth = 2 - --- | Shut down one or both halves of the connection, depending on the --- second argument to the function. If the second argument is --- 'ShutdownReceive', further receives are disallowed. If it is --- 'ShutdownSend', further sends are disallowed. If it is --- 'ShutdownBoth', further sends and receives are disallowed. -shutdown :: Socket -> ShutdownCmd -> IO () -shutdown (MkSocket s _ _ _ _) stype = do - throwSocketErrorIfMinus1Retry_ "Network.Socket.shutdown" $ - c_shutdown s (sdownCmdToInt stype) - return () - --- ----------------------------------------------------------------------------- - --- | Close the socket. This function does not throw exceptions even if --- the underlying system call returns errors. --- --- Sending data to or receiving data from closed socket --- may lead to undefined behaviour. --- --- If multiple threads use the same socket and one uses 'fdSocket' and --- the other use 'close', unexpected behavior may happen. --- For more information, please refer to the documentation of 'fdSocket'. -close :: Socket -> IO () -close (MkSocket s _ _ _ socketStatus) = modifyMVar_ socketStatus $ \ status -> - case status of - ConvertedToHandle -> return ConvertedToHandle - Closed -> return Closed - _ -> do - -- closeFdWith avoids the deadlock of IO manager. - closeFdWith (void . c_close . fromIntegral) (fromIntegral s) - return Closed - --- | Close the socket. This function throws exceptions if --- the underlying system call returns errors. --- --- Sending data to or receiving data from closed socket --- may lead to undefined behaviour. -close' :: Socket -> IO () -close' (MkSocket s _ _ _ socketStatus) = modifyMVar_ socketStatus $ \ status -> - case status of - ConvertedToHandle -> ioError (userError ("close: converted to a Handle, use hClose instead")) - Closed -> return Closed - _ -> do - -- closeFdWith avoids the deadlock of IO manager. - -- closeFd throws exceptions. - closeFdWith (closeFd . fromIntegral) (fromIntegral s) - return Closed - --- ----------------------------------------------------------------------------- - --- | Determines whether 'close' has been used on the 'Socket'. This --- does /not/ indicate any status about the socket beyond this. If the --- socket has been closed remotely, this function can still return --- 'True'. -isConnected :: Socket -> IO Bool -isConnected (MkSocket _ _ _ _ status) = do - value <- readMVar status - return (value == Connected) -{-# DEPRECATED isConnected "SocketStatus will be removed" #-} - --- ----------------------------------------------------------------------------- --- Socket Predicates - -isBound :: Socket -> IO Bool -isBound (MkSocket _ _ _ _ status) = do - value <- readMVar status - return (value == Bound) -{-# DEPRECATED isBound "SocketStatus will be removed" #-} - -isListening :: Socket -> IO Bool -isListening (MkSocket _ _ _ _ status) = do - value <- readMVar status - return (value == Listening) -{-# DEPRECATED isListening "SocketStatus will be removed" #-} - -isReadable :: Socket -> IO Bool -isReadable (MkSocket _ _ _ _ status) = do - value <- readMVar status - return (value == Listening || value == Connected) -{-# DEPRECATED isReadable "SocketStatus will be removed" #-} - -isWritable :: Socket -> IO Bool -isWritable = isReadable -- sort of. -{-# DEPRECATED isWritable "SocketStatus will be removed" #-} - -isAcceptable :: Family -> SocketType -> SocketStatus -> Bool -#if defined(DOMAIN_SOCKET_SUPPORT) -isAcceptable AF_UNIX sockTyp status - | sockTyp == Stream || sockTyp == SeqPacket = - status == Connected || status == Bound || status == Listening -isAcceptable AF_UNIX _ _ = False -#endif -isAcceptable _ _ status = status == Connected || status == Listening -{-# DEPRECATED isAcceptable "SocketStatus will be removed" #-} - --- ----------------------------------------------------------------------------- --- Internet address manipulation routines: - -{-# DEPRECATED inet_addr "Use \"getAddrInfo\" instead" #-} -inet_addr :: String -> IO HostAddress -inet_addr ipstr = withSocketsDo $ do - withCString ipstr $ \str -> do - had <- c_inet_addr str - if had == maxBound - then ioError $ userError $ - "Network.Socket.inet_addr: Malformed address: " ++ ipstr - else return had -- network byte order - -{-# DEPRECATED inet_ntoa "Use \"getNameInfo\" instead" #-} -inet_ntoa :: HostAddress -> IO String -inet_ntoa haddr = withSocketsDo $ do - pstr <- c_inet_ntoa haddr - peekCString pstr - --- | Turns a Socket into an 'Handle'. By default, the new handle is --- unbuffered. Use 'System.IO.hSetBuffering' to change the buffering. --- --- Note that since a 'Handle' is automatically closed by a finalizer --- when it is no longer referenced, you should avoid doing any more --- operations on the 'Socket' after calling 'socketToHandle'. To --- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose' --- on the 'Handle'. - -socketToHandle :: Socket -> IOMode -> IO Handle -socketToHandle s@(MkSocket fd _ _ _ socketStatus) mode = do - modifyMVar socketStatus $ \ status -> - if status == ConvertedToHandle - then ioError (userError ("socketToHandle: already a Handle")) - else do - h <- fdToHandle' (fromIntegral fd) (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-} - hSetBuffering h NoBuffering - return (ConvertedToHandle, h) - --- | Pack a list of values into a bitmask. The possible mappings from --- value to bit-to-set are given as the first argument. We assume --- that each value can cause exactly one bit to be set; unpackBits will --- break if this property is not true. - -packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b - -packBits mapping xs = foldl' pack 0 mapping - where pack acc (k, v) | k `elem` xs = acc .|. v - | otherwise = acc - --- | Unpack a bitmask into a list of values. - -unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a] - --- Be permissive and ignore unknown bit values. At least on OS X, --- getaddrinfo returns an ai_flags field with bits set that have no --- entry in . -unpackBits [] _ = [] -unpackBits ((k,v):xs) r - | r .&. v /= 0 = k : unpackBits xs (r .&. complement v) - | otherwise = unpackBits xs r - ------------------------------------------------------------------------------ --- Address and service lookups - -#if defined(IPV6_SOCKET_SUPPORT) - --- | Flags that control the querying behaviour of 'getAddrInfo'. --- For more information, see -data AddrInfoFlag = - -- | The list of returned 'AddrInfo' values will - -- only contain IPv4 addresses if the local system has at least - -- one IPv4 interface configured, and likewise for IPv6. - -- (Only some platforms support this.) - AI_ADDRCONFIG - -- | If 'AI_ALL' is specified, return all matching IPv6 and - -- IPv4 addresses. Otherwise, this flag has no effect. - -- (Only some platforms support this.) - | AI_ALL - -- | The 'addrCanonName' field of the first returned - -- 'AddrInfo' will contain the "canonical name" of the host. - | AI_CANONNAME - -- | The 'HostName' argument /must/ be a numeric - -- address in string form, and network name lookups will not be - -- attempted. - | AI_NUMERICHOST - -- | The 'ServiceName' argument /must/ be a port - -- number in string form, and service name lookups will not be - -- attempted. (Only some platforms support this.) - | AI_NUMERICSERV - -- | If no 'HostName' value is provided, the network - -- address in each 'SockAddr' - -- will be left as a "wild card". - -- This is useful for server applications that - -- will accept connections from any client. - | AI_PASSIVE - -- | If an IPv6 lookup is performed, and no IPv6 - -- addresses are found, IPv6-mapped IPv4 addresses will be - -- returned. (Only some platforms support this.) - | AI_V4MAPPED - deriving (Eq, Read, Show, Typeable) - -aiFlagMapping :: [(AddrInfoFlag, CInt)] - -aiFlagMapping = - [ -#if HAVE_DECL_AI_ADDRCONFIG - (AI_ADDRCONFIG, #const AI_ADDRCONFIG), -#else - (AI_ADDRCONFIG, 0), -#endif -#if HAVE_DECL_AI_ALL - (AI_ALL, #const AI_ALL), -#else - (AI_ALL, 0), -#endif - (AI_CANONNAME, #const AI_CANONNAME), - (AI_NUMERICHOST, #const AI_NUMERICHOST), -#if HAVE_DECL_AI_NUMERICSERV - (AI_NUMERICSERV, #const AI_NUMERICSERV), -#else - (AI_NUMERICSERV, 0), -#endif - (AI_PASSIVE, #const AI_PASSIVE), -#if HAVE_DECL_AI_V4MAPPED - (AI_V4MAPPED, #const AI_V4MAPPED) -#else - (AI_V4MAPPED, 0) -#endif - ] - --- | Indicate whether the given 'AddrInfoFlag' will have any effect on --- this system. -addrInfoFlagImplemented :: AddrInfoFlag -> Bool -addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0 - -data AddrInfo = - AddrInfo { - addrFlags :: [AddrInfoFlag], - addrFamily :: Family, - addrSocketType :: SocketType, - addrProtocol :: ProtocolNumber, - addrAddress :: SockAddr, - addrCanonName :: Maybe String - } - deriving (Eq, Show, Typeable) - -instance Storable AddrInfo where - sizeOf _ = #const sizeof(struct addrinfo) - alignment _ = alignment (undefined :: CInt) - - peek p = do - ai_flags <- (#peek struct addrinfo, ai_flags) p - ai_family <- (#peek struct addrinfo, ai_family) p - ai_socktype <- (#peek struct addrinfo, ai_socktype) p - ai_protocol <- (#peek struct addrinfo, ai_protocol) p - ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr - ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p - - ai_canonname <- if ai_canonname_ptr == nullPtr - then return Nothing - else liftM Just $ peekCString ai_canonname_ptr - - socktype <- unpackSocketType' "AddrInfo.peek" ai_socktype - return (AddrInfo - { - addrFlags = unpackBits aiFlagMapping ai_flags, - addrFamily = unpackFamily ai_family, - addrSocketType = socktype, - addrProtocol = ai_protocol, - addrAddress = ai_addr, - addrCanonName = ai_canonname - }) - - poke p (AddrInfo flags family socketType protocol _ _) = do - c_stype <- packSocketTypeOrThrow "AddrInfo.poke" socketType - - (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags) - (#poke struct addrinfo, ai_family) p (packFamily family) - (#poke struct addrinfo, ai_socktype) p c_stype - (#poke struct addrinfo, ai_protocol) p protocol - - -- stuff below is probably not needed, but let's zero it for safety - - (#poke struct addrinfo, ai_addrlen) p (0::CSize) - (#poke struct addrinfo, ai_addr) p nullPtr - (#poke struct addrinfo, ai_canonname) p nullPtr - (#poke struct addrinfo, ai_next) p nullPtr - --- | Flags that control the querying behaviour of 'getNameInfo'. --- For more information, see -data NameInfoFlag = - -- | Resolve a datagram-based service name. This is - -- required only for the few protocols that have different port - -- numbers for their datagram-based versions than for their - -- stream-based versions. - NI_DGRAM - -- | If the hostname cannot be looked up, an IO error is thrown. - | NI_NAMEREQD - -- | If a host is local, return only the hostname part of the FQDN. - | NI_NOFQDN - -- | The name of the host is not looked up. - -- Instead, a numeric representation of the host's - -- address is returned. For an IPv4 address, this will be a - -- dotted-quad string. For IPv6, it will be colon-separated - -- hexadecimal. - | NI_NUMERICHOST - -- | The name of the service is not - -- looked up. Instead, a numeric representation of the - -- service is returned. - | NI_NUMERICSERV - deriving (Eq, Read, Show, Typeable) - -niFlagMapping :: [(NameInfoFlag, CInt)] - -niFlagMapping = [(NI_DGRAM, #const NI_DGRAM), - (NI_NAMEREQD, #const NI_NAMEREQD), - (NI_NOFQDN, #const NI_NOFQDN), - (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'. --- --- >>> addrFlags defaultHints --- [] --- >>> addrFamily defaultHints --- AF_UNSPEC --- >>> addrSocketType defaultHints --- NoSocketType --- >>> addrProtocol defaultHints --- 0 - -defaultHints :: AddrInfo -defaultHints = AddrInfo { - addrFlags = [], - addrFamily = AF_UNSPEC, - addrSocketType = NoSocketType, - addrProtocol = defaultProtocol, - addrAddress = undefined, - addrCanonName = undefined - } - --- | 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' --- values that you can pass directly to 'connect' or --- 'bind'. --- --- This function is protocol independent. It can return both IPv4 and --- IPv6 address information. --- --- The 'AddrInfo' argument specifies the preferred query behaviour, --- socket options, or protocol. You can override these conveniently --- using Haskell's record update syntax on 'defaultHints', for example --- as follows: --- --- >>> let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Stream } --- --- You must provide a 'Just' value for at least one of the 'HostName' --- or 'ServiceName' arguments. 'HostName' can be either a numeric --- network address (dotted quad for IPv4, colon-separated hex for --- IPv6) or a hostname. In the latter case, its addresses will be --- looked up unless 'AI_NUMERICHOST' is specified as a hint. If you --- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as --- a hint, network addresses in the result will contain the address of --- the loopback interface. --- --- If the query fails, this function throws an IO exception instead of --- returning an empty list. Otherwise, it returns a non-empty list --- of 'AddrInfo' values. --- --- There are several reasons why a query might result in several --- values. For example, the queried-for host could be multihomed, or --- the service might be available via several protocols. --- --- Note: the order of arguments is slightly different to that defined --- for @getaddrinfo@ in RFC 2553. The 'AddrInfo' parameter comes first --- to make partial application easier. --- --- >>> addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just "http") --- >>> addrAddress addr --- 127.0.0.1:80 - -getAddrInfo :: Maybe AddrInfo -- ^ preferred socket type or protocol - -> Maybe HostName -- ^ host name to look up - -> Maybe ServiceName -- ^ service name to look up - -> IO [AddrInfo] -- ^ resolved addresses, with "best" first - -getAddrInfo hints node service = withSocketsDo $ - maybeWith withCString node $ \c_node -> - maybeWith withCString service $ \c_service -> - maybeWith with filteredHints $ \c_hints -> - alloca $ \ptr_ptr_addrs -> do - ret <- c_getaddrinfo c_node c_service c_hints ptr_ptr_addrs - case ret of - 0 -> do ptr_addrs <- peek ptr_ptr_addrs - ais <- followAddrInfo ptr_addrs - c_freeaddrinfo ptr_addrs - return ais - _ -> do err <- gai_strerror ret - let message = concat - [ "Network.Socket.getAddrInfo (called with preferred socket type/protocol: " - , maybe (show hints) showDefaultHints hints - , ", host name: " - , show node - , ", service name: " - , show service - , ")" - ] - ioError (ioeSetErrorString - (mkIOError NoSuchThing message Nothing - Nothing) err) - -- Leaving out the service and using AI_NUMERICSERV causes a - -- segfault on OS X 10.8.2. This code removes AI_NUMERICSERV - -- (which has no effect) in that case. - where -#if defined(darwin_HOST_OS) - filteredHints = case service of - Nothing -> fmap (\ h -> h { addrFlags = delete AI_NUMERICSERV (addrFlags h) }) hints - _ -> hints -#else - filteredHints = hints -#endif - -followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo] - -followAddrInfo ptr_ai | ptr_ai == nullPtr = return [] - | otherwise = do - a <- peek ptr_ai - as <- (#peek struct addrinfo, ai_next) ptr_ai >>= followAddrInfo - return (a:as) - -foreign import ccall safe "hsnet_getaddrinfo" - c_getaddrinfo :: CString -> CString -> Ptr AddrInfo -> Ptr (Ptr AddrInfo) - -> IO CInt - -foreign import ccall safe "hsnet_freeaddrinfo" - c_freeaddrinfo :: Ptr AddrInfo -> IO () - -gai_strerror :: CInt -> IO String - -#ifdef HAVE_GAI_STRERROR -gai_strerror n = c_gai_strerror n >>= peekCString - -foreign import ccall safe "gai_strerror" - c_gai_strerror :: CInt -> IO CString -#else -gai_strerror n = ioError $ userError $ "Network.Socket.gai_strerror not supported: " ++ show n -#endif - -withCStringIf :: Bool -> Int -> (CSize -> CString -> IO a) -> IO a -withCStringIf False _ f = f 0 nullPtr -withCStringIf True n f = allocaBytes n (f (fromIntegral n)) - --- | Resolve an address to a host or service name. --- This function is protocol independent. --- The list of 'NameInfoFlag' values controls query behaviour. --- --- If a host or service's name cannot be looked up, then the numeric --- form of the address or service will be returned. --- --- If the query fails, this function throws an IO exception. --- --- Example: --- @ --- (hostName, _) <- getNameInfo [] True False myAddress --- @ - -getNameInfo :: [NameInfoFlag] -- ^ flags to control lookup behaviour - -> Bool -- ^ whether to look up a hostname - -> Bool -- ^ whether to look up a service name - -> SockAddr -- ^ the address to look up - -> IO (Maybe HostName, Maybe ServiceName) - -getNameInfo flags doHost doService addr = withSocketsDo $ - withCStringIf doHost (#const NI_MAXHOST) $ \c_hostlen c_host -> - withCStringIf doService (#const NI_MAXSERV) $ \c_servlen c_serv -> do - withSockAddr addr $ \ptr_addr sz -> do - ret <- c_getnameinfo ptr_addr (fromIntegral sz) c_host c_hostlen - c_serv c_servlen (packBits niFlagMapping flags) - case ret of - 0 -> do - let peekIf doIf c_val = if doIf - then liftM Just $ peekCString c_val - else return Nothing - host <- peekIf doHost c_host - serv <- peekIf doService c_serv - return (host, serv) - _ -> do err <- gai_strerror ret - let message = concat - [ "Network.Socket.getNameInfo (called with flags: " - , show flags - , ", hostname lookup: " - , show doHost - , ", service name lookup: " - , show doService - , ", socket address: " - , show addr - , ")" - ] - ioError (ioeSetErrorString - (mkIOError NoSuchThing message Nothing - Nothing) err) - -foreign import ccall safe "hsnet_getnameinfo" - c_getnameinfo :: Ptr SockAddr -> CInt{-CSockLen???-} -> CString -> CSize -> CString - -> CSize -> CInt -> IO CInt -#endif - -mkInvalidRecvArgError :: String -> IOError -mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError - InvalidArgument - loc Nothing Nothing) "non-positive length" - -mkEOFError :: String -> IOError -mkEOFError loc = ioeSetErrorString (mkIOError EOF loc Nothing Nothing) "end of file" - --- --------------------------------------------------------------------------- --- foreign imports from the C library - -foreign import ccall unsafe "hsnet_inet_ntoa" - c_inet_ntoa :: HostAddress -> IO (Ptr CChar) - -foreign import CALLCONV unsafe "inet_addr" - c_inet_addr :: Ptr CChar -> IO HostAddress - -foreign import CALLCONV unsafe "shutdown" - c_shutdown :: CInt -> CInt -> IO CInt - -closeFd :: CInt -> IO () -closeFd fd = throwSocketErrorIfMinus1_ "Network.Socket.close" $ c_close fd - -#if !defined(WITH_WINSOCK) -foreign import ccall unsafe "close" - c_close :: CInt -> IO CInt -#else -foreign import stdcall unsafe "closesocket" - c_close :: CInt -> IO CInt -#endif - -foreign import CALLCONV unsafe "socket" - c_socket :: CInt -> CInt -> CInt -> IO CInt -foreign import CALLCONV unsafe "bind" - c_bind :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt -foreign import CALLCONV SAFE_ON_WIN "connect" - c_connect :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt -#ifdef HAVE_ACCEPT4 -foreign import CALLCONV unsafe "accept4" - c_accept4 :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> CInt -> IO CInt -#else -foreign import CALLCONV unsafe "accept" - c_accept :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt -#endif -foreign import CALLCONV unsafe "listen" - c_listen :: CInt -> CInt -> IO CInt - -#if defined(mingw32_HOST_OS) -foreign import CALLCONV safe "accept" - c_accept_safe :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt - -foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool -#endif - -foreign import CALLCONV unsafe "send" - c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt -foreign import CALLCONV SAFE_ON_WIN "sendto" - c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr SockAddr -> CInt -> IO CInt -foreign import CALLCONV unsafe "recv" - c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt -foreign import CALLCONV SAFE_ON_WIN "recvfrom" - c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt -foreign import CALLCONV unsafe "getpeername" - c_getpeername :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt -foreign import CALLCONV unsafe "getsockname" - c_getsockname :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt - -foreign import CALLCONV unsafe "getsockopt" - c_getsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt -foreign import CALLCONV unsafe "setsockopt" - c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt - -#if defined(HAVE_GETPEEREID) -foreign import CALLCONV unsafe "getpeereid" - c_getpeereid :: CInt -> Ptr CUInt -> Ptr CUInt -> IO CInt -#endif --- --------------------------------------------------------------------------- --- * Deprecated aliases - --- $deprecated-aliases --- --- These aliases are deprecated and should not be used in new code. --- They will be removed in some future version of the package. - -{-# DEPRECATED bindSocket "use 'bind'" #-} - --- | Deprecated alias for 'bind'. -bindSocket :: Socket -- Unconnected Socket - -> SockAddr -- Address to Bind to - -> IO () -bindSocket = bind - -{-# DEPRECATED sClose "use 'close'" #-} - --- | Deprecated alias for 'close'. -sClose :: Socket -> IO () -sClose = close - -{-# DEPRECATED sIsConnected "SocketStatus will be removed" #-} - -sIsConnected :: Socket -> IO Bool -sIsConnected = isConnected - -{-# DEPRECATED sIsBound "SocketStatus will be removed" #-} - -sIsBound :: Socket -> IO Bool -sIsBound = isBound - -{-# DEPRECATED sIsListening "SocketStatus will be removed" #-} - -sIsListening :: Socket -> IO Bool -sIsListening = isListening - -{-# DEPRECATED sIsReadable "SocketStatus will be removed" #-} - -sIsReadable :: Socket -> IO Bool -sIsReadable = isReadable - -{-# DEPRECATED sIsWritable "SocketStatus will be removed" #-} - -sIsWritable :: Socket -> IO Bool -sIsWritable = isWritable - -#if defined(HAVE_IF_NAMETOINDEX) --- | Returns the index corresponding to the interface name. --- --- Since 2.7.0.0. -ifNameToIndex :: String -> IO (Maybe Int) -ifNameToIndex ifname = do - index <- withCString ifname c_if_nametoindex - -- On failure zero is returned. We'll return Nothing. - return $ if index == 0 then Nothing else Just $ fromIntegral index - --- | Returns the interface name corresponding to the index. --- --- Since 2.7.0.0. -ifIndexToName :: Int -> IO (Maybe String) -ifIndexToName ifn = allocaBytes 16 $ \ptr -> do -- 16 == IFNAMSIZ - r <- c_if_indextoname (fromIntegral ifn) ptr - if r == nullPtr then - return Nothing - else - Just <$> peekCString ptr - -foreign import CALLCONV safe "if_nametoindex" - c_if_nametoindex :: CString -> IO CUInt - -foreign import CALLCONV safe "if_indextoname" - c_if_indextoname :: CUInt -> CString -> IO CString -#endif diff --git a/Network/Socket/Address.hs b/Network/Socket/Address.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Address.hs @@ -0,0 +1,25 @@ +-- | This module provides extensible APIs for socket addresses. +-- +module Network.Socket.Address ( + -- * Socket Address + SocketAddress(..) + , getPeerName + , getSocketName + -- * Socket operations + , connect + , bind + , accept + -- * Sending and receiving ByteString + , sendTo + , sendAllTo + , recvFrom + -- * Sending and receiving data from a buffer + , sendBufTo + , recvBufFrom + ) where + +import Network.Socket.ByteString.IO +import Network.Socket.Buffer +import Network.Socket.Name +import Network.Socket.Syscall +import Network.Socket.Types diff --git a/Network/Socket/Buffer.hs b/Network/Socket/Buffer.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Buffer.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} + +#include "HsNetDef.h" + +module Network.Socket.Buffer ( + sendBufTo + , sendBuf + , recvBufFrom + , recvBuf + ) where + +import qualified Control.Exception as E +import Foreign.Marshal.Alloc (alloca) +import GHC.IO.Exception (IOErrorType(InvalidArgument)) +import System.IO.Error (mkIOError, ioeSetErrorString) + +#if defined(mingw32_HOST_OS) +import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr) +#endif + +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Name +import Network.Socket.Types + +-- | 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 +-- ensuring that all data has been sent. +sendBufTo :: SocketAddress sa => + Socket -- (possibly) bound/connected Socket + -> Ptr a + -> Int -- Data to send + -> sa + -> IO Int -- Number of Bytes sent +sendBufTo s ptr nbytes sa = + withSocketAddress sa $ \p_sa siz -> fromIntegral <$> do + fd <- fdSocket s + let sz = fromIntegral siz + n = fromIntegral nbytes + flags = 0 + throwSocketErrorWaitWrite s "Network.Socket.sendBufTo" $ + c_sendto fd ptr n flags p_sa sz + +#if defined(mingw32_HOST_OS) +socket2FD :: Socket -> IO FD +socket2FD s = do + fd <- fdSocket s + -- HACK, 1 means True + return $ FD{ fdFD = fd, fdIsSocket_ = 1 } +#endif + +-- | Send data to the socket. The socket must be connected to a remote +-- socket. Returns the number of bytes sent. Applications are +-- responsible for ensuring that all data has been sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +sendBuf :: Socket -- Bound/Connected Socket + -> Ptr Word8 -- Pointer to the data to send + -> Int -- Length of the buffer + -> IO Int -- Number of Bytes sent +sendBuf s str len = fromIntegral <$> do +#if defined(mingw32_HOST_OS) +-- writeRawBufferPtr is supposed to handle checking for errors, but it's broken +-- on x86_64 because of GHC bug #12010 so we duplicate the check here. The call +-- to throwSocketErrorIfMinus1Retry can be removed when no GHC version with the +-- bug is supported. + fd <- socket2FD s + let clen = fromIntegral len + throwSocketErrorIfMinus1Retry "Network.Socket.sendBuf" $ + writeRawBufferPtr "Network.Socket.sendBuf" fd (castPtr str) 0 clen +#else + fd <- fdSocket s + let flags = 0 + clen = fromIntegral len + throwSocketErrorWaitWrite s "Network.Socket.sendBuf" $ + c_send fd str clen flags +#endif + +-- | Receive data from the socket, writing it into buffer instead of +-- creating a new string. The socket need not be in a connected +-- state. Returns @(nbytes, address)@ where @nbytes@ is the number of +-- bytes received and @address@ is a 'SockAddr' representing the +-- address of the sending socket. +-- +-- If the first return value is zero, it means EOF. +-- +-- For 'Stream' sockets, the second return value would be invalid. +-- +-- NOTE: blocking on Windows unless you compile with -threaded (see +-- GHC ticket #1129) +recvBufFrom :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa) +recvBufFrom s ptr nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom") + | otherwise = withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len -> do + fd <- fdSocket s + poke ptr_len (fromIntegral sz) + let cnbytes = fromIntegral nbytes + flags = 0 + len <- throwSocketErrorWaitRead s "Network.Socket.recvBufFrom" $ + c_recvfrom fd ptr cnbytes flags ptr_sa ptr_len + sockaddr <- peekSocketAddress ptr_sa + `E.catch` \(E.SomeException _) -> getPeerName s + return (fromIntegral len, sockaddr) + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If the +-- message is longer than the specified length, it may be discarded +-- depending on the type of socket. This function may block until a +-- message arrives. +-- +-- Considering hardware and network realities, the maximum number of +-- bytes to receive should be a small power of 2, e.g., 4096. +-- +-- The return value is the length of received data. Zero means +-- EOF. Historical note: Version 2.8.x.y or earlier, +-- an EOF error was thrown. This was changed in version 3.0. +-- +-- Receiving data from closed socket may lead to undefined behaviour. +recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int +recvBuf s ptr nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf") + | otherwise = do +#if defined(mingw32_HOST_OS) +-- see comment in sendBuf above. + fd <- socket2FD s + let cnbytes = fromIntegral nbytes + len <- throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $ + readRawBufferPtr "Network.Socket.recvBuf" fd ptr 0 cnbytes +#else + fd <- fdSocket s + len <- throwSocketErrorWaitRead s "Network.Socket.recvBuf" $ + c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-} +#endif + return $ fromIntegral len + +mkInvalidRecvArgError :: String -> IOError +mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError + InvalidArgument + loc Nothing Nothing) "non-positive length" + +#if !defined(mingw32_HOST_OS) +foreign import ccall unsafe "send" + c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt +foreign import ccall unsafe "recv" + c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt +#endif +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 new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString.hs @@ -0,0 +1,95 @@ +-- | +-- Module : Network.Socket.ByteString +-- Copyright : (c) Johan Tibell 2007-2010 +-- License : BSD-style +-- +-- Maintainer : johan.tibell@gmail.com +-- 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 +-- > import Network.Socket.ByteString +-- +module Network.Socket.ByteString + ( + -- * Send data to a socket + send + , sendAll + , sendTo + , sendAllTo + + -- ** Vectored I/O + -- $vectored + , sendMany + , sendManyTo + + -- * Receive data from a socket + , recv + , recvFrom + ) 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.Types + +-- ---------------------------------------------------------------------------- +-- ** Vectored I/O + +-- $vectored +-- +-- Vectored I\/O, also known as scatter\/gather I\/O, allows multiple +-- data segments to be sent using a single system call, without first +-- concatenating the segments. For example, given a list of +-- @ByteString@s, @xs@, +-- +-- > sendMany sock xs +-- +-- is equivalent to +-- +-- > sendAll sock (concat xs) +-- +-- but potentially more efficient. +-- +-- Vectored I\/O are often useful when implementing network protocols +-- that, for example, group data into segments consisting of one or +-- more fixed-length headers followed by a variable-length body. + +-- | 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 +-- ensuring that all data has been sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +sendTo :: Socket -> ByteString -> SockAddr -> IO Int +sendTo = G.sendTo + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. Unlike +-- 'sendTo', this function continues to send data until either all +-- data has been sent or an error occurs. On error, an exception is +-- raised, and there is no way to determine how much data, if any, was +-- successfully sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +sendAllTo :: Socket -> ByteString -> SockAddr -> IO () +sendAllTo = G.sendAllTo + +-- | Receive data from the socket. The socket need not be in a +-- connected state. Returns @(bytes, address)@ where @bytes@ is a +-- 'ByteString' representing the data received and @address@ is a +-- 'SockAddr' representing the address of the sending socket. +-- +-- Receiving data from closed socket may lead to undefined behaviour. +recvFrom :: Socket -> Int -> IO (ByteString, SockAddr) +recvFrom = G.recvFrom + diff --git a/Network/Socket/ByteString.hsc b/Network/Socket/ByteString.hsc deleted file mode 100644 --- a/Network/Socket/ByteString.hsc +++ /dev/null @@ -1,285 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} - -#include "HsNet.h" - --- | --- Module : Network.Socket.ByteString --- Copyright : (c) Johan Tibell 2007-2010 --- License : BSD-style --- --- Maintainer : johan.tibell@gmail.com --- 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 - ( - -- * Send data to a socket - send - , sendAll - , sendTo - , sendAllTo - - -- ** Vectored I/O - -- $vectored - , sendMany - , sendManyTo - - -- * Receive data from a socket - , recv - , recvFrom - ) where - -import Control.Exception as E (catch, throwIO) -import Control.Monad (when) -import Data.ByteString (ByteString) -import Data.ByteString.Internal (createAndTrim) -import Data.ByteString.Unsafe (unsafeUseAsCStringLen) -import Foreign.Marshal.Alloc (allocaBytes) -import Foreign.Ptr (castPtr) -import Network.Socket (sendBuf, sendBufTo, recvBuf, recvBufFrom) -import System.IO.Error (isEOFError) - -import qualified Data.ByteString as B - -import Network.Socket.ByteString.Internal -import Network.Socket.Internal -import Network.Socket.Types - -#if !defined(mingw32_HOST_OS) -import Control.Monad (liftM, zipWithM_) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (Storable(..)) - -import Network.Socket.ByteString.IOVec (IOVec(..)) -import Network.Socket.ByteString.MsgHdr (MsgHdr(..)) -#endif - --- ---------------------------------------------------------------------------- --- Sending - --- | Send data to the socket. The socket must be connected to a --- remote socket. Returns the number of bytes sent. Applications are --- responsible for ensuring that all data has been sent. --- --- Sending data to closed socket may lead to undefined behaviour. -send :: Socket -- ^ Connected socket - -> ByteString -- ^ Data to send - -> IO Int -- ^ Number of bytes sent -send sock xs = unsafeUseAsCStringLen xs $ \(str, len) -> - sendBuf sock (castPtr str) len - --- | Send data to the socket. The socket must be connected to a --- remote socket. Unlike 'send', this function continues to send data --- until either all data has been sent or an error occurs. On error, --- an exception is raised, and there is no way to determine how much --- data, if any, was successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. -sendAll :: Socket -- ^ Connected socket - -> ByteString -- ^ Data to send - -> IO () -sendAll _ "" = return () -sendAll sock bs = do - sent <- send sock bs - waitWhen0 sent sock - when (sent >= 0) $ sendAll sock $ B.drop sent bs - --- | 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 --- ensuring that all data has been sent. --- --- Sending data to closed socket may lead to undefined behaviour. -sendTo :: Socket -- ^ Socket - -> ByteString -- ^ Data to send - -> SockAddr -- ^ Recipient address - -> IO Int -- ^ Number of bytes sent -sendTo sock xs addr = - unsafeUseAsCStringLen xs $ \(str, len) -> sendBufTo sock str len addr - --- | Send data to the socket. The recipient can be specified --- explicitly, so the socket need not be in a connected state. Unlike --- 'sendTo', this function continues to send data until either all --- data has been sent or an error occurs. On error, an exception is --- raised, and there is no way to determine how much data, if any, was --- successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. -sendAllTo :: Socket -- ^ Socket - -> ByteString -- ^ Data to send - -> SockAddr -- ^ Recipient address - -> IO () -sendAllTo _ "" _ = return () -sendAllTo sock xs addr = do - sent <- sendTo sock xs addr - waitWhen0 sent sock - when (sent >= 0) $ sendAllTo sock (B.drop sent xs) addr - --- ---------------------------------------------------------------------------- --- ** Vectored I/O - --- $vectored --- --- Vectored I\/O, also known as scatter\/gather I\/O, allows multiple --- data segments to be sent using a single system call, without first --- concatenating the segments. For example, given a list of --- @ByteString@s, @xs@, --- --- > sendMany sock xs --- --- is equivalent to --- --- > sendAll sock (concat xs) --- --- but potentially more efficient. --- --- Vectored I\/O are often useful when implementing network protocols --- that, for example, group data into segments consisting of one or --- more fixed-length headers followed by a variable-length body. - --- | Send data to the socket. The socket must be in a connected --- state. The data is sent as if the parts have been concatenated. --- This function continues to send data until either all data has been --- sent or an error occurs. On error, an exception is raised, and --- there is no way to determine how much data, if any, was --- successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. -sendMany :: Socket -- ^ Connected socket - -> [ByteString] -- ^ Data to send - -> IO () -#if !defined(mingw32_HOST_OS) -sendMany _ [] = return () -sendMany sock@(MkSocket fd _ _ _ _) cs = do - sent <- sendManyInner - waitWhen0 sent sock - when (sent >= 0) $ sendMany sock (remainingChunks sent cs) - where - sendManyInner = - liftM fromIntegral . withIOVec cs $ \(iovsPtr, iovsLen) -> - throwSocketErrorWaitWrite sock "Network.Socket.ByteString.sendMany" $ - c_writev (fromIntegral fd) iovsPtr - (fromIntegral (min iovsLen (#const IOV_MAX))) -#else -sendMany sock = sendAll sock . B.concat -#endif - --- | Send data to the socket. The recipient can be specified --- explicitly, so the socket need not be in a connected state. The --- data is sent as if the parts have been concatenated. This function --- continues to send data until either all data has been sent or an --- error occurs. On error, an exception is raised, and there is no --- way to determine how much data, if any, was successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. -sendManyTo :: Socket -- ^ Socket - -> [ByteString] -- ^ Data to send - -> SockAddr -- ^ Recipient address - -> IO () -#if !defined(mingw32_HOST_OS) -sendManyTo _ [] _ = return () -sendManyTo sock@(MkSocket fd _ _ _ _) cs addr = do - sent <- liftM fromIntegral sendManyToInner - waitWhen0 sent sock - when (sent >= 0) $ sendManyTo sock (remainingChunks sent cs) addr - where - sendManyToInner = - withSockAddr addr $ \addrPtr addrSize -> - withIOVec cs $ \(iovsPtr, iovsLen) -> do - let msgHdr = MsgHdr - addrPtr (fromIntegral addrSize) - iovsPtr (fromIntegral iovsLen) - with msgHdr $ \msgHdrPtr -> - throwSocketErrorWaitWrite sock "Network.Socket.ByteString.sendManyTo" $ - c_sendmsg (fromIntegral fd) msgHdrPtr 0 -#else -sendManyTo sock cs = sendAllTo sock (B.concat cs) -#endif - --- ---------------------------------------------------------------------------- --- Receiving - --- | Receive data from the socket. The socket must be in a connected --- state. This function may return fewer bytes than specified. If --- the message is longer than the specified length, it may be --- discarded depending on the type of socket. This function may block --- until a message arrives. --- --- Considering hardware and network realities, the maximum number of bytes to --- receive should be a small power of 2, e.g., 4096. --- --- For TCP sockets, a zero length return value means the peer has --- closed its half side of the connection. --- --- Receiving data from closed socket may lead to undefined behaviour. -recv :: Socket -- ^ Connected socket - -> Int -- ^ Maximum number of bytes to receive - -> IO ByteString -- ^ Data received -recv sock nbytes - | nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv") - | otherwise = createAndTrim nbytes $ \ptr -> - E.catch - (recvBuf sock ptr nbytes) - (\e -> if isEOFError e then return 0 else throwIO e) - --- | Receive data from the socket. The socket need not be in a --- connected state. Returns @(bytes, address)@ where @bytes@ is a --- 'ByteString' representing the data received and @address@ is a --- 'SockAddr' representing the address of the sending socket. --- --- Receiving data from closed socket may lead to undefined behaviour. -recvFrom :: Socket -- ^ Socket - -> Int -- ^ Maximum number of bytes to receive - -> IO (ByteString, SockAddr) -- ^ Data received and sender address -recvFrom sock nbytes = - allocaBytes nbytes $ \ptr -> do - (len, sockaddr) <- recvBufFrom sock ptr nbytes - str <- B.packCStringLen (ptr, len) - return (str, sockaddr) - --- ---------------------------------------------------------------------------- --- 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. -remainingChunks :: Int -> [ByteString] -> [ByteString] -remainingChunks _ [] = [] -remainingChunks i (x:xs) - | i < len = B.drop i x : xs - | otherwise = let i' = i - len in i' `seq` remainingChunks i' xs - where - len = B.length x - --- | @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 :: [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) -#endif diff --git a/Network/Socket/ByteString/IO.hsc b/Network/Socket/ByteString/IO.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/IO.hsc @@ -0,0 +1,271 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "HsNet.h" + +-- | +-- Module : Network.Socket.ByteString +-- Copyright : (c) Johan Tibell 2007-2010 +-- License : BSD-style +-- +-- Maintainer : johan.tibell@gmail.com +-- 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 + send + , sendAll + , sendTo + , sendAllTo + + -- ** Vectored I/O + -- $vectored + , sendMany + , sendManyTo + + -- * Receive data from a socket + , recv + , recvFrom + , waitWhen0 + ) where + +import Control.Concurrent (threadWaitWrite, rtsSupportsBoundThreads) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +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 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(..)) +#endif + +-- ---------------------------------------------------------------------------- +-- Sending + +-- | Send data to the socket. The socket must be connected to a +-- remote socket. Returns the number of bytes sent. Applications are +-- responsible for ensuring that all data has been sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +send :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO Int -- ^ Number of bytes sent +send s xs = unsafeUseAsCStringLen xs $ \(str, len) -> + sendBuf s (castPtr str) len + +waitWhen0 :: Int -> Socket -> IO () +waitWhen0 0 s = when rtsSupportsBoundThreads $ do + fd <- fromIntegral <$> fdSocket s + threadWaitWrite fd +waitWhen0 _ _ = return () + +-- | Send data to the socket. The socket must be connected to a +-- remote socket. Unlike 'send', this function continues to send data +-- until either all data has been sent or an error occurs. On error, +-- an exception is raised, and there is no way to determine how much +-- data, if any, was successfully sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +sendAll :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO () +sendAll _ "" = return () +sendAll s bs = do + sent <- send s bs + waitWhen0 sent s + when (sent >= 0) $ sendAll s $ B.drop sent bs + +-- | 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 +-- ensuring that all data has been sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +sendTo :: SocketAddress sa => + Socket -- ^ Socket + -> ByteString -- ^ Data to send + -> sa -- ^ Recipient address + -> IO Int -- ^ Number of bytes sent +sendTo s xs sa = + unsafeUseAsCStringLen xs $ \(str, len) -> sendBufTo s str len sa + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. Unlike +-- 'sendTo', this function continues to send data until either all +-- data has been sent or an error occurs. On error, an exception is +-- raised, and there is no way to determine how much data, if any, was +-- successfully sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +sendAllTo :: SocketAddress sa => + Socket -- ^ Socket + -> ByteString -- ^ Data to send + -> sa -- ^ Recipient address + -> IO () +sendAllTo _ "" _ = return () +sendAllTo s xs sa = do + sent <- sendTo s xs sa + waitWhen0 sent s + when (sent >= 0) $ sendAllTo s (B.drop sent xs) sa + +-- | Send data to the socket. The socket must be in a connected +-- state. The data is sent as if the parts have been concatenated. +-- This function continues to send data until either all data has been +-- sent or an error occurs. On error, an exception is raised, and +-- there is no way to determine how much data, if any, was +-- successfully sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +sendMany :: Socket -- ^ Connected socket + -> [ByteString] -- ^ Data to send + -> IO () +#if !defined(mingw32_HOST_OS) +sendMany _ [] = return () +sendMany s cs = do + sent <- sendManyInner + waitWhen0 sent s + when (sent >= 0) $ sendMany s $ remainingChunks sent cs + where + sendManyInner = + fmap fromIntegral . withIOVec cs $ \(iovsPtr, iovsLen) -> do + fd <- fdSocket s + 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 +#endif + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. The +-- data is sent as if the parts have been concatenated. This function +-- continues to send data until either all data has been sent or an +-- error occurs. On error, an exception is raised, and there is no +-- way to determine how much data, if any, was successfully sent. +-- +-- Sending data to closed socket may lead to undefined behaviour. +sendManyTo :: Socket -- ^ Socket + -> [ByteString] -- ^ Data to send + -> SockAddr -- ^ Recipient address + -> IO () +#if !defined(mingw32_HOST_OS) +sendManyTo _ [] _ = return () +sendManyTo s cs addr = do + sent <- fromIntegral <$> sendManyToInner + waitWhen0 sent s + when (sent >= 0) $ sendManyTo s (remainingChunks sent cs) addr + where + sendManyToInner = + withSockAddr addr $ \addrPtr addrSize -> + withIOVec cs $ \(iovsPtr, iovsLen) -> do + let msgHdr = MsgHdr + addrPtr (fromIntegral addrSize) + iovsPtr (fromIntegral iovsLen) + fd <- fdSocket s + with msgHdr $ \msgHdrPtr -> + throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $ + c_sendmsg fd msgHdrPtr 0 +#else +sendManyTo s cs = sendAllTo s (B.concat cs) +#endif + +-- ---------------------------------------------------------------------------- +-- Receiving + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If +-- the message is longer than the specified length, it may be +-- discarded depending on the type of socket. This function may block +-- until a message arrives. +-- +-- Considering hardware and network realities, the maximum number of bytes to +-- receive should be a small power of 2, e.g., 4096. +-- +-- For TCP sockets, a zero length return value means the peer has +-- closed its half side of the connection. +-- +-- Receiving data from closed socket may lead to undefined behaviour. +recv :: Socket -- ^ Connected socket + -> Int -- ^ Maximum number of bytes to receive + -> IO ByteString -- ^ Data received +recv s nbytes + | nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv") + | otherwise = createAndTrim nbytes $ \ptr -> recvBuf s ptr nbytes + +-- | Receive data from the socket. The socket need not be in a +-- connected state. Returns @(bytes, address)@ where @bytes@ is a +-- 'ByteString' representing the data received and @address@ is a +-- 'SockAddr' representing the address of the sending socket. +-- +-- If the first return value is zero, it means EOF. +-- +-- Receiving data from closed socket may lead to undefined behaviour. +recvFrom :: SocketAddress sa => + Socket -- ^ Socket + -> Int -- ^ Maximum number of bytes to receive + -> IO (ByteString, sa) -- ^ Data received and sender address +recvFrom sock nbytes = + allocaBytes nbytes $ \ptr -> do + (len, sockaddr) <- recvBufFrom sock ptr nbytes + str <- B.packCStringLen (ptr, len) + return (str, sockaddr) + +-- ---------------------------------------------------------------------------- +-- 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. +remainingChunks :: Int -> [ByteString] -> [ByteString] +remainingChunks _ [] = [] +remainingChunks i (x:xs) + | i < len = B.drop i x : xs + | otherwise = let i' = i - len in i' `seq` remainingChunks i' xs + where + len = B.length x + +-- | @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 :: [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) +#endif diff --git a/Network/Socket/ByteString/IOVec.hsc b/Network/Socket/ByteString/IOVec.hsc --- a/Network/Socket/ByteString/IOVec.hsc +++ b/Network/Socket/ByteString/IOVec.hsc @@ -5,9 +5,7 @@ ( IOVec(..) ) where -import Foreign.C.Types (CChar, CInt, CSize) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable(..)) +import Network.Socket.Imports #include #include 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} -- | -- Module : Network.Socket.ByteString.Internal @@ -16,25 +16,19 @@ , c_writev , c_sendmsg #endif - , waitWhen0 ) where +import GHC.IO.Exception (IOErrorType(..)) import System.IO.Error (ioeSetErrorString, mkIOError) #if !defined(mingw32_HOST_OS) -import Foreign.C.Types (CInt(..)) import System.Posix.Types (CSsize(..)) -import Foreign.Ptr (Ptr) +import Network.Socket.Imports import Network.Socket.ByteString.IOVec (IOVec) import Network.Socket.ByteString.MsgHdr (MsgHdr) #endif -import Control.Concurrent (threadWaitWrite, rtsSupportsBoundThreads) -import Control.Monad (when) -import GHC.IO.Exception (IOErrorType(..)) -import Network.Socket.Types - mkInvalidRecvArgError :: String -> IOError mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError InvalidArgument @@ -47,9 +41,3 @@ foreign import ccall unsafe "sendmsg" c_sendmsg :: CInt -> Ptr MsgHdr -> CInt -> IO CSsize #endif - -waitWhen0 :: Int -> Socket -> IO () -waitWhen0 0 s = when rtsSupportsBoundThreads $ do - let fd = fromIntegral $ fdSocket s - threadWaitWrite fd -waitWhen0 _ _ = return () 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 @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} - -- | -- Module : Network.Socket.ByteString.Lazy -- Copyright : (c) Bryan O'Sullivan 2009 @@ -17,42 +16,37 @@ -- -- This module is made to be imported with 'Network.Socket' like so: -- --- > import Network.Socket hiding (send, sendTo, recv, recvFrom) +-- > import Network.Socket -- > import Network.Socket.ByteString.Lazy -- > import Prelude hiding (getContents) -- -module Network.Socket.ByteString.Lazy - ( +module Network.Socket.ByteString.Lazy ( -- * Send data to a socket - send - , sendAll - , - + send + , sendAll -- * Receive data from a socket - getContents - , recv - ) where - -import Control.Monad (liftM) -import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) -import Data.Int (Int64) -import Network.Socket (Socket(..), ShutdownCmd(..), shutdown) -import Prelude hiding (getContents) -import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO.Error (catchIOError) + , getContents + , recv + ) where -import qualified Data.ByteString as S -import qualified Network.Socket.ByteString as N +import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) +import Network.Socket (ShutdownCmd (..), shutdown) +import Prelude hiding (getContents) +import System.IO.Unsafe (unsafeInterleaveIO) #if defined(mingw32_HOST_OS) -import Network.Socket.ByteString.Lazy.Windows (send, sendAll) +import Network.Socket.ByteString.Lazy.Windows (send, sendAll) #else -import Network.Socket.ByteString.Lazy.Posix (send, sendAll) +import Network.Socket.ByteString.Lazy.Posix (send, sendAll) #endif +import qualified Data.ByteString as S +import qualified Network.Socket.ByteString as N +import Network.Socket.Imports +import Network.Socket.Types + -- ----------------------------------------------------------------------------- -- Receiving - -- | Receive data from the socket. The socket must be in a connected -- state. Data is received on demand, in chunks; each chunk will be -- sized to reflect the amount of data received by individual 'recv' @@ -62,16 +56,16 @@ -- more data to be received, the receiving side of the socket is shut -- down. If there is an error and an exception is thrown, the socket -- is not shut down. -getContents :: Socket -- ^ Connected socket - -> IO ByteString -- ^ Data received -getContents sock = loop where - loop = unsafeInterleaveIO $ do - s <- N.recv sock defaultChunkSize - if S.null s - then do - shutdown sock ShutdownReceive `catchIOError` const (return ()) - return Empty - else Chunk s `liftM` loop +getContents + :: Socket -- ^ Connected socket + -> IO ByteString -- ^ Data received +getContents s = loop + where + loop = unsafeInterleaveIO $ do + sbs <- N.recv s defaultChunkSize + if S.null sbs + then shutdown s ShutdownReceive >> return Empty + else Chunk sbs <$> loop -- | Receive data from the socket. The socket must be in a connected -- state. This function may return fewer bytes than specified. If @@ -82,10 +76,11 @@ -- If there is no more data to be received, returns an empty 'ByteString'. -- -- Receiving data from closed socket may lead to undefined behaviour. -recv :: Socket -- ^ Connected socket - -> Int64 -- ^ Maximum number of bytes to receive - -> IO ByteString -- ^ Data received -recv sock nbytes = chunk `liftM` N.recv sock (fromIntegral nbytes) where - chunk k - | S.null k = Empty - | otherwise = Chunk k Empty +recv + :: Socket -- ^ Connected socket + -> Int64 -- ^ Maximum number of bytes to receive + -> IO ByteString -- ^ Data received +recv s nbytes = chunk <$> N.recv s (fromIntegral nbytes) + where + chunk k | S.null k = Empty + | otherwise = Chunk k Empty 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 @@ -1,59 +1,58 @@ -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Socket.ByteString.Lazy.Posix - ( +module Network.Socket.ByteString.Lazy.Posix ( -- * Send data to a socket - send - , sendAll - ) where + send + , sendAll + ) where -import Control.Monad (liftM, when) -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Internal (ByteString(..)) -import Data.ByteString.Unsafe (unsafeUseAsCStringLen) -import Data.Int (Int64) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (plusPtr) -import Foreign.Storable (Storable(..)) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Foreign.Marshal.Array (allocaArray) -import Network.Socket (Socket(..)) -import Network.Socket.ByteString.IOVec (IOVec(IOVec)) -import Network.Socket.ByteString.Internal (c_writev, waitWhen0) -import Network.Socket.Internal +import Network.Socket.ByteString.Internal (c_writev) +import Network.Socket.ByteString.IO (waitWhen0) +import Network.Socket.ByteString.IOVec (IOVec (IOVec)) +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Types -- ----------------------------------------------------------------------------- -- Sending - -send :: Socket -- ^ Connected socket - -> ByteString -- ^ Data to send - -> IO Int64 -- ^ Number of bytes sent -send sock@(MkSocket fd _ _ _ _) s = do - let cs = take maxNumChunks (L.toChunks s) - len = length cs - liftM fromIntegral . allocaArray len $ \ptr -> - withPokes cs ptr $ \niovs -> - throwSocketErrorWaitWrite sock "writev" $ - c_writev (fromIntegral fd) ptr niovs +send + :: Socket -- ^ Connected socket + -> L.ByteString -- ^ Data to send + -> IO Int64 -- ^ Number of bytes sent +send s lbs = do + let cs = take maxNumChunks (L.toChunks lbs) + len = length cs + fd <- fdSocket s + siz <- allocaArray len $ \ptr -> + withPokes cs ptr $ \niovs -> + throwSocketErrorWaitWrite s "writev" $ c_writev fd ptr niovs + return $ fromIntegral siz where withPokes ss p f = loop ss p 0 0 - where loop (c:cs) q k !niovs - | k < maxNumBytes = - unsafeUseAsCStringLen c $ \(ptr,len) -> do - poke q $ IOVec ptr (fromIntegral len) - loop cs (q `plusPtr` sizeOf (undefined :: IOVec)) - (k + fromIntegral len) (niovs + 1) - | otherwise = f niovs - loop _ _ _ niovs = f niovs - maxNumBytes = 4194304 :: Int -- maximum number of bytes to transmit in one system call - maxNumChunks = 1024 :: Int -- maximum number of chunks to transmit in one system call + where + loop (c:cs) q k !niovs + | k < maxNumBytes = unsafeUseAsCStringLen c $ \(ptr, len) -> do + poke q $ IOVec ptr (fromIntegral len) + loop cs + (q `plusPtr` sizeOf (undefined :: IOVec)) + (k + fromIntegral len) + (niovs + 1) + | otherwise = f niovs + loop _ _ _ niovs = f niovs + maxNumBytes = 4194304 :: Int -- maximum number of bytes to transmit in one system call + maxNumChunks = 1024 :: Int -- maximum number of chunks to transmit in one system call -sendAll :: Socket -- ^ Connected socket - -> ByteString -- ^ Data to send - -> IO () -sendAll _ "" = return () -sendAll sock bs = do - sent <- send sock bs - waitWhen0 (fromIntegral sent) sock - when (sent >= 0) $ sendAll sock $ L.drop sent bs +sendAll + :: Socket -- ^ Connected socket + -> L.ByteString -- ^ Data to send + -> IO () +sendAll _ "" = return () +sendAll s bs = do + sent <- send s bs + waitWhen0 (fromIntegral sent) s + when (sent >= 0) $ sendAll s $ L.drop sent bs diff --git a/Network/Socket/ByteString/Lazy/Windows.hs b/Network/Socket/ByteString/Lazy/Windows.hs --- a/Network/Socket/ByteString/Lazy/Windows.hs +++ b/Network/Socket/ByteString/Lazy/Windows.hs @@ -1,40 +1,35 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Socket.ByteString.Lazy.Windows - ( +module Network.Socket.ByteString.Lazy.Windows ( -- * Send data to a socket - send - , sendAll - ) where - -import Control.Applicative ((<$>)) -import Control.Monad (when) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Int (Int64) + send + , sendAll + ) where -import Network.Socket (Socket(..)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L import qualified Network.Socket.ByteString as Socket -import Network.Socket.ByteString.Internal (waitWhen0) +import Network.Socket.Imports +import Network.Socket.ByteString.IO (waitWhen0) +import Network.Socket.Types -- ----------------------------------------------------------------------------- -- Sending - -send :: Socket -- ^ Connected socket - -> L.ByteString -- ^ Data to send - -> IO Int64 -- ^ Number of bytes sent -send sock s = do - fromIntegral <$> case L.toChunks s of - -- TODO: Consider doing nothing if the string is empty. - [] -> Socket.send sock S.empty - (x:_) -> Socket.send sock x +send + :: Socket -- ^ Connected socket + -> L.ByteString -- ^ Data to send + -> IO Int64 -- ^ Number of bytes sent +send s lbs = case L.toChunks lbs of + -- TODO: Consider doing nothing if the string is empty. + [] -> fromIntegral <$> Socket.send s S.empty + (x:_) -> fromIntegral <$> Socket.send s x -sendAll :: Socket -- ^ Connected socket - -> L.ByteString -- ^ Data to send - -> IO () -sendAll _ "" = return () -sendAll sock bs = do - sent <- send sock bs - waitWhen0 (fromIntegral sent) sock - when (sent >= 0) $ sendAll sock $ L.drop sent bs +sendAll + :: Socket -- ^ Connected socket + -> L.ByteString -- ^ Data to send + -> IO () +sendAll _ "" = return () +sendAll s bs = do + sent <- send s bs + waitWhen0 (fromIntegral sent) s + when (sent >= 0) $ sendAll s $ L.drop sent bs diff --git a/Network/Socket/ByteString/MsgHdr.hsc b/Network/Socket/ByteString/MsgHdr.hsc --- a/Network/Socket/ByteString/MsgHdr.hsc +++ b/Network/Socket/ByteString/MsgHdr.hsc @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- | Support module for the POSIX 'sendmsg' system call. @@ -9,11 +8,9 @@ #include #include -import Foreign.C.Types (CInt, CSize, CUInt) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable(..)) -import Network.Socket (SockAddr) +import Network.Socket.Imports import Network.Socket.Internal (zeroMemory) +import Network.Socket.Types (SockAddr) import Network.Socket.ByteString.IOVec (IOVec) diff --git a/Network/Socket/Cbits.hsc b/Network/Socket/Cbits.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Cbits.hsc @@ -0,0 +1,31 @@ +module Network.Socket.Cbits where + +#include "HsNet.h" + +import Network.Socket.Imports + +-- | This is the value of SOMAXCONN, typically 128. +-- 128 is good enough for normal network servers but +-- is too small for high performance servers. +maxListenQueue :: Int +maxListenQueue = #const SOMAXCONN + +#if defined(mingw32_HOST_OS) +wsaNotInitialized :: CInt +wsaNotInitialized = #const WSANOTINITIALISED +#else +fGetFd :: CInt +fGetFd = #const F_GETFD +fGetFl :: CInt +fGetFl = #const F_GETFL +fdCloexec :: CInt +fdCloexec = #const FD_CLOEXEC +oNonBlock :: CInt +oNonBlock = #const O_NONBLOCK +# if defined(HAVE_ADVANCED_SOCKET_FLAGS) +sockNonBlock :: CInt +sockNonBlock = #const SOCK_NONBLOCK +sockCloexec :: CInt +sockCloexec = #const SOCK_CLOEXEC +# endif +#endif diff --git a/Network/Socket/Fcntl.hs b/Network/Socket/Fcntl.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Fcntl.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} + +module Network.Socket.Fcntl where + +import qualified System.Posix.Internals + +#if !defined(mingw32_HOST_OS) +import Network.Socket.Cbits +#endif +import Network.Socket.Imports + +-- | Set the nonblocking flag on Unix. +-- On Windows, nothing is done. +setNonBlockIfNeeded :: CInt -> IO () +setNonBlockIfNeeded fd = + System.Posix.Internals.setNonBlockingFD fd True + +-- | Set the nonblocking flag on Unix. +-- On Windows, nothing is done. +-- +-- Since 2.7.0.0. +setCloseOnExecIfNeeded :: CInt -> IO () +#if defined(mingw32_HOST_OS) +setCloseOnExecIfNeeded _ = return () +#else +setCloseOnExecIfNeeded fd = System.Posix.Internals.setCloseOnExec fd +#endif + +#if !defined(mingw32_HOST_OS) +foreign import ccall unsafe "fcntl" + c_fcntl_read :: CInt -> CInt -> CInt -> IO CInt +#endif + +-- | Get the close_on_exec flag. +-- On Windows, this function always returns 'False'. +-- +-- Since 2.7.0.0. +getCloseOnExec :: CInt -> IO Bool +#if defined(mingw32_HOST_OS) +getCloseOnExec _ = return False +#else +getCloseOnExec fd = do + flags <- c_fcntl_read fd fGetFd 0 + let ret = flags .&. fdCloexec + return (ret /= 0) +#endif + +-- | Get the close_on_exec flag. +-- On Windows, this function always returns 'False'. +-- +-- Since 2.7.0.0. +getNonBlock :: CInt -> IO Bool +#if defined(mingw32_HOST_OS) +getNonBlock _ = return False +#else +getNonBlock fd = do + flags <- c_fcntl_read fd fGetFl 0 + let ret = flags .&. oNonBlock + return (ret /= 0) +#endif diff --git a/Network/Socket/Handle.hs b/Network/Socket/Handle.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Handle.hs @@ -0,0 +1,24 @@ +module Network.Socket.Handle where + +import qualified GHC.IO.Device (IODeviceType(Stream)) +import GHC.IO.Handle.FD (fdToHandle') +import System.IO (IOMode(..), Handle, BufferMode(..), hSetBuffering) + +import Network.Socket.Types + +-- | Turns a Socket into an 'Handle'. By default, the new handle is +-- unbuffered. Use 'System.IO.hSetBuffering' to change the buffering. +-- +-- Note that since a 'Handle' is automatically closed by a finalizer +-- when it is no longer referenced, you should avoid doing any more +-- operations on the 'Socket' after calling 'socketToHandle'. To +-- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose' +-- on the 'Handle'. + +socketToHandle :: Socket -> IOMode -> IO Handle +socketToHandle s mode = invalidateSocket s err $ \oldfd -> do + h <- fdToHandle' oldfd (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-} + hSetBuffering h NoBuffering + return h + where + err _ = ioError $ userError $ "socketToHandle: socket is no longer valid" diff --git a/Network/Socket/If.hs b/Network/Socket/If.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/If.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} + +#include "HsNetDef.h" + +module Network.Socket.If ( + ifNameToIndex + , ifIndexToName + ) where + +import Foreign.Marshal.Alloc (allocaBytes) + +import Network.Socket.Imports + +-- | Returns the index corresponding to the interface name. +-- +-- Since 2.7.0.0. +ifNameToIndex :: String -> IO (Maybe Int) +ifNameToIndex ifname = do + index <- withCString ifname c_if_nametoindex + -- On failure zero is returned. We'll return Nothing. + return $ if index == 0 then Nothing else Just $ fromIntegral index + +-- | Returns the interface name corresponding to the index. +-- +-- Since 2.7.0.0. +ifIndexToName :: Int -> IO (Maybe String) +ifIndexToName ifn = allocaBytes 16 $ \ptr -> do -- 16 == IFNAMSIZ + r <- c_if_indextoname (fromIntegral ifn) ptr + if r == nullPtr then + return Nothing + else + Just <$> peekCString ptr + +foreign import CALLCONV safe "if_nametoindex" + c_if_nametoindex :: CString -> IO CUInt + +foreign import CALLCONV safe "if_indextoname" + c_if_indextoname :: CUInt -> CString -> IO CString diff --git a/Network/Socket/Imports.hs b/Network/Socket/Imports.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Imports.hs @@ -0,0 +1,33 @@ +module Network.Socket.Imports ( + module Control.Applicative + , module Control.Monad + , module Data.Bits + , module Data.Int + , module Data.List + , module Data.Maybe + , module Data.Monoid + , module Data.Ord + , module Data.Typeable + , module Data.Word + , module Foreign.C.String + , module Foreign.C.Types + , module Foreign.Ptr + , module Foreign.Storable + , module Numeric + ) where + +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.Int +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Typeable +import Data.Word +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable +import Numeric diff --git a/Network/Socket/Info.hsc b/Network/Socket/Info.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Info.hsc @@ -0,0 +1,452 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#include "HsNet.h" +##include "HsNetDef.h" + +module Network.Socket.Info where + +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.Types + +----------------------------------------------------------------------------- + +-- | Either a host name e.g., @\"haskell.org\"@ or a numeric host +-- address string consisting of a dotted decimal IPv4 address or an +-- IPv6 address e.g., @\"192.168.0.1\"@. +type HostName = String +-- | Either a service name e.g., @\"http\"@ or a numeric port number. +type ServiceName = String + +----------------------------------------------------------------------------- +-- Address and service lookups + +-- | Flags that control the querying behaviour of 'getAddrInfo'. +-- For more information, see +data AddrInfoFlag = + -- | The list of returned 'AddrInfo' values will + -- only contain IPv4 addresses if the local system has at least + -- one IPv4 interface configured, and likewise for IPv6. + -- (Only some platforms support this.) + AI_ADDRCONFIG + -- | If 'AI_ALL' is specified, return all matching IPv6 and + -- IPv4 addresses. Otherwise, this flag has no effect. + -- (Only some platforms support this.) + | AI_ALL + -- | The 'addrCanonName' field of the first returned + -- 'AddrInfo' will contain the "canonical name" of the host. + | AI_CANONNAME + -- | The 'HostName' argument /must/ be a numeric + -- address in string form, and network name lookups will not be + -- attempted. + | AI_NUMERICHOST + -- | The 'ServiceName' argument /must/ be a port + -- number in string form, and service name lookups will not be + -- attempted. (Only some platforms support this.) + | AI_NUMERICSERV + -- | If no 'HostName' value is provided, the network + -- address in each 'SockAddr' + -- will be left as a "wild card". + -- This is useful for server applications that + -- will accept connections from any client. + | AI_PASSIVE + -- | If an IPv6 lookup is performed, and no IPv6 + -- addresses are found, IPv6-mapped IPv4 addresses will be + -- returned. (Only some platforms support this.) + | AI_V4MAPPED + deriving (Eq, Read, Show, Typeable) + +aiFlagMapping :: [(AddrInfoFlag, CInt)] + +aiFlagMapping = + [ +#if HAVE_DECL_AI_ADDRCONFIG + (AI_ADDRCONFIG, #const AI_ADDRCONFIG), +#else + (AI_ADDRCONFIG, 0), +#endif +#if HAVE_DECL_AI_ALL + (AI_ALL, #const AI_ALL), +#else + (AI_ALL, 0), +#endif + (AI_CANONNAME, #const AI_CANONNAME), + (AI_NUMERICHOST, #const AI_NUMERICHOST), +#if HAVE_DECL_AI_NUMERICSERV + (AI_NUMERICSERV, #const AI_NUMERICSERV), +#else + (AI_NUMERICSERV, 0), +#endif + (AI_PASSIVE, #const AI_PASSIVE), +#if HAVE_DECL_AI_V4MAPPED + (AI_V4MAPPED, #const AI_V4MAPPED) +#else + (AI_V4MAPPED, 0) +#endif + ] + +-- | Indicate whether the given 'AddrInfoFlag' will have any effect on +-- this system. +addrInfoFlagImplemented :: AddrInfoFlag -> Bool +addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0 + +data AddrInfo = AddrInfo { + addrFlags :: [AddrInfoFlag] + , addrFamily :: Family + , addrSocketType :: SocketType + , addrProtocol :: ProtocolNumber + , addrAddress :: SockAddr + , addrCanonName :: Maybe String + } deriving (Eq, Show, Typeable) + +instance Storable AddrInfo where + sizeOf _ = #const sizeof(struct addrinfo) + alignment _ = alignment (undefined :: CInt) + + peek p = do + ai_flags <- (#peek struct addrinfo, ai_flags) p + ai_family <- (#peek struct addrinfo, ai_family) p + ai_socktype <- (#peek struct addrinfo, ai_socktype) p + ai_protocol <- (#peek struct addrinfo, ai_protocol) p + ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr + ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p + + ai_canonname <- if ai_canonname_ptr == nullPtr + 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 + , addrProtocol = ai_protocol + , addrAddress = ai_addr + , addrCanonName = ai_canonname + } + + poke p (AddrInfo flags family sockType protocol _ _) = do + c_stype <- packSocketTypeOrThrow "AddrInfo.poke" sockType + + (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags) + (#poke struct addrinfo, ai_family) p (packFamily family) + (#poke struct addrinfo, ai_socktype) p c_stype + (#poke struct addrinfo, ai_protocol) p protocol + + -- stuff below is probably not needed, but let's zero it for safety + + (#poke struct addrinfo, ai_addrlen) p (0::CSize) + (#poke struct addrinfo, ai_addr) p nullPtr + (#poke struct addrinfo, ai_canonname) p nullPtr + (#poke struct addrinfo, ai_next) p nullPtr + +-- | Flags that control the querying behaviour of 'getNameInfo'. +-- For more information, see +data NameInfoFlag = + -- | Resolve a datagram-based service name. This is + -- required only for the few protocols that have different port + -- numbers for their datagram-based versions than for their + -- stream-based versions. + NI_DGRAM + -- | If the hostname cannot be looked up, an IO error is thrown. + | NI_NAMEREQD + -- | If a host is local, return only the hostname part of the FQDN. + | NI_NOFQDN + -- | The name of the host is not looked up. + -- Instead, a numeric representation of the host's + -- address is returned. For an IPv4 address, this will be a + -- dotted-quad string. For IPv6, it will be colon-separated + -- hexadecimal. + | NI_NUMERICHOST + -- | The name of the service is not + -- looked up. Instead, a numeric representation of the + -- service is returned. + | NI_NUMERICSERV + deriving (Eq, Read, Show, Typeable) + +niFlagMapping :: [(NameInfoFlag, CInt)] + +niFlagMapping = [(NI_DGRAM, #const NI_DGRAM), + (NI_NAMEREQD, #const NI_NAMEREQD), + (NI_NOFQDN, #const NI_NOFQDN), + (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'. +-- +-- >>> addrFlags defaultHints +-- [] +-- >>> addrFamily defaultHints +-- AF_UNSPEC +-- >>> addrSocketType defaultHints +-- NoSocketType +-- >>> addrProtocol defaultHints +-- 0 + +defaultHints :: AddrInfo +defaultHints = AddrInfo { + addrFlags = [] + , addrFamily = AF_UNSPEC + , addrSocketType = NoSocketType + , addrProtocol = defaultProtocol + , addrAddress = undefined + , addrCanonName = undefined + } + +-- | 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' +-- values that you can pass directly to 'connect' or +-- 'bind'. +-- +-- This function is protocol independent. It can return both IPv4 and +-- IPv6 address information. +-- +-- The 'AddrInfo' argument specifies the preferred query behaviour, +-- socket options, or protocol. You can override these conveniently +-- using Haskell's record update syntax on 'defaultHints', for example +-- as follows: +-- +-- >>> let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Stream } +-- +-- You must provide a 'Just' value for at least one of the 'HostName' +-- or 'ServiceName' arguments. 'HostName' can be either a numeric +-- network address (dotted quad for IPv4, colon-separated hex for +-- IPv6) or a hostname. In the latter case, its addresses will be +-- looked up unless 'AI_NUMERICHOST' is specified as a hint. If you +-- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as +-- a hint, network addresses in the result will contain the address of +-- the loopback interface. +-- +-- If the query fails, this function throws an IO exception instead of +-- returning an empty list. Otherwise, it returns a non-empty list +-- of 'AddrInfo' values. +-- +-- There are several reasons why a query might result in several +-- values. For example, the queried-for host could be multihomed, or +-- the service might be available via several protocols. +-- +-- Note: the order of arguments is slightly different to that defined +-- for @getaddrinfo@ in RFC 2553. The 'AddrInfo' parameter comes first +-- to make partial application easier. +-- +-- >>> addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just "http") +-- >>> addrAddress addr +-- 127.0.0.1:80 + +getAddrInfo + :: Maybe AddrInfo -- ^ preferred socket type or protocol + -> Maybe HostName -- ^ host name to look up + -> Maybe ServiceName -- ^ service name to look up + -> IO [AddrInfo] -- ^ resolved addresses, with "best" first +getAddrInfo hints node service = alloc getaddrinfo + where + alloc body = withSocketsDo $ maybeWith withCString node $ \c_node -> + maybeWith withCString service $ \c_service -> + maybeWith with filteredHints $ \c_hints -> + alloca $ \ptr_ptr_addrs -> + body c_node c_service c_hints ptr_ptr_addrs + getaddrinfo c_node c_service c_hints ptr_ptr_addrs = do + ret <- c_getaddrinfo c_node c_service c_hints ptr_ptr_addrs + if ret == 0 then do + ptr_addrs <- peek ptr_ptr_addrs + ais <- followAddrInfo ptr_addrs + c_freeaddrinfo ptr_addrs + return ais + else do + err <- gai_strerror ret + ioError $ ioeSetErrorString + (mkIOError NoSuchThing message Nothing Nothing) + err + message = concat [ + "Network.Socket.getAddrInfo (called with preferred socket type/protocol: " + , maybe (show hints) showDefaultHints hints + , ", host name: " + , show node + , ", service name: " + , show service + , ")" + ] +#if defined(darwin_HOST_OS) + -- Leaving out the service and using AI_NUMERICSERV causes a + -- segfault on OS X 10.8.2. This code removes AI_NUMERICSERV + -- (which has no effect) in that case. + toHints h = h { addrFlags = delete AI_NUMERICSERV (addrFlags h) } + filteredHints = case service of + Nothing -> toHints <$> hints + _ -> hints +#else + filteredHints = hints +#endif + +followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo] +followAddrInfo ptr_ai + | ptr_ai == nullPtr = return [] + | otherwise = do + a <- peek ptr_ai + as <- (# peek struct addrinfo, ai_next) ptr_ai >>= followAddrInfo + return (a : as) + +foreign import ccall safe "hsnet_getaddrinfo" + c_getaddrinfo :: CString -> CString -> Ptr AddrInfo -> Ptr (Ptr AddrInfo) + -> IO CInt + +foreign import ccall safe "hsnet_freeaddrinfo" + c_freeaddrinfo :: Ptr AddrInfo -> IO () + +gai_strerror :: CInt -> IO String + +#ifdef HAVE_GAI_STRERROR +gai_strerror n = c_gai_strerror n >>= peekCString + +foreign import ccall safe "gai_strerror" + c_gai_strerror :: CInt -> IO CString +#else +gai_strerror n = ioError $ userError $ "Network.Socket.gai_strerror not supported: " ++ show n +#endif + +----------------------------------------------------------------------------- + +withCStringIf :: Bool -> Int -> (CSize -> CString -> IO a) -> IO a +withCStringIf False _ f = f 0 nullPtr +withCStringIf True n f = allocaBytes n (f (fromIntegral n)) + +-- | Resolve an address to a host or service name. +-- This function is protocol independent. +-- The list of 'NameInfoFlag' values controls query behaviour. +-- +-- If a host or service's name cannot be looked up, then the numeric +-- form of the address or service will be returned. +-- +-- If the query fails, this function throws an IO exception. +-- +-- >>> addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "http") +-- >>> getNameInfo [NI_NUMERICHOST, NI_NUMERICSERV] True True $ addrAddress addr +-- (Just "127.0.0.1",Just "80") +{- +-- >>> getNameInfo [] True True $ addrAddress addr +-- (Just "localhost",Just "http") +-} +getNameInfo + :: [NameInfoFlag] -- ^ flags to control lookup behaviour + -> Bool -- ^ whether to look up a hostname + -> Bool -- ^ whether to look up a service name + -> SockAddr -- ^ the address to look up + -> IO (Maybe HostName, Maybe ServiceName) +getNameInfo flags doHost doService addr = alloc getnameinfo + where + alloc body = withSocketsDo $ + withCStringIf doHost (# const NI_MAXHOST) $ \c_hostlen c_host -> + withCStringIf doService (# const NI_MAXSERV) $ \c_servlen c_serv -> + withSockAddr addr $ \ptr_addr sz -> + body c_hostlen c_host c_servlen c_serv ptr_addr sz + getnameinfo c_hostlen c_host c_servlen c_serv ptr_addr sz = do + ret <- c_getnameinfo ptr_addr + (fromIntegral sz) + c_host + c_hostlen + c_serv + c_servlen + (packBits niFlagMapping flags) + if ret == 0 then do + let peekIf doIf c_val = + if doIf then Just <$> peekCString c_val else return Nothing + host <- peekIf doHost c_host + serv <- peekIf doService c_serv + return (host, serv) + else do + err <- gai_strerror ret + ioError $ ioeSetErrorString + (mkIOError NoSuchThing message Nothing Nothing) + err + message = concat [ + "Network.Socket.getNameInfo (called with flags: " + , show flags + , ", hostname lookup: " + , show doHost + , ", service name lookup: " + , show doService + , ", socket address: " + , show addr + , ")" + ] + +foreign import ccall safe "hsnet_getnameinfo" + c_getnameinfo :: Ptr SockAddr -> CInt{-CSockLen???-} -> CString -> CSize -> CString + -> CSize -> CInt -> IO CInt + +-- | Pack a list of values into a bitmask. The possible mappings from +-- value to bit-to-set are given as the first argument. We assume +-- that each value can cause exactly one bit to be set; unpackBits will +-- break if this property is not true. + +----------------------------------------------------------------------------- + +packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b +packBits mapping xs = foldl' pack 0 mapping + where + pack acc (k, v) | k `elem` xs = acc .|. v + | otherwise = acc + +-- | Unpack a bitmask into a list of values. +unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a] +-- Be permissive and ignore unknown bit values. At least on OS X, +-- getaddrinfo returns an ai_flags field with bits set that have no +-- entry in . +unpackBits [] _ = [] +unpackBits ((k,v):xs) r + | r .&. v /= 0 = k : unpackBits xs (r .&. complement v) + | otherwise = unpackBits xs r + +----------------------------------------------------------------------------- +-- SockAddr + +instance Show SockAddr where +#if defined(DOMAIN_SOCKET_SUPPORT) + showsPrec _ (SockAddrUnix str) = showString str +#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) + . showString ":" + . shows port + showsPrec _ addr@(SockAddrInet6 port _ _ _) + = showChar '[' + . showString (unsafePerformIO $ + fst <$> getNameInfo [NI_NUMERICHOST] True False addr >>= + maybe (fail "showsPrec: impossible internal error") return) + . showString "]:" + . shows port diff --git a/Network/Socket/Internal.hs b/Network/Socket/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Internal.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#include "HsNetDef.h" + +----------------------------------------------------------------------------- +-- | +-- Module : Network.Socket.Internal +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/network/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- 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. +-- +----------------------------------------------------------------------------- + +module Network.Socket.Internal + ( + -- * Socket error functions + throwSocketError + , throwSocketErrorCode +#if defined(mingw32_HOST_OS) + , c_getLastError +#endif + + -- * Guards for socket operations that may fail + , throwSocketErrorIfMinus1_ + , throwSocketErrorIfMinus1Retry + , throwSocketErrorIfMinus1Retry_ + , throwSocketErrorIfMinus1RetryMayBlock + + -- ** 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 + , throwSocketErrorWaitWrite + + -- * Initialization + , withSocketsDo + + -- * Low-level helpers + , zeroMemory + ) where + +import GHC.Conc (threadWaitRead, threadWaitWrite) + +#if defined(mingw32_HOST_OS) +import Control.Exception (evaluate) +import System.IO.Unsafe (unsafePerformIO) +# if __GLASGOW_HASKELL__ >= 707 +import GHC.IO.Exception (IOErrorType(..)) +# else +import GHC.IOBase (IOErrorType(..)) +# endif +import System.IO.Error (ioeSetErrorString, mkIOError) +#else +import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry, + throwErrnoIfMinus1RetryMayBlock, throwErrnoIfMinus1_, + Errno(..), errnoToIOError) +#endif + +#if defined(mingw32_HOST_OS) +import Network.Socket.Cbits +#endif +import Network.Socket.Imports +import Network.Socket.Types + +-- --------------------------------------------------------------------- +-- Guards for socket operations that may fail + +-- | Throw an 'IOError' corresponding to the current socket error. +throwSocketError :: String -- ^ textual description of the error location + -> IO a + +-- | Like 'throwSocketError', but the error code is supplied as an argument. +-- +-- On Windows, do not use errno. Use a system error code instead. +throwSocketErrorCode :: String -> CInt -> IO a + +-- | Throw an 'IOError' corresponding to the current socket error if +-- the IO action returns a result of @-1@. Discards the result of the +-- IO action after error handling. +throwSocketErrorIfMinus1_ + :: (Eq a, Num a) + => String -- ^ textual description of the location + -> IO a -- ^ the 'IO' operation to be executed + -> IO () + +{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-} + +-- | 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. +throwSocketErrorIfMinus1Retry + :: (Eq a, Num a) + => String -- ^ textual description of the location + -> IO a -- ^ the 'IO' operation to be executed + -> IO a + +{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> 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. Discards the result of the IO action after +-- error handling. +throwSocketErrorIfMinus1Retry_ + :: (Eq a, Num a) + => String -- ^ textual description of the location + -> IO a -- ^ the 'IO' operation to be executed + -> IO () +throwSocketErrorIfMinus1Retry_ loc m = + void $ throwSocketErrorIfMinus1Retry loc m +{-# SPECIALIZE throwSocketErrorIfMinus1Retry_ :: String -> IO CInt -> IO () #-} + +-- | 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. +throwSocketErrorIfMinus1RetryMayBlock + :: (Eq a, Num a) + => 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 + +throwSocketErrorIfMinus1_ name act = do + _ <- throwSocketErrorIfMinus1Retry name act + return () + +throwSocketErrorIfMinus1Retry name act = do + r <- act + if (r == -1) + then do + rc <- c_getLastError + if rc == wsaNotInitialized then do + withSocketsDo (return ()) + r' <- act + if (r' == -1) + then throwSocketError name + else return r' + else + throwSocketError name + else return r + +throwSocketErrorCode name rc = do + pstr <- c_getWSError rc + str <- peekCString pstr + ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str) + +throwSocketError name = + c_getLastError >>= throwSocketErrorCode name + +foreign import CALLCONV unsafe "WSAGetLastError" + c_getLastError :: IO CInt + +foreign import ccall unsafe "getWSErrorDescr" + c_getWSError :: CInt -> IO (Ptr CChar) + +#else + +throwSocketErrorIfMinus1RetryMayBlock name on_block act = + throwErrnoIfMinus1RetryMayBlock name act on_block + +throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry + +throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_ + +throwSocketError = throwErrno + +throwSocketErrorCode loc errno = + ioError (errnoToIOError loc (Errno errno) Nothing Nothing) + +#endif + +-- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with +-- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready, +-- and try again. +throwSocketErrorWaitRead :: (Eq a, Num a) => Socket -> String -> IO a -> IO a +throwSocketErrorWaitRead s name io = do + fd <- fromIntegral <$> fdSocket s + throwSocketErrorIfMinus1RetryMayBlock name (threadWaitRead fd) io + +-- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with +-- @EWOULDBLOCK@ or similar, wait for the socket to be write-ready, +-- and try again. +throwSocketErrorWaitWrite :: (Eq a, Num a) => Socket -> String -> IO a -> IO a +throwSocketErrorWaitWrite s name io = do + fd <- fromIntegral <$> fdSocket s + throwSocketErrorIfMinus1RetryMayBlock name (threadWaitWrite fd) io + +-- --------------------------------------------------------------------------- +-- WinSock support + +{-| With older versions of the @network@ library (version 2.6.0.2 or earlier) +on Windows operating systems, +the networking subsystem must be initialised using 'withSocketsDo' before +any networking operations can be used. eg. + +> main = withSocketsDo $ do {...} + +It is fine to nest calls to 'withSocketsDo', and to perform networking operations +after 'withSocketsDo' has returned. + +'withSocketsDo' is not necessary for the current network library. +However, for compatibility with older versions on Windows, it is good practice +to always call 'withSocketsDo' (it's very cheap). +-} +{-# INLINE withSocketsDo #-} +withSocketsDo :: IO a -> IO a +#if defined(mingw32_HOST_OS) + +withSocketsDo act = evaluate withSocketsInit >> act + +{-# NOINLINE withSocketsInit #-} +withSocketsInit :: () +-- Use a CAF to make forcing it do initialisation once, but subsequent forces will be cheap +withSocketsInit = unsafePerformIO $ do + x <- initWinSock + when (x /= 0) $ ioError $ + userError "Network.Socket.Internal.withSocketsDo: Failed to initialise WinSock" + +foreign import ccall unsafe "initWinSock" initWinSock :: IO Int + +#else + +withSocketsDo x = x + +#endif diff --git a/Network/Socket/Internal.hsc b/Network/Socket/Internal.hsc deleted file mode 100644 --- a/Network/Socket/Internal.hsc +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Network.Socket.Internal --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/network/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- 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. --- ------------------------------------------------------------------------------ - -#include "HsNet.h" -##include "HsNetDef.h" - -module Network.Socket.Internal - ( - -- * Socket addresses - HostAddress -#if defined(IPV6_SOCKET_SUPPORT) - , HostAddress6 - , FlowInfo - , ScopeID -#endif - , PortNumber(..) - , SockAddr(..) - - , peekSockAddr - , pokeSockAddr - , sizeOfSockAddr - , sizeOfSockAddrByFamily - , withSockAddr - , withNewSockAddr - - -- * Protocol families - , Family(..) - - -- * Socket error functions -#if defined(HAVE_WINSOCK2_H) - , c_getLastError -#endif - , throwSocketError - , throwSocketErrorCode - - -- * Guards for socket operations that may fail - , throwSocketErrorIfMinus1_ - , throwSocketErrorIfMinus1Retry - , throwSocketErrorIfMinus1Retry_ - , throwSocketErrorIfMinus1RetryMayBlock - - -- ** 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 - , throwSocketErrorWaitWrite - - -- * Initialization - , withSocketsDo - - -- * Low-level helpers - , zeroMemory - ) where - -import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry, - throwErrnoIfMinus1RetryMayBlock, throwErrnoIfMinus1_, - Errno(..), errnoToIOError) -#if defined(HAVE_WINSOCK2_H) -import Foreign.C.String (peekCString) -import Foreign.Ptr (Ptr) -#endif -import Foreign.C.Types (CInt(..)) -import GHC.Conc (threadWaitRead, threadWaitWrite) - -#if defined(HAVE_WINSOCK2_H) -import Control.Exception ( evaluate ) -import System.IO.Unsafe ( unsafePerformIO ) -import Control.Monad ( when ) -# if __GLASGOW_HASKELL__ >= 707 -import GHC.IO.Exception ( IOErrorType(..) ) -# else -import GHC.IOBase ( IOErrorType(..) ) -# endif -import Foreign.C.Types ( CChar ) -import System.IO.Error ( ioeSetErrorString, mkIOError ) -#endif - -import Network.Socket.Types - --- --------------------------------------------------------------------- --- Guards for socket operations that may fail - --- | Throw an 'IOError' corresponding to the current socket error. -throwSocketError :: String -- ^ textual description of the error location - -> IO a - --- | Like 'throwSocketError', but the error code is supplied as an argument. --- --- On Windows, do not use errno. Use a system error code instead. -throwSocketErrorCode :: String -> CInt -> IO a - --- | Throw an 'IOError' corresponding to the current socket error if --- the IO action returns a result of @-1@. Discards the result of the --- IO action after error handling. -throwSocketErrorIfMinus1_ - :: (Eq a, Num a) - => String -- ^ textual description of the location - -> IO a -- ^ the 'IO' operation to be executed - -> IO () - -{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-} - --- | 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. -throwSocketErrorIfMinus1Retry - :: (Eq a, Num a) - => String -- ^ textual description of the location - -> IO a -- ^ the 'IO' operation to be executed - -> IO a - -{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> 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. Discards the result of the IO action after --- error handling. -throwSocketErrorIfMinus1Retry_ - :: (Eq a, Num a) - => String -- ^ textual description of the location - -> IO a -- ^ the 'IO' operation to be executed - -> IO () -throwSocketErrorIfMinus1Retry_ loc m = - throwSocketErrorIfMinus1Retry loc m >> return () -{-# SPECIALIZE throwSocketErrorIfMinus1Retry_ :: String -> IO CInt -> IO () #-} - --- | 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. -throwSocketErrorIfMinus1RetryMayBlock - :: (Eq a, Num a) - => 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(HAVE_WINSOCK2_H)) - -throwSocketErrorIfMinus1RetryMayBlock name on_block act = - throwErrnoIfMinus1RetryMayBlock name act on_block - -throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry - -throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_ - -throwSocketError = throwErrno - -throwSocketErrorCode loc errno = - ioError (errnoToIOError loc (Errno errno) Nothing Nothing) - -#else - -throwSocketErrorIfMinus1RetryMayBlock name _ act - = throwSocketErrorIfMinus1Retry name act - -throwSocketErrorIfMinus1_ name act = do - throwSocketErrorIfMinus1Retry name act - return () - -# if defined(HAVE_WINSOCK2_H) -throwSocketErrorIfMinus1Retry name act = do - r <- act - if (r == -1) - then do - rc <- c_getLastError - case rc of - #{const WSANOTINITIALISED} -> do - withSocketsDo (return ()) - r <- act - if (r == -1) - then throwSocketError name - else return r - _ -> throwSocketError name - else return r - -throwSocketErrorCode name rc = do - pstr <- c_getWSError rc - str <- peekCString pstr - ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str) - -throwSocketError name = - c_getLastError >>= throwSocketErrorCode name - -foreign import CALLCONV unsafe "WSAGetLastError" - c_getLastError :: IO CInt - -foreign import ccall unsafe "getWSErrorDescr" - c_getWSError :: CInt -> IO (Ptr CChar) - - -# else -throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry -throwSocketError = throwErrno -throwSocketErrorCode loc errno = - ioError (errnoToIOError loc (Errno errno) Nothing Nothing) -# endif -#endif - --- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with --- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready, --- and try again. -throwSocketErrorWaitRead :: (Eq a, Num a) => Socket -> String -> IO a -> IO a -throwSocketErrorWaitRead sock name io = - throwSocketErrorIfMinus1RetryMayBlock name - (threadWaitRead $ fromIntegral $ fdSocket sock) - io - --- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with --- @EWOULDBLOCK@ or similar, wait for the socket to be write-ready, --- and try again. -throwSocketErrorWaitWrite :: (Eq a, Num a) => Socket -> String -> IO a -> IO a -throwSocketErrorWaitWrite sock name io = - throwSocketErrorIfMinus1RetryMayBlock name - (threadWaitWrite $ fromIntegral $ fdSocket sock) - io - --- --------------------------------------------------------------------------- --- WinSock support - -{-| With older versions of the @network@ library (version 2.6.0.2 or earlier) -on Windows operating systems, -the networking subsystem must be initialised using 'withSocketsDo' before -any networking operations can be used. eg. - -> main = withSocketsDo $ do {...} - -It is fine to nest calls to 'withSocketsDo', and to perform networking operations -after 'withSocketsDo' has returned. - -In newer versions of the @network@ library (version v2.6.1.0 or later) -it is only necessary to call -'withSocketsDo' if you are calling the 'MkSocket' constructor directly. -However, for compatibility with older versions on Windows, it is good practice -to always call 'withSocketsDo' (it's very cheap). --} -{-# INLINE withSocketsDo #-} -withSocketsDo :: IO a -> IO a -#if !defined(WITH_WINSOCK) -withSocketsDo x = x -#else -withSocketsDo act = evaluate withSocketsInit >> act - - -{-# NOINLINE withSocketsInit #-} -withSocketsInit :: () --- Use a CAF to make forcing it do initialisation once, but subsequent forces will be cheap -withSocketsInit = unsafePerformIO $ do - x <- initWinSock - when (x /= 0) $ ioError $ - userError "Network.Socket.Internal.withSocketsDo: Failed to initialise WinSock" - -foreign import ccall unsafe "initWinSock" initWinSock :: IO Int - -#endif diff --git a/Network/Socket/Name.hs b/Network/Socket/Name.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Name.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP #-} + +#include "HsNetDef.h" + +module Network.Socket.Name ( + getPeerName + , getSocketName + , socketPort + , socketPortSafe + ) where + +import Foreign.Marshal.Utils (with) + +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Types + +-- | Getting peer's socket address. +getPeerName :: SocketAddress sa => Socket -> IO sa +getPeerName s = + withNewSocketAddress $ \ptr sz -> + with (fromIntegral sz) $ \int_star -> do + fd <- fdSocket s + throwSocketErrorIfMinus1Retry_ "Network.Socket.getPeerName" $ + c_getpeername fd ptr int_star + _sz <- peek int_star + peekSocketAddress ptr + +-- | Getting my socket address. +getSocketName :: SocketAddress sa => Socket -> IO sa +getSocketName s = + withNewSocketAddress $ \ptr sz -> + with (fromIntegral sz) $ \int_star -> do + fd <- fdSocket s + throwSocketErrorIfMinus1Retry_ "Network.Socket.getSocketName" $ + c_getsockname fd ptr int_star + peekSocketAddress ptr + +foreign import CALLCONV unsafe "getpeername" + c_getpeername :: CInt -> Ptr sa -> Ptr CInt -> IO CInt +foreign import CALLCONV unsafe "getsockname" + c_getsockname :: CInt -> Ptr sa -> Ptr CInt -> IO CInt + +-- --------------------------------------------------------------------------- +-- socketPort +-- +-- The port number the given socket is currently connected to can be +-- determined by calling $port$, is generally only useful when bind +-- was given $aNY\_PORT$. + +-- | Getting the port of socket. +-- `IOError` is thrown if a port is not available. +socketPort :: Socket -- Connected & Bound Socket + -> IO PortNumber -- Port Number of Socket +socketPort s = do + sa <- getSocketName s + case sa of + SockAddrInet port _ -> return port + SockAddrInet6 port _ _ _ -> return port + _ -> ioError $ userError "Network.Socket.socketPort: AF_UNIX not supported." + +-- --------------------------------------------------------------------------- +-- socketPortSafe +-- | Getting the port of socket. +socketPortSafe :: Socket -- Connected & Bound Socket + -> IO (Maybe PortNumber) -- Port Number of Socket +socketPortSafe s = do + sa <- getSocketName s + return $ case sa of + SockAddrInet port _ -> Just port + SockAddrInet6 port _ _ _ -> Just port + _ -> Nothing diff --git a/Network/Socket/Options.hsc b/Network/Socket/Options.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Options.hsc @@ -0,0 +1,242 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#include "HsNet.h" +##include "HsNetDef.h" + +module Network.Socket.Options ( + SocketOption(..) + , isSupportedSocketOption + , getSocketOption + , setSocketOption + , c_getsockopt + , c_setsockopt + ) where + +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Utils (with) + +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Types + +----------------------------------------------------------------------------- +-- Socket Properties + +-- | Socket options for use with 'setSocketOption' and 'getSocketOption'. +-- +-- 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) + +-- | Does the 'SocketOption' exist on this system? +isSupportedSocketOption :: SocketOption -> Bool +isSupportedSocketOption = isJust . packSocketOption + +-- | 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 +#ifdef SOL_SOCKET +#ifdef SO_DEBUG + Just Debug -> Just ((#const SOL_SOCKET), (#const SO_DEBUG)) +#endif +#ifdef SO_REUSEADDR + Just ReuseAddr -> Just ((#const SOL_SOCKET), (#const SO_REUSEADDR)) +#endif +#ifdef SO_TYPE + Just Type -> Just ((#const SOL_SOCKET), (#const SO_TYPE)) +#endif +#ifdef SO_ERROR + Just SoError -> Just ((#const SOL_SOCKET), (#const SO_ERROR)) +#endif +#ifdef SO_DONTROUTE + Just DontRoute -> Just ((#const SOL_SOCKET), (#const SO_DONTROUTE)) +#endif +#ifdef SO_BROADCAST + Just Broadcast -> Just ((#const SOL_SOCKET), (#const SO_BROADCAST)) +#endif +#ifdef SO_SNDBUF + Just SendBuffer -> Just ((#const SOL_SOCKET), (#const SO_SNDBUF)) +#endif +#ifdef SO_RCVBUF + Just RecvBuffer -> Just ((#const SOL_SOCKET), (#const SO_RCVBUF)) +#endif +#ifdef SO_KEEPALIVE + Just KeepAlive -> Just ((#const SOL_SOCKET), (#const SO_KEEPALIVE)) +#endif +#ifdef SO_OOBINLINE + Just OOBInline -> Just ((#const SOL_SOCKET), (#const SO_OOBINLINE)) +#endif +#ifdef SO_LINGER + Just Linger -> Just ((#const SOL_SOCKET), (#const SO_LINGER)) +#endif +#ifdef SO_REUSEPORT + Just ReusePort -> Just ((#const SOL_SOCKET), (#const SO_REUSEPORT)) +#endif +#ifdef SO_RCVLOWAT + Just RecvLowWater -> Just ((#const SOL_SOCKET), (#const SO_RCVLOWAT)) +#endif +#ifdef SO_SNDLOWAT + Just SendLowWater -> Just ((#const SOL_SOCKET), (#const SO_SNDLOWAT)) +#endif +#ifdef SO_RCVTIMEO + Just RecvTimeOut -> Just ((#const SOL_SOCKET), (#const SO_RCVTIMEO)) +#endif +#ifdef SO_SNDTIMEO + Just SendTimeOut -> Just ((#const SOL_SOCKET), (#const SO_SNDTIMEO)) +#endif +#ifdef SO_USELOOPBACK + Just UseLoopBack -> Just ((#const SOL_SOCKET), (#const SO_USELOOPBACK)) +#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 +#ifdef TCP_MAXSEG + Just MaxSegment -> Just ((#const IPPROTO_TCP), (#const TCP_MAXSEG)) +#endif +#ifdef TCP_NODELAY + Just NoDelay -> Just ((#const IPPROTO_TCP), (#const TCP_NODELAY)) +#endif +#ifdef TCP_USER_TIMEOUT + Just UserTimeout -> Just ((#const IPPROTO_TCP), (#const TCP_USER_TIMEOUT)) +#endif +#ifdef TCP_CORK + Just Cork -> Just ((#const IPPROTO_TCP), (#const TCP_CORK)) +#endif +#endif // HAVE_DECL_IPPROTO_TCP +#if HAVE_DECL_IPPROTO_IPV6 +#if HAVE_DECL_IPV6_V6ONLY + Just IPv6Only -> Just ((#const IPPROTO_IPV6), (#const IPV6_V6ONLY)) +#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"] + +#ifdef SO_LINGER +data StructLinger = StructLinger CInt CInt + +instance Storable StructLinger where + sizeOf _ = (#const sizeof(struct linger)) + alignment _ = alignment (undefined :: CInt) + + peek p = do + onoff <- (#peek struct linger, l_onoff) p + linger <- (#peek struct linger, l_linger) p + return $ StructLinger onoff linger + + poke p (StructLinger onoff linger) = do + (#poke struct linger, l_onoff) p onoff + (#poke struct linger, l_linger) p linger +#endif + +-- | Set a socket option that expects an Int value. +-- There is currently no API to set e.g. the timeval socket options +setSocketOption :: Socket + -> SocketOption -- Option Name + -> 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) + fd <- fdSocket s + throwSocketErrorIfMinus1_ "Network.Socket.setSocketOption" $ + c_setsockopt fd level opt ptr sz +#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) + fd <- fdSocket s + throwSocketErrorIfMinus1_ "Network.Socket.setSocketOption" $ + 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) + fd <- fdSocket s + 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 +#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) + fd <- fdSocket s + with sz $ \ptr_sz -> do + throwSocketErrorIfMinus1Retry_ "Network.Socket.getSocketOption" $ + c_getsockopt fd level opt ptr ptr_sz + fromIntegral <$> peek ptr + +foreign import CALLCONV unsafe "getsockopt" + c_getsockopt :: CInt -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt +foreign import CALLCONV unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr a -> CInt -> IO CInt diff --git a/Network/Socket/Shutdown.hs b/Network/Socket/Shutdown.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Shutdown.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + +#include "HsNetDef.h" + +module Network.Socket.Shutdown ( + ShutdownCmd(..) + , shutdown + ) where + +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Types + +data ShutdownCmd = ShutdownReceive + | ShutdownSend + | ShutdownBoth + deriving Typeable + +sdownCmdToInt :: ShutdownCmd -> CInt +sdownCmdToInt ShutdownReceive = 0 +sdownCmdToInt ShutdownSend = 1 +sdownCmdToInt ShutdownBoth = 2 + +-- | Shut down one or both halves of the connection, depending on the +-- second argument to the function. If the second argument is +-- 'ShutdownReceive', further receives are disallowed. If it is +-- 'ShutdownSend', further sends are disallowed. If it is +-- 'ShutdownBoth', further sends and receives are disallowed. +shutdown :: Socket -> ShutdownCmd -> IO () +shutdown s stype = void $ do + fd <- fdSocket s + throwSocketErrorIfMinus1Retry_ "Network.Socket.shutdown" $ + c_shutdown fd $ sdownCmdToInt stype + +foreign import CALLCONV unsafe "shutdown" + c_shutdown :: CInt -> CInt -> IO CInt diff --git a/Network/Socket/SockAddr.hs b/Network/Socket/SockAddr.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/SockAddr.hs @@ -0,0 +1,66 @@ +module Network.Socket.SockAddr ( + getPeerName + , getSocketName + , connect + , bind + , accept + , sendBufTo + , recvBufFrom + ) where + +import qualified Network.Socket.Buffer as G +import qualified Network.Socket.Name as G +import qualified Network.Socket.Syscall as G +import Network.Socket.Imports +import Network.Socket.Types + +-- | Getting peer's 'SockAddr'. +getPeerName :: Socket -> IO SockAddr +getPeerName = G.getPeerName + +-- | Getting my 'SockAddr'. +getSocketName :: Socket -> IO SockAddr +getSocketName = G.getSocketName + +-- | Connect to a remote socket at address. +connect :: Socket -> SockAddr -> IO () +connect = G.connect + +-- | Bind the socket to an address. The socket must not already be +-- bound. The 'Family' passed to @bind@ must be the +-- same as that passed to 'socket'. If the special port number +-- 'defaultPort' is passed then the system assigns the next available +-- use port. +bind :: Socket -> SockAddr -> IO () +bind = G.bind + +-- | Accept a connection. The socket must be bound to an address and +-- listening for connections. The return value is a pair @(conn, +-- address)@ where @conn@ is a new socket object usable to send and +-- receive data on the connection, and @address@ is the address bound +-- to the socket on the other end of the connection. +-- On Unix, FD_CLOEXEC is set to the new 'Socket'. +accept :: Socket -> IO (Socket, SockAddr) +accept = G.accept + +-- | 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 +-- ensuring that all data has been sent. +sendBufTo :: Socket -> Ptr a -> Int -> SockAddr -> IO Int +sendBufTo = G.sendBufTo + +-- | Receive data from the socket, writing it into buffer instead of +-- creating a new string. The socket need not be in a connected +-- state. Returns @(nbytes, address)@ where @nbytes@ is the number of +-- bytes received and @address@ is a 'SockAddr' representing the +-- address of the sending socket. +-- +-- If the first return value is zero, it means EOF. +-- +-- For 'Stream' sockets, the second return value would be invalid. +-- +-- NOTE: blocking on Windows unless you compile with -threaded (see +-- GHC ticket #1129) +recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr) +recvBufFrom = G.recvBufFrom diff --git a/Network/Socket/Syscall.hs b/Network/Socket/Syscall.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/Syscall.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#include "HsNetDef.h" + +module Network.Socket.Syscall where + +import Foreign.Marshal.Utils (with) +import qualified Control.Exception as E + +#if defined(mingw32_HOST_OS) +import Foreign (FunPtr) +import GHC.Conc (asyncDoProc) +#else +import Foreign.C.Error (getErrno, eINTR, eINPROGRESS) +import GHC.Conc (threadWaitWrite) +#endif + +#ifdef HAVE_ADVANCED_SOCKET_FLAGS +import Network.Socket.Cbits +#else +import Network.Socket.Fcntl +#endif + +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Options +import Network.Socket.Types + +-- ---------------------------------------------------------------------------- +-- On Windows, our sockets are not put in non-blocking mode (non-blocking +-- is not supported for regular file descriptors on Windows, and it would +-- be a pain to support it only for sockets). So there are two cases: +-- +-- - the threaded RTS uses safe calls for socket operations to get +-- non-blocking I/O, just like the rest of the I/O library +-- +-- - with the non-threaded RTS, only some operations on sockets will be +-- non-blocking. Reads and writes go through the normal async I/O +-- system. accept() uses asyncDoProc so is non-blocking. A handful +-- of others (recvFrom, sendFd, recvFd) will block all threads - if this +-- is a problem, -threaded is the workaround. +-- + +----------------------------------------------------------------------------- +-- Connection Functions + +-- In the following connection and binding primitives. The names of +-- the equivalent C functions have been preserved where possible. It +-- should be noted that some of these names used in the C library, +-- \tr{bind} in particular, have a different meaning to many Haskell +-- programmers and have thus been renamed by appending the prefix +-- Socket. + +-- | Create a new socket using the given address family, socket type +-- and protocol number. The address family is usually 'AF_INET', +-- 'AF_INET6', or 'AF_UNIX'. The socket type is usually 'Stream' or +-- 'Datagram'. The protocol number is usually 'defaultProtocol'. +-- If 'AF_INET6' is used and the socket type is 'Stream' or 'Datagram', +-- the 'IPv6Only' socket option is set to 0 so that both IPv4 and IPv6 +-- can be handled with one socket. +-- +-- >>> import Network.Socket +-- >>> let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } +-- >>> addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just "5000") +-- >>> sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +-- >>> Network.Socket.bind sock (addrAddress addr) +-- >>> getSocketName sock +-- 127.0.0.1:5000 +socket :: Family -- Family Name (usually AF_INET) + -> SocketType -- Socket Type (usually Stream) + -> ProtocolNumber -- Protocol Number (getProtocolByName to find value) + -> IO Socket -- Unconnected Socket +socket family stype protocol = E.bracketOnError create c_close $ \fd -> do + -- Let's ensure that the socket (file descriptor) is closed even on + -- asynchronous exceptions. + setNonBlock fd + s <- mkSocket fd + -- This socket is not managed by the IO manager yet. + -- So, we don't have to call "close" which uses "closeFdWith". + unsetIPv6Only s + return s + where + create = do + c_stype <- modifyFlag <$> packSocketTypeOrThrow "socket" stype + throwSocketErrorIfMinus1Retry "Network.Socket.socket" $ + c_socket (packFamily family) c_stype protocol + +#ifdef HAVE_ADVANCED_SOCKET_FLAGS + modifyFlag c_stype = c_stype .|. sockNonBlock +#else + modifyFlag c_stype = c_stype +#endif + +#ifdef HAVE_ADVANCED_SOCKET_FLAGS + setNonBlock _ = return () +#else + setNonBlock fd = setNonBlockIfNeeded fd +#endif + +#if HAVE_DECL_IPV6_V6ONLY + unsetIPv6Only s = when (family == AF_INET6 && stype `elem` [Stream, Datagram]) $ +# if defined(mingw32_HOST_OS) + -- The IPv6Only option is only supported on Windows Vista and later, + -- so trying to change it might throw an error. + E.catch (setSocketOption s IPv6Only 0) $ (\(_ :: E.IOException) -> return ()) +# elif defined(__OpenBSD__) + -- don't change IPv6Only + return () +# else + -- The default value of the IPv6Only option is platform specific, + -- so we explicitly set it to 0 to provide a common default. + setSocketOption s IPv6Only 0 +# endif +#else + unsetIPv6Only _ = return () +#endif + +----------------------------------------------------------------------------- +-- Binding a socket + +-- | Bind the socket to an address. The socket must not already be +-- bound. The 'Family' passed to @bind@ must be the +-- same as that passed to 'socket'. If the special port number +-- 'defaultPort' is passed then the system assigns the next available +-- use port. +bind :: SocketAddress sa => Socket -> sa -> IO () +bind s sa = withSocketAddress sa $ \p_sa siz -> void $ do + fd <- fdSocket s + let sz = fromIntegral siz + throwSocketErrorIfMinus1Retry "Network.Socket.bind" $ c_bind fd p_sa sz + +----------------------------------------------------------------------------- +-- Connecting a socket + +-- | Connect to a remote socket at address. +connect :: SocketAddress sa => Socket -> sa -> IO () +connect s sa = withSocketsDo $ withSocketAddress sa $ \p_sa sz -> + connectLoop s p_sa (fromIntegral sz) + +connectLoop :: SocketAddress sa => Socket -> Ptr sa -> CInt -> IO () +connectLoop s p_sa sz = loop + where + errLoc = "Network.Socket.connect: " ++ show s + loop = do + fd <- fdSocket s + r <- c_connect fd p_sa sz + when (r == -1) $ do +#if defined(mingw32_HOST_OS) + throwSocketError errLoc +#else + err <- getErrno + case () of + _ | err == eINTR -> loop + _ | err == eINPROGRESS -> connectBlocked +-- _ | err == eAGAIN -> connectBlocked + _otherwise -> throwSocketError errLoc + + connectBlocked = do + fd <- fromIntegral <$> fdSocket s + threadWaitWrite fd + err <- getSocketOption s SoError + when (err == -1) $ throwSocketErrorCode errLoc (fromIntegral err) +#endif + +----------------------------------------------------------------------------- +-- Listen + +-- | Listen for connections made to the socket. The second argument +-- specifies the maximum number of queued connections and should be at +-- least 1; the maximum value is system-dependent (usually 5). +listen :: Socket -> Int -> IO () +listen s backlog = do + fd <- fdSocket s + throwSocketErrorIfMinus1Retry_ "Network.Socket.listen" $ + c_listen fd $ fromIntegral backlog + +----------------------------------------------------------------------------- +-- Accept +-- +-- A call to `accept' only returns when data is available on the given +-- socket, unless the socket has been set to non-blocking. It will +-- return a new socket which should be used to read the incoming data and +-- should then be closed. Using the socket returned by `accept' allows +-- incoming requests to be queued on the original socket. + +-- | Accept a connection. The socket must be bound to an address and +-- listening for connections. The return value is a pair @(conn, +-- address)@ where @conn@ is a new socket object usable to send and +-- receive data on the connection, and @address@ is the address bound +-- to the socket on the other end of the connection. +-- On Unix, FD_CLOEXEC is set to the new 'Socket'. +accept :: SocketAddress sa => Socket -> IO (Socket, sa) +accept listing_sock = withNewSocketAddress $ \new_sa sz -> do + listing_fd <- fdSocket listing_sock + new_sock <- callAccept listing_fd new_sa sz >>= mkSocket + new_addr <- peekSocketAddress new_sa + return (new_sock, new_addr) + where +#if defined(mingw32_HOST_OS) + callAccept fd sa sz + | threaded = with (fromIntegral sz) $ \ ptr_len -> + throwSocketErrorIfMinus1Retry "Network.Socket.accept" $ + c_accept_safe fd sa ptr_len + | otherwise = do + paramData <- c_newAcceptParams fd (fromIntegral sz) sa + rc <- asyncDoProc c_acceptDoProc paramData + new_fd <- c_acceptNewSock paramData + c_free paramData + when (rc /= 0) $ + throwSocketErrorCode "Network.Socket.accept" (fromIntegral rc) + return new_fd +#else + callAccept fd sa sz = with (fromIntegral sz) $ \ ptr_len -> do +# ifdef HAVE_ADVANCED_SOCKET_FLAGS + throwSocketErrorWaitRead listing_sock "Network.Socket.accept" + (c_accept4 fd sa ptr_len (sockNonBlock .|. sockCloexec)) +# else + new_fd <- throwSocketErrorWaitRead listing_sock "Network.Socket.accept" + (c_accept fd sa ptr_len) + setNonBlockIfNeeded new_fd + setCloseOnExecIfNeeded new_fd + return new_fd +# endif /* HAVE_ADVANCED_SOCKET_FLAGS */ +#endif + +foreign import CALLCONV unsafe "socket" + c_socket :: CInt -> CInt -> CInt -> IO CInt +foreign import CALLCONV unsafe "bind" + c_bind :: CInt -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt +foreign import CALLCONV SAFE_ON_WIN "connect" + c_connect :: CInt -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt +foreign import CALLCONV unsafe "listen" + c_listen :: CInt -> CInt -> IO CInt + +#ifdef HAVE_ADVANCED_SOCKET_FLAGS +foreign import CALLCONV unsafe "accept4" + c_accept4 :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> CInt -> IO CInt +#else +foreign import CALLCONV unsafe "accept" + c_accept :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CInt +#endif + +#if defined(mingw32_HOST_OS) +foreign import CALLCONV safe "accept" + c_accept_safe :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CInt +foreign import ccall unsafe "rtsSupportsBoundThreads" + threaded :: Bool +foreign import ccall unsafe "HsNet.h acceptNewSock" + c_acceptNewSock :: Ptr () -> IO CInt +foreign import ccall unsafe "HsNet.h newAcceptParams" + c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ()) +foreign import ccall unsafe "HsNet.h &acceptDoProc" + c_acceptDoProc :: FunPtr (Ptr () -> IO Int) +foreign import ccall unsafe "free" + c_free:: Ptr a -> IO () +#endif diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -1,23 +1,22 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} #include "HsNet.h" ##include "HsNetDef.h" -module Network.Socket.Types - ( - -- * Socket - Socket(..) +module Network.Socket.Types ( + -- * Socket type + Socket , fdSocket - , sockFamily - , sockType - , sockProtocol - , sockStatus - , SocketStatus(..) - - -- * Socket types + , mkSocket + , invalidateSocket + , close + , close' + , c_close + -- * Types of socket , SocketType(..) , isSupportedSocketType , packSocketType @@ -32,61 +31,64 @@ , packFamily , unpackFamily - -- * Socket addresses + -- * Socket address typeclass + , SocketAddress(..) + , withSocketAddress + , withNewSocketAddress + + -- * Socket address type , SockAddr(..) , isSupportedSockAddr , HostAddress , hostAddressToTuple , tupleToHostAddress -#if defined(IPV6_SOCKET_SUPPORT) , HostAddress6 , hostAddress6ToTuple , tupleToHostAddress6 , FlowInfo , ScopeID -#endif , peekSockAddr , pokeSockAddr - , sizeOfSockAddr - , sizeOfSockAddrByFamily , withSockAddr - , withNewSockAddr -- * Unsorted , ProtocolNumber - , PortNumber(..) + , defaultProtocol + , PortNumber + , defaultPort -- * Low-level helpers , zeroMemory + , htonl + , ntohl ) where -import Control.Concurrent.MVar -import Control.Monad -import Data.Bits -import Data.Maybe -import Data.Typeable -import Data.Word -import Data.Int -import Foreign.C +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 (..)) + +#if defined(DOMAIN_SOCKET_SUPPORT) import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable +#endif --- | A socket data type. --- 'Socket's are not GCed unless they are closed by 'close'. -data Socket - = MkSocket - CInt -- File Descriptor - Family - SocketType - ProtocolNumber -- Protocol Number - (MVar SocketStatus) -- Status Flag - deriving Typeable +import Network.Socket.Imports -{-# DEPRECATED MkSocket "'MkSocket' will not be available in version 3.0.0.0 or later. Use fdSocket instead" #-} +----------------------------------------------------------------------------- --- | Obtaining the file descriptor from a socket. +-- | 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 + +-- | Getting a file descriptor from a socket. -- -- If a 'Socket' is shared with multiple threads and -- one uses 'fdSocket', unexpected issues may happen. @@ -102,46 +104,92 @@ -- In this case, it is safer for Thread A to clone 'Fd' by -- 'System.Posix.IO.dup'. But this would still suffer from -- a rase condition between 'fdSocket' and 'close'. -fdSocket :: Socket -> CInt -fdSocket (MkSocket fd _ _ _ _) = fd +fdSocket :: Socket -> IO CInt +fdSocket (Socket ref _) = readIORef ref -sockFamily :: Socket -> Family -sockFamily (MkSocket _ f _ _ _) = f +-- | 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 -sockType :: Socket -> SocketType -sockType (MkSocket _ _ t _ _) = t +invalidSocket :: CInt +#if defined(mingw32_HOST_OS) +invalidSocket = #const INVALID_SOCKET +#else +invalidSocket = -1 +#endif -sockProtocol :: Socket -> ProtocolNumber -sockProtocol (MkSocket _ _ _ p _) = p +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 -sockStatus :: Socket -> MVar SocketStatus -sockStatus (MkSocket _ _ _ _ s) = s +----------------------------------------------------------------------------- -instance Eq Socket where - (MkSocket _ _ _ _ m1) == (MkSocket _ _ _ _ m2) = m1 == m2 +-- | Close the socket. This function does not throw exceptions even if +-- the underlying system call returns errors. +-- +-- Sending data to or receiving data from closed socket +-- may lead to undefined behaviour. +-- +-- If multiple threads use the same socket and one uses 'fdSocket' and +-- the other use 'close', unexpected behavior may happen. +-- For more information, please refer to the documentation of 'fdSocket'. +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 -instance Show Socket where - showsPrec _n (MkSocket fd _ _ _ _) = - showString "" +-- | Close the socket. This function throws exceptions if +-- the underlying system call returns errors. +-- +-- Sending data to or receiving data from closed socket +-- may lead to undefined behaviour. +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 + +----------------------------------------------------------------------------- + +-- | Protocl number. type ProtocolNumber = CInt --- | The status of the socket as /determined by this library/, not --- necessarily reflecting the state of the connection itself. +-- | This is the default protocol for a given service. -- --- For example, the 'Closed' status is applied when the 'close' --- function is called. -data SocketStatus - -- Returned Status Function called - = NotConnected -- ^ Newly created, unconnected socket - | Bound -- ^ Bound, via 'bind' - | Listening -- ^ Listening, via 'listen' - | Connected -- ^ Connected or accepted, via 'connect' or 'accept' - | ConvertedToHandle -- ^ Is now a 'Handle' (via 'socketToHandle'), don't touch - | Closed -- ^ Closed was closed by 'close' - deriving (Eq, Show, Typeable) - -{-# DEPRECATED SocketStatus "SocketStatus will be removed" #-} +-- >>> defaultProtocol +-- 0 +defaultProtocol :: ProtocolNumber +defaultProtocol = 0 ----------------------------------------------------------------------------- -- Socket types @@ -201,8 +249,6 @@ #endif _ -> Nothing -{-# DEPRECATED packSocketType "packSocketType will not be available in version 3.0.0.0 or later." #-} - packSocketType :: SocketType -> CInt packSocketType stype = fromMaybe (error errMsg) (packSocketType' stype) where @@ -254,74 +300,75 @@ -- A constructor being present here does not mean it is supported by the -- operating system: see 'isSupportedFamily'. data Family - = AF_UNSPEC -- unspecified - | AF_UNIX -- local to host (pipes, portals - | AF_INET -- internetwork: UDP, TCP, etc - | 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 - | 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 - | AF_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 -- (rev.) addr. res. prot. (RFC 826) - | Pseudo_AF_HDRCMPLT -- Used by BPF to not rewrite hdrs in iface output - | AF_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 -- 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 + = 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 @@ -538,6 +585,7 @@ --------- ---------- +-- | Converting 'CInt' to 'Family'. unpackFamily :: CInt -> Family unpackFamily f = case f of (#const AF_UNSPEC) -> AF_UNSPEC @@ -745,8 +793,9 @@ ------------------------------------------------------------------------ -- Port Numbers --- | Use the @Num@ instance (i.e. use a literal) to create a --- @PortNumber@ value. +-- | Port number. +-- Use the @Num@ instance (i.e. use a literal) to create a +-- @PortNumber@ value. -- -- >>> 1 :: PortNumber -- 1 @@ -772,16 +821,50 @@ foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16 foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16 -foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32 +-- | 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) `liftM` peek (castPtr p) + 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 @@ -801,49 +884,51 @@ -- families. Currently only UNIX-domain sockets and the Internet -- families are supported. +-- | Flow information. type FlowInfo = Word32 +-- | Scope identifier. type ScopeID = Word32 --- | The existence of a constructor does not necessarily imply that --- that socket address type is supported on your system: see +-- | 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 -- C Names +data SockAddr = SockAddrInet - PortNumber -- sin_port - HostAddress -- sin_addr (ditto) + !PortNumber -- sin_port + !HostAddress -- sin_addr (ditto) | SockAddrInet6 - PortNumber -- sin6_port - FlowInfo -- sin6_flowinfo (ditto) - HostAddress6 -- sin6_addr (ditto) - ScopeID -- sin6_scope_id (ditto) + !PortNumber -- sin6_port + !FlowInfo -- sin6_flowinfo (ditto) + !HostAddress6 -- sin6_addr (ditto) + !ScopeID -- sin6_scope_id (ditto) + -- | 'String' must be a list of 0-255 values and its length should be less than 104. | SockAddrUnix - String -- sun_path - | SockAddrCan - Int32 -- can_ifindex (can be get by Network.BSD.ifNameToIndex "can0") - -- TODO: Extend this to include transport protocol information + 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 -#if defined(IPV6_SOCKET_SUPPORT) - SockAddrInet6 {} -> True -#endif + SockAddrInet{} -> True + SockAddrInet6{} -> True #if defined(DOMAIN_SOCKET_SUPPORT) - SockAddrUnix{} -> True -#endif -#if defined(CAN_SOCKET_SUPPORT) - SockAddrCan{} -> True -#endif -#if !(defined(IPV6_SOCKET_SUPPORT) \ - && defined(DOMAIN_SOCKET_SUPPORT) && defined(CAN_SOCKET_SUPPORT)) - _ -> False + SockAddrUnix{} -> True +#else + SockAddrUnix{} -> False #endif -{-# DEPRECATED SockAddrCan "This will be removed in 3.0" #-} +instance SocketAddress SockAddr where + sizeOfSocketAddress = sizeOfSockAddr + peekSocketAddress = peekSockAddr + pokeSocketAddress = pokeSockAddr -#if defined(WITH_WINSOCK) +#if defined(mingw32_HOST_OS) type CSaFamily = (#type unsigned short) #elif defined(darwin_HOST_OS) type CSaFamily = (#type u_char) @@ -856,39 +941,12 @@ -- in that the value of the argument /is/ used. sizeOfSockAddr :: SockAddr -> Int #if defined(DOMAIN_SOCKET_SUPPORT) -sizeOfSockAddr (SockAddrUnix path) = - case path of - '\0':_ -> (#const sizeof(sa_family_t)) + length path - _ -> #const sizeof(struct sockaddr_un) -#endif -sizeOfSockAddr (SockAddrInet _ _) = #const sizeof(struct sockaddr_in) -#if defined(IPV6_SOCKET_SUPPORT) -sizeOfSockAddr (SockAddrInet6 _ _ _ _) = #const sizeof(struct sockaddr_in6) -#endif -#if defined(CAN_SOCKET_SUPPORT) -sizeOfSockAddr (SockAddrCan _) = #const sizeof(struct sockaddr_can) -#endif -#if !(defined(IPV6_SOCKET_SUPPORT) \ - && defined(DOMAIN_SOCKET_SUPPORT) && defined(CAN_SOCKET_SUPPORT)) -sizeOfSockAddr _ = error "sizeOfSockAddr: not supported" -#endif - --- | Computes the storage requirements (in bytes) required for a --- 'SockAddr' with the given 'Family'. -sizeOfSockAddrByFamily :: Family -> Int -#if defined(DOMAIN_SOCKET_SUPPORT) -sizeOfSockAddrByFamily AF_UNIX = #const sizeof(struct sockaddr_un) -#endif -#if defined(IPV6_SOCKET_SUPPORT) -sizeOfSockAddrByFamily AF_INET6 = #const sizeof(struct sockaddr_in6) -#endif -sizeOfSockAddrByFamily AF_INET = #const sizeof(struct sockaddr_in) -#if defined(CAN_SOCKET_SUPPORT) -sizeOfSockAddrByFamily AF_CAN = #const sizeof(struct sockaddr_can) +sizeOfSockAddr SockAddrUnix{} = #const sizeof(struct sockaddr_un) +#else +sizeOfSockAddr SockAddrUnix{} = error "sizeOfSockAddr: not supported" #endif -sizeOfSockAddrByFamily family = error $ - "Network.Socket.Types.sizeOfSockAddrByFamily: address family '" ++ - show family ++ "' not supported." +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'. @@ -897,13 +955,6 @@ let sz = sizeOfSockAddr addr allocaBytes sz $ \p -> pokeSockAddr p addr >> f (castPtr p) sz --- | Create a new 'SockAddr' for use with a function requiring a --- pointer to a 'SockAddr' and the length of that 'SockAddr'. -withNewSockAddr :: Family -> (Ptr SockAddr -> Int -> IO a) -> IO a -withNewSockAddr family f = do - let sz = sizeOfSockAddrByFamily family - allocaBytes sz $ \ptr -> f ptr 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. @@ -926,48 +977,34 @@ 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) +# if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) (#poke struct sockaddr_un, sun_len) p ((#const sizeof(struct sockaddr_un)) :: Word8) -#endif +# 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 -#if defined(darwin_HOST_OS) zeroMemory p (#const sizeof(struct sockaddr_in)) -#endif #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 -#if defined(IPV6_SOCKET_SUPPORT) pokeSockAddr p (SockAddrInet6 port flow addr scope) = do -#if defined(darwin_HOST_OS) zeroMemory p (#const sizeof(struct sockaddr_in6)) -#endif -#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) +# if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) (#poke struct sockaddr_in6, sin6_len) p ((#const sizeof(struct sockaddr_in6)) :: Word8) -#endif +# 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 -#endif -#if defined(CAN_SOCKET_SUPPORT) -pokeSockAddr p (SockAddrCan ifIndex) = do -#if defined(darwin_HOST_OS) - zeroMemory p (#const sizeof(struct sockaddr_can)) -#endif - (#poke struct sockaddr_can, can_ifindex) p ifIndex -#endif -#if !(defined(IPV6_SOCKET_SUPPORT) \ - && defined(DOMAIN_SOCKET_SUPPORT) && defined(CAN_SOCKET_SUPPORT)) -pokeSockAddr _ _ = error "pokeSockAddr: not supported" -#endif -- | Read a 'SockAddr' from the given memory location. peekSockAddr :: Ptr SockAddr -> IO SockAddr @@ -976,26 +1013,19 @@ case family :: CSaFamily of #if defined(DOMAIN_SOCKET_SUPPORT) (#const AF_UNIX) -> do - str <- peekCString ((#ptr struct sockaddr_un, sun_path) p) + 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) -#if defined(IPV6_SOCKET_SUPPORT) (#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) -#endif -#if defined(CAN_SOCKET_SUPPORT) - (#const AF_CAN) -> do - ifidx <- (#peek struct sockaddr_can, can_ifindex) p - return (SockAddrCan ifidx) -#endif _ -> ioError $ userError $ "Network.Socket.Types.peekSockAddr: address family '" ++ show family ++ "' not supported." @@ -1014,6 +1044,8 @@ -- | 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' @@ -1032,7 +1064,9 @@ -- 'tupleToHostAddress6'. type HostAddress6 = (Word32, Word32, Word32, Word32) -#if defined(IPV6_SOCKET_SUPPORT) +-- | 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) = @@ -1041,6 +1075,7 @@ 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) = @@ -1099,7 +1134,6 @@ poke32 p 1 b poke32 p 2 c poke32 p 3 d -#endif ------------------------------------------------------------------------ -- Helper functions diff --git a/Network/Socket/Unix.hsc b/Network/Socket/Unix.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Unix.hsc @@ -0,0 +1,177 @@ +{-# LANGUAGE CPP #-} + +#include "HsNet.h" +##include "HsNetDef.h" + +module Network.Socket.Unix ( + isUnixDomainSocketAvailable + , socketPair + , sendFd + , recvFd + , getPeerCredential + , getPeerCred + , getPeerEid + ) where + +import Network.Socket.Imports +import Network.Socket.Types + +#ifdef HAVE_STRUCT_UCRED_SO_PEERCRED +import Foreign.Marshal.Utils (with) +#endif +#ifdef HAVE_GETPEEREID +import qualified Control.Exception as E +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) +#endif + +-- | Getting process ID, user ID and group ID for UNIX-domain sockets. +-- +-- This is implemented with SO_PEERCRED on Linux and getpeereid() +-- on BSD variants. Unfortunately, on some BSD variants +-- getpeereid() returns unexpected results, rather than an error, +-- for AF_INET sockets. It is the user's responsibility to make sure +-- that the socket is a UNIX-domain socket. +-- Also, on some BSD variants, getpeereid() does not return credentials +-- for sockets created via 'socketPair', only separately created and then +-- explicitly connected UNIX-domain sockets work on such systems. +-- +-- Since 2.7.0.0. +getPeerCredential :: Socket -> IO (Maybe CUInt, Maybe CUInt, Maybe CUInt) +#ifdef HAVE_STRUCT_UCRED_SO_PEERCRED +getPeerCredential sock = do + (pid, uid, gid) <- getPeerCred sock + if uid == maxBound then + return (Nothing, Nothing, Nothing) + else + return (Just pid, Just uid, Just gid) +#elif defined(HAVE_GETPEEREID) +getPeerCredential sock = E.handle (\(E.SomeException _) -> return (Nothing,Nothing,Nothing)) $ do + (uid, gid) <- getPeerEid sock + return (Nothing, Just uid, Just gid) +#else +getPeerCredential _ = return (Nothing, Nothing, Nothing) +#endif + +-- | Returns the processID, userID and groupID of the peer of +-- a UNIX-domain socket. +-- +-- Only available on platforms that support SO_PEERCRED. +getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt) +#ifdef HAVE_STRUCT_UCRED_SO_PEERCRED +getPeerCred s = do + let sz = (#const sizeof(struct ucred)) + fd <- fdSocket s + 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) +#else +getPeerCred _ = return (0, 0, 0) +#endif +{-# Deprecated getPeerCred "Use getPeerCredential instead" #-} + +-- | Returns the userID and groupID of the peer of +-- a UNIX-domain socket. +-- +-- Only available on platforms that support getpeereid(). +getPeerEid :: Socket -> IO (CUInt, CUInt) +#ifdef HAVE_GETPEEREID +getPeerEid s = do + alloca $ \ ptr_uid -> + alloca $ \ ptr_gid -> do + fd <- fdSocket s + throwSocketErrorIfMinus1Retry_ "Network.Socket.getPeerEid" $ + c_getpeereid fd ptr_uid ptr_gid + uid <- peek ptr_uid + gid <- peek ptr_gid + return (uid, gid) + +foreign import CALLCONV unsafe "getpeereid" + c_getpeereid :: CInt -> Ptr CUInt -> Ptr CUInt -> IO CInt +#else +getPeerEid _ = return (0, 0) +#endif + +{-# Deprecated getPeerEid "Use getPeerCredential instead" #-} + +-- | Whether or not UNIX-domain sockets are available. +-- +-- Since 2.7.0.0. +isUnixDomainSocketAvailable :: Bool +#if defined(DOMAIN_SOCKET_SUPPORT) +isUnixDomainSocketAvailable = True +#else +isUnixDomainSocketAvailable = False +#endif + +-- | 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 + fd <- fdSocket s + throwSocketErrorWaitWrite s "Network.Socket.sendFd" $ c_sendFd fd outfd +foreign import ccall SAFE_ON_WIN "sendFd" c_sendFd :: CInt -> CInt -> IO CInt +#else +sendFd _ _ = error "Network.Socket.sendFd" +#endif + +-- | Receive a file descriptor over a UNIX-domain socket. Note that the resulting +-- file descriptor may have to be put into non-blocking mode in order to be +-- used safely. See 'setNonBlockIfNeeded'. +-- Use this function in the case where 'isUnixDomainSocketAvailable' is +-- 'True'. +recvFd :: Socket -> IO CInt +#if defined(DOMAIN_SOCKET_SUPPORT) +recvFd s = do + fd <- fdSocket s + throwSocketErrorWaitRead s "Network.Socket.recvFd" $ c_recvFd fd +foreign import ccall SAFE_ON_WIN "recvFd" c_recvFd :: CInt -> IO CInt +#else +recvFd _ = error "Network.Socket.recvFd" +#endif + +-- | Build a pair of connected socket objects. +-- For portability, use this function in the case +-- where 'isUnixDomainSocketAvailable' is 'True' +-- and specify 'AF_UNIX' to the first argument. +socketPair :: Family -- Family Name (usually AF_UNIX) + -> SocketType -- Socket Type (usually Stream) + -> ProtocolNumber -- Protocol Number + -> IO (Socket, Socket) -- unnamed and connected. +#if defined(DOMAIN_SOCKET_SUPPORT) +socketPair family stype protocol = + allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do + c_stype <- packSocketTypeOrThrow "socketPair" stype + _rc <- throwSocketErrorIfMinus1Retry "Network.Socket.socketpair" $ + c_socketpair (packFamily family) c_stype protocol fdArr + [fd1,fd2] <- peekArray 2 fdArr + setNonBlockIfNeeded fd1 + setNonBlockIfNeeded fd2 + s1 <- mkSocket fd1 + s2 <- mkSocket fd2 + return (s1, s2) + +foreign import ccall unsafe "socketpair" + c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt +#else +socketPair _ _ _ = error "Network.Socket.socketPair" +#endif diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,19 +1,66 @@ # [`network`](http://hackage.haskell.org/package/network) [![Build Status](https://travis-ci.org/haskell/network.svg?branch=master)](https://travis-ci.org/haskell/network) [![Build status](https://ci.appveyor.com/api/projects/status/5erq63o4m29bhl57/branch/master?svg=true)](https://ci.appveyor.com/project/eborden/network/branch/master) -To build this package using Cabal directly from git, you must run -`autoreconf` before the usual Cabal build steps -(configure/build/install). `autoreconf` is included in the -[GNU Autoconf](http://www.gnu.org/software/autoconf/) tools. There is -no need to run the `configure` script: the `setup configure` step will -do this for you. +To build this package directly from git, you must run `autoreconf -i`. +And then use `cabal configure; cabal build` or `stack build`. ## Support Policy ### GHC -`network`'s GHC policy supports 3 [stable](https://downloads.haskell.org/~ghc/8.0.2/docs/html/users_guide/intro.html#ghc-version-numbering-policy) versions. The current stable -version and two previous stable versions are supported. +The `network` package support [3 major versions of GHC](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/intro.html#ghc-version-numbering-policy) only. +This means that the current stable version and two previous stable versions are supported. -### Hugs, JHC, UHC +### Windows -`network` does not officially support these compilers. +We use MSYS to build this package on Windows. +To use the `network` package on Cygwin, use `stack`. + +## Coding + +### .hs files + +If you need C macros created by "configure" or `CALLCONV`/`SAFE_ON_WIN`, put + +``` +#include "HsNetDef.h" +``` + +"HsNet.h" does now work well since Mac's cpp sucks. + +### .hsc files + +If you need `#peek`, `#poke` and others, create a `.hsc` file with + +``` +#include "HsNet.h" +``` + +`HsNet.h` includes `HsNefDef.h` and necessary C structures. +Unfortunately, `hsc2hs` does not convert C macros. +So, if you use `CALLCONV`/`SAFE_ON_WIN`, the following is also necessary: + +``` +##include "HsNetDef.h" +``` + +## Milestones + +### 2.6 + +- [x] Making `SockAddrCan` deprecated + +### 2.7 + +See https://github.com/haskell/network/issues/296 + +- Making `Network` deprecated +- Making `Network.BSD` deprecated +- Making `MkSocket` deprecated +- Making many APIs deprecated + +### 3.0 + +- Removing `Network` +- Removing `Network.BSD` +- Removing `SockAddrCan` +- Changing the internal structure of `Socket`. diff --git a/cbits/asyncAccept.c b/cbits/asyncAccept.c --- a/cbits/asyncAccept.c +++ b/cbits/asyncAccept.c @@ -5,14 +5,14 @@ #include "HsNet.h" #include "HsFFI.h" -#if defined(HAVE_WINSOCK2_H) +#if defined(_WIN32) /* all the way to the end */ /* * To support non-blocking accept()s with WinSock, we use the asyncDoProc# * primop, which lets a Haskell thread call an external routine without - * blocking the progress of other threads. + * blocking the progress of other threads. * * As can readily be seen, this is a low-level mechanism. * @@ -26,7 +26,7 @@ } AcceptData; /* - * Fill in parameter block that's passed along when the RTS invokes the + * Fill in parameter block that's passed along when the RTS invokes the * accept()-calling proc below (acceptDoProc()) */ void* @@ -40,7 +40,7 @@ data->newSock = 0; data->sockAddr = sockaddr; data->size = sz; - + return data; } diff --git a/cbits/initWinSock.c b/cbits/initWinSock.c --- a/cbits/initWinSock.c +++ b/cbits/initWinSock.c @@ -1,7 +1,7 @@ #include "HsNet.h" #include "HsFFI.h" -#if defined(HAVE_WINSOCK2_H) +#if defined(_WIN32) static int winsock_inited = 0; @@ -16,14 +16,14 @@ initWinSock () { WORD wVersionRequested; - WSADATA wsaData; + WSADATA wsaData; int err; if (!winsock_inited) { wVersionRequested = MAKEWORD( 2, 2 ); err = WSAStartup ( wVersionRequested, &wsaData ); - + if ( err != 0 ) { return err; } diff --git a/cbits/winSockErr.c b/cbits/winSockErr.c --- a/cbits/winSockErr.c +++ b/cbits/winSockErr.c @@ -1,7 +1,7 @@ #include "HsNet.h" #include "HsFFI.h" -#if defined(HAVE_WINSOCK2_H) +#if defined(_WIN32) #include /* to the end */ diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for Haskell network package 2.8.0.1. +# Generated by GNU Autoconf 2.69 for Haskell network package 3.0.0.0. # # Report bugs to . # @@ -580,8 +580,8 @@ # Identity of this package. PACKAGE_NAME='Haskell network package' PACKAGE_TARNAME='network' -PACKAGE_VERSION='2.8.0.1' -PACKAGE_STRING='Haskell network package 2.8.0.1' +PACKAGE_VERSION='3.0.0.0' +PACKAGE_STRING='Haskell network package 3.0.0.0' PACKAGE_BUGREPORT='libraries@haskell.org' PACKAGE_URL='' @@ -624,9 +624,6 @@ ac_subst_vars='LTLIBOBJS LIBOBJS -EXTRA_SRCS -EXTRA_LIBS -EXTRA_CPPFLAGS EGREP GREP CPP @@ -1248,7 +1245,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures Haskell network package 2.8.0.1 to adapt to many kinds of systems. +\`configure' configures Haskell network package 3.0.0.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1314,7 +1311,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of Haskell network package 2.8.0.1:";; + short | recursive ) echo "Configuration of Haskell network package 3.0.0.0:";; esac cat <<\_ACEOF @@ -1399,7 +1396,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -Haskell network package configure 2.8.0.1 +Haskell network package configure 3.0.0.0 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1652,6 +1649,60 @@ } # ac_fn_c_check_header_compile +# ac_fn_c_check_type LINENO TYPE VAR INCLUDES +# ------------------------------------------- +# Tests whether TYPE exists after having included INCLUDES, setting cache +# variable VAR accordingly. +ac_fn_c_check_type () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=no" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +if (sizeof ($2)) + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +if (sizeof (($2))) + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + eval "$3=yes" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_type + # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. @@ -1765,6 +1816,52 @@ } # ac_fn_c_check_func +# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES +# --------------------------------------------- +# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR +# accordingly. +ac_fn_c_check_decl () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + as_decl_name=`echo $2|sed 's/ *(.*//'` + as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 +$as_echo_n "checking whether $as_decl_name is declared... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +#ifndef $as_decl_name +#ifdef __cplusplus + (void) $as_decl_use; +#else + (void) $as_decl_name; +#endif +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_decl + # ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES # ---------------------------------------------------- # Tries to find if the field MEMBER exists in type AGGR, after including @@ -1821,57 +1918,11 @@ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_member - -# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES -# --------------------------------------------- -# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR -# accordingly. -ac_fn_c_check_decl () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - as_decl_name=`echo $2|sed 's/ *(.*//'` - as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 -$as_echo_n "checking whether $as_decl_name is declared... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -int -main () -{ -#ifndef $as_decl_name -#ifdef __cplusplus - (void) $as_decl_use; -#else - (void) $as_decl_name; -#endif -#endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_decl cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by Haskell network package $as_me 2.8.0.1, which was +It was created by Haskell network package $as_me 3.0.0.0, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2220,26 +2271,59 @@ -ac_includes_default="$ac_includes_default +ac_includes_default="#define _GNU_SOURCE 1 /* for struct ucred on Linux */ +$ac_includes_default + +#ifdef _WIN32 +# include +# include +# define IPV6_V6ONLY 27 +#endif + +#ifdef HAVE_LIMITS_H +# include +#endif +#ifdef HAVE_STDLIB_H +# include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_FCNTL_H +# include +#endif +#ifdef HAVE_SYS_UIO_H +# include +#endif #ifdef HAVE_SYS_SOCKET_H # include #endif #ifdef HAVE_NETINET_IN_H # include #endif +#ifdef HAVE_NETINET_TCP_H +# include +#endif +#ifdef HAVE_SYS_UN_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif #ifdef HAVE_NETDB_H -# include +#include #endif -#ifdef HAVE_WINSOCK2_H -# include +#ifdef HAVE_NET_IF_H +# include #endif -#ifdef HAVE_WS2TCPIP_H -# include -// fix for MingW not defining IPV6_V6ONLY -# define IPV6_V6ONLY 27 -#endif" +#ifdef HAVE_NETIOAPI_H +# include +#endif +" -# Safety check: Ensure that we are in the correct source directory. ac_config_headers="$ac_config_headers include/HsNetworkConfig.h" @@ -3622,7 +3706,7 @@ done -for ac_header in fcntl.h limits.h stdlib.h sys/types.h unistd.h winsock2.h ws2tcpip.h +for ac_header in limits.h stdlib.h unistd.h sys/types.h fcntl.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" @@ -3635,7 +3719,7 @@ done -for ac_header in arpa/inet.h netdb.h netinet/in.h netinet/tcp.h sys/socket.h sys/uio.h sys/un.h linux/can.h linux/tcp.h +for ac_header in sys/uio.h sys/socket.h netinet/in.h netinet/tcp.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" @@ -3648,294 +3732,62 @@ done -for ac_header in net/if.h +for ac_header in sys/un.h arpa/inet.h netdb.h do : - ac_fn_c_check_header_mongrel "$LINENO" "net/if.h" "ac_cv_header_net_if_h" "$ac_includes_default" -if test "x$ac_cv_header_net_if_h" = xyes; then : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF -#define HAVE_NET_IF_H 1 +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done - -for ac_func in readlink symlink if_nametoindex +for ac_header in net/if.h netioapi.h do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` -ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" -if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi -done - -ac_fn_c_check_member "$LINENO" "struct msghdr" "msg_control" "ac_cv_member_struct_msghdr_msg_control" "#if HAVE_SYS_TYPES_H -# include -#endif -#if HAVE_SYS_SOCKET_H -# include -#endif -#if HAVE_SYS_UIO_H -# include -#endif -" -if test "x$ac_cv_member_struct_msghdr_msg_control" = xyes; then : - -cat >>confdefs.h <<_ACEOF -#define HAVE_STRUCT_MSGHDR_MSG_CONTROL 1 -_ACEOF - - -fi -ac_fn_c_check_member "$LINENO" "struct msghdr" "msg_accrights" "ac_cv_member_struct_msghdr_msg_accrights" "#if HAVE_SYS_TYPES_H -# include -#endif -#if HAVE_SYS_SOCKET_H -# include -#endif -#if HAVE_SYS_UIO_H -# include -#endif -" -if test "x$ac_cv_member_struct_msghdr_msg_accrights" = xyes; then : - -cat >>confdefs.h <<_ACEOF -#define HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS 1 -_ACEOF - - -fi +done -ac_fn_c_check_member "$LINENO" "struct sockaddr" "sa_len" "ac_cv_member_struct_sockaddr_sa_len" "#if HAVE_SYS_TYPES_H -# include -#endif -#if HAVE_SYS_SOCKET_H -# include -#endif -" -if test "x$ac_cv_member_struct_sockaddr_sa_len" = xyes; then : +ac_fn_c_check_type "$LINENO" "struct ucred" "ac_cv_type_struct_ucred" "$ac_includes_default" +if test "x$ac_cv_type_struct_ucred" = xyes; then : cat >>confdefs.h <<_ACEOF -#define HAVE_STRUCT_SOCKADDR_SA_LEN 1 +#define HAVE_STRUCT_UCRED 1 _ACEOF fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for in_addr_t in netinet/in.h" >&5 -$as_echo_n "checking for in_addr_t in netinet/in.h... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "in_addr_t" >/dev/null 2>&1; then : - -$as_echo "#define HAVE_IN_ADDR_T 1" >>confdefs.h - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi -rm -f conftest* - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for SO_PEERCRED and struct ucred in sys/socket.h" >&5 -$as_echo_n "checking for SO_PEERCRED and struct ucred in sys/socket.h... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -#include -#ifndef SO_PEERCRED -# error no SO_PEERCRED -#endif -struct ucred u; -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_ucred=yes -else - ac_cv_ucred=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -if test "x$ac_cv_ucred" = xno; then - old_CFLAGS="$CFLAGS" - CFLAGS="-D_GNU_SOURCE $CFLAGS" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -#include -#ifndef SO_PEERCRED -# error no SO_PEERCRED -#endif -struct ucred u; -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_ucred=yes -else - ac_cv_ucred=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - if test "x$ac_cv_ucred" = xyes; then - EXTRA_CPPFLAGS=-D_GNU_SOURCE - fi -else - old_CFLAGS="$CFLAGS" -fi -if test "x$ac_cv_ucred" = xno; then - CFLAGS="$old_CFLAGS" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -else - -$as_echo "#define HAVE_STRUCT_UCRED 1" >>confdefs.h - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -fi - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for getpeereid in unistd.h" >&5 -$as_echo_n "checking for getpeereid in unistd.h... " >&6; } -ac_fn_c_check_func "$LINENO" "getpeereid" "ac_cv_func_getpeereid" -if test "x$ac_cv_func_getpeereid" = xyes; then : - -$as_echo "#define HAVE_GETPEEREID 1" >>confdefs.h - -fi - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for _head_libws2_32_a in -lws2_32" >&5 -$as_echo_n "checking for _head_libws2_32_a in -lws2_32... " >&6; } -if ${ac_cv_lib_ws2_32__head_libws2_32_a+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lws2_32 $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char _head_libws2_32_a (); -int -main () -{ -return _head_libws2_32_a (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_ws2_32__head_libws2_32_a=yes -else - ac_cv_lib_ws2_32__head_libws2_32_a=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ws2_32__head_libws2_32_a" >&5 -$as_echo "$ac_cv_lib_ws2_32__head_libws2_32_a" >&6; } -if test "x$ac_cv_lib_ws2_32__head_libws2_32_a" = xyes; then : +for ac_func in gai_strerror gethostent accept4 +do : + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` +ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF -#define HAVE_LIBWS2_32 1 +#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF - LIBS="-lws2_32 $LIBS" - fi - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for getaddrinfo" >&5 -$as_echo_n "checking for getaddrinfo... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$ac_includes_default -int testme(){ getaddrinfo; } -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -$as_echo "#define HAVE_GETADDRINFO 1" >>confdefs.h - ac_have_getaddrinfo=yes; { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -if test "x$ac_have_getaddrinfo" = x; then - old_CFLAGS="$CFLAGS" - if test "z$ac_cv_lib_ws2_32__head_libws2_32_a" = zyes; then - CFLAGS="-DWINVER=0x0501 $CFLAGS" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for getaddrinfo if WINVER is 0x0501" >&5 -$as_echo_n "checking for getaddrinfo if WINVER is 0x0501... " >&6; } - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$ac_includes_default - int testme(){ getaddrinfo; } -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -$as_echo "#define HAVE_GETADDRINFO 1" >>confdefs.h - -$as_echo "#define NEED_WINVER_XP 1" >>confdefs.h - EXTRA_CPPFLAGS="-DWINVER=0x0501 $EXTRA_CPPFLAGS"; { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -else - CFLAGS="$old_CFLAGS"; { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - fi -fi +done -for ac_func in gai_strerror +for ac_func in getpeereid do : - ac_fn_c_check_func "$LINENO" "gai_strerror" "ac_cv_func_gai_strerror" -if test "x$ac_cv_func_gai_strerror" = xyes; then : + ac_fn_c_check_func "$LINENO" "getpeereid" "ac_cv_func_getpeereid" +if test "x$ac_cv_func_getpeereid" = xyes; then : cat >>confdefs.h <<_ACEOF -#define HAVE_GAI_STRERROR 1 +#define HAVE_GETPEEREID 1 _ACEOF fi @@ -3983,7 +3835,6 @@ #define HAVE_DECL_AI_V4MAPPED $ac_have_decl _ACEOF - ac_fn_c_check_decl "$LINENO" "IPV6_V6ONLY" "ac_cv_have_decl_IPV6_V6ONLY" "$ac_includes_default" if test "x$ac_cv_have_decl_IPV6_V6ONLY" = xyes; then : ac_have_decl=1 @@ -3995,7 +3846,6 @@ #define HAVE_DECL_IPV6_V6ONLY $ac_have_decl _ACEOF - ac_fn_c_check_decl "$LINENO" "IPPROTO_IP" "ac_cv_have_decl_IPPROTO_IP" "$ac_includes_default" if test "x$ac_cv_have_decl_IPPROTO_IP" = xyes; then : ac_have_decl=1 @@ -4027,91 +3877,51 @@ #define HAVE_DECL_IPPROTO_IPV6 $ac_have_decl _ACEOF - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for sendfile in sys/sendfile.h" >&5 -$as_echo_n "checking for sendfile in sys/sendfile.h... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "sendfile" >/dev/null 2>&1; then : - -$as_echo "#define HAVE_LINUX_SENDFILE 1" >>confdefs.h - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } +ac_fn_c_check_decl "$LINENO" "SO_PEERCRED" "ac_cv_have_decl_SO_PEERCRED" "$ac_includes_default" +if test "x$ac_cv_have_decl_SO_PEERCRED" = xyes; then : + ac_have_decl=1 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } + ac_have_decl=0 fi -rm -f conftest* - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for sendfile in sys/socket.h" >&5 -$as_echo_n "checking for sendfile in sys/socket.h... " >&6; } -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_SO_PEERCRED $ac_have_decl _ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "sendfile" >/dev/null 2>&1; then : -$as_echo "#define HAVE_BSD_SENDFILE 1" >>confdefs.h - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi -rm -f conftest* +ac_fn_c_check_member "$LINENO" "struct msghdr" "msg_control" "ac_cv_member_struct_msghdr_msg_control" "$ac_includes_default" +if test "x$ac_cv_member_struct_msghdr_msg_control" = xyes; then : -for ac_func in gethostent -do : - ac_fn_c_check_func "$LINENO" "gethostent" "ac_cv_func_gethostent" -if test "x$ac_cv_func_gethostent" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_GETHOSTENT 1 +cat >>confdefs.h <<_ACEOF +#define HAVE_STRUCT_MSGHDR_MSG_CONTROL 1 _ACEOF -fi -done +fi +ac_fn_c_check_member "$LINENO" "struct msghdr" "msg_accrights" "ac_cv_member_struct_msghdr_msg_accrights" "$ac_includes_default" +if test "x$ac_cv_member_struct_msghdr_msg_accrights" = xyes; then : -for ac_func in accept4 -do : - ac_fn_c_check_func "$LINENO" "accept4" "ac_cv_func_accept4" -if test "x$ac_cv_func_accept4" = xyes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_ACCEPT4 1 +cat >>confdefs.h <<_ACEOF +#define HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS 1 _ACEOF + fi -done +ac_fn_c_check_member "$LINENO" "struct sockaddr" "sa_len" "ac_cv_member_struct_sockaddr_sa_len" "$ac_includes_default" +if test "x$ac_cv_member_struct_sockaddr_sa_len" = xyes; then : -case "$host" in -*-mingw* | *-msys*) - EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c" - EXTRA_LIBS=ws2_32 - ;; -*-solaris2*) - EXTRA_SRCS="cbits/ancilData.c" - EXTRA_LIBS="nsl, socket" - ;; -*) - EXTRA_SRCS="cbits/ancilData.c" - EXTRA_LIBS= - ;; -esac +cat >>confdefs.h <<_ACEOF +#define HAVE_STRUCT_SOCKADDR_SA_LEN 1 +_ACEOF +fi -ac_config_files="$ac_config_files network.buildinfo" - +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating ./network.buildinfo" >&5 +$as_echo "$as_me: creating ./network.buildinfo" >&6;} +echo "install-includes: HsNetworkConfig.h" > network.buildinfo cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure @@ -4619,7 +4429,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by Haskell network package $as_me 2.8.0.1, which was +This file was extended by Haskell network package $as_me 3.0.0.0, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -4633,9 +4443,6 @@ _ACEOF -case $ac_config_files in *" -"*) set x $ac_config_files; shift; ac_config_files=$*;; -esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; @@ -4644,7 +4451,6 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. -config_files="$ac_config_files" config_headers="$ac_config_headers" _ACEOF @@ -4664,14 +4470,9 @@ do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE -Configuration files: -$config_files - Configuration headers: $config_headers @@ -4681,7 +4482,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -Haskell network package config.status 2.8.0.1 +Haskell network package config.status 3.0.0.0 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" @@ -4727,14 +4528,6 @@ $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; - --file | --fil | --fi | --f ) - $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" - ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in @@ -4803,7 +4596,6 @@ do case $ac_config_target in "include/HsNetworkConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS include/HsNetworkConfig.h" ;; - "network.buildinfo") CONFIG_FILES="$CONFIG_FILES network.buildinfo" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac @@ -4815,7 +4607,6 @@ # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then - test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers fi @@ -4846,164 +4637,6 @@ } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp -# Set up the scripts for CONFIG_FILES section. -# No need to generate them if there are no CONFIG_FILES. -# This happens for instance with `./config.status config.h'. -if test -n "$CONFIG_FILES"; then - - -ac_cr=`echo X | tr X '\015'` -# On cygwin, bash can eat \r inside `` if the user requested igncr. -# But we know of no other shell where ac_cr would be empty at this -# point, so we can use a bashism as a fallback. -if test "x$ac_cr" = x; then - eval ac_cr=\$\'\\r\' -fi -ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` -if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' -else - ac_cs_awk_cr=$ac_cr -fi - -echo 'BEGIN {' >"$ac_tmp/subs1.awk" && -_ACEOF - - -{ - echo "cat >conf$$subs.awk <<_ACEOF" && - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" -} >conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` -ac_delim='%!_!# ' -for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done -rm -f conf$$subs.sh - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && -_ACEOF -sed -n ' -h -s/^/S["/; s/!.*/"]=/ -p -g -s/^[^!]*!// -:repl -t repl -s/'"$ac_delim"'$// -t delim -:nl -h -s/\(.\{148\}\)..*/\1/ -t more1 -s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ -p -n -b repl -:more1 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t nl -:delim -h -s/\(.\{148\}\)..*/\1/ -t more2 -s/["\\]/\\&/g; s/^/"/; s/$/"/ -p -b -:more2 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t delim -' >$CONFIG_STATUS || ac_write_fail=1 -rm -f conf$$subs.awk -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACAWK -cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && - for (key in S) S_is_set[key] = 1 - FS = "" - -} -{ - line = $ 0 - nfields = split(line, field, "@") - substed = 0 - len = length(field[1]) - for (i = 2; i < nfields; i++) { - key = field[i] - keylen = length(key) - if (S_is_set[key]) { - value = S[key] - line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) - len += length(value) + length(field[++i]) - substed = 1 - } else - len += 1 + keylen - } - - print line -} - -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then - sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" -else - cat -fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 -_ACEOF - -# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -s/^[^=]*=[ ]*$// -}' -fi - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -fi # test -n "$CONFIG_FILES" - # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. @@ -5113,7 +4746,7 @@ fi # test -n "$CONFIG_HEADERS" -eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " +eval set X " :H $CONFIG_HEADERS " shift for ac_tag do @@ -5242,85 +4875,7 @@ case $ac_mode in - :F) - # - # CONFIG_FILE - # -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# If the template does not know about datarootdir, expand it. -# FIXME: This hack should be removed a few years after 2.60. -ac_datarootdir_hack=; ac_datarootdir_seen= -ac_sed_dataroot=' -/datarootdir/ { - p - q -} -/@datadir@/p -/@docdir@/p -/@infodir@/p -/@localedir@/p -/@mandir@/p' -case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in -*datarootdir*) ac_datarootdir_seen=yes;; -*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 -$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - ac_datarootdir_hack=' - s&@datadir@&$datadir&g - s&@docdir@&$docdir&g - s&@infodir@&$infodir&g - s&@localedir@&$localedir&g - s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; -esac -_ACEOF - -# Neutralize VPATH when `$srcdir' = `.'. -# Shell code in configure.ac might set extrasub. -# FIXME: do we really want to maintain this feature? -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_sed_extra="$ac_vpsub -$extrasub -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -:t -/@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s|@configure_input@|$ac_sed_conf_input|;t t -s&@top_builddir@&$ac_top_builddir_sub&;t t -s&@top_build_prefix@&$ac_top_build_prefix&;t t -s&@srcdir@&$ac_srcdir&;t t -s&@abs_srcdir@&$ac_abs_srcdir&;t t -s&@top_srcdir@&$ac_top_srcdir&;t t -s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t -s&@builddir@&$ac_builddir&;t t -s&@abs_builddir@&$ac_abs_builddir&;t t -s&@abs_top_builddir@&$ac_abs_top_builddir&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - -test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&5 -$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; - esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; :H) # # CONFIG_HEADER diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,25 +1,62 @@ -AC_INIT([Haskell network package], [2.8.0.1], [libraries@haskell.org], [network]) +AC_INIT([Haskell network package], + [3.0.0.0], + [libraries@haskell.org], + [network]) -ac_includes_default="$ac_includes_default +dnl See also HsNet.h +ac_includes_default="#define _GNU_SOURCE 1 /* for struct ucred on Linux */ +$ac_includes_default + +#ifdef _WIN32 +# include +# include +# define IPV6_V6ONLY 27 +#endif + +#ifdef HAVE_LIMITS_H +# include +#endif +#ifdef HAVE_STDLIB_H +# include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_FCNTL_H +# include +#endif +#ifdef HAVE_SYS_UIO_H +# include +#endif #ifdef HAVE_SYS_SOCKET_H # include #endif #ifdef HAVE_NETINET_IN_H # include #endif +#ifdef HAVE_NETINET_TCP_H +# include +#endif +#ifdef HAVE_SYS_UN_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif #ifdef HAVE_NETDB_H -# include +#include #endif -#ifdef HAVE_WINSOCK2_H -# include +#ifdef HAVE_NET_IF_H +# include #endif -#ifdef HAVE_WS2TCPIP_H -# include -// fix for MingW not defining IPV6_V6ONLY -# define IPV6_V6ONLY 27 -#endif" +#ifdef HAVE_NETIOAPI_H +# include +#endif +" -# Safety check: Ensure that we are in the correct source directory. AC_CONFIG_SRCDIR([include/HsNet.h]) AC_CONFIG_HEADERS([include/HsNetworkConfig.h]) @@ -33,160 +70,26 @@ AC_C_CONST -dnl ** check for specific header (.h) files that we are interested in -AC_CHECK_HEADERS([fcntl.h limits.h stdlib.h sys/types.h unistd.h winsock2.h ws2tcpip.h]) -AC_CHECK_HEADERS([arpa/inet.h netdb.h netinet/in.h netinet/tcp.h sys/socket.h sys/uio.h sys/un.h linux/can.h linux/tcp.h]) -AC_CHECK_HEADERS([net/if.h]) - -AC_CHECK_FUNCS([readlink symlink if_nametoindex]) - -dnl ** check what fields struct msghdr contains -AC_CHECK_MEMBERS([struct msghdr.msg_control, struct msghdr.msg_accrights], [], [], [#if HAVE_SYS_TYPES_H -# include -#endif -#if HAVE_SYS_SOCKET_H -# include -#endif -#if HAVE_SYS_UIO_H -# include -#endif]) - -dnl ** check if struct sockaddr contains sa_len -AC_CHECK_MEMBERS([struct sockaddr.sa_len], [], [], [#if HAVE_SYS_TYPES_H -# include -#endif -#if HAVE_SYS_SOCKET_H -# include -#endif]) - -dnl -------------------------------------------------- -dnl * test for in_addr_t -dnl -------------------------------------------------- -AC_MSG_CHECKING(for in_addr_t in netinet/in.h) -AC_EGREP_HEADER(in_addr_t, netinet/in.h, - [ AC_DEFINE([HAVE_IN_ADDR_T], [1], [Define to 1 if in_addr_t is available.]) AC_MSG_RESULT(yes) ], - AC_MSG_RESULT(no)) - -dnl -------------------------------------------------- -dnl * test for SO_PEERCRED and struct ucred -dnl -------------------------------------------------- -AC_MSG_CHECKING(for SO_PEERCRED and struct ucred in sys/socket.h) -AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include -#include -#ifndef SO_PEERCRED -# error no SO_PEERCRED -#endif -struct ucred u;]])],ac_cv_ucred=yes,ac_cv_ucred=no) -if test "x$ac_cv_ucred" = xno; then - old_CFLAGS="$CFLAGS" - CFLAGS="-D_GNU_SOURCE $CFLAGS" - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include -#include -#ifndef SO_PEERCRED -# error no SO_PEERCRED -#endif -struct ucred u;]])],ac_cv_ucred=yes,ac_cv_ucred=no) - if test "x$ac_cv_ucred" = xyes; then - EXTRA_CPPFLAGS=-D_GNU_SOURCE - fi -else - old_CFLAGS="$CFLAGS" -fi -if test "x$ac_cv_ucred" = xno; then - CFLAGS="$old_CFLAGS" - AC_MSG_RESULT(no) -else - AC_DEFINE([HAVE_STRUCT_UCRED], [1], [Define to 1 if you have both SO_PEERCRED and struct ucred.]) - AC_MSG_RESULT(yes) -fi - -dnl -------------------------------------------------- -dnl * test for GETPEEREID(3) -dnl -------------------------------------------------- -AC_MSG_CHECKING(for getpeereid in unistd.h) -AC_CHECK_FUNC( getpeereid, AC_DEFINE([HAVE_GETPEEREID], [1], [Define to 1 if you have getpeereid.] )) - -dnl -------------------------------------------------- -dnl * check for Windows networking libraries -dnl -------------------------------------------------- -AC_CHECK_LIB(ws2_32, _head_libws2_32_a) - -dnl -------------------------------------------------- -dnl * test for getaddrinfo as proxy for IPv6 support -dnl -------------------------------------------------- -AC_MSG_CHECKING(for getaddrinfo) -dnl Can't use AC_CHECK_FUNC here, because it doesn't do the right -dnl thing on Windows. -AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[$ac_includes_default -int testme(){ getaddrinfo; }]])],[AC_DEFINE([HAVE_GETADDRINFO], [1], [Define to 1 if you have the `getaddrinfo' function.]) ac_have_getaddrinfo=yes; AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)]) +AC_CHECK_HEADERS([limits.h stdlib.h unistd.h sys/types.h fcntl.h]) +AC_CHECK_HEADERS([sys/uio.h sys/socket.h netinet/in.h netinet/tcp.h]) +AC_CHECK_HEADERS([sys/un.h arpa/inet.h netdb.h]) +AC_CHECK_HEADERS([net/if.h netioapi.h]) -dnl Under mingw, we may need to set WINVER to 0x0501 to expose getaddrinfo. -if test "x$ac_have_getaddrinfo" = x; then - old_CFLAGS="$CFLAGS" - if test "z$ac_cv_lib_ws2_32__head_libws2_32_a" = zyes; then - CFLAGS="-DWINVER=0x0501 $CFLAGS" - AC_MSG_CHECKING(for getaddrinfo if WINVER is 0x0501) - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[$ac_includes_default - int testme(){ getaddrinfo; }]])],[AC_DEFINE([HAVE_GETADDRINFO], [1], [Define to 1 if you have the `getaddrinfo' function.]) AC_DEFINE([NEED_WINVER_XP], [1], [Define to 1 if the `getaddrinfo' function needs WINVER set.]) EXTRA_CPPFLAGS="-DWINVER=0x0501 $EXTRA_CPPFLAGS"; AC_MSG_RESULT(yes)],[CFLAGS="$old_CFLAGS"; AC_MSG_RESULT(no)]) - fi -fi +AC_CHECK_TYPES([struct ucred]) -dnl Missing under mingw, sigh. -AC_CHECK_FUNCS(gai_strerror) +AC_CHECK_FUNCS([gai_strerror gethostent accept4]) +AC_CHECK_FUNCS([getpeereid]) -dnl ------------------------------------------------------- -dnl * test for AI_* flags that not all implementations have -dnl ------------------------------------------------------- AC_CHECK_DECLS([AI_ADDRCONFIG, AI_ALL, AI_NUMERICSERV, AI_V4MAPPED]) - -dnl ------------------------------------------------------- -dnl * test for IPV6_V6ONLY flags that not all implementations have -dnl ------------------------------------------------------- AC_CHECK_DECLS([IPV6_V6ONLY]) - -dnl ------------------------------------------------------- -dnl * test for IPPROTO_* macros/constants -dnl ------------------------------------------------------- AC_CHECK_DECLS([IPPROTO_IP, IPPROTO_TCP, IPPROTO_IPV6]) - -dnl -------------------------------------------------- -dnl * test for Linux sendfile(2) -dnl -------------------------------------------------- -AC_MSG_CHECKING(for sendfile in sys/sendfile.h) -AC_EGREP_HEADER(sendfile, sys/sendfile.h, - [ AC_DEFINE([HAVE_LINUX_SENDFILE], [1], [Define to 1 if you have a Linux sendfile(2) implementation.]) AC_MSG_RESULT(yes) ], - AC_MSG_RESULT(no)) - -dnl -------------------------------------------------- -dnl * test for BSD sendfile(2) -dnl -------------------------------------------------- -AC_MSG_CHECKING(for sendfile in sys/socket.h) -AC_EGREP_HEADER(sendfile, sys/socket.h, - [ AC_DEFINE([HAVE_BSD_SENDFILE], [1], [Define to 1 if you have a BSDish sendfile(2) implementation.]) AC_MSG_RESULT(yes) ], - AC_MSG_RESULT(no)) - -AC_CHECK_FUNCS(gethostent) - -AC_CHECK_FUNCS(accept4) +AC_CHECK_DECLS([SO_PEERCRED]) -case "$host" in -*-mingw* | *-msys*) - EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c" - EXTRA_LIBS=ws2_32 - ;; -*-solaris2*) - EXTRA_SRCS="cbits/ancilData.c" - EXTRA_LIBS="nsl, socket" - ;; -*) - EXTRA_SRCS="cbits/ancilData.c" - EXTRA_LIBS= - ;; -esac -AC_SUBST([EXTRA_CPPFLAGS]) -AC_SUBST([EXTRA_LIBS]) -AC_SUBST([EXTRA_SRCS]) +AC_CHECK_MEMBERS([struct msghdr.msg_control, struct msghdr.msg_accrights]) +AC_CHECK_MEMBERS([struct sockaddr.sa_len]) -AC_CONFIG_FILES([network.buildinfo]) +dnl This is a necessary hack +AC_MSG_NOTICE([creating ./network.buildinfo]) +echo "install-includes: HsNetworkConfig.h" > network.buildinfo AC_OUTPUT diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -4,7 +4,7 @@ import qualified Control.Exception as E import qualified Data.ByteString.Char8 as C -import Network.Socket hiding (recv) +import Network.Socket import Network.Socket.ByteString (recv, sendAll) main :: IO () diff --git a/examples/EchoServer.hs b/examples/EchoServer.hs --- a/examples/EchoServer.hs +++ b/examples/EchoServer.hs @@ -5,7 +5,7 @@ import qualified Control.Exception as E import Control.Monad (unless, forever, void) import qualified Data.ByteString as S -import Network.Socket hiding (recv) +import Network.Socket import Network.Socket.ByteString (recv, sendAll) main :: IO () @@ -25,7 +25,7 @@ setSocketOption sock ReuseAddr 1 -- If the prefork technique is not used, -- set CloseOnExec for the security reasons. - let fd = fdSocket sock + fd <- fdSocket sock setCloseOnExecIfNeeded fd bind sock (addrAddress addr) listen sock 10 diff --git a/include/HsNet.h b/include/HsNet.h --- a/include/HsNet.h +++ b/include/HsNet.h @@ -9,10 +9,6 @@ #include "HsNetDef.h" -#ifdef NEED_WINVER -# define WINVER 0x0501 -#endif - #ifndef INLINE # if defined(_MSC_VER) # define INLINE extern __inline @@ -23,29 +19,13 @@ # endif #endif -#ifdef HAVE_GETADDRINFO -# define IPV6_SOCKET_SUPPORT 1 -#else -# undef IPV6_SOCKET_SUPPORT -#endif - -#if defined(HAVE_WINSOCK2_H) -#include -# ifdef HAVE_WS2TCPIP_H -# include -// fix for MingW not defining IPV6_V6ONLY -# define IPV6_V6ONLY 27 -# endif - -extern int initWinSock (); -extern const char* getWSErrorDescr(int err); -extern void* newAcceptParams(int sock, - int sz, - void* sockaddr); -extern int acceptNewSock(void* d); -extern int acceptDoProc(void* param); +#define _GNU_SOURCE 1 /* for struct ucred on Linux */ -#else +#ifdef _WIN32 +# include +# include +# define IPV6_V6ONLY 27 +#endif #ifdef HAVE_LIMITS_H # include @@ -68,14 +48,12 @@ #ifdef HAVE_SYS_SOCKET_H # include #endif -#ifdef HAVE_LINUX_TCP_H -# include -#elif HAVE_NETINET_TCP_H -# include -#endif #ifdef HAVE_NETINET_IN_H # include #endif +#ifdef HAVE_NETINET_TCP_H +# include +#endif #ifdef HAVE_SYS_UN_H # include #endif @@ -85,34 +63,32 @@ #ifdef HAVE_NETDB_H #include #endif -#ifdef HAVE_LINUX_CAN_H -# include -# define CAN_SOCKET_SUPPORT 1 -#endif -#ifdef HAVE_NET_IF +#ifdef HAVE_NET_IF_H # include #endif - -#ifdef HAVE_BSD_SENDFILE -#include -#endif -#ifdef HAVE_LINUX_SENDFILE -#if !defined(__USE_FILE_OFFSET64) -#include -#endif +#ifdef HAVE_NETIOAPI_H +# include #endif +#ifdef _WIN32 +extern int initWinSock (); +extern const char* getWSErrorDescr(int err); +extern void* newAcceptParams(int sock, + int sz, + void* sockaddr); +extern int acceptNewSock(void* d); +extern int acceptDoProc(void* param); +#else /* _WIN32 */ extern int sendFd(int sock, int outfd); extern int recvFd(int sock); - -#endif /* HAVE_WINSOCK2_H */ +#endif /* _WIN32 */ INLINE char * hsnet_inet_ntoa( -#if defined(HAVE_WINSOCK2_H) +#if defined(_WIN32) u_long addr #elif defined(HAVE_IN_ADDR_T) in_addr_t addr @@ -128,10 +104,9 @@ return inet_ntoa(a); } -#ifdef HAVE_GETADDRINFO INLINE int hsnet_getnameinfo(const struct sockaddr* a,socklen_t b, char* c, -# if defined(HAVE_WINSOCK2_H) +# if defined(_WIN32) DWORD d, char* e, DWORD f, int g) # else socklen_t d, char* e, socklen_t f, int g) @@ -152,13 +127,12 @@ { freeaddrinfo(ai); } -#endif -#if !defined(IOV_MAX) +#ifndef IOV_MAX # define IOV_MAX 1024 #endif -#if !defined(SOCK_NONBLOCK) // Missing define in Bionic libc (Android) +#ifndef SOCK_NONBLOCK // Missing define in Bionic libc (Android) # define SOCK_NONBLOCK O_NONBLOCK #endif diff --git a/include/HsNetDef.h b/include/HsNetDef.h --- a/include/HsNetDef.h +++ b/include/HsNetDef.h @@ -10,14 +10,22 @@ #undef PACKAGE_TARNAME #undef PACKAGE_VERSION -#if defined(HAVE_WINSOCK2_H) -# define WITH_WINSOCK 1 -#endif - #if !defined(mingw32_HOST_OS) && !defined(_WIN32) # define DOMAIN_SOCKET_SUPPORT 1 #endif +#if defined(HAVE_STRUCT_UCRED) && HAVE_DECL_SO_PEERCRED +# define HAVE_STRUCT_UCRED_SO_PEERCRED 1 +#else +# undef HAVE_STRUCT_UCRED_SO_PEERCRED +#endif + +#ifdef HAVE_ACCEPT4 +# define HAVE_ADVANCED_SOCKET_FLAGS 1 +#else +# undef HAVE_ADVANCED_SOCKET_FLAGS +#endif + /* stdcall is for Windows 32. Haskell FFI does not have a keyword for Windows 64. If ccall/stdcall is specified on Windows 64, @@ -36,6 +44,7 @@ #else # define CALLCONV ccall #endif + #if defined(mingw32_HOST_OS) # define SAFE_ON_WIN safe #else diff --git a/include/HsNetworkConfig.h.in b/include/HsNetworkConfig.h.in --- a/include/HsNetworkConfig.h.in +++ b/include/HsNetworkConfig.h.in @@ -6,9 +6,6 @@ /* Define to 1 if you have the header file. */ #undef HAVE_ARPA_INET_H -/* Define to 1 if you have a BSDish sendfile(2) implementation. */ -#undef HAVE_BSD_SENDFILE - /* Define to 1 if you have the declaration of `AI_ADDRCONFIG', and to 0 if you don't. */ #undef HAVE_DECL_AI_ADDRCONFIG @@ -41,45 +38,28 @@ don't. */ #undef HAVE_DECL_IPV6_V6ONLY +/* Define to 1 if you have the declaration of `SO_PEERCRED', and to 0 if you + don't. */ +#undef HAVE_DECL_SO_PEERCRED + /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H /* Define to 1 if you have the `gai_strerror' function. */ #undef HAVE_GAI_STRERROR -/* Define to 1 if you have the `getaddrinfo' function. */ -#undef HAVE_GETADDRINFO - /* Define to 1 if you have the `gethostent' function. */ #undef HAVE_GETHOSTENT -/* Define to 1 if you have getpeereid. */ +/* Define to 1 if you have the `getpeereid' function. */ #undef HAVE_GETPEEREID -/* Define to 1 if you have the `if_nametoindex' function. */ -#undef HAVE_IF_NAMETOINDEX - /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H -/* Define to 1 if in_addr_t is available. */ -#undef HAVE_IN_ADDR_T - -/* Define to 1 if you have the `ws2_32' library (-lws2_32). */ -#undef HAVE_LIBWS2_32 - /* Define to 1 if you have the header file. */ #undef HAVE_LIMITS_H -/* Define to 1 if you have the header file. */ -#undef HAVE_LINUX_CAN_H - -/* Define to 1 if you have a Linux sendfile(2) implementation. */ -#undef HAVE_LINUX_SENDFILE - -/* Define to 1 if you have the header file. */ -#undef HAVE_LINUX_TCP_H - /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H @@ -92,12 +72,12 @@ /* Define to 1 if you have the header file. */ #undef HAVE_NETINET_TCP_H +/* Define to 1 if you have the header file. */ +#undef HAVE_NETIOAPI_H + /* Define to 1 if you have the header file. */ #undef HAVE_NET_IF_H -/* Define to 1 if you have the `readlink' function. */ -#undef HAVE_READLINK - /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H @@ -119,12 +99,9 @@ /* Define to 1 if `sa_len' is a member of `struct sockaddr'. */ #undef HAVE_STRUCT_SOCKADDR_SA_LEN -/* Define to 1 if you have both SO_PEERCRED and struct ucred. */ +/* Define to 1 if the system has the type `struct ucred'. */ #undef HAVE_STRUCT_UCRED -/* Define to 1 if you have the `symlink' function. */ -#undef HAVE_SYMLINK - /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SOCKET_H @@ -142,15 +119,6 @@ /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_WINSOCK2_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_WS2TCPIP_H - -/* Define to 1 if the `getaddrinfo' function needs WINVER set. */ -#undef NEED_WINVER_XP /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT diff --git a/network.buildinfo.in b/network.buildinfo.in deleted file mode 100644 --- a/network.buildinfo.in +++ /dev/null @@ -1,7 +0,0 @@ -ghc-options: @EXTRA_CPPFLAGS@ -ghc-prof-options: @EXTRA_CPPFLAGS@ -ld-options: @LDFLAGS@ -cc-options: @EXTRA_CPPFLAGS@ -c-sources: @EXTRA_SRCS@ -extra-libraries: @EXTRA_LIBS@ -install-includes: HsNetworkConfig.h diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,5 +1,6 @@ +cabal-version: 1.18 name: network -version: 2.8.0.1 +version: 3.0.0.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Evan Borden @@ -7,23 +8,35 @@ description: This package provides a low-level networking interface. . - In network-2.6 the @Network.URI@ module was split off into its own - package, network-uri-2.6. If you're using the @Network.URI@ module - you can automatically get it from the right package by adding this - to your .cabal file: + === High-Level Packages + Other packages provide higher level interfaces: . + * connection + * hookup + * network-simple + . + === Related Packages + ==== @network-bsd@ + In @network-3.0.0.0@ the @Network.BSD@ module was split off into its own + package, @network-bsd-3.0.0.0@. + . + ==== @network-uri@ + In @network-2.6@ the @Network.URI@ module was split off into its own package, + @network-uri-2.6@. If you're using the @Network.URI@ module you can + automatically get it from the right package by adding this to your @.cabal@ + file: + . > library > build-depends: network-uri-flag category: Network build-type: Configure -cabal-version: >=1.8 extra-tmp-files: config.log config.status autom4te.cache network.buildinfo include/HsNetworkConfig.h extra-source-files: README.md CHANGELOG.md examples/*.hs tests/*.hs config.guess config.sub install-sh - configure.ac configure network.buildinfo.in + 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 @@ -34,53 +47,76 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.3 + , GHC == 8.4.4 + , GHC == 8.6.2 library + default-language: Haskell2010 exposed-modules: - Network - Network.BSD Network.Socket + Network.Socket.Address Network.Socket.ByteString Network.Socket.ByteString.Lazy Network.Socket.Internal other-modules: + Network.Socket.Buffer Network.Socket.ByteString.Internal + Network.Socket.ByteString.IO + Network.Socket.Cbits + Network.Socket.Fcntl + Network.Socket.Handle + Network.Socket.Imports + Network.Socket.If + Network.Socket.Info + Network.Socket.Name + Network.Socket.Options + Network.Socket.Shutdown + Network.Socket.SockAddr + Network.Socket.Syscall Network.Socket.Types - - if !os(windows) - other-modules: - Network.Socket.ByteString.IOVec - Network.Socket.ByteString.Lazy.Posix - Network.Socket.ByteString.MsgHdr - if os(windows) - other-modules: - Network.Socket.ByteString.Lazy.Windows + Network.Socket.Unix build-depends: base >= 4.7 && < 5, - bytestring == 0.10.* - - if !os(windows) - build-depends: - unix >= 2 + bytestring == 0.10.*, + deepseq - extensions: - CPP, DeriveDataTypeable, ForeignFunctionInterface, TypeSynonymInstances include-dirs: include includes: HsNet.h HsNetDef.h install-includes: HsNet.h HsNetDef.h c-sources: cbits/HsNet.c ghc-options: -Wall -fwarn-tabs + build-tools: hsc2hs + + -- Add some platform specific stuff + if !os(windows) + other-modules: + Network.Socket.ByteString.IOVec + Network.Socket.ByteString.Lazy.Posix + Network.Socket.ByteString.MsgHdr + build-depends: + unix >= 2 + c-sources: cbits/ancilData.c + + if os(solaris) + extra-libraries: nsl, socket + + if os(windows) + other-modules: + Network.Socket.ByteString.Lazy.Windows + c-sources: cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c + extra-libraries: ws2_32 + -- See https://github.com/haskell/network/pull/362 + if impl(ghc >= 7.10) + cpp-options: -D_WIN32_WINNT=0x0600 + test-suite spec + default-language: Haskell2010 hs-source-dirs: tests main-is: Spec.hs - other-modules: - Network.Test.Common - Network.SocketSpec - Network.Socket.ByteStringSpec - Network.Socket.ByteString.LazySpec + other-modules: RegressionSpec + SimpleSpec type: exitcode-stdio-1.0 ghc-options: -Wall -threaded -- NB: make sure to versions of hspec and hspec-discover @@ -95,14 +131,17 @@ network, hspec >= 2.6 -test-suite doctest +test-suite doctests + buildable: False + default-language: Haskell2010 hs-source-dirs: tests main-is: doctests.hs type: exitcode-stdio-1.0 build-depends: base >= 4.7 && < 5, - doctest >= 0.10.1 + doctest >= 0.10.1, + network ghc-options: -Wall diff --git a/tests/Network/Socket/ByteString/LazySpec.hs b/tests/Network/Socket/ByteString/LazySpec.hs deleted file mode 100644 --- a/tests/Network/Socket/ByteString/LazySpec.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Socket.ByteString.LazySpec (main, spec) where - -import Prelude hiding (getContents) - -import qualified Data.ByteString.Lazy as L -import Network.Socket hiding (recv, recvFrom, send, sendTo) -import Network.Socket.ByteString.Lazy -import Network.Test.Common -import Control.Monad - -import Test.Hspec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "send" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` lazyTestMsg - client sock = send sock lazyTestMsg - tcpTest client server - - describe "sendAll" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` lazyTestMsg - client sock = sendAll sock lazyTestMsg - tcpTest client server - - describe "getContents" $ do - it "works well" $ do - let server sock = getContents sock `shouldReturn` lazyTestMsg - client sock = do - void $ send sock lazyTestMsg - shutdown sock ShutdownSend - tcpTest client server - - describe "recv" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` lazyTestMsg - client sock = send sock lazyTestMsg - tcpTest client server - - it "can treat overflow" $ do - let server sock = do - seg1 <- recv sock (L.length lazyTestMsg - 3) - seg2 <- recv sock 1024 - let msg = L.append seg1 seg2 - msg `shouldBe` lazyTestMsg - client sock = send sock lazyTestMsg - tcpTest client server diff --git a/tests/Network/Socket/ByteStringSpec.hs b/tests/Network/Socket/ByteStringSpec.hs deleted file mode 100644 --- a/tests/Network/Socket/ByteStringSpec.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.Socket.ByteStringSpec (main, spec) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as C -import Network.Socket hiding (recv, recvFrom, send, sendTo) -import Network.Socket.ByteString -import Network.Test.Common - -import Test.Hspec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "send" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock = send sock testMsg - tcpTest client server - - it "checks -1 correctly on Windows" $ do - sock <- socket AF_INET Stream defaultProtocol - send sock "hello world" `shouldThrow` anyException - - describe "sendAll" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock = sendAll sock testMsg - tcpTest client server - - 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 - 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 - udpTest client server - - describe "sendMany" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` S.append seg1 seg2 - client sock = sendMany sock [seg1, seg2] - - seg1 = C.pack "This is a " - seg2 = C.pack "test message." - tcpTest client server - - 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 - - seg1 = C.pack "This is a " - seg2 = C.pack "test message." - udpTest client server - - describe "recv" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock = send sock testMsg - tcpTest client server - - it "can treat overflow" $ do - let server sock = do - seg1 <- recv sock (S.length testMsg - 3) - seg2 <- recv sock 1024 - let msg = S.append seg1 seg2 - msg `shouldBe` testMsg - client sock = send sock testMsg - tcpTest client server - - it "checks -1 correctly on Windows" $ do - sock <- socket AF_INET Stream defaultProtocol - recv sock 1024 `shouldThrow` anyException - - describe "recvFrom" $ do - it "works well" $ do - let server sock = do - (msg, _) <- recvFrom sock 1024 - testMsg `shouldBe` msg - client sock = do - addr <- getPeerName sock - sendTo sock testMsg addr - tcpTest client server - - it "can treat overflow" $ do - let server sock = do - (seg1, _) <- recvFrom sock (S.length testMsg - 3) - (seg2, _) <- recvFrom sock 1024 - let msg = S.append seg1 seg2 - testMsg `shouldBe` msg - client sock = send sock testMsg - tcpTest client server diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs deleted file mode 100644 --- a/tests/Network/SocketSpec.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.SocketSpec (main, spec) where - -import Control.Concurrent.MVar (readMVar) -import Control.Monad -import Network.Socket hiding (recv, send) -import Network.Socket.ByteString -import Network.Test.Common - -import Test.Hspec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "connect" $ do - let - hints = defaultHints { addrSocketType = Stream } - connect' serverPort = do - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - connect sock (addrAddress addr) - return sock - - it "fails to connect and throws an IOException" $ do - connect' (8080 :: Int) `shouldThrow` anyIOException - - it "successfully connects to a socket with no exception" $ do - tcpTestUsingClient return return $ readMVar >=> connect' - - describe "UserTimeout" $ do - it "can be set" $ do - when (isSupportedSocketOption UserTimeout) $ do - sock <- socket AF_INET Stream defaultProtocol - setSocketOption sock UserTimeout 1000 - getSocketOption sock UserTimeout `shouldReturn` 1000 - setSocketOption sock UserTimeout 2000 - getSocketOption sock UserTimeout `shouldReturn` 2000 - close sock - - -- On various BSD systems the peer credentials are exchanged during - -- connect(), and this does not happen with `socketpair()`. Therefore, - -- we must actually set up a listener and connect, rather than use a - -- socketpair(). - -- - describe "getPeerCredential" $ do - it "can return something" $ do - when isUnixDomainSocketAvailable $ do - -- It would be useful to check that we did not get garbage - -- back, but rather the actual uid of the test program. For - -- that we'd need System.Posix.User, but that is not available - -- under Windows. For now, accept the risk that we did not get - -- the right answer. - -- - let client sock = do - (_, uid, _) <- getPeerCredential sock - uid `shouldNotBe` Nothing - server (sock, _) = do - (_, uid, _) <- getPeerCredential sock - uid `shouldNotBe` Nothing - unixTest client server - {- The below test fails on many *BSD systems, because the getsockopt() - call that underlies getpeereid() does not have the same meaning for - all address families, but the C-library was not checking that the - provided sock is an AF_UNIX socket. This will fixed some day, but - we should not fail on those systems in the mean-time. The upstream - C-library fix is to call getsockname() and check the address family - before calling `getpeereid()`. We could duplicate that in our own - code, and then this test would work on those platforms that have - `getpeereid()` and not the SO_PEERCRED socket option. - - it "return nothing for non-UNIX-domain socket" $ do - when isUnixDomainSocketAvailable $ do - s <- socket AF_INET Stream defaultProtocol - cred1 <- getPeerCredential s - cred1 `shouldBe` (Nothing,Nothing,Nothing) - -} - - describe "getAddrInfo" $ do - it "works for IPv4 address" $ do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } - AddrInfo{addrAddress = (SockAddrInet _ hostAddr)}:_ <- - 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" - AddrInfo{addrAddress = (SockAddrInet6 _ _ hostAddr _)}:_ <- - 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] } - void $ getAddrInfo (Just hints) (Just "localhost") Nothing - - describe "unix sockets" $ do - it "basic unix sockets end-to-end" $ do - when isUnixDomainSocketAvailable $ do - let client sock = send sock testMsg - server (sock, addr) = do - recv sock 1024 `shouldReturn` testMsg - addr `shouldBe` (SockAddrUnix "") - unixTest client server -#ifdef linux_HOST_OS - it "can end-to-end with an abstract socket" $ do - when isUnixDomainSocketAvailable $ do - let - abstractAddress = toEnum 0:"/haskell/network/abstract" - clientAct sock = send sock testMsg - server (sock, addr) = do - recv sock 1024 `shouldReturn` testMsg - addr `shouldBe` (SockAddrUnix "") - unixTestWith abstractAddress (const $ return ()) clientAct server - it "safely throws an exception" $ do - when isUnixDomainSocketAvailable $ do - let abstractAddress = toEnum 0:"/haskell/network/abstract-longlonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglong" - sock <- socket AF_UNIX Stream defaultProtocol - bind sock (SockAddrUnix abstractAddress) `shouldThrow` anyErrorCall -#endif diff --git a/tests/Network/Test/Common.hs b/tests/Network/Test/Common.hs deleted file mode 100644 --- a/tests/Network/Test/Common.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Network.Test.Common - ( serverAddr - , testMsg - , lazyTestMsg - , tcpTest - , tcpTestUsingClient - , unixTest - , unixTestWith - , udpTest - ) where - -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 Network.Socket -import System.Directory -import qualified Data.ByteString.Lazy as L -import System.Timeout (timeout) - -import Test.Hspec - -serverAddr :: String -serverAddr = "127.0.0.1" - -testMsg :: ByteString -testMsg = "This is a test message." - -lazyTestMsg :: L.ByteString -lazyTestMsg = L.fromStrict "This is a test message." - -unixAddr :: String -unixAddr = "/tmp/network-test" - --- | Establish a connection between client and server and then run --- 'clientAct' and 'serverAct', in different threads. Both actions --- get passed a connected 'Socket', used for communicating between --- client and server. 'unixTest' makes sure that the 'Socket' is --- closed after the actions have run. -unixTest :: (Socket -> IO a) -> ((Socket, SockAddr) -> IO b) -> IO () -unixTest = unixTestWith unixAddr unlink - where - unlink file = do - exist <- doesFileExist file - when exist $ removeFile file - -unixTestWith - :: String -- ^ address - -> (String -> IO ()) -- ^ clean up action - -> (Socket -> IO a) -- ^ client action - -> ((Socket, SockAddr) -> IO b) -- ^ server action - -> IO () -unixTestWith address cleanupAct clientAct serverAct = - test clientSetup clientAct serverSetup server - where - clientSetup = do - sock <- socket AF_UNIX Stream defaultProtocol - connect sock (SockAddrUnix address) - return sock - - serverSetup = do - sock <- socket AF_UNIX Stream defaultProtocol - cleanupAct address -- just in case - bind sock (SockAddrUnix address) - listen sock 1 - return sock - - server sock = E.bracket (accept sock) (killClientSock . fst) serverAct - - killClientSock sock = do - shutdown sock ShutdownBoth - close sock - cleanupAct address - --- | Establish a connection between client and server and then run --- 'clientAct' and 'serverAct', in different threads. Both actions --- get passed a connected 'Socket', used for communicating between --- 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 clientAct serverAct = - tcpTestUsingClient serverAct clientAct clientSetup - where - clientSetup portVar = 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) -#if !defined(mingw32_HOST_OS) - let fd = fdSocket sock - getNonBlock fd `shouldReturn` True - getCloseOnExec fd `shouldReturn` False -#endif - connect sock $ addrAddress addr - return sock - -tcpTestUsingClient - :: (Socket -> IO a) -> (Socket -> IO b) -> (MVar PortNumber -> IO Socket) -> IO () -tcpTestUsingClient serverAct clientAct clientSetup = do - portVar <- newEmptyMVar - test (clientSetup portVar) clientAct (serverSetup portVar) server - where - serverSetup portVar = do - let hints = defaultHints { - addrFlags = [AI_PASSIVE] - , addrSocketType = Stream - } - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - let fd = fdSocket sock -#if !defined(mingw32_HOST_OS) - getNonBlock fd `shouldReturn` True - getCloseOnExec fd `shouldReturn` False -#endif - setSocketOption sock ReuseAddr 1 - setCloseOnExecIfNeeded fd -#if !defined(mingw32_HOST_OS) - getCloseOnExec fd `shouldReturn` True -#endif - bind sock $ addrAddress addr - listen sock 1 - serverPort <- socketPort sock - putMVar portVar serverPort - return sock - - server sock = do - (clientSock, _) <- accept sock -#if !defined(mingw32_HOST_OS) - let fd = fdSocket clientSock - getNonBlock fd `shouldReturn` True - getCloseOnExec fd `shouldReturn` True -#endif - _ <- serverAct clientSock - close clientSock - --- | 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 clientAct serverAct = do - portVar <- newEmptyMVar - test clientSetup (client portVar) (serverSetup portVar) serverAct - where - clientSetup = socket AF_INET Datagram defaultProtocol - - client portVar sock = do - serverPort <- readMVar portVar - clientAct sock serverPort - - serverSetup portVar = do - let hints = defaultHints { - addrFlags = [AI_PASSIVE] - , addrSocketType = Datagram - } - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - setSocketOption sock ReuseAddr 1 - bind sock $ addrAddress addr - serverPort <- socketPort sock - putMVar portVar serverPort - return sock - --- | Run a client/server pair and synchronize them so that the server --- is started before the client and the specified server action is --- finished before the client closes the 'Socket'. -test :: IO Socket -> (Socket -> IO b) -> IO Socket -> (Socket -> IO c) -> IO () -test clientSetup clientAct serverSetup serverAct = do - tid <- myThreadId - barrier <- newEmptyMVar - _ <- forkIO $ server barrier - -- Release MVar if server setup fails - `E.catch` \(e :: E.SomeException) -> putMVar barrier $ Just e - client tid barrier - where - server barrier = - E.bracket serverSetup close $ \sock -> do - serverReady - Just _ <- timeout 1000000 $ serverAct sock - putMVar barrier Nothing - where - -- | Signal to the client that it can proceed. - serverReady = putMVar barrier Nothing - - client tid barrier = do - maybe (return ()) E.throwIO =<< takeMVar barrier - -- Transfer exceptions to the main thread. - bracketWithReraise tid clientSetup close $ \res -> do - Just _ <- timeout 1000000 $ clientAct res - maybe (return ()) E.throwIO =<< takeMVar barrier - --- | Like 'bracket' but catches and reraises the exception in another --- thread, specified by the first argument. -bracketWithReraise :: ThreadId -> IO a -> (a -> IO b) -> (a -> IO ()) -> IO () -bracketWithReraise tid setup teardown thing = - E.bracket setup teardown thing - `E.catch` \ (e :: E.SomeException) -> E.throwTo tid e diff --git a/tests/RegressionSpec.hs b/tests/RegressionSpec.hs new file mode 100644 --- /dev/null +++ b/tests/RegressionSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Tests for things that didn't work in the past. +module RegressionSpec (main, spec) where + +import Control.Monad +import Network.Socket +import Network.Socket.ByteString + +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "getAddrInfo" $ do + it "does not cause segfault on macOS 10.8.2 due to AI_NUMERICSERV" $ do + let hints = defaultHints { addrFlags = [AI_NUMERICSERV] } + void $ getAddrInfo (Just hints) (Just "localhost") Nothing + + describe "Network.Socket.ByteString.recv" $ do + it "checks -1 correctly on Windows" $ do + sock <- socket AF_INET Stream defaultProtocol + recv sock 1024 `shouldThrow` anyException + + describe "Network.Socket.ByteString.send" $ do + it "checks -1 correctly on Windows" $ do + sock <- socket AF_INET Stream defaultProtocol + send sock "hello world" `shouldThrow` anyException diff --git a/tests/SimpleSpec.hs b/tests/SimpleSpec.hs new file mode 100644 --- /dev/null +++ b/tests/SimpleSpec.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SimpleSpec (main, spec) where + +import Control.Concurrent (ThreadId, forkIO, myThreadId) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, readMVar) +import qualified Control.Exception as E +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import Network.Socket +import Network.Socket.ByteString +import qualified Network.Socket.ByteString.Lazy as Lazy +import System.Directory +import System.Timeout (timeout) + +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "send" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock = send sock testMsg + tcpTest client server + + describe "sendAll" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock = sendAll sock testMsg + tcpTest client server + + 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 + 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 + udpTest client server + + describe "sendMany" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` (S.append seg1 seg2) + client sock = sendMany sock [seg1, seg2] + + seg1 = C.pack "This is a " + seg2 = C.pack "test message." + tcpTest client server + + 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 + + seg1 = C.pack "This is a " + seg2 = C.pack "test message." + udpTest client server + + describe "recv" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock = send sock testMsg + tcpTest client server + + it "can treat overflow" $ do + let server sock = do seg1 <- recv sock (S.length testMsg - 3) + seg2 <- recv sock 1024 + let msg = S.append seg1 seg2 + msg `shouldBe` testMsg + client sock = send sock testMsg + tcpTest client server + + it "returns empty string at EOF" $ do + let client s = recv s 4096 `shouldReturn` S.empty + server s = shutdown s ShutdownSend + tcpTest client server + + describe "recvFrom" $ do + it "works well" $ do + let server sock = do (msg, _) <- recvFrom sock 1024 + testMsg `shouldBe` msg + client sock = do + addr <- getPeerName sock + sendTo sock testMsg addr + tcpTest client server + it "can treat overflow" $ do + let server sock = do (seg1, _) <- recvFrom sock (S.length testMsg - 3) + (seg2, _) <- recvFrom sock 1024 + let msg = S.append seg1 seg2 + testMsg `shouldBe` msg + + client sock = send sock testMsg + tcpTest client server + + describe "UserTimeout" $ do + it "can be set" $ do + when (isSupportedSocketOption UserTimeout) $ do + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock UserTimeout 1000 + getSocketOption sock UserTimeout `shouldReturn` 1000 + setSocketOption sock UserTimeout 2000 + getSocketOption sock UserTimeout `shouldReturn` 2000 + close sock + + -- On various BSD systems the peer credentials are exchanged during + -- connect(), and this does not happen with `socketpair()`. Therefore, + -- we must actually set up a listener and connect, rather than use a + -- socketpair(). + -- + describe "getPeerCredential" $ do + it "can return something" $ do + when isUnixDomainSocketAvailable $ do + -- It would be useful to check that we did not get garbage + -- back, but rather the actual uid of the test program. For + -- that we'd need System.Posix.User, but that is not available + -- under Windows. For now, accept the risk that we did not get + -- the right answer. + -- + let client sock = do + (_, uid, _) <- getPeerCredential sock + uid `shouldNotBe` Nothing + server (sock, _) = do + (_, uid, _) <- getPeerCredential sock + uid `shouldNotBe` Nothing + unixTest client server + {- The below test fails on many *BSD systems, because the getsockopt() + call that underlies getpeereid() does not have the same meaning for + all address families, but the C-library was not checking that the + provided sock is an AF_UNIX socket. This will fixed some day, but + we should not fail on those systems in the mean-time. The upstream + C-library fix is to call getsockname() and check the address family + before calling `getpeereid()`. We could duplicate that in our own + code, and then this test would work on those platforms that have + `getpeereid()` and not the SO_PEERCRED socket option. + + it "return nothing for non-UNIX-domain socket" $ do + when isUnixDomainSocketAvailable $ do + s <- socket AF_INET Stream defaultProtocol + cred1 <- getPeerCredential s + cred1 `shouldBe` (Nothing,Nothing,Nothing) + -} + + describe "getAddrInfo" $ do + it "works for IPv4 address" $ do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } + AddrInfo{addrAddress = (SockAddrInet _ hostAddr)}:_ <- + 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" + AddrInfo{addrAddress = (SockAddrInet6 _ _ hostAddr _)}:_ <- + getAddrInfo (Just hints) (Just host) Nothing + hostAddress6ToTuple hostAddr + `shouldBe` (0x2001, 0x0db8, 0x85a3, 0x0000, 0x0000, 0x8a2e, 0x0370, 0x7334) +#endif + + describe "unix sockets" $ do + it "basic unix sockets end-to-end" $ do + when isUnixDomainSocketAvailable $ do + let client sock = send sock testMsg + server (sock, addr) = do + recv sock 1024 `shouldReturn` testMsg + addr `shouldBe` (SockAddrUnix "") + unixTest client server + + describe "Lazy.sendAll" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock = Lazy.sendAll sock $ L.fromChunks [testMsg] + tcpTest client server + +------------------------------------------------------------------------ + +serverAddr :: String +serverAddr = "127.0.0.1" + +testMsg :: ByteString +testMsg = "This is a test message." + +unixAddr :: String +unixAddr = "/tmp/network-test" + +------------------------------------------------------------------------ +-- Test helpers + +-- | Establish a connection between client and server and then run +-- 'clientAct' and 'serverAct', in different threads. Both actions +-- get passed a connected 'Socket', used for communicating between +-- client and server. 'unixTest' makes sure that the 'Socket' is +-- closed after the actions have run. +unixTest :: (Socket -> IO a) -> ((Socket, SockAddr) -> IO b) -> IO () +unixTest clientAct serverAct = do + test clientSetup clientAct serverSetup server + where + clientSetup = do + sock <- socket AF_UNIX Stream defaultProtocol + connect sock (SockAddrUnix unixAddr) + return sock + + serverSetup = do + sock <- socket AF_UNIX Stream defaultProtocol + unlink unixAddr -- just in case + bind sock (SockAddrUnix unixAddr) + listen sock 1 + return sock + + server sock = E.bracket (accept sock) (killClientSock . fst) serverAct + + unlink file = do + exist <- doesFileExist file + when exist $ removeFile file + + killClientSock sock = do + shutdown sock ShutdownBoth + close sock + unlink unixAddr + +-- | Establish a connection between client and server and then run +-- 'clientAct' and 'serverAct', in different threads. Both actions +-- get passed a connected 'Socket', used for communicating between +-- 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 clientAct serverAct = do + portVar <- newEmptyMVar + test (clientSetup portVar) clientAct (serverSetup portVar) server + where + clientSetup portVar = 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) +#if !defined(mingw32_HOST_OS) + fd <- fdSocket sock + getNonBlock fd `shouldReturn` True + getCloseOnExec fd `shouldReturn` False +#endif + connect sock $ addrAddress addr + return sock + + serverSetup portVar = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + fd <- fdSocket sock +#if !defined(mingw32_HOST_OS) + getNonBlock fd `shouldReturn` True + getCloseOnExec fd `shouldReturn` False +#endif + setSocketOption sock ReuseAddr 1 + setCloseOnExecIfNeeded fd +#if !defined(mingw32_HOST_OS) + getCloseOnExec fd `shouldReturn` True +#endif + bind sock $ addrAddress addr + listen sock 1 + serverPort <- socketPort sock + putMVar portVar serverPort + return sock + + server sock = do + (clientSock, _) <- accept sock +#if !defined(mingw32_HOST_OS) + fd <- fdSocket clientSock + getNonBlock fd `shouldReturn` True + getCloseOnExec fd `shouldReturn` True +#endif + _ <- serverAct clientSock + close clientSock + +-- | 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 clientAct serverAct = do + portVar <- newEmptyMVar + test clientSetup (client portVar) (serverSetup portVar) serverAct + where + clientSetup = socket AF_INET Datagram defaultProtocol + + client portVar sock = do + serverPort <- readMVar portVar + clientAct sock serverPort + + serverSetup portVar = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Datagram + } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + setSocketOption sock ReuseAddr 1 + bind sock $ addrAddress addr + serverPort <- socketPort sock + putMVar portVar serverPort + return sock + +-- | Run a client/server pair and synchronize them so that the server +-- is started before the client and the specified server action is +-- finished before the client closes the 'Socket'. +test :: IO Socket -> (Socket -> IO b) -> IO Socket -> (Socket -> IO c) -> IO () +test clientSetup clientAct serverSetup serverAct = do + tid <- myThreadId + barrier <- newEmptyMVar + _ <- forkIO $ server barrier + client tid barrier + where + server barrier = do + E.bracket serverSetup close $ \sock -> do + serverReady + Just _ <- timeout 1000000 $ serverAct sock + putMVar barrier () + where + -- | Signal to the client that it can proceed. + serverReady = putMVar barrier () + + client tid barrier = do + takeMVar barrier + -- Transfer exceptions to the main thread. + bracketWithReraise tid clientSetup close $ \res -> do + Just _ <- timeout 1000000 $ clientAct res + takeMVar barrier + +-- | Like 'bracket' but catches and reraises the exception in another +-- thread, specified by the first argument. +bracketWithReraise :: ThreadId -> IO a -> (a -> IO b) -> (a -> IO ()) -> IO () +bracketWithReraise tid setup teardown thing = + E.bracket setup teardown thing + `E.catch` \ (e :: E.SomeException) -> E.throwTo tid e diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -1,20 +1,15 @@ -import Test.DocTest +module Main where +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Data.List (isSuffixOf, isPrefixOf) +import Test.DocTest (doctest) + main :: IO () -main = doctest [ - "-i" - , "-idist/build" - , "-i." - , "-idist/build/autogen" - , "-Idist/build/autogen" - , "-Idist/build" - , "-Iinclude" - , "-optP-include" - , "-optPdist/build/autogen/cabal_macros.h" - , "-DCALLCONV=ccall" - , "-XCPP" - , "-XDeriveDataTypeable" - , "-package-db dist/package.conf.inplace" - , "-package network" - , "Network" - ] +main = do + traverse_ putStrLn args + doctest args + where + builddir = filter ("build" `isSuffixOf`) $ filter ("-i" `isPrefixOf`) flags + addinc path = "-I" ++ drop 2 path ++ "/include" + args = map addinc builddir ++ flags ++ pkgs ++ module_sources