Combined XMPP daemon into examples/dhtd.

1 files changed, 64 insertions, 22 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 837cb210..025f957f 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -21,11 +21,13 @@ 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.IO.Class (liftIO)
+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 +55,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 +64,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
@@ -88,6 +90,12 @@ import Data.Typeable
 import Roster
 import OnionRouter
 
+-- Presence imports.
+import ConsoleWriter
+import Presence
+import XMPPServer
+
+
 showReport :: [(String,String)] -> String
 showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
 
@@ -386,7 +394,7 @@ data Session = Session
     , roster            :: Roster
     , onionRouter       :: OnionRouter
     , announcer         :: Announcer
-    , signalQuit        :: MVar ()
+    , signalQuit        :: IO ()
     }
 
 exceptionsToClient :: ClientHandle -> IO () -> IO ()
@@ -481,7 +489,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
@@ -957,21 +965,30 @@ 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 = 0
     }
 
 -- bt=<port>,tox=<port>
@@ -1283,8 +1300,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,7 +1316,7 @@ 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
@@ -1307,9 +1327,10 @@ main = do
                 , 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
+               )
 
 
     forM_ (Map.toList dhts)
@@ -1331,7 +1352,28 @@ main = do
             bootstrap btSaved fallbackNodes
         return ()
 
-    waitForSignal
+    -- XMPP initialization
+    cw    <- newConsoleWriter
+    state <- newPresenceState cw
+
+    -- XMPP stanza handling
+    runResourceT $ do
+        sv    <- xmppServer (presenceHooks state (verbosity opts))
+
+        fork $ liftIO $ do
+            myThreadId >>= flip labelThread "XMPP.stanzas"
+            let console = cwPresenceChan $ consoleWriter state
+            fix $ \loop -> do
+            what <- atomically
+                $ orElse (do (client,stanza) <- takeTMVar console
+                             return $ do informClientPresence0 state Nothing client stanza
+                                         loop)
+                         (checkQuit >> return (return ()))
+            what
+
+        -- Wait for DHT and XMPP threads to finish.
+        -- Use ResourceT to clean-up XMPP server.
+        liftIO waitForSignal
 
     stopAnnouncer announcer
     quitBt