diff --git a/Network.hs b/Network.hs --- a/Network.hs +++ b/Network.hs @@ -461,12 +461,26 @@ 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 :: [IO a] -> IO a -firstSuccessful [] = error "firstSuccessful: empty list" -firstSuccessful (p:ps) = catchIO p $ \e -> - case ps of - [] -> Exception.throwIO e - _ -> firstSuccessful ps +firstSuccessful = 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 [] = error "firstSuccessful: empty list" + go (Just e) [] = Exception.throwIO e diff --git a/Network/BSD.hsc b/Network/BSD.hsc --- a/Network/BSD.hsc +++ b/Network/BSD.hsc @@ -86,6 +86,12 @@ , getNetworkEntry , endNetworkEntry #endif + +#if defined(HAVE_IF_NAMETOINDEX) + -- * Interface names + , ifNameToIndex +#endif + ) where import Network.Socket @@ -96,7 +102,7 @@ #if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) import Foreign.C.Types ( CShort ) #endif -import Foreign.C.Types ( CInt(..), CULong(..), CSize(..) ) +import Foreign.C.Types ( CInt(..), CUInt(..), CULong(..), CSize(..) ) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (Storable(..)) import Foreign.Marshal.Array (allocaArray0, peekArray0) @@ -173,7 +179,7 @@ withCString name $ \ cstr_name -> do withCString proto $ \ cstr_proto -> do throwNoSuchThingIfNull "getServiceByName" "no such service entry" - $ (trySysCall (c_getservbyname cstr_name cstr_proto)) + $ c_getservbyname cstr_name cstr_proto >>= peek foreign import CALLCONV unsafe "getservbyname" @@ -184,7 +190,7 @@ getServiceByPort (PortNum port) proto = withLock $ do withCString proto $ \ cstr_proto -> do throwNoSuchThingIfNull "getServiceByPort" "no such service entry" - $ (trySysCall (c_getservbyport (fromIntegral port) cstr_proto)) + $ c_getservbyport (fromIntegral port) cstr_proto >>= peek foreign import CALLCONV unsafe "getservbyport" @@ -200,18 +206,18 @@ getServiceEntry :: IO ServiceEntry getServiceEntry = withLock $ do throwNoSuchThingIfNull "getServiceEntry" "no such service entry" - $ trySysCall c_getservent + $ c_getservent >>= peek foreign import ccall unsafe "getservent" c_getservent :: IO (Ptr ServiceEntry) setServiceEntry :: Bool -> IO () -setServiceEntry flg = withLock $ trySysCall $ c_setservent (fromBool flg) +setServiceEntry flg = withLock $ c_setservent (fromBool flg) foreign import ccall unsafe "setservent" c_setservent :: CInt -> IO () endServiceEntry :: IO () -endServiceEntry = withLock $ trySysCall $ c_endservent +endServiceEntry = withLock $ c_endservent foreign import ccall unsafe "endservent" c_endservent :: IO () @@ -270,7 +276,7 @@ getProtocolByName name = withLock $ do withCString name $ \ name_cstr -> do throwNoSuchThingIfNull "getProtocolByName" ("no such protocol name: " ++ name) - $ (trySysCall.c_getprotobyname) name_cstr + $ c_getprotobyname name_cstr >>= peek foreign import CALLCONV unsafe "getprotobyname" @@ -280,7 +286,7 @@ getProtocolByNumber :: ProtocolNumber -> IO ProtocolEntry getProtocolByNumber num = withLock $ do throwNoSuchThingIfNull "getProtocolByNumber" ("no such protocol number: " ++ show num) - $ (trySysCall.c_getprotobynumber) (fromIntegral num) + $ c_getprotobynumber (fromIntegral num) >>= peek foreign import CALLCONV unsafe "getprotobynumber" @@ -296,18 +302,18 @@ getProtocolEntry :: IO ProtocolEntry -- Next Protocol Entry from DB getProtocolEntry = withLock $ do ent <- throwNoSuchThingIfNull "getProtocolEntry" "no such protocol entry" - $ trySysCall c_getprotoent + $ c_getprotoent peek ent foreign import ccall unsafe "getprotoent" c_getprotoent :: IO (Ptr ProtocolEntry) setProtocolEntry :: Bool -> IO () -- Keep DB Open ? -setProtocolEntry flg = withLock $ trySysCall $ c_setprotoent (fromBool flg) +setProtocolEntry flg = withLock $ c_setprotoent (fromBool flg) foreign import ccall unsafe "setprotoent" c_setprotoent :: CInt -> IO () endProtocolEntry :: IO () -endProtocolEntry = withLock $ trySysCall $ c_endprotoent +endProtocolEntry = withLock $ c_endprotoent foreign import ccall unsafe "endprotoent" c_endprotoent :: IO () @@ -371,7 +377,7 @@ getHostByName name = withLock $ do withCString name $ \ name_cstr -> do ent <- throwNoSuchThingIfNull "getHostByName" "no such host entry" - $ trySysCall $ c_gethostbyname name_cstr + $ c_gethostbyname name_cstr peek ent foreign import CALLCONV safe "gethostbyname" @@ -385,7 +391,7 @@ getHostByAddr family addr = do with addr $ \ ptr_addr -> withLock $ do throwNoSuchThingIfNull "getHostByAddr" "no such host entry" - $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family) + $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family) >>= peek foreign import CALLCONV safe "gethostbyaddr" @@ -395,13 +401,13 @@ getHostEntry :: IO HostEntry getHostEntry = withLock $ do throwNoSuchThingIfNull "getHostEntry" "unable to retrieve host entry" - $ trySysCall $ c_gethostent + $ c_gethostent >>= peek foreign import ccall unsafe "gethostent" c_gethostent :: IO (Ptr HostEntry) setHostEntry :: Bool -> IO () -setHostEntry flg = withLock $ trySysCall $ c_sethostent (fromBool flg) +setHostEntry flg = withLock $ c_sethostent (fromBool flg) foreign import ccall unsafe "sethostent" c_sethostent :: CInt -> IO () @@ -462,7 +468,7 @@ getNetworkByName name = withLock $ do withCString name $ \ name_cstr -> do throwNoSuchThingIfNull "getNetworkByName" "no such network entry" - $ trySysCall $ c_getnetbyname name_cstr + $ c_getnetbyname name_cstr >>= peek foreign import ccall unsafe "getnetbyname" @@ -471,7 +477,7 @@ getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry getNetworkByAddr addr family = withLock $ do throwNoSuchThingIfNull "getNetworkByAddr" "no such network entry" - $ trySysCall $ c_getnetbyaddr addr (packFamily family) + $ c_getnetbyaddr addr (packFamily family) >>= peek foreign import ccall unsafe "getnetbyaddr" @@ -480,7 +486,7 @@ getNetworkEntry :: IO NetworkEntry getNetworkEntry = withLock $ do throwNoSuchThingIfNull "getNetworkEntry" "no more network entries" - $ trySysCall $ c_getnetent + $ c_getnetent >>= peek foreign import ccall unsafe "getnetent" c_getnetent :: IO (Ptr NetworkEntry) @@ -489,13 +495,13 @@ -- whether a connection is maintained open between various -- networkEntry calls setNetworkEntry :: Bool -> IO () -setNetworkEntry flg = withLock $ trySysCall $ c_setnetent (fromBool flg) +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 $ trySysCall $ c_endnetent +endNetworkEntry = withLock $ c_endnetent foreign import ccall unsafe "endnetent" c_endnetent :: IO () @@ -506,11 +512,29 @@ getEntries (getNetworkEntry) (endNetworkEntry) #endif +-- --------------------------------------------------------------------------- +-- Interface names + +#if defined(HAVE_IF_NAMETOINDEX) + +-- returns the index of the network interface corresponding to the name ifname. +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 + +foreign import CALLCONV safe "if_nametoindex" + c_if_nametoindex :: CString -> IO CUInt + +#endif + + -- Mutex for name service lockdown {-# NOINLINE lock #-} lock :: MVar () -lock = unsafePerformIO $ newMVar () +lock = unsafePerformIO $ withSocketsDo $ newMVar () withLock :: IO a -> IO a withLock act = withMVar lock (\_ -> act) @@ -546,23 +570,6 @@ Nothing -> return [] Just v -> loop >>= \ vs -> atEnd >> return (v:vs) - --- --------------------------------------------------------------------------- --- Winsock only: --- The BSD API networking calls made locally return NULL upon failure. --- That failure may very well be due to WinSock not being initialised, --- so if NULL is seen try init'ing and repeat the call. -#if !defined(mingw32_HOST_OS) && !defined(_WIN32) -trySysCall :: IO a -> IO a -trySysCall act = act -#else -trySysCall :: IO (Ptr a) -> IO (Ptr a) -trySysCall act = do - ptr <- act - if (ptr == nullPtr) - then withSocketsDo act - else return ptr -#endif throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a) throwNoSuchThingIfNull loc desc act = do diff --git a/Network/Socket.hsc b/Network/Socket.hsc --- a/Network/Socket.hsc +++ b/Network/Socket.hsc @@ -256,6 +256,7 @@ -> IO Socket mkSocket fd fam sType pNum stat = do mStat <- newMVar stat + withSocketsDo $ return () return (MkSocket fd fam sType pNum mStat) @@ -313,6 +314,7 @@ c_socket (packFamily family) c_stype protocol setNonBlockIfNeeded fd socket_status <- newMVar NotConnected + withSocketsDo $ return () let sock = MkSocket fd family stype protocol socket_status #if HAVE_DECL_IPV6_V6ONLY # if defined(mingw32_HOST_OS) @@ -348,6 +350,7 @@ mkNonBlockingSocket fd = do setNonBlockIfNeeded fd stat <- newMVar Connected + withSocketsDo $ return () return (MkSocket fd family stype protocol stat) foreign import ccall unsafe "socketpair" @@ -388,7 +391,7 @@ connect :: Socket -- Unconnected Socket -> SockAddr -- Socket address stuff -> IO () -connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = do +connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = withSocketsDo $ do modifyMVar_ socketStatus $ \currentStatus -> do if currentStatus /= NotConnected && currentStatus /= Bound then @@ -409,15 +412,7 @@ -- _ | err == eAGAIN -> connectBlocked _otherwise -> throwSocketError "connect" #else - rc <- c_getLastError - case rc of - #{const WSANOTINITIALISED} -> do - withSocketsDo (return ()) - r <- c_connect s p_addr (fromIntegral sz) - if r == -1 - then throwSocketError "connect" - else return () - _ -> throwSocketError "connect" + throwSocketError "connect" #endif else return () @@ -1126,7 +1121,7 @@ -- Internet address manipulation routines: inet_addr :: String -> IO HostAddress -inet_addr ipstr = do +inet_addr ipstr = withSocketsDo $ do withCString ipstr $ \str -> do had <- c_inet_addr str if had == -1 @@ -1134,7 +1129,7 @@ else return had -- network byte order inet_ntoa :: HostAddress -> IO String -inet_ntoa haddr = do +inet_ntoa haddr = withSocketsDo $ do pstr <- c_inet_ntoa haddr peekCString pstr @@ -1402,7 +1397,7 @@ -> Maybe ServiceName -- ^ service name to look up -> IO [AddrInfo] -- ^ resolved addresses, with "best" first -getAddrInfo hints node service = +getAddrInfo hints node service = withSocketsDo $ maybeWith withCString node $ \c_node -> maybeWith withCString service $ \c_service -> maybeWith with filteredHints $ \c_hints -> @@ -1507,7 +1502,7 @@ -> SockAddr -- ^ the address to look up -> IO (Maybe HostName, Maybe ServiceName) -getNameInfo flags doHost doService addr = +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 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,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} -- | -- Module : Network.Socket.ByteString.Lazy @@ -23,12 +23,10 @@ -- module Network.Socket.ByteString.Lazy ( -#if !defined(mingw32_HOST_OS) -- * Send data to a socket send , sendAll , -#endif -- * Receive data from a socket getContents @@ -45,71 +43,10 @@ import qualified Data.ByteString as S import qualified Network.Socket.ByteString as N -#if !defined(mingw32_HOST_OS) -import Control.Monad (unless) -import Data.ByteString.Unsafe (unsafeUseAsCStringLen) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (plusPtr) -import Foreign.Storable (Storable(..)) -import Network.Socket.ByteString.IOVec (IOVec(IOVec)) -import Network.Socket.ByteString.Internal (c_writev) -import Network.Socket.Internal - -import qualified Data.ByteString.Lazy as L - -import GHC.Conc (threadWaitWrite) -#endif - -#if !defined(mingw32_HOST_OS) --- ----------------------------------------------------------------------------- --- Sending - --- | Send data to the socket. The socket must be in a connected state. --- Returns the number of bytes sent. Applications are responsible for --- ensuring that all data has been sent. --- --- Because a lazily generated 'ByteString' may be arbitrarily long, --- this function caps the amount it will attempt to send at 4MB. This --- number is large (so it should not penalize performance on fast --- networks), but not outrageously so (to avoid demanding lazily --- computed data unnecessarily early). Before being sent, the lazy --- 'ByteString' will be converted to a list of strict 'ByteString's --- with 'L.toChunks'; at most 1024 chunks will be sent. /Unix only/. -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 - 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 - --- | Send data to the socket. The socket must be in a connected --- state. This function continues to send data until either all data --- has been sent or an error occurs. If there is an error, an --- exception is raised, and there is no way to determine how much data --- was sent. /Unix only/. -sendAll :: Socket -- ^ Connected socket - -> ByteString -- ^ Data to send - -> IO () -sendAll sock bs = do - sent <- send sock bs - let bs' = L.drop sent bs - unless (L.null bs') $ sendAll sock bs' +#if defined(mingw32_HOST_OS) +import Network.Socket.ByteString.Lazy.Windows (send, sendAll) +#else +import Network.Socket.ByteString.Lazy.Posix (send, sendAll) #endif -- ----------------------------------------------------------------------------- diff --git a/Network/Socket/Internal.hsc b/Network/Socket/Internal.hsc --- a/Network/Socket/Internal.hsc +++ b/Network/Socket/Internal.hsc @@ -78,7 +78,9 @@ import GHC.Conc (threadWaitRead, threadWaitWrite) #if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) -import Control.Exception ( finally ) +import Control.Exception ( evaluate ) +import System.IO.Unsafe ( unsafePerformIO ) +import Control.Monad ( when ) # if __GLASGOW_HASKELL__ >= 707 import GHC.IO.Exception ( IOErrorType(..) ) # else @@ -235,27 +237,35 @@ -- --------------------------------------------------------------------------- -- WinSock support -{-| On Windows operating systems, the networking subsystem has to be -initialised using 'withSocketsDo' before any networking operations can -be used. eg. +{-| With older versions of the @network@ library on Windows operating systems, +the networking subsystem must be initialised using 'withSocketsDo' before +any networking operations can be used. eg. > main = withSocketsDo $ do {...} -Although this is only strictly necessary on Windows platforms, it is -harmless on other platforms, so for portability it is good practice to -use it all the time. +It is fine to nest calls to 'withSocketsDo', and to perform networking operations +after 'withSocketsDo' has returned. + +In newer versions of the @network@ library 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 = do +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 - if x /= 0 - then ioError (userError "Failed to initialise WinSock") - else act `finally` shutdownWinSock + when (x /= 0) $ ioError $ userError "Failed to initialise WinSock" foreign import ccall unsafe "initWinSock" initWinSock :: IO Int -foreign import ccall unsafe "shutdownWinSock" shutdownWinSock :: IO () #endif diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -60,12 +60,23 @@ import Data.Ratio import Data.Typeable import Data.Word +import Data.Int import Foreign.C import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable +-- | Represents a socket. The fields are, respectively: +-- +-- * File descriptor +-- * Socket family +-- * Socket type +-- * Protocol number +-- * Status flag +-- +-- If you are calling the 'MkSocket' constructor directly you should ensure +-- you have called 'Network.withSocketsDo'. data Socket = MkSocket CInt -- File Descriptor @@ -288,6 +299,7 @@ | AF_PPPOX -- PPPoX sockets | AF_WANPIPE -- Wanpipe API sockets | AF_BLUETOOTH -- bluetooth sockets + | AF_CAN -- Controller Area Network deriving (Eq, Ord, Read, Show) packFamily :: Family -> CInt @@ -499,6 +511,9 @@ #ifdef AF_BLUETOOTH Just AF_BLUETOOTH -> Just #const AF_BLUETOOTH #endif +#ifdef AF_CAN + Just AF_CAN -> Just #const AF_CAN +#endif _ -> Nothing --------- ---------- @@ -700,17 +715,26 @@ #ifdef AF_BLUETOOTH (#const AF_BLUETOOTH) -> AF_BLUETOOTH #endif +#ifdef AF_CAN + (#const AF_CAN) -> AF_CAN +#endif unknown -> error ("Network.Socket.unpackFamily: unknown address " ++ "family " ++ show unknown) ------------------------------------------------------------------------ -- Port Numbers +-- | Use the @Num@ instance (i.e. use a literal) to create a +-- @PortNumber@ value with the correct network-byte-ordering. You +-- should not use the PortNum constructor. It will be removed in the +-- next release. newtype PortNumber = PortNum Word16 deriving (Eq, Ord, Typeable) -- newtyped to prevent accidental use of sane-looking -- port numbers that haven't actually been converted to -- network-byte-order first. +{-# DEPRECATED PortNum "Do not use the PortNum constructor. Use the Num instance. PortNum will be removed in the next release." #-} + instance Show PortNumber where showsPrec p pn = showsPrec p (portNumberToInt pn) @@ -792,6 +816,11 @@ | SockAddrUnix String -- sun_path #endif +#if defined(AF_CAN) + | SockAddrCan + Int32 -- can_ifindex (can be get by Network.BSD.ifNameToIndex "can0") + -- TODO: Extend this to include transport protocol information +#endif deriving (Eq, Ord, Typeable) #if defined(WITH_WINSOCK) || defined(cygwin32_HOST_OS) @@ -816,6 +845,9 @@ #if defined(IPV6_SOCKET_SUPPORT) sizeOfSockAddr (SockAddrInet6 _ _ _ _) = #const sizeof(struct sockaddr_in6) #endif +#if defined(AF_CAN) +sizeOfSockAddr (SockAddrCan _) = #const sizeof(struct sockaddr_can) +#endif -- | Computes the storage requirements (in bytes) required for a -- 'SockAddr' with the given 'Family'. @@ -827,6 +859,9 @@ sizeOfSockAddrByFamily AF_INET6 = #const sizeof(struct sockaddr_in6) #endif sizeOfSockAddrByFamily AF_INET = #const sizeof(struct sockaddr_in) +#if defined(AF_CAN) +sizeOfSockAddrByFamily AF_CAN = #const sizeof(struct sockaddr_can) +#endif -- | Use a 'SockAddr' with a function requiring a pointer to a -- 'SockAddr' and the length of that 'SockAddr'. @@ -888,6 +923,13 @@ (#poke struct sockaddr_in6, sin6_addr) p addr (#poke struct sockaddr_in6, sin6_scope_id) p scope #endif +#if defined(AF_CAN) +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 -- | Read a 'SockAddr' from the given memory location. peekSockAddr :: Ptr SockAddr -> IO SockAddr @@ -910,6 +952,11 @@ addr <- (#peek struct sockaddr_in6, sin6_addr) p scope <- (#peek struct sockaddr_in6, sin6_scope_id) p return (SockAddrInet6 (PortNum port) flow addr scope) +#endif +#if defined(AF_CAN) + (#const AF_CAN) -> do + ifidx <- (#peek struct sockaddr_can, can_ifindex) p + return (SockAddrCan ifidx) #endif ------------------------------------------------------------------------ diff --git a/cbits/initWinSock.c b/cbits/initWinSock.c --- a/cbits/initWinSock.c +++ b/cbits/initWinSock.c @@ -4,8 +4,13 @@ #if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__) static int winsock_inited = 0; -static int winsock_uninited = 0; +static void +shutdownHandler(void) +{ + WSACleanup(); +} + /* Initialising WinSock... */ int initWinSock () @@ -29,24 +34,10 @@ return (-1); } + atexit(shutdownHandler); winsock_inited = 1; } return 0; -} - -static void -shutdownHandler(void) -{ - WSACleanup(); -} - -void -shutdownWinSock() -{ - if (!winsock_uninited) { - atexit(shutdownHandler); - winsock_uninited = 1; - } } #endif diff --git a/configure b/configure --- a/configure +++ b/configure @@ -3624,7 +3624,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 +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 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" @@ -3637,8 +3637,20 @@ done +for ac_header in net/if.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 : + cat >>confdefs.h <<_ACEOF +#define HAVE_NET_IF_H 1 +_ACEOF -for ac_func in readlink symlink +fi + +done + + +for ac_func in readlink symlink if_nametoindex 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" @@ -4070,7 +4082,7 @@ case "$host" in -*-mingw*) +*-mingw* | *-msys*) EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c" EXTRA_LIBS=ws2_32 CALLCONV=stdcall ;; diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -35,9 +35,10 @@ 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]) +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]) +AC_CHECK_HEADERS([net/if.h]) -AC_CHECK_FUNCS([readlink symlink]) +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 @@ -169,7 +170,7 @@ AC_CHECK_FUNCS(accept4) case "$host" in -*-mingw*) +*-mingw* | *-msys*) EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c" EXTRA_LIBS=ws2_32 CALLCONV=stdcall ;; diff --git a/include/HsNet.h b/include/HsNet.h --- a/include/HsNet.h +++ b/include/HsNet.h @@ -44,7 +44,6 @@ # define IPV6_V6ONLY 27 # endif -extern void shutdownWinSock(); extern int initWinSock (); extern const char* getWSErrorDescr(int err); extern void* newAcceptParams(int sock, @@ -90,6 +89,12 @@ #endif #ifdef HAVE_NETDB_H #include +#endif +#ifdef HAVE_LINUX_CAN_H +# include +#endif +#ifdef HAVE_NET_IF +# include #endif #ifdef HAVE_BSD_SENDFILE diff --git a/include/HsNetworkConfig.h b/include/HsNetworkConfig.h --- a/include/HsNetworkConfig.h +++ b/include/HsNetworkConfig.h @@ -57,6 +57,9 @@ /* Define to 1 if you have getpeereid. */ #define HAVE_GETPEEREID 1 +/* Define to 1 if you have the `if_nametoindex' function. */ +#define HAVE_IF_NAMETOINDEX 1 + /* Define to 1 if you have the header file. */ #define HAVE_INTTYPES_H 1 @@ -69,6 +72,9 @@ /* Define to 1 if you have the header file. */ #define HAVE_LIMITS_H 1 +/* 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 */ @@ -83,6 +89,9 @@ /* Define to 1 if you have the header file. */ #define HAVE_NETINET_TCP_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_NET_IF_H 1 /* Define to 1 if you have the `readlink' function. */ #define HAVE_READLINK 1 diff --git a/include/HsNetworkConfig.h.in b/include/HsNetworkConfig.h.in --- a/include/HsNetworkConfig.h.in +++ b/include/HsNetworkConfig.h.in @@ -56,6 +56,9 @@ /* Define to 1 if you have getpeereid. */ #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 @@ -68,6 +71,9 @@ /* 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 @@ -82,6 +88,9 @@ /* 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_NET_IF_H /* Define to 1 if you have the `readlink' function. */ #undef HAVE_READLINK diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,5 +1,5 @@ name: network -version: 2.6.0.2 +version: 2.6.1.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 @@ -1,14 +1,31 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} module Main where import Control.Concurrent (ThreadId, forkIO, myThreadId) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, readMVar) import qualified Control.Exception as E +import Control.Monad (liftM) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C +import Data.Maybe (fromJust) import Network.Socket hiding (recv, recvFrom, send, sendTo) import Network.Socket.ByteString + +--- To tests for AF_CAN on Linux, you need to bring up a virtual (or real can +--- interface.). Run as root: +--- # modprobe can +--- # modprobe can_raw +--- # modprobe vcan +--- # sudo ip link add dev vcan0 type vcan +--- # ip link show vcan0 +--- 3: can0: mtu 16 qdisc noqueue state UNKNOWN link/can +--- Define HAVE_LINUX_CAN to run CAN tests as well. +--- #define HAVE_LINUX_CAN 1 +-- #include "../include/HsNetworkConfig.h" +#if defined(HAVE_LINUX_CAN_H) +import Network.BSD (ifNameToIndex) +#endif import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@=?)) @@ -173,6 +190,33 @@ putStrLn $ C.unpack msg -} +#if defined(HAVE_LINUX_CAN_H) +canTestMsg = S.pack [ 0,0,0,0 -- can ID = 0 + , 4,0,0,0 -- data length counter = 2 (bytes) + , 0x80,123,321,55 -- SYNC with some random extra bytes + , 0, 0, 0, 0 -- padding + ] + +testCanSend :: Assertion +testCanSend = canTest "vcan0" client server + where + server sock = recv sock 1024 >>= (@=?) canTestMsg + client sock = send sock canTestMsg + +canTest :: String -> (Socket -> IO a) -> (Socket -> IO b) -> IO () +canTest ifname clientAct serverAct = do + ifIndex <- liftM fromJust $ ifNameToIndex ifname + test (clientSetup ifIndex) clientAct (serverSetup ifIndex) serverAct + where + clientSetup ifIndex = do + sock <- socket AF_CAN Raw 1 -- protocol 1 = raw CAN + -- bind the socket to the interface + bind sock (SockAddrCan $ fromIntegral $ ifIndex) + return sock + + serverSetup = clientSetup +#endif + ------------------------------------------------------------------------ -- Other @@ -195,6 +239,9 @@ , testCase "testOverFlowRecvFrom" testOverFlowRecvFrom -- , testCase "testGetPeerCred" testGetPeerCred -- , testCase "testGetPeerEid" testGetPeerEid +#if defined(HAVE_LINUX_CAN_H) + , testCase "testCanSend" testCanSend +#endif ] tests :: [Test]