ConnectWithEndlessRetry

1 files changed, 30 insertions, 72 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 4fbb775b..987e7dbc 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -27,14 +27,12 @@ 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)
@@ -288,66 +286,49 @@ forkConnection k pingflag src snk stanzas = do
         wlog $ "end reader fork: " ++ show k
     return output
 
+data ConnectionKey
+       = PeerKey { callBackAddress :: SockAddr }
+       | 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 <- 
+      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)
+
+clientKey (sock,addr) = return $ ClientKey addr
+
 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
-                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 ()
+                 wlog $ tomsg k "Connection"
+                 let (xsrc,xsnk) = xmlStream conread conwrite
+                 forkConnection k pingflag xsrc xsnk stanzas
+                 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 ()
@@ -363,29 +344,6 @@ monitor sv params = do
         where
             _ = str :: String
 
-data ConnectionKey
-       = PeerKey { callBackAddress :: SockAddr }
-       | 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 <- 
-      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)
-
-clientKey (sock,addr) = return $ ClientKey addr
-
 
 peerport = 5269
 clientport = 5222
@@ -404,7 +362,7 @@ main = runResourceT $ do
                 (Just testaddr0)
                 (Just "5269")
     putStrLn $ "Connecting to "++show testaddr
-    control sv (Connect testaddr peer_params)
+    control sv (ConnectWithEndlessRetry testaddr peer_params 2000)
     forkIO $ monitor sv peer_params
     control sv (Listen peerport peer_params)
     -- control sv (Listen clientport client_params)