More flexible Connection interface.

3 files changed, 41 insertions, 31 deletions

diff --git a/Connection.hs b/Connection.hs
index fc4025eb..a7e5d4cc 100644
--- a/Connection.hs
+++ b/Connection.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase    #-}
 module Connection where
 
 import Control.Applicative
@@ -25,12 +26,11 @@ data Policy
     | TryingToConnect   -- ^ We desire to be connected.
  deriving (Eq,Ord,Show)
 
--- | Read-only information obtained via the 'connections' interface to
+-- | Information obtained via the 'connectionStatus' interface to
 -- 'Manager'.
 data Connection status = Connection
-    { connStatus    :: STM (Status status)
-    , connPolicy    :: STM Policy
-    , connPingLogic :: PingMachine
+    { connStatus    :: Status status
+    , connPolicy    :: Policy
     }
  deriving Functor
 
@@ -48,9 +48,10 @@ data Connection status = Connection
 data Manager status k = Manager
     { -- | Connect or disconnect a connection.
       setPolicy    :: k -> Policy -> IO ()
-      -- | Obtain a list (in Map form) of all possible connections, whether
-      -- connected or not.
-    , connections  :: STM (Map k (Connection status))
+      -- | Lookup a connection status.
+    , status       :: k -> STM (Connection status)
+      -- | Obtain a list of all known connections.
+    , connections  :: STM [k]
       -- | Parse a connection key out of a string.  Inverse of 'showKey'.
     , stringToKey  :: String -> Maybe k
       -- | Convert a progress value to a string.
@@ -74,10 +75,13 @@ addManagers :: (Ord kA, Ord kB) =>
             -> Manager (Either statusA statusB) (Either kA kB)
 addManagers mgrA mgrB = Manager
     { setPolicy = either (setPolicy mgrA) (setPolicy mgrB)
+    , status = \case
+        Left  k -> fmap Left  <$> status mgrA k
+        Right k -> fmap Right <$> status mgrB k
     , 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
+        as <- connections mgrA
+        bs <- connections mgrB
+        return $ map Left as ++ map Right bs
     , stringToKey = \str ->  Left <$> stringToKey mgrA str
                         <|> Right <$> stringToKey mgrB str
     , showProgress = either (showProgress mgrA) (showProgress mgrB)
diff --git a/Connection/Tcp.hs b/Connection/Tcp.hs
index e6be15b7..c6f3a8ce 100644
--- a/Connection/Tcp.hs
+++ b/Connection/Tcp.hs
@@ -790,9 +790,11 @@ tcpManager grokKey s2k resolvKey sv = do
                                     (saddr,params,ms) -> ConnectWithEndlessRetry saddr params ms
         OpenToConnect     -> dput XMisc "TODO: TCP OpenToConnect"
         RefusingToConnect -> dput XMisc "TODO: TCP RefusingToConnect"
-    , connections = do
-        c <- readTVar $ conmap sv
-        fmap (exportConnection nullping c) <$> readTVar rmap
+    , status = \k -> do
+        c <- readTVar (conmap sv)
+        ck <- Map.lookup k <$> readTVar rmap
+        return $ exportConnection c (join ck)
+    , connections = Map.keys <$> readTVar rmap
     , stringToKey = s2k
     , showProgress = \case
         Resolving     -> "resolving"
@@ -801,19 +803,16 @@ tcpManager grokKey s2k resolvKey sv = do
     , showKey = show
     }
 
-exportConnection :: Ord conkey => PingMachine -> Map conkey (ConnectionRecord u) -> Maybe conkey -> G.Connection TCPStatus
-exportConnection nullping conmap mkey = G.Connection
+exportConnection :: Ord conkey => Map conkey (ConnectionRecord u) -> Maybe conkey -> G.Connection TCPStatus
+exportConnection conmap mkey = G.Connection
     { G.connStatus    = case mkey of
-        Nothing     -> return $ G.Dormant
+        Nothing     -> G.Dormant
         Just conkey -> case Map.lookup conkey conmap of
-            Nothing                                    -> return $ G.InProgress Resolving
-            Just (ConnectionRecord ckont cstate cdata) -> return $ case cstate of
+            Nothing                                    -> G.InProgress Resolving
+            Just (ConnectionRecord ckont cstate cdata) -> case cstate of
                 SaneConnection      {} -> G.Established
                 ConnectionPair      {} -> G.Established
                 ReadOnlyConnection  {} -> G.InProgress AwaitingWrite
                 WriteOnlyConnection {} -> G.InProgress AwaitingRead
-    , G.connPolicy    = return TryingToConnect
-    , G.connPingLogic = case mkey >>= flip Map.lookup conmap of
-            Nothing                            -> nullping
-            Just (ConnectionRecord _ cstate _) -> connPingTimer cstate
+    , G.connPolicy    = TryingToConnect
     }
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index d6049c13..45a2a682 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -351,6 +351,10 @@ clientSession0 s sock cnum h = do
 parseDebugTag :: String -> Maybe DebugTag
 parseDebugTag s' = readMaybe ('X':map toUpper (take 1 s') ++ drop 1 s')
 
+showPolicy TryingToConnect   = "*"
+showPolicy OpenToConnect     = "o"
+showPolicy RefusingToConnect = "x"
+
 clientSession :: Session -> t1 -> t -> ClientHandle -> IO ()
 clientSession s@Session{..} sock cnum h = do
     line <- dropWhile isSpace <$> hGetClientLine h
@@ -640,10 +644,7 @@ clientSession s@Session{..} sock cnum h = do
                         ca <- readTVar $ contactLastSeenAddr c
                         cf <- readTVar $ contactFriendRequest c
                         cp <- readTVar $ contactPolicy c
-                        let showPolicy TryingToConnect   = "*"
-                            showPolicy OpenToConnect     = "o"
-                            showPolicy RefusingToConnect = "x"
-                            summarizeNodeId | nosummary = id
+                        let summarizeNodeId | nosummary = id
                                             | otherwise = take 6
                             summarizeAddr | nosummary = id
                                           | otherwise = reverse . take 20 . reverse
@@ -1275,12 +1276,18 @@ clientSession s@Session{..} sock cnum h = do
         ("c", s) | Just (ConnectionManager mgr) <- connectionManager
                  , "" <- strp s
                  -> cmd0 $ join $ atomically $ do
-            cmap <- connections mgr
-            cs <- Map.toList <$> mapM connStatus cmap
-            let mkrow = Connection.showKey mgr *** Connection.showStatus mgr
-                rs    = map mkrow cs
+            cs <- do
+                ks <- connections mgr
+                forM ks $ \k -> do
+                    stat <- Connection.status mgr k
+                    return (k,stat)
+            let mkrow (k,st) = [ Connection.showKey mgr k
+                               , Connection.showStatus mgr (connStatus st)
+                               , showPolicy (connPolicy st)
+                               ]
+                rs = map mkrow cs
             return $ do
-            hPutClient h $ showReport rs
+            hPutClient h $ showColumns rs
 
         ("help", s) | Just DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do