Added ConnectFail event

2 files changed, 24 insertions, 2 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index e5ceaf2d..4cbaaa7d 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -145,6 +145,8 @@ data ConnectionEvent b
     -- ^ Arrival of data from a socket
     | Connection (STM Bool) (IO (Maybe ByteString)) (ByteString -> IO Bool)
     -- ^ A new connection was established
+    | ConnectFailure SockAddr
+    -- ^ A 'Connect' command failed.
     | HalfConnection InOrOut
     -- ^ Half of a half-duplex connection is avaliable.
     | EOF 
@@ -267,7 +269,14 @@ server = do
         proto <- getProtocolNumber "tcp"
         sock <- bracketOnError
             (socket (socketFamily addr) Stream proto)
-            (sClose . trace "connect-error" )  -- only done if there's an error
+            (\sock -> do -- only done if there's an error
+                         -- Weird hack: puting the would-be peer address
+                         -- instead of local socketName
+                         conkey <- makeConnKey params (sock,addr) -- XXX: ?
+                         sClose sock
+                         atomically 
+                            $ writeTChan (serverEvent server) 
+                                $ (conkey,ConnectFailure addr))
             $ \sock -> do connect sock addr
                           return sock
         me <- getSocketName sock
diff --git a/xmppServer.hs b/xmppServer.hs
index f91c20ce..40c423aa 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -298,6 +298,8 @@ monitor sv params = do
                  let (xsrc,xsnk) = xmlStream conread conwrite
                  forkConnection k pingflag xsrc xsnk stanzas
                  return ()
+            ConnectFailure addr -> do
+                wlog $ tomsg k "ConnectFailure"
             EOF        -> wlog $ tomsg k "EOF"
             HalfConnection In -> do
                 wlog $ tomsg k "ReadOnly"
@@ -323,11 +325,15 @@ data ConnectionKey
  deriving (Show, Ord, Eq)
 
 peerKey (sock,addr) = do
-    peer <- getPeerName sock
+    peer <- 
+      sIsBound sock >>= \c -> 
+        if c then getPeerName sock -- addr is normally socketName
+             else return addr      -- Weird hack: addr is would-be peer name
     return $ PeerKey (peer `withPort` fromIntegral peerport)
 
 clientKey (sock,addr) = return $ ClientKey addr
 
+
 peerport = 5269
 clientport = 5222
 
@@ -339,6 +345,13 @@ main = runResourceT $ do
                           , timeout = 10000
                           , duplex = False }
     client_params <- return $ connectionDefaults clientKey
+    let testaddr0 = "fd97:ca88:fa7c:b94b:c8b8:fad4:1021:a54d"
+    testaddr<- fmap (addrAddress . head) $
+        getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME ]})
+                (Just testaddr0)
+                (Just "5269")
+    putStrLn $ "Connecting to "++show testaddr
+    control sv (Connect testaddr peer_params)
     forkIO $ monitor sv peer_params
     control sv (Listen peerport peer_params)
     -- control sv (Listen clientport client_params)