diff --git a/Network.hs b/Network.hs --- a/Network.hs +++ b/Network.hs @@ -4,7 +4,7 @@ -- 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 @@ -32,7 +32,7 @@ -- * Initialisation , withSocketsDo - + -- * Server-side connections , listenOn , accept @@ -63,7 +63,8 @@ import Control.Monad (liftM) import Data.Maybe (fromJust) import Network.BSD -import Network.Socket hiding (accept, socketPort, recvFrom, sendTo, PortNumber) +import Network.Socket hiding (accept, socketPort, recvFrom, + sendTo, PortNumber, sClose) import qualified Network.Socket as Socket (accept) import System.IO import Prelude @@ -77,7 +78,7 @@ -- raised. Alternatively an empty string may be given to @connectTo@ -- signalling that the current hostname applies. -data PortID = +data PortID = Service String -- Service Name eg "ftp" | PortNumber PortNumber -- User defined Port Number #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) @@ -88,7 +89,7 @@ -- | 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. +-- then the result is always an internet family 'Stream' socket. connectTo :: HostName -- Hostname -> PortID -- Port Identifier @@ -267,14 +268,14 @@ accept :: Socket -- ^ Listening Socket -> IO (Handle, HostName, - PortNumber) -- ^ Triple of: read\/write 'Handle' for + 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 + (do (HostEntry peer _ _ _) <- getHostByAddr AF_INET haddr return peer ) @@ -308,6 +309,13 @@ accept (MkSocket _ family _ _ _) = error $ "Sorry, address family " ++ (show family) ++ " is not supported!" + +-- | Close the socket. All future operations on the socket object will fail. +-- The remote end will receive no more data (after queued data is flushed). +sClose :: Socket -> IO () +sClose = close -- Explicit redefinition because Network.sClose is deperecated, + -- hence the re-export would also be marked as such. + -- ----------------------------------------------------------------------------- -- sendTo/recvFrom @@ -361,7 +369,7 @@ ip <- getHostByName host let ipHs = hostAddresses ip s <- listenOn port - let + let waiting = do ~(s', SockAddrInet _ haddr) <- Socket.accept s he <- getHostByAddr AF_INET haddr @@ -400,7 +408,7 @@ -- --------------------------------------------------------------------------- -- Utils --- Like bracket, but only performs the final action if there was an +-- 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\") diff --git a/Network/BSD.hsc b/Network/BSD.hsc --- a/Network/BSD.hsc +++ b/Network/BSD.hsc @@ -4,7 +4,7 @@ -- 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 @@ -141,7 +141,7 @@ -- close the database a call to endServiceEntry is required. This -- database file is usually stored in the file /etc/services. -data ServiceEntry = +data ServiceEntry = ServiceEntry { serviceName :: ServiceName, -- Official Name serviceAliases :: [ServiceName], -- aliases @@ -187,7 +187,7 @@ $ (trySysCall (c_getservbyname cstr_name cstr_proto)) >>= peek -foreign import CALLCONV unsafe "getservbyname" +foreign import CALLCONV unsafe "getservbyname" c_getservbyname :: CString -> CString -> IO (Ptr ServiceEntry) -- | Get the service given a 'PortNumber' and 'ProtocolName'. @@ -198,7 +198,7 @@ $ (trySysCall (c_getservbyport (fromIntegral port) cstr_proto)) >>= peek -foreign import CALLCONV unsafe "getservbyport" +foreign import CALLCONV unsafe "getservbyport" c_getservbyport :: CInt -> CString -> IO (Ptr ServiceEntry) -- | Get the 'PortNumber' corresponding to the 'ServiceName'. @@ -242,9 +242,9 @@ -- 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, +-- getProtocolEntry. Similarly, -data ProtocolEntry = +data ProtocolEntry = ProtocolEntry { protoName :: ProtocolName, -- Official Name protoAliases :: [ProtocolName], -- aliases @@ -264,12 +264,12 @@ -- 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 + 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 + p_proto <- (#peek struct protoent, p_proto) p #endif - return (ProtocolEntry { + return (ProtocolEntry { protoName = p_name, protoAliases = p_aliases, protoNumber = p_proto @@ -284,7 +284,7 @@ $ (trySysCall.c_getprotobyname) name_cstr >>= peek -foreign import CALLCONV unsafe "getprotobyname" +foreign import CALLCONV unsafe "getprotobyname" c_getprotobyname :: CString -> IO (Ptr ProtocolEntry) @@ -331,7 +331,7 @@ -- --------------------------------------------------------------------------- -- Host lookups -data HostEntry = +data HostEntry = HostEntry { hostName :: HostName, -- Official Name hostAliases :: [HostName], -- aliases @@ -385,7 +385,7 @@ $ trySysCall $ c_gethostbyname name_cstr peek ent -foreign import CALLCONV safe "gethostbyname" +foreign import CALLCONV safe "gethostbyname" c_gethostbyname :: CString -> IO (Ptr HostEntry) @@ -460,7 +460,7 @@ return (NetworkEntry { networkName = n_name, networkAliases = n_aliases, - networkFamily = unpackFamily (fromIntegral + networkFamily = unpackFamily (fromIntegral (n_addrtype :: CInt)), networkAddress = n_net }) @@ -476,7 +476,7 @@ $ trySysCall $ c_getnetbyname name_cstr >>= peek -foreign import ccall unsafe "getnetbyname" +foreign import ccall unsafe "getnetbyname" c_getnetbyname :: CString -> IO (Ptr NetworkEntry) getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry @@ -485,7 +485,7 @@ $ trySysCall $ c_getnetbyaddr addr (packFamily family) >>= peek -foreign import ccall unsafe "getnetbyaddr" +foreign import ccall unsafe "getnetbyaddr" c_getnetbyaddr :: NetworkAddr -> CInt -> IO (Ptr NetworkEntry) getNetworkEntry :: IO NetworkEntry @@ -539,7 +539,7 @@ throwSocketErrorIfMinus1_ "getHostName" $ c_gethostname cstr (fromIntegral size) peekCString cstr -foreign import CALLCONV unsafe "gethostname" +foreign import CALLCONV unsafe "gethostname" c_gethostname :: CString -> CSize -> IO CInt -- Helper function used by the exported functions that provides a diff --git a/Network/Socket.hsc b/Network/Socket.hsc --- a/Network/Socket.hsc +++ b/Network/Socket.hsc @@ -82,10 +82,13 @@ , getPeerName , getSocketName -#ifdef HAVE_STRUCT_UCRED +#if defined(HAVE_STRUCT_UCRED) || defined(HAVE_GETPEEREID) -- get the credentials of our domain socket peer. , getPeerCred +#if defined(HAVE_GETPEEREID) + , getPeerEid #endif +#endif , socketPort @@ -179,7 +182,7 @@ import Foreign.Ptr (Ptr, castPtr, nullPtr) import Foreign.Storable (Storable(..)) import Foreign.C.Error -import Foreign.C.String (CString, withCString, peekCString, peekCStringLen) +import Foreign.C.String (CString, withCString, withCStringLen, peekCString, peekCStringLen) import Foreign.C.Types (CUInt, CChar) #if __GLASGOW_HASKELL__ >= 703 import Foreign.C.Types (CInt(..), CSize(..)) @@ -510,17 +513,16 @@ return new_sock #else with (fromIntegral sz) $ \ ptr_len -> do - new_sock <- # ifdef HAVE_ACCEPT4 - throwSocketErrorIfMinus1RetryMayBlock "accept" + new_sock <- throwSocketErrorIfMinus1RetryMayBlock "accept" (threadWaitRead (fromIntegral s)) (c_accept4 s sockaddr ptr_len (#const SOCK_NONBLOCK)) # else - throwSocketErrorWaitRead sock "accept" + new_sock <- throwSocketErrorWaitRead sock "accept" (c_accept s sockaddr ptr_len) + setNonBlockIfNeeded new_sock # endif /* HAVE_ACCEPT4 */ #endif - setNonBlockIfNeeded new_sock addr <- peekSockAddr sockaddr new_status <- newMVar Connected return ((MkSocket new_sock family stype protocol new_status), addr) @@ -562,8 +564,8 @@ -> SockAddr -> IO Int -- Number of Bytes sent sendTo sock xs addr = do - withCString xs $ \str -> do - sendBufTo sock str (length xs) addr + 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. @@ -638,8 +640,7 @@ -> String -- Data to send -> IO Int -- Number of Bytes sent send sock@(MkSocket s _family _stype _protocol _status) xs = do - let len = length xs - withCString xs $ \str -> do + withCStringLen xs $ \(str, len) -> do liftM fromIntegral $ #if defined(mingw32_HOST_OS) # if __GLASGOW_HASKELL__ >= 611 @@ -983,12 +984,15 @@ fromIntegral `liftM` peek ptr_v -#ifdef HAVE_STRUCT_UCRED +#if defined(HAVE_STRUCT_UCRED) || defined(HAVE_GETPEEREID) -- | Returns the processID, userID and groupID of the socket's peer. -- --- Only available on platforms that support SO_PEERCRED on domain sockets. +-- 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 = (fromIntegral (#const sizeof(struct ucred))) with sz $ \ ptr_cr -> @@ -1000,8 +1004,27 @@ 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 +-- | 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 "getPeerEid" $ + c_getpeereid fd ptr_uid ptr_gid + uid <- peek ptr_uid + gid <- peek ptr_gid + return (uid, gid) +#endif +#endif + ##if !(MIN_VERSION_base(4,3,1)) closeFdWith closer fd = closer fd ##endif @@ -1634,6 +1657,10 @@ 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 diff --git a/Network/Socket/ByteString.hsc b/Network/Socket/ByteString.hsc --- a/Network/Socket/ByteString.hsc +++ b/Network/Socket/ByteString.hsc @@ -23,7 +23,7 @@ -- > import Network.Socket.ByteString -- module Network.Socket.ByteString - ( + ( -- * Send data to a socket send , sendAll 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 @@ -9,6 +9,7 @@ import Foreign.Ptr (Ptr) import Foreign.Storable (Storable(..)) +#include #include data IOVec = IOVec diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -1,6 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} + +#include "HsNet.h" + module Network.Socket.Types ( -- * Socket @@ -49,8 +52,6 @@ -- * Low-level helpers , zeroMemory ) where - -#include "HsNet.h" import Control.Concurrent.MVar import Control.Monad diff --git a/Network/URI.hs b/Network/URI.hs --- a/Network/URI.hs +++ b/Network/URI.hs @@ -64,13 +64,13 @@ URI(..) , URIAuth(..) , nullURI - + -- * Parsing , parseURI , parseURIReference , parseRelativeReference , parseAbsoluteURI - + -- * Test for strings containing various kinds of URI , isURI , isURIReference @@ -78,16 +78,16 @@ , isAbsoluteURI , isIPv6address , isIPv4address - + -- * Predicates , uriIsAbsolute , uriIsRelative - + -- * Relative URIs , relativeTo , nonStrictRelativeTo , relativeFrom - + -- * Operations on URI strings -- | Support for putting strings into URI-friendly -- escaped format and getting them back again. @@ -103,12 +103,12 @@ , escapeURIChar , escapeURIString , unEscapeString - + -- * URI Normalization functions , normalizeCase , normalizeEscape , normalizePathSegments - + -- * Deprecated functions , parseabsoluteURI , escapeString diff --git a/configure b/configure --- a/configure +++ b/configure @@ -687,7 +687,7 @@ ac_subst_files='' ac_user_opts=' enable_option_checking -with_cc +with_gcc ' ac_precious_vars='build_alias host_alias @@ -2339,9 +2339,9 @@ -# Check whether --with-cc was given. -if test "${with_cc+set}" = set; then : - withval=$with_cc; CC=$withval +# Check whether --with-gcc was given. +if test "${with_gcc+set}" = set; then : + withval=$with_gcc; CC=$withval fi ac_ext=c diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -29,7 +29,7 @@ AC_CANONICAL_HOST -AC_ARG_WITH([cc], +AC_ARG_WITH([gcc], [C compiler], [CC=$withval]) AC_PROG_CC() @@ -101,6 +101,12 @@ 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 diff --git a/include/HsNet.h b/include/HsNet.h --- a/include/HsNet.h +++ b/include/HsNet.h @@ -176,4 +176,8 @@ # define IOV_MAX 1024 #endif +#if !defined(SOCK_NONBLOCK) // Missing define in Bionic libc (Android) +# define SOCK_NONBLOCK O_NONBLOCK +#endif + #endif /* HSNET_H */ diff --git a/network.buildinfo.in b/network.buildinfo.in --- a/network.buildinfo.in +++ b/network.buildinfo.in @@ -1,5 +1,6 @@ ghc-options: -DCALLCONV=@CALLCONV@ @EXTRA_CPPFLAGS@ ghc-prof-options: -DCALLCONV=@CALLCONV@ @EXTRA_CPPFLAGS@ +ld-options: @LDFLAGS@ cc-options: -DCALLCONV=@CALLCONV@ @EXTRA_CPPFLAGS@ c-sources: @EXTRA_SRCS@ extra-libraries: @EXTRA_LIBS@ diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,5 +1,5 @@ name: network -version: 2.4.1.2 +version: 2.4.2.0 license: BSD3 license-file: LICENSE maintainer: Johan Tibell diff --git a/tests/Simple.hs b/tests/Simple.hs --- a/tests/Simple.hs +++ b/tests/Simple.hs @@ -112,6 +112,67 @@ client sock = send sock testMsg +{- +testGetPeerCred:: Assertion +testGetPeerCred = + test clientSetup clientAct serverSetup server + where + clientSetup = do + sock <- socket AF_UNIX Stream defaultProtocol + connect sock $ SockAddrUnix addr + return sock + + serverSetup = do + sock <- socket AF_UNIX Stream defaultProtocol + bindSocket sock $ SockAddrUnix addr + listen sock 1 + return sock + + server sock = do + (clientSock, _) <- accept sock + serverAct clientSock + sClose clientSock + + addr = "/tmp/testAddr1" + clientAct sock = withSocketsDo $ do + sendAll sock testMsg + (pid,uid,gid) <- getPeerCred sock + putStrLn $ unwords ["pid=",show pid,"uid=",show uid, "gid=", show gid] + serverAct sock = withSocketsDo $ do + msg <- recv sock 1024 + putStrLn $ C.unpack msg + + +testGetPeerEid :: Assertion +testGetPeerEid = + test clientSetup clientAct serverSetup server + where + clientSetup = do + sock <- socket AF_UNIX Stream defaultProtocol + connect sock $ SockAddrUnix addr + return sock + + serverSetup = do + sock <- socket AF_UNIX Stream defaultProtocol + bindSocket sock $ SockAddrUnix addr + listen sock 1 + return sock + + server sock = do + (clientSock, _) <- accept sock + serverAct clientSock + sClose clientSock + + addr = "/tmp/testAddr2" + clientAct sock = withSocketsDo $ do + sendAll sock testMsg + (uid,gid) <- getPeerEid sock + putStrLn $ unwords ["uid=",show uid, "gid=", show gid] + serverAct sock = withSocketsDo $ do + msg <- recv sock 1024 + putStrLn $ C.unpack msg +-} + ------------------------------------------------------------------------ -- Other @@ -132,6 +193,8 @@ , testCase "testOverFlowRecv" testOverFlowRecv , testCase "testRecvFrom" testRecvFrom , testCase "testOverFlowRecvFrom" testOverFlowRecvFrom +-- , testCase "testGetPeerCred" testGetPeerCred +-- , testCase "testGetPeerEid" testGetPeerEid ] tests :: [Test]