1 files changed, 58 insertions, 5 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 40c423aa..4fbb775b 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -27,12 +27,14 @@ import Data.Maybe (catMaybes,fromJust)
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
 import qualified Data.Text as Text (pack)
+import qualified Data.Map as Map
 
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
 import ControlMaybe
 import Nesting
 import EventUtil
 import Server
+import Data.Time.Clock (UTCTime,getCurrentTime)
 
 addrToText :: SockAddr -> Text
 addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr)
@@ -289,21 +291,63 @@ forkConnection k pingflag src snk stanzas = do
 monitor sv params = do
     chan <- return $ serverEvent sv
     stanzas <- atomically newTChan
+    peersVar <- atomically $ newTVar Map.empty
+    let doConnect utc k = do
+                  peers <- readTVar peersVar
+                  let mb = Map.lookup k peers
+                  maybe (do false <- newTVar False
+                            pending <- newTVar (PeerPendingConnect utc)
+                            let v = Peer { peerWanted = false
+                                         , peerState  = pending }
+                            writeTVar (peersVar) $ Map.insert k v peers)
+                        (\peer -> 
+                            writeTVar (peerState peer)
+                                $ PeerPendingConnect utc)
+                        mb
     fix $ \loop -> do
     action <- atomically $ foldr1 orElse
       [ readTChan chan >>= \(k,e) -> return $ do 
         case e of
             Connection pingflag conread conwrite -> do
-                 wlog $ tomsg k "Connection"
-                 let (xsrc,xsnk) = xmlStream conread conwrite
-                 forkConnection k pingflag xsrc xsnk stanzas
-                 return ()
+                wlog $ tomsg k "Connection"
+                let (xsrc,xsnk) = xmlStream conread conwrite
+                outs <- forkConnection k pingflag xsrc xsnk stanzas
+                atomically $ do
+                  peers <- readTVar peersVar
+                  let mb = Map.lookup k peers
+                  maybe (do false <- newTVar True -- False -- TODO: should be False
+                            connected <- newTVar (PeerConnected outs)
+                            let v = Peer { peerWanted = false
+                                         , peerState  = connected }
+                            writeTVar (peersVar) $ Map.insert k v peers)
+                          (\peer -> do
+                              writeTVar (peerWanted peer) True -- TODO REMOVE
+                              writeTVar (peerState peer)
+                                  $ PeerConnected outs)
+                          mb
+                return ()
             ConnectFailure addr -> do
                 wlog $ tomsg k "ConnectFailure"
+                action <- atomically $ do
+                  peers <- readTVar peersVar
+                  let mb = Map.lookup k peers
+                  maybe (return $ return ())
+                        (\peer -> do
+                            wanted <- readTVar (peerWanted peer)
+                            if wanted then return $ do
+                                            utc <- getCurrentTime
+                                            control sv (Connect addr params)
+                                            wlog $ tomsg k "Retry"
+                                            atomically $ doConnect utc k
+                                      else return $ return ())
+                        mb
+                action
             EOF        -> wlog $ tomsg k "EOF"
             HalfConnection In -> do
                 wlog $ tomsg k "ReadOnly"
+                utc <- getCurrentTime
                 control sv (Connect (callBackAddress k) params)
+                atomically $ doConnect utc k
             HalfConnection Out -> wlog $ tomsg k "WriteOnly"
             RequiresPing -> wlog $ tomsg k "RequiresPing"
             _ -> return ()
@@ -324,9 +368,18 @@ data ConnectionKey
        | ClientKey { localAddress :: SockAddr }
  deriving (Show, Ord, Eq)
 
+data Peer = Peer
+    { peerWanted :: TVar Bool -- ^ False when this peer is on a you-call-me basis
+    , peerState :: TVar PeerState
+    }
+data PeerState
+    = PeerPendingConnect UTCTime
+    | PeerPendingAccept UTCTime
+    | PeerConnected (TChan Stanza)
+
 peerKey (sock,addr) = do
     peer <- 
-      sIsBound sock >>= \c -> 
+      sIsConnected 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)