3 files changed, 142 insertions, 46 deletions

diff --git a/Connection.hs b/Connection.hs
new file mode 100644
index 00000000..e3e9a8ca
--- /dev/null
+++ b/Connection.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE DeriveFunctor #-}
+module Connection where
+
+import Control.Arrow
+import Control.Concurrent.STM
+import qualified Data.Map as Map
+         ;import Data.Map (Map)
+
+import PingMachine
+
+data Status status
+    = Dormant
+    | InProgress status
+    | Established
+ deriving Functor
+
+data Policy
+    = RefusingToConnect
+    | OpenToConnect
+    | TryingToConnect
+
+data Connection status = Connection
+    { connStatus    :: STM (Status status)
+    , connPolicy    :: STM Policy
+    , connPingLogic :: PingMachine
+    }
+ deriving Functor
+
+data Manager status k = Manager
+    { setPolicy    :: k -> Policy -> IO ()
+    , connections  :: STM (Map k (Connection status))
+    , stringToKey  :: String -> IO (Maybe k) -- TODO: It'd be nice for this to be pure, but
+                                             -- currently we do a DNS resolve.
+    , showProgress :: status -> String
+    , showKey      :: k -> String
+    }
+
+addManagers :: (Ord kA, Ord kB) =>
+            Manager statusA kA
+            -> Manager statusB kB
+            -> Manager (Either statusA statusB) (Either kA kB)
+addManagers mgrA mgrB = Manager
+    { setPolicy = either (setPolicy mgrA) (setPolicy mgrB)
+    , connections = do
+        as <- Map.toList <$> connections mgrA
+        bs <- Map.toList <$> connections mgrB
+        return $ Map.fromList $ map (Left *** fmap Left) as ++ map (Right *** fmap Right) bs
+    , stringToKey = \str -> do
+        ka <- fmap Left <$> stringToKey mgrA str
+        maybe (fmap Right <$> stringToKey mgrB str) (return . Just) ka
+    , showProgress = either (showProgress mgrA) (showProgress mgrB)
+    , showKey = either (showKey mgrA) (showKey mgrB)
+    }
diff --git a/Presence/Server.hs b/Presence/Server.hs
index 46b32b81..da0a6973 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -20,7 +20,9 @@
 --
 --  * interface tweaks
 --
-module Server where
+module Server
+    ( module Server
+    , module PingMachine ) where
 
 import Data.ByteString (ByteString,hGetNonBlocking)
 import qualified Data.ByteString.Char8 as S -- ( hPutStrLn, hPutStr, pack)
@@ -76,6 +78,9 @@ import InterruptibleDelay
 import PingMachine
 import Network.StreamServer
 import Network.SocketLike hiding (sClose)
+import qualified Connection as G
+         ;import Connection (Manager (..), Policy(..))
+
 
 type Microseconds = Int
 
@@ -762,3 +767,35 @@ warn str = S.hPutStrLn stderr str >> hFlush stderr
 
 debugNoise :: Monad m => t -> m ()
 debugNoise str = return ()
+
+data TCPStatus = AwaitingRead | AwaitingWrite
+
+tcpManager :: Show conkey =>
+              (conkey -> (SockAddr, ConnectionParameters conkey u, Miliseconds))
+              -> (String -> IO (Maybe conkey))
+              -> Server conkey u releaseKey x
+              -> Manager TCPStatus conkey
+tcpManager grokKey parseKey sv = Manager
+    { setPolicy = \k -> \case
+        TryingToConnect -> control sv $ case grokKey k of
+                            (saddr,params,ms) -> ConnectWithEndlessRetry saddr params ms
+        OpenToConnect     -> return () -- TODO
+        RefusingToConnect -> return () -- TODO
+    , connections = fmap exportConnection <$> readTVar (conmap sv)
+    , stringToKey = parseKey
+    , showProgress = \case
+        AwaitingRead  -> "awaiting inbound"
+        AwaitingWrite -> "awaiting outbound"
+    , showKey = show
+    }
+
+exportConnection :: ConnectionRecord u -> G.Connection TCPStatus
+exportConnection (ConnectionRecord ckont cstate cdata) = G.Connection
+    { G.connStatus    = return $ case cstate of
+        SaneConnection      {} -> G.Established
+        ConnectionPair      {} -> G.Established
+        ReadOnlyConnection  {} -> G.InProgress AwaitingWrite
+        WriteOnlyConnection {} -> G.InProgress AwaitingRead
+    , G.connPolicy    = return TryingToConnect
+    , G.connPingLogic = connPingTimer cstate
+    }
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 3505a0a2..b23bb42e 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -8,7 +8,7 @@ module XMPPServer
     , ConnectionKey(..)
     , XMPPServerParameters(..)
     , XMPPServer
-    , addPeer
+    , xmppConnections
     , StanzaWrap(..)
     , Stanza(..)
     , StanzaType(..)
@@ -81,11 +81,12 @@ import qualified Data.Map as Map
 import Data.Set (Set, (\\) )
 import qualified Data.Set as Set
 import Data.String ( IsString(..) )
-import qualified System.Random 
+import qualified System.Random
 import Data.Void (Void)
 import System.Endian (toBE32)
 import Control.Applicative
 import System.IO
+import qualified Connection
 
 peerport :: PortNumber
 peerport = 5269
@@ -103,7 +104,7 @@ data JabberShow = Offline
                 | Chatty
  deriving (Show,Enum,Ord,Eq,Read)
 
-data MessageThread = MessageThread { 
+data MessageThread = MessageThread {
         msgThreadParent  :: Maybe Text,
         msgThreadContent :: Text
     }
@@ -202,9 +203,9 @@ data XMPPServerParameters =
     , xmppInformPeerPresence :: ConnectionKey -> Stanza -> IO ()
     , -- | Called when a remote peer requests our status.
       xmppAnswerProbe :: ConnectionKey -> Stanza -> TChan Stanza -> IO ()
-    , xmppClientSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () 
+    , xmppClientSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
     , -- | Called when a remote peer sends subscription request.
-      xmppPeerSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO () 
+      xmppPeerSubscriptionRequest :: IO () -> ConnectionKey -> Stanza -> TChan Stanza -> IO ()
     , xmppClientInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
     , -- | Called when a remote peer informs us of our subscription status.
       xmppPeerInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
@@ -220,14 +221,14 @@ enableClientHacks "Pidgin" version replyto = do
     wlog "Enabling hack SimulatedChatErrors for client Pidgin"
     donevar <- atomically newEmptyTMVar
     sendReply donevar
-              (InternalEnableHack SimulatedChatErrors) 
+              (InternalEnableHack SimulatedChatErrors)
               []
               replyto
 enableClientHacks "irssi-xmpp" version replyto = do
     wlog "Enabling hack SimulatedChatErrors for client irssi-xmpp"
     donevar <- atomically newEmptyTMVar
     sendReply donevar
-              (InternalEnableHack SimulatedChatErrors) 
+              (InternalEnableHack SimulatedChatErrors)
               []
               replyto
 enableClientHacks _ _ _ = return ()
@@ -240,7 +241,7 @@ cacheMessageId id' replyto = do
               (InternalCacheId id')
               []
               replyto
-    
+
 
 -- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
 -- client connection
@@ -318,7 +319,7 @@ copyToChannel
      (Event -> a) -> LockedChan a -> TVar (Maybe [Event]) -> ConduitM Event Event m ()
 copyToChannel f chan closer_stack = awaitForever copy
  where
-    copy x = do 
+    copy x = do
         liftIO . atomically $ writeLChan chan (f x)
         case x of
             EventBeginDocument {} -> do
@@ -333,9 +334,9 @@ copyToChannel f chan closer_stack = awaitForever copy
 
 
 prettyPrint :: ByteString -> ConduitM Event Void IO ()
-prettyPrint prefix = 
+prettyPrint prefix =
         XML.renderBytes (XML.def { XML.rsPretty=True })
-        =$= CB.lines 
+        =$= CB.lines
         =$ CL.mapM_ (wlogb . (prefix <>))
 
 swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m ()
@@ -534,7 +535,7 @@ stanzaFromList stype reply = do
 
 grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
 grokStanzaIQGet stanza = do
-    mtag <- nextElement 
+    mtag <- nextElement
     flip (maybe $ return Nothing)  mtag $ \tag -> do
     case tagName tag of
         "{urn:xmpp:ping}ping" -> return $ Just Ping
@@ -564,7 +565,7 @@ parseClientVersion = parseit Nothing Nothing
 
 grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
 grokStanzaIQResult stanza = do
-    mtag <- nextElement 
+    mtag <- nextElement
     flip (maybe $ return (Just Pong))  mtag $ \tag -> do
     case tagName tag of
         "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
@@ -573,7 +574,7 @@ grokStanzaIQResult stanza = do
 
 grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
 grokStanzaIQSet stanza = do
-    mtag <- nextElement 
+    mtag <- nextElement
     flip (maybe $ return Nothing)  mtag $ \tag -> do
     case tagName tag of
         "{urn:ietf:params:xml:ns:xmpp-bind}bind" -> do
@@ -689,7 +690,7 @@ parseMessage ns stanza = do
         parseChildren (th,cmap) = do
             child <- nextElement
             lvl <- nesting
-            xmllang <- xmlLang 
+            xmllang <- xmlLang
             let lang = maybe "" id xmllang
             let c = maybe emptyMsg id (Map.lookup lang cmap)
             -- log $ " child: "<> bshow child
@@ -719,7 +720,7 @@ parseMessage ns stanza = do
                 Nothing -> return (th,cmap)
     (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
                                   , Map.empty )
-    return Message { 
+    return Message {
         msgLangMap = Map.toList langmap,
         msgThread = if msgThreadContent th/="" then Just th else Nothing
     }
@@ -772,7 +773,7 @@ grokMessage ns stanzaTag = do
 
 grokStanza
   ::  Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
-grokStanza "jabber:server" stanzaTag = 
+grokStanza "jabber:server" stanzaTag =
             case () of
                 _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
                 _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
@@ -780,7 +781,7 @@ grokStanza "jabber:server" stanzaTag =
                 _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
                 _ -> return $ Just Unrecognized
 
-grokStanza "jabber:client" stanzaTag = 
+grokStanza "jabber:client" stanzaTag =
             case () of
                 _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
                 _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
@@ -812,7 +813,7 @@ makeMessage namespace from to bod =
             , msgSubject = Nothing }
 
 makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
-makeInformSubscription namespace from to approved = 
+makeInformSubscription namespace from to approved =
     stanzaFromList (PresenceInformSubscription approved)
       $ [ EventBeginElement (mkname namespace "presence")
             [ attr "from" from
@@ -843,16 +844,16 @@ makePresenceStanza namespace mjid pstat = do
     shw Away         = ["away"]
     shw DoNotDisturb = ["dnd"]
     shw _            = []
-    jabberShow stat = 
+    jabberShow stat =
       [ EventBeginElement "{jabber:client}show" []
       , EventContent (ContentText stat)
       , EventEndElement "{jabber:client}show" ]
-    
+
 makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
 makeRosterUpdate tojid contact as = do
     let attrs = map (uncurry attr) as
     stanzaFromList Unrecognized
-      [ EventBeginElement "{jabber:client}iq" 
+      [ EventBeginElement "{jabber:client}iq"
             [ attr "to"   tojid
             , attr "id"   "someid"
             , attr "type" "set"
@@ -932,7 +933,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
                               }
                 ioWriteChan stanzas s
           you <- liftIO tellyourname
-          flip (maybe $ unrecog) dispatch $ \dispatch -> 
+          flip (maybe $ unrecog) dispatch $ \dispatch ->
             case dispatch of
               -- Checking that the to-address matches this server.
               -- Otherwise it could be a client-to-client ping or a
@@ -969,7 +970,7 @@ xmppInbound sv xmpp k laddr pingflag stanzas output donevar = doNestingXML $ do
           awaitCloser stanza_lvl
         liftIO . atomically $ writeTVar clsrs Nothing
         loop
-    
+
 
 while :: IO Bool -> IO a -> IO [a]
 while cond body = do
@@ -1033,7 +1034,7 @@ data XMPPState
  deriving (Eq,Ord)
 
 makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
-makePing namespace mid to from = 
+makePing namespace mid to from =
        [ EventBeginElement (mkname namespace "iq")
          $ (case mid of
             Just c -> (("id",[ContentText c]):)
@@ -1073,7 +1074,7 @@ iq_bind_reply mid jid =
 iq_session_reply :: Maybe Text -> Text -> [XML.Event]
 iq_session_reply mid host =
     -- Note: similar to Pong
-    [ EventBeginElement "{jabber:client}iq" 
+    [ EventBeginElement "{jabber:client}iq"
         (consid mid [("from",[ContentText host])
                     ,("type",[ContentText "result"])
                     ])
@@ -1082,12 +1083,12 @@ iq_session_reply mid host =
 
 iq_service_unavailable :: Maybe Text -> Text -> XML.Name -> [XML.Event]
 iq_service_unavailable mid host {- mjid -} req =
-    [ EventBeginElement "{jabber:client}iq" 
+    [ EventBeginElement "{jabber:client}iq"
         (consid mid [attr "type" "error"
                     ,attr "from" host])
     , EventBeginElement req []
     , EventEndElement req
-    , EventBeginElement "{jabber:client}error" 
+    , EventBeginElement "{jabber:client}error"
         [ attr "type" "cancel"
         , attr "code" "503" ]
     , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
@@ -1139,7 +1140,7 @@ greet namespace =
 -}
 
 goodbye :: [XML.Event]
-goodbye = 
+goodbye =
     [ EventEndElement (streamP "stream")
     , EventEndDocument
     ]
@@ -1274,7 +1275,7 @@ forkConnection sv xmpp k laddr pingflag src snk stanzas = do
                 -- TODO: Probably some stanzas should be queued or saved for re-connect.
                 mapM_ fail $ filter notError (maybeToList last ++ es')
                 wlog $ "end post-queue fork: " ++ show k
-    
+
     output <- atomically newTChan
     hacks <- atomically $ newTVar Map.empty
     msgids <- atomically $ newTVar []
@@ -1376,8 +1377,8 @@ data PeerState
 peerKey :: SocketLike sock => sock -> IO (ConnectionKey,SockAddr)
 peerKey sock = do
     addr <- getSocketName sock
-    peer <- 
-      sIsConnected sock >>= \c -> 
+    peer <-
+      sIsConnected sock >>= \c ->
         if c then getPeerName sock -- addr is normally socketName
              else return addr      -- Weird hack: addr is would-be peer name
     laddr <- getSocketName sock
@@ -1390,12 +1391,12 @@ clientKey sock = do
     return $ (ClientKey addr,paddr)
 
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
-xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set) 
+xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
  where
-  item jid = do yield $ EventBeginElement "{jabber:iq:roster}item" 
+  item jid = do yield $ EventBeginElement "{jabber:iq:roster}item"
                         ([ attr "jid" jid
                          , attr "subscription" stype
-                         ]++if Set.member jid solicited 
+                         ]++if Set.member jid solicited
                              then [attr "ask" "subscribe"]
                              else [] )
                 yield $ EventEndElement "{jabber:iq:roster}item"
@@ -1430,7 +1431,7 @@ sendRoster query xmpp replyto = do
                         (consid (stanzaId query)
                             [ attr "to" jid
                             , attr "type" "result" ])
-            yield $ EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver? 
+            yield $ EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver?
             xmlifyRosterItems solicited "to" subto
             xmlifyRosterItems solicited "from" subfrom
             xmlifyRosterItems solicited "both" subboth
@@ -1462,7 +1463,7 @@ socketFromKey sv k = do
     case mcd of
         Nothing -> case k of
                     ClientKey addr -> return addr
-                    PeerKey addr -> return addr 
+                    PeerKey addr -> return addr
                         -- XXX: ? wrong address
                         -- Shouldnt happen anyway.
         Just cd -> return $ cdata cd
@@ -1533,7 +1534,7 @@ xep0086 e =
     UnexpectedRequest     -> ("wait", 400)
 
 errorText :: StanzaError -> Text
-errorText e = 
+errorText e =
  case e of
     BadRequest            -> "Bad request"
     Conflict              -> "Conflict"
@@ -1635,7 +1636,7 @@ monitor sv params xmpp = do
     quitVar <- atomically newEmptyTMVar
     fix $ \loop -> do
     action <- atomically $ foldr1 orElse
-      [ readTChan chan >>= \((k,u),e) -> return $ do 
+      [ readTChan chan >>= \((k,u),e) -> return $ do
         case e of
             Connection pingflag xsrc xsnk -> do
                 wlog $ tomsg k "Connection"
@@ -1665,7 +1666,7 @@ monitor sv params xmpp = do
 
         forkIO $ do
             case stanzaOrigin stanza of
-                NetworkOrigin k@(ClientKey {}) replyto -> 
+                NetworkOrigin k@(ClientKey {}) replyto ->
                     case stanzaType stanza of
                         RequestResource wanted -> do
                             sockaddr <- socketFromKey sv k
@@ -1676,7 +1677,7 @@ monitor sv params xmpp = do
                             let requestVersion :: Producer IO XML.Event
                                 requestVersion = do
                                   yield $ EventBeginElement "{jabber:client}iq"
-                                              [ attr "to" rsc 
+                                              [ attr "to" rsc
                                               , attr "from" hostname
                                               , attr "type" "get"
                                               , attr "id" "version"]
@@ -1780,7 +1781,7 @@ monitor sv params xmpp = do
                     NetworkOrigin (PeerKey {})   _ -> "P"
         wlog ""
         stanzaToConduit dup $$ prettyPrint typ
-        
+
       ]
     action
     loop
@@ -1794,9 +1795,14 @@ data XMPPServer
                  , _xmpp_peer_params :: ConnectionParameters ConnectionKey SockAddr
                  }
 
-addPeer :: XMPPServer -> SockAddr -> IO ()
-addPeer sv addr = do
-    control (_xmpp_sv sv) (ConnectWithEndlessRetry addr (_xmpp_peer_params sv) 10000)
+grokPeer :: XMPPServer -> ConnectionKey -> (SockAddr, ConnectionParameters ConnectionKey SockAddr, Miliseconds)
+grokPeer sv (PeerKey addr) = (addr, _xmpp_peer_params sv, 10000)
+
+xmppConnections :: XMPPServer -> Connection.Manager TCPStatus ConnectionKey
+xmppConnections sv = tcpManager (grokPeer sv) resolvPeer (_xmpp_sv sv)
+ where
+    resolvPeer :: String -> IO (Maybe ConnectionKey)
+    resolvPeer str = fmap PeerKey <$> listToMaybe <$> resolvePeer (Text.pack str)
 
 xmppServer :: ( MonadResource m
               , MonadIO m