1 files changed, 47 insertions, 0 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
new file mode 100644
index 00000000..b0a53e8b
--- /dev/null
+++ b/xmppServer.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource (runResourceT)
+import Data.Monoid
+import System.Environment
+import System.Posix.Signals
+
+import ConsoleWriter
+import Presence
+import XMPPServer
+
+main :: IO ()
+main = runResourceT $ do
+    args <- liftIO getArgs
+    let verbosity = getSum $ flip foldMap args $ \case
+            ('-':xs) -> Sum $ length (filter (=='-') xs)
+            _        -> mempty
+    cw    <- liftIO newConsoleWriter
+    state <- liftIO $ newPresenceState cw
+    sv    <- xmppServer (presenceHooks state verbosity)
+    liftIO $ do
+    atomically $ putTMVar (server state) sv
+
+    quitVar <- newEmptyTMVarIO
+    installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
+    installHandler sigINT (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
+
+    forkIO $ do
+        let console = cwPresenceChan $ consoleWriter state
+        fix $ \loop -> do
+        what <- atomically
+            $ orElse (do (client,stanza) <- takeTMVar console
+                         return $ do informClientPresence0 state Nothing client stanza
+                                     loop)
+                     (do readTMVar quitVar
+                         return $ return ())
+        what
+
+    quitMessage <- atomically $ takeTMVar quitVar
+
+    putStrLn "goodbye."
+    return ()