hargettp · carletes · Jul 6, 2014 · Jul 6, 2014
diff --git a/README.md b/README.md
@@ -49,8 +49,8 @@ module HelloWorld (
  main = do
     let name1 = "endpoint1"
         name2 = "endpoint2"
-        resolver = resolverFromList [(name1,"localhost:2000"),
-                                (name2,"localhost:2001")]
+        resolver = resolverFromList [(name1,"tcp://localhost:2000"),
+                                (name2,"tcp://localhost:2001")]
     transport <- newTCPTransport resolver
     endpoint1 <- newEndpoint [transport]
     endpoint2 <- newEndpoint [transport]

diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs
@@ -15,8 +15,8 @@ main :: IO ()
 main = do
     let name1 = "endpoint1"
         name2 = "endpoint2"
-        resolver = resolverFromList [(name1,"localhost:2000"),
-                                (name2,"localhost:2001")]
+        resolver = resolverFromList [(name1,"tcp://localhost:2000"),
+                                (name2,"tcp://localhost:2001")]
     transport <- newTCPTransport resolver
     endpoint1 <- newEndpoint [transport]
     endpoint2 <- newEndpoint [transport]
@@ -28,4 +28,4 @@ main = do
         in print (txt :: String)
     Right () <- unbindEndpoint endpoint1 name1
     Right () <- unbindEndpoint endpoint2 name2
-    shutdown transport
+    shutdown transport
diff --git a/src/Network/Endpoints.hs b/src/Network/Endpoints.hs
@@ -97,8 +97,8 @@ import qualified Data.Map as M
 -- > main = do
 -- >    let name1 = "endpoint1"
 -- >        name2 = "endpoint2"
--- >        resolver = resolverFromList [(name1,"localhost:2000"),
--- >                                (name2,"localhost:2001")]
+-- >        resolver = resolverFromList [(name1,"tcp://localhost:2000"),
+-- >                                (name2,"tcp://localhost:2001")]
 -- >    transport <- newTCPTransport resolver
 -- >    endpoint1 <- newEndpoint [transport]
 -- >    endpoint2 <- newEndpoint [transport]

diff --git a/src/Network/Transport/Sockets.hs b/src/Network/Transport/Sockets.hs
@@ -76,6 +76,7 @@ import qualified Data.Text as T
 
 import GHC.Generics
 
+import qualified Network.URI as U
 import Network.Socket hiding (recv,socket,bind,sendTo,shutdown)
 import qualified Network.Socket.ByteString as NSB
 
@@ -240,32 +241,34 @@ data IdentifyMessage = IdentifyMessage Address deriving (Generic)
 instance Serialize IdentifyMessage
 
 {-|
-Parse a TCP 'Address' into its respective 'HostName' and 'PortNumber' components, on the
-assumption the 'Address' has an identifer in the format @host:port@. If
+Parse a URI 'Address' into its respective 'HostName' and 'PortNumber' components, on the
+assumption the 'Address' has an identifer in the format @scheme://host:port@. If
 the port number is missing from the supplied address, it will default to 0.  If the
 hostname component is missing from the identifier (e.g., just @:port@), then hostname
 is assumed to be @localhost@.
 -}
-parseSocketAddress :: Address -> (HostName,ServiceName)
-parseSocketAddress address = 
-  let identifer = T.pack $ address 
-      parts = T.splitOn ":" identifer
-  in if (length parts) > 1 then
-       (host $ T.unpack $ parts !! 0, port $ T.unpack $ parts !! 1)
-     else (host $ T.unpack $ parts !! 0, "0")
-  where
-    host h = if h == "" then
-               "localhost"
-             else h
-    port p = p
+parseSocketAddress :: Address -> Maybe (HostName, ServiceName)
+parseSocketAddress address = do
+  uri <- U.parseURI address
+  auth <- U.uriAuthority uri
+  return (regname $ U.uriRegName auth, port $ U.uriPort auth)
+      where port p =
+                case p of
+                  "" ->  "0"
+                  (':':xs) ->  if null xs then "0" else xs
+                  _ -> "0"
+            regname r = if null r
+                        then "localhost"
+                        else dropWhile (== '[') $ takeWhile (/= ']') r
 
 lookupAddresses :: Family -> SocketType -> Address -> IO [SockAddr]
 lookupAddresses family socketType address =
-    let (host,port) = parseSocketAddress address
-        hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME, AI_NUMERICSERV] }
-    in do
-        addresses <- getAddrInfo (Just hints) (Just host) (Just port)
-        return $ map addrAddress $ filter (\addrInfo -> addrFamily addrInfo == family && addrSocketType addrInfo == socketType) addresses
+    case parseSocketAddress address of
+      Nothing -> return []
+      Just (host, port) -> let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME, AI_NUMERICSERV] }
+                      in do
+                        addresses <- getAddrInfo (Just hints) (Just host) (Just port)
+                        return $ map addrAddress $ filter (\addrInfo -> addrFamily addrInfo == family && addrSocketType addrInfo == socketType) addresses
 
 lookupAddress :: Family -> SocketType -> Address -> IO SockAddr
 lookupAddress family socketType address = do
@@ -369,11 +372,15 @@ sender conn done mailbox = sendMessages
           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)
-          socket <- connConnect conn
-          infoM _log $ "Connected to " ++ (show $ connAddress conn)
-          atomically $ putTMVar (connSocket conn) socket
+                  case parseSocketAddress $ connAddress conn of
+                    Nothing -> do
+                       infoM _log $ "Invalid URI " ++ (show $ connAddress conn)
+                       return ()
+                    Just (host, port) -> do
+                       infoM _log $ "Connecting to " ++ (show host) ++ ":" ++ (show port) -- (show address)
+                       socket <- connConnect conn
+                       infoM _log $ "Connected to " ++ (show $ connAddress conn)
+                       atomically $ putTMVar (connSocket conn) socket
     disconnect = do
       connected <- atomically $ tryTakeTMVar $ connSocket conn
       case connected of

diff --git a/tests/TestTransports.hs b/tests/TestTransports.hs
@@ -46,10 +46,11 @@ pause = threadDelay testDelay
 
 whenIPv6 :: Assertion -> Assertion
 whenIPv6 assn = do
-    addresses <- lookupAddresses NS.AF_INET6 NS.Stream "localhost:1"
+    addresses <- catch (lookupAddresses NS.AF_INET6 NS.Stream "tcp://[::1]:1")
+                       ((\_ -> return []) :: (IOException -> IO [NS.SockAddr]))
     case addresses of
         [] -> do
-            warningM _log $ "IPv6 not available"
+            warningM _log "IPv6 not available"
             return ()
         _ -> assn
 

diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
@@ -11,22 +11,22 @@ import qualified Network.Socket as NS
 newTCPAddress :: IO String
 newTCPAddress = do
   NS.SockAddrInet (NS.PortNum p) _ <- availablePort NS.AF_INET NS.Stream
-  return $ "localhost:" ++ show p
+  return $ "tcp://127.0.0.1:" ++ show p
 
 newUDPAddress :: IO String
 newUDPAddress = do
   NS.SockAddrInet (NS.PortNum p) _ <- availablePort NS.AF_INET NS.Datagram
-  return $ "localhost:" ++ show p
+  return $ "udp://127.0.0.1:" ++ show p
 
 newTCPAddress6 :: IO String
 newTCPAddress6 = do
   NS.SockAddrInet6 (NS.PortNum p) _ _ _ <- availablePort NS.AF_INET6 NS.Stream
-  return $ "localhost:" ++ show p
+  return $ "tcp://[::1]:" ++ show p
 
 newUDPAddress6 :: IO String
 newUDPAddress6 = do
   NS.SockAddrInet6 (NS.PortNum p) _ _ _ <- availablePort NS.AF_INET6 NS.Datagram
-  return $ "localhost:" ++ show p
+  return $ "udp://[::1]:" ++ show p
 
 availablePort     :: NS.Family -> NS.SocketType -> IO NS.SockAddr
 availablePort f t = do