diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013 Phil Hargett +Copyright (c) 2013-14 Phil Hargett Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/changes.md b/changes.md --- a/changes.md +++ b/changes.md @@ -1,3 +1,12 @@ +0.1.0.12 + + * Fixed a long-standing issue concerning inconsistent failures. Turns out, on operating + systems with both IPv4 and IPv6 support, the TCP and UDP transports (which were really + only intended to be IPv4 for now) were not properly finding IPv4 addresses--in some + cases, IPv6 were being used instead, resulting in errors. Both TCP and UDP now + pass (IPv4 only, of course), and in the future, IPv6 versions of these transports + will be added. + 0.1.0.11 * API breaking change: RPC functions no longer take / return instances of Serialize, diff --git a/courier.cabal b/courier.cabal --- a/courier.cabal +++ b/courier.cabal @@ -1,5 +1,5 @@ name: courier -version: 0.1.0.11 +version: 0.1.0.12 synopsis: A message-passing library for simplifying network applications description: Inspired by Erlang's simple message-passing facilities, courier provides roughly similar capabilities. Applications simply create one or more endpoints, diff --git a/src/Network/Transport/Sockets.hs b/src/Network/Transport/Sockets.hs --- a/src/Network/Transport/Sockets.hs +++ b/src/Network/Transport/Sockets.hs @@ -23,6 +23,7 @@ SocketBindings, bindAddress, unbindAddress, + closeBindings, SocketTransport(..), @@ -240,7 +241,7 @@ hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME, AI_NUMERICSERV] } in do addresses <- getAddrInfo (Just hints) (Just host) (Just port) - return $ map addrAddress addresses + return $ map addrAddress $ filter (\addrinfo -> addrFamily addrinfo == AF_INET) addresses lookupAddress :: (HostName,ServiceName) -> IO SockAddr lookupAddress hostAndPort = do @@ -329,9 +330,12 @@ else sendMessages reconnect = do -- TODO need a timeout here, in case connecting always fails + infoM _log $ "Reconnecting to " ++ (show $ connAddress conn) connected <- atomically $ tryReadTMVar $ connSocket conn case connected of - Just _ -> return () + Just _ -> do + infoM _log $ "Reconnected to " ++ (show $ connAddress conn) + return () Nothing -> do let (host,port) = parseSocketAddress $ connAddress conn infoM _log $ "Connecting to " ++ (show host) ++ ":" ++ (show port) -- (show address) @@ -442,3 +446,10 @@ cancel $ messengerReceiver msngr connClose $ messengerConnection msngr infoM _log $ "Closed messenger to " ++ (messengerAddress msngr) + +closeBindings :: SocketBindings -> IO () +closeBindings sockets = do + infoM _log $ "Closing bindings" + bindings <- atomically $ readTVar sockets + mapM_ (unbindAddress sockets) $ M.keys bindings + infoM _log $ "Closed bindings" diff --git a/src/Network/Transport/TCP.hs b/src/Network/Transport/TCP.hs --- a/src/Network/Transport/TCP.hs +++ b/src/Network/Transport/TCP.hs @@ -80,7 +80,7 @@ handles = tcpHandles transport, bind = tcpBind transport sockets, sendTo = socketSendTo transport, - shutdown = tcpShutdown transport + shutdown = tcpShutdown transport sockets } tcpHandles :: SocketTransport -> Name -> IO Bool @@ -169,9 +169,17 @@ connConnect = do socket <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol sockAddrs <- NS.getAddrInfo - (Just NS.defaultHints {NS.addrFlags = [NS.AI_NUMERICSERV]}) (Just host) (Just port) - NS.connect socket $ NS.addrAddress $ head sockAddrs + (Just NS.defaultHints {NS.addrFlags = [NS.AI_NUMERICSERV,NS.AI_ADDRCONFIG]}) (Just host) (Just port) + let ipv4Addrs = filter (\sockAddr -> + (NS.addrFamily sockAddr == NS.AF_INET) + && (NS.addrSocketType sockAddr == NS.Stream)) + sockAddrs + infoM _log $ "Socket addresses are " ++ (show sockAddrs) + infoM _log $ "IPv4 addresses are " ++ (show ipv4Addrs) + infoM _log $ "Initiating socket connection to " ++ (show $ head ipv4Addrs) + NS.connect socket $ NS.addrAddress $ head ipv4Addrs atomically $ putTMVar sock socket + infoM _log $ "Initiated socket connection to " ++ (show $ head ipv4Addrs) return socket, connSend = tcpSend address, connReceive = receiveSocketBytes, @@ -213,8 +221,9 @@ infoM _log $ "Message sent to" ++ (show addr) -tcpShutdown :: SocketTransport -> IO () -tcpShutdown transport = do +tcpShutdown :: SocketTransport -> SocketBindings -> IO () +tcpShutdown transport sockets = do + closeBindings sockets infoM _log $ "Closing messengers" msngrs <- atomically $ readTVar $ socketMessengers transport mapM_ closeMessenger $ M.elems msngrs diff --git a/src/Network/Transport/UDP.hs b/src/Network/Transport/UDP.hs --- a/src/Network/Transport/UDP.hs +++ b/src/Network/Transport/UDP.hs @@ -81,7 +81,7 @@ handles = udpHandles transport, bind = udpBind transport sockets, sendTo = socketSendTo transport, - shutdown = udpShutdown transport + shutdown = udpShutdown transport sockets } udpHandles :: SocketTransport -> Name -> IO Bool @@ -102,7 +102,13 @@ addrinfos <- N.getAddrInfo (Just (N.defaultHints {N.addrFlags = [N.AI_PASSIVE,N.AI_NUMERICSERV]})) Nothing (Just port) - let serveraddr = head addrinfos + let ipv4Addrs = filter (\sockAddr -> + (N.addrFamily sockAddr == N.AF_INET) + && (N.addrSocketType sockAddr == N.Datagram)) + addrinfos + infoM _log $ "Socket addresses are " ++ (show addrinfos) + infoM _log $ "IPv4 addresses are " ++ (show ipv4Addrs) + let serveraddr = head ipv4Addrs sock <- N.socket (N.addrFamily serveraddr) N.Datagram N.defaultProtocol -- have to set this option in case we frequently rebind sockets infoM _log $ "Binding to " ++ (show port) ++ " over UDP" @@ -174,9 +180,10 @@ then return Nothing else return $ Just bs -udpShutdown :: SocketTransport -> IO () -udpShutdown transport = do +udpShutdown :: SocketTransport -> SocketBindings -> IO () +udpShutdown transport sockets = do infoM _log $ "Unbinding transport" + closeBindings sockets infoM _log $ "Closing messengers" msngrs <- atomically $ readTVar $ socketMessengers transport mapM_ closeMessenger $ M.elems msngrs diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -6,9 +6,11 @@ -- external imports -import System.Directory -import System.Log.Logger +import System.IO +import System.Log.Formatter +import System.Log.Handler (setFormatter) import System.Log.Handler.Simple +import System.Log.Logger import Test.Framework import Test.HUnit @@ -31,14 +33,10 @@ initLogging :: IO () initLogging = do - let logFile = "tests.log" - exists <- doesFileExist logFile - if exists - then removeFile logFile - else return () - s <- fileHandler logFile INFO + s <- streamHandler stdout INFO + let fs = setFormatter s $ simpleLogFormatter "$time [$prio] - $msg" updateGlobalLogger rootLoggerName (setLevel WARNING) - updateGlobalLogger rootLoggerName (addHandler s) + updateGlobalLogger rootLoggerName $ setHandlers [fs] tests :: [Test.Framework.Test] tests =