New cli "c" interface to Connection.Manager.

2 files changed, 56 insertions, 86 deletions

diff --git a/Connection.hs b/Connection.hs
index 22c5b1da..3287bc1b 100644
--- a/Connection.hs
+++ b/Connection.hs
@@ -35,6 +35,12 @@ data Manager status k = Manager
     , showKey      :: k -> String
     }
 
+showStatus :: Manager status k -> Status status -> String
+showStatus mgr Dormant        = "dormant"
+showStatus mgr Established    = "established"
+showStatus mgr (InProgress s) = "in progress ("++showProgress mgr s++")"
+
+
 addManagers :: (Ord kA, Ord kB) =>
             Manager statusA kA
             -> Manager statusB kB
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index abf0c297..219221e5 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -23,7 +23,6 @@ import Control.Applicative
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
-import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource (runResourceT)
 import Data.Bool
 import Data.Char
@@ -73,6 +72,7 @@ import qualified Data.Aeson as J
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as B
 import Control.Concurrent.Tasks
+import Control.Monad.Trans.Control
 import System.IO.Error
 import qualified Data.Serialize as S
 import Network.BitTorrent.DHT.ContactInfo as Peers
@@ -94,6 +94,7 @@ import OnionRouter
 import ConsoleWriter
 import Presence
 import XMPPServer
+import Connection
 
 
 showReport :: [(String,String)] -> String
@@ -154,21 +155,6 @@ data DHTAnnouncable nid = forall dta tok ni r.
     , qresultAddr :: dta -> nid
     }
 
-data DHTLink = forall status linkid params.
-                ( Show status
-                , Show linkid
-                , Typeable status
-                , Typeable linkid
-                , Typeable params
-                ) => DHTLink
-    { linkInit    :: params -> IO (Either String status)
-    , linkParamParser :: [String] -> Either String params
-    , linkStatus  :: IO (Either String status)
-    , showLinkStatus :: status -> String
-    , linkNewPipe :: String -> linkid -> IO (Either String status)
-    , linkUnPipe  :: linkid -> IO (Either String status)
-    }
-
 data DHTSearch nid ni = forall addr tok r. DHTSearch
     { searchThread     :: ThreadId
     , searchState      :: SearchState nid addr tok ni r
@@ -199,7 +185,6 @@ data DHT = forall nid ni. ( Show     ni
     , dhtPing          :: Map.Map String (DHTPing ni)
     , dhtQuery         :: Map.Map String (DHTQuery nid ni)
     , dhtAnnouncables  :: Map.Map String (DHTAnnouncable nid)
-    , dhtLinks         :: Map.Map String DHTLink
     , dhtParseId       :: String -> Either String nid
     , dhtSearches      :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
     , dhtFallbackNodes :: IO [ni]
@@ -383,6 +368,8 @@ reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} =
         ns'           = map showN ns
     reportResult meth id (const Nothing) id h (Right (ns',rs, Just ()))
 
+data ConnectionManager = forall status k. ConnectionManager { typedManager :: Connection.Manager status k }
+
 data Session = Session
     { netname           :: String
     , dhts              :: Map.Map String DHT
@@ -392,6 +379,7 @@ data Session = Session
     , toxkeys           :: TVar Tox.AnnouncedKeys
     , userkeys          :: TVar [(SecretKey,PublicKey)]
     , roster            :: Roster
+    , connectionManager :: ConnectionManager
     , onionRouter       :: OnionRouter
     , announcer         :: Announcer
     , signalQuit        :: IO ()
@@ -641,7 +629,6 @@ clientSession s@Session{..} sock cnum h = do
                 hPutClientChunk h $ "trampolines: " ++ show (IntMap.size ts) ++ "\n"
                 hPutClient h $ showColumns $ ["","responses","timeouts"]:r
 
-
         ("g", s) | Just DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
                         -- arguments: method
@@ -909,46 +896,29 @@ clientSession s@Session{..} sock cnum h = do
                             mkentry (k :-> Down tm) = [ show cnt, show k, show (now - tm) ]
                                 where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb)
                         hPutClient h $ showColumns entries
-        ("c", s) | "" <- strp s -> cmd0 $ do
-                        let combinedLinkMap = Map.unions $map (dhtLinks . snd) (Map.toList dhts)
-                        -- TODO: list all connections
-                        let connections =  [[{-TODO-}]]
-                        hPutClient h $ showColumns connections
-        ("c", s) -> cmd0 $ do
-                        let combinedLinkMap = Map.unions $map (dhtLinks . snd) (Map.toList dhts)
-                        -- form new connection according of type corresponding to parameter
-                        let ws = words s
-                        result
-                          <- case ws of
-                              (linktype:rest)
-                                -> case (Map.lookup (head ws) combinedLinkMap) of
-                                    Nothing -> return . Left $ "I don't know a '" ++ head ws ++ "' link type."
-                                    Just l@(DHTLink
-                                              { linkInit        {- :: params   -> IO (Either String status) -}
-                                              , linkParamParser {- :: [String] -> Either String params      -}
-                                              , showLinkStatus  {- :: status   -> String                    -}
-                                              }) -> case linkParamParser rest of
-                                                        Left er -> return $ Left er
-                                                        Right params -> fmap showLinkStatus <$> linkInit params
-                              _ -> return $ Left "parse error"
-                        case result of
-                            Left er -> hPutClient h er
-                            Right statusstr -> hPutClient h statusstr
+
+        ("c", s) | "" <- strp s -> cmd0 $ join $ atomically $ do
+            ConnectionManager mgr <- return connectionManager
+            cmap <- connections mgr
+            cs <- Map.toList <$> mapM connStatus cmap
+            let mkrow = Connection.showKey mgr *** Connection.showStatus mgr
+                rs    = map mkrow cs
+            return $ do
+            hPutClient h $ showReport rs
 
         ("help", s) | Just DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
             let tolist :: a -> [a]
                 tolist = (:[])
 
-                dhtkeys, announcables, links, ks, allcommands :: [[String]]
+                dhtkeys, announcables, ks, allcommands :: [[String]]
                 dhtkeys = map tolist $ Map.keys dhts
                 queries = map (tolist . ("s "++)) $ Map.keys dhtQuery
                 xs = map (tolist . ("x "++)) $ Map.keys dhtQuery
                 gs = map (tolist . ("g "++)) $ Map.keys dhtQuery
                 announcables = map (tolist . ("p "++)) $ Map.keys dhtAnnouncables
-                links = map (tolist . ("c "++)) $ Map.keys dhtLinks
                 ks = [["k gen"],["k public"],["k secret"]]
-                allcommands = sortBy (comparing head) $ concat [sessionCommands, dhtkeys, announcables, links, ks, queries, gs,xs]
+                allcommands = sortBy (comparing (take 1)) $ concat [sessionCommands, dhtkeys, announcables, ks, queries, gs,xs]
 
             hPutClient h ("Available commands:\n" ++ showColumns allcommands)
 
@@ -1013,7 +983,7 @@ noArgPing f [] x = f x
 noArgPing _ _  _ = return Nothing
 
 main :: IO ()
-main = do
+main = runResourceT $ liftBaseWith $ \resT -> do
     args <- getArgs
     let opts = parseArgs args sensibleDefaults
     print opts
@@ -1027,6 +997,18 @@ main = do
 
     announcer <- forkAnnouncer
 
+    -- XMPP initialization
+    cw        <- newConsoleWriter
+    serverVar <- atomically $ newEmptyTMVar
+    state     <- newPresenceState cw serverVar
+
+    -- XMPP stanza handling
+    sv    <- resT $ xmppServer (presenceHooks state (verbosity opts))
+    -- We now have a server object but it's not ready to use until
+    -- we put it into the 'server' field of our /state/ record.
+
+    conns <- xmppConnections sv
+
     (quitBt,btdhts,btips,baddrs) <- case portbt opts of
         "" -> return (return (), Map.empty,return [],[])
         p  -> do
@@ -1097,9 +1079,6 @@ main = do
                                                               , qresultAddr = const $ Mainline.zeroID
                                                               })]
 
-                    , dhtLinks = Map.fromList
-                                    [ {- TODO -}
-                                    ]
                     , dhtSecretKey = return Nothing
                     , dhtBootstrap = case wantip of
                                         Want_IP4 -> btBootstrap4
@@ -1279,9 +1258,6 @@ main = do
 
                                                                , announceInterval = 8
                                                                })]
-                    , dhtLinks = Map.fromList
-                                    [ {- TODO -}
-                                    ]
                     , dhtSecretKey = return $ Just $ transportSecret (Tox.toxCryptoKeys tox)
                     , dhtBootstrap = case wantip of
                                         Want_IP4 -> toxStrap4
@@ -1322,6 +1298,7 @@ main = do
                 , toxkeys           = keysdb
                 , userkeys          = toxids
                 , roster            = rstr
+                , connectionManager = ConnectionManager conns
                 , onionRouter       = orouter
                 , externalAddresses = liftM2 (++) btips toxips
                 , announcer         = announcer
@@ -1352,39 +1329,26 @@ main = do
             bootstrap btSaved fallbackNodes
         return ()
 
-    -- XMPP initialization
-    cw        <- newConsoleWriter
-    serverVar <- atomically $ newEmptyTMVar
-    state     <- newPresenceState cw serverVar
-
-    -- XMPP stanza handling
-    runResourceT $ do
-        sv    <- xmppServer (presenceHooks state (verbosity opts))
-        -- We now have a server object but it's not ready to use until
-        -- we put it into the 'server' field of our /state/ record.
-
-        liftIO $ do
-        conns <- xmppConnections sv
-        atomically $ do
-            putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
-                                           -- FIXME: This is error prone.
-
-        forkIO $ do
-            myThreadId >>= flip labelThread "XMPP.stanzas"
-            let console = cwPresenceChan <$> consoleWriter state
-            fix $ \loop -> do
-            what <- atomically
-                $ orElse (do (client,stanza) <- maybe retry takeTMVar console
-                             return $ do informClientPresence0 state Nothing client stanza
-                                         loop)
-                         (checkQuit >> return (return ()))
-            what
-
-        hPutStrLn stderr "Started XMPP server."
-
-        -- Wait for DHT and XMPP threads to finish.
-        -- Use ResourceT to clean-up XMPP server.
-        waitForSignal
+    atomically $ do
+        putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
+                                       -- FIXME: This is error prone.
+
+    forkIO $ do
+        myThreadId >>= flip labelThread "XMPP.stanzas"
+        let console = cwPresenceChan <$> consoleWriter state
+        fix $ \loop -> do
+        what <- atomically
+            $ orElse (do (client,stanza) <- maybe retry takeTMVar console
+                         return $ do informClientPresence0 state Nothing client stanza
+                                     loop)
+                     (checkQuit >> return (return ()))
+        what
+
+    hPutStrLn stderr "Started XMPP server."
+
+    -- Wait for DHT and XMPP threads to finish.
+    -- Use ResourceT to clean-up XMPP server.
+    waitForSignal
 
     stopAnnouncer announcer
     quitBt