1 files changed, 91 insertions, 74 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 837cb210..219221e5 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -21,11 +21,12 @@ module Main where
 import Control.Arrow
 import Control.Applicative
 import Control.Concurrent.STM
-import Control.DeepSeq
 import Control.Exception
 import Control.Monad
+import Control.Monad.Trans.Resource (runResourceT)
 import Data.Bool
 import Data.Char
+import Data.Function
 import Data.Hashable
 import Data.List
 import qualified Data.IntMap.Strict as IntMap
@@ -53,6 +54,8 @@ import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Vector as V
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import System.Posix.Signals
+
 
 import Announcer
 import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
@@ -60,8 +63,6 @@ import Network.UPNP as UPNP
 import Network.Address hiding (NodeId, NodeInfo(..))
 import Network.QueryResponse
 import Network.StreamServer
-import Network.Kademlia
-import Network.Kademlia.Bootstrap
 import Network.Kademlia.Search
 import qualified Network.BitTorrent.MainlineDHT as Mainline
 import qualified Network.Tox as Tox
@@ -71,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
@@ -88,6 +90,13 @@ import Data.Typeable
 import Roster
 import OnionRouter
 
+-- Presence imports.
+import ConsoleWriter
+import Presence
+import XMPPServer
+import Connection
+
+
 showReport :: [(String,String)] -> String
 showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
 
@@ -146,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
@@ -191,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]
@@ -375,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
@@ -384,9 +379,10 @@ data Session = Session
     , toxkeys           :: TVar Tox.AnnouncedKeys
     , userkeys          :: TVar [(SecretKey,PublicKey)]
     , roster            :: Roster
+    , connectionManager :: ConnectionManager
     , onionRouter       :: OnionRouter
     , announcer         :: Announcer
-    , signalQuit        :: MVar ()
+    , signalQuit        :: IO ()
     }
 
 exceptionsToClient :: ClientHandle -> IO () -> IO ()
@@ -481,7 +477,7 @@ clientSession s@Session{..} sock cnum h = do
 
         ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
                           hCloseClient h
-                          putMVar signalQuit ()
+                          signalQuit
 
         ("throw", er) -> cmd0 $ do
                             throwIO $ userError er
@@ -633,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
@@ -901,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)
 
@@ -957,27 +935,36 @@ readExternals nodeAddr vars = do
     return $ filter (not . unspecified) as
 
 data Options = Options
-    { portbt  :: String
-    , porttox :: String
-    , ip6bt   :: Bool
-    , ip6tox  :: Bool
-    , dhtkey  :: Maybe SecretKey
+    { portbt    :: String
+    , porttox   :: String
+    , ip6bt     :: Bool
+    , ip6tox    :: Bool
+    , dhtkey    :: Maybe SecretKey
+    -- | Currently only relevant to XMPP server code.
+    --
+    --   [ 0 ] Don't log XMPP stanzas.
+    --
+    --   [ 1 ] Log non-ping stanzas.
+    --
+    --   [ 2 ] Log all stanzas, even pings.
+    , verbosity :: Int
     }
  deriving (Eq,Show)
 
 sensibleDefaults :: Options
 sensibleDefaults = Options
-    { portbt  = "6881"
-    , porttox = "33445"
-    , ip6bt   = True
-    , ip6tox  = True
-    , dhtkey  = Nothing
+    { portbt    = "6881"
+    , porttox   = "33445"
+    , ip6bt     = True
+    , ip6tox    = True
+    , dhtkey    = Nothing
+    , verbosity = 1
     }
 
 -- bt=<port>,tox=<port>
 -- -4
 parseArgs :: [String] -> Options -> Options
-parseArgs []          opts         = opts
+parseArgs []                  opts = opts
 parseArgs ("--dhtkey":k:args) opts = parseArgs args opts
     { dhtkey = decodeSecret $ B.pack k }
 parseArgs ("-4":args) opts         = parseArgs args opts
@@ -996,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
@@ -1010,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
@@ -1080,9 +1079,6 @@ main = do
                                                               , qresultAddr = const $ Mainline.zeroID
                                                               })]
 
-                    , dhtLinks = Map.fromList
-                                    [ {- TODO -}
-                                    ]
                     , dhtSecretKey = return Nothing
                     , dhtBootstrap = case wantip of
                                         Want_IP4 -> btBootstrap4
@@ -1262,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
@@ -1283,8 +1276,11 @@ main = do
 
     let dhts = Map.union btdhts toxdhts
 
-    waitForSignal <- do
-        signalQuit <- newEmptyMVar
+    (waitForSignal, checkQuit) <- do
+        signalQuit <- atomically $ newTVar False
+        let quitCommand = atomically $ writeTVar signalQuit True
+        installHandler sigTERM (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
+        installHandler sigINT (CatchOnce (atomically $ writeTVar signalQuit True)) Nothing
         let defaultToxData = do
                 toxids <- atomically $ newTVar []
                 rster <- newRoster
@@ -1296,20 +1292,22 @@ main = do
         let session = clientSession0 $ Session
                 { netname           = concat $ take 1 $ Map.keys dhts -- initial default DHT
                 , dhts              = dhts  -- all DHTs
-                , signalQuit        = signalQuit
+                , signalQuit        = quitCommand
                 , swarms            = swarms
                 , cryptosessions    = netCryptoSessionsState
                 , toxkeys           = keysdb
                 , userkeys          = toxids
                 , roster            = rstr
+                , connectionManager = ConnectionManager conns
                 , onionRouter       = orouter
                 , externalAddresses = liftM2 (++) btips toxips
                 , announcer         = announcer
                 }
         srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
-        return $ do
-            () <- takeMVar signalQuit
-            quitListening srv
+        return ( do atomically $ readTVar signalQuit >>= check
+                    quitListening srv
+               , readTVar signalQuit >>= check
+               )
 
 
     forM_ (Map.toList dhts)
@@ -1331,6 +1329,25 @@ main = do
             bootstrap btSaved fallbackNodes
         return ()
 
+    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