From fe3087cc86552fdccac5b90d49d998611a493a45 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Sun, 16 Mar 2014 14:04:14 -0400
Subject: Deliver messages to X via notify-send.

---
 Presence/ConsoleWriter.hs | 28 ++++++++++++++++++++++++----
 xmppServer.hs             | 29 +++++++++++++++++------------
 2 files changed, 41 insertions(+), 16 deletions(-)

diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
index 2024131b..d75dfec0 100644
--- a/Presence/ConsoleWriter.hs
+++ b/Presence/ConsoleWriter.hs
@@ -16,6 +16,11 @@ import Data.Monoid
 import Data.Char
 import Data.Maybe
 import System.Environment
+import System.Process ( rawSystem )
+import System.Exit ( ExitCode(ExitSuccess) )
+import System.Posix.Env     ( setEnv )
+import System.Posix.Process ( forkProcess, exitImmediately )
+import System.Posix.User  ( setUserID, getUserEntryForName, userID )
 import System.Posix.Files ( getFileStatus, fileMode )
 import System.INotify ( initINotify, EventVariety(Modify), addWatch )
 import Data.Word      ( Word8 )
@@ -32,7 +37,8 @@ import qualified Network.BSD as BSD
 import UTmp           ( users2, utmp_file, UtmpRecord(..), UT_Type(..) )
 import FGConsole      ( monitorTTY )
 import XMPPServer     ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
-                      , LangSpecificMessage(..), msgLangMap, cloneStanza )
+                      , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom )
+import ControlMaybe   ( handleIO_ )
 import ClientState
 
 data ConsoleWriter = ConsoleWriter
@@ -197,6 +203,7 @@ readEnvFile var file = fmap parse $ readFile file
 
 writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
 writeActiveTTY cw msg = do
+    putStrLn $ "writeActiveTTY"
     (tty, mbu) <- atomically $ do
                 num <- readTVar $ csActiveTTY cw
                 utmp <- readTVar $ csUtmp cw
@@ -212,9 +219,22 @@ writeActiveTTY cw msg = do
         _ -> deliverTerminalMessage cw tty utmp msg
 
 deliverGUIMessage cw tty utmp msg = do
-    -- TODO: deliver to active x (notify-send of libnotify package)
-    --         chpst seems neccessary for notify-send to work
-    return False
+    text <- do
+        t <- messageText msg
+        return $ Text.unpack
+            $ case stanzaFrom msg of
+                Just from -> from <> ": " <> t
+                Nothing -> t
+    putStrLn $ "deliverGUI: " ++ text
+    handleIO_ (return False) $ do
+    uentry <- getUserEntryForName (Text.unpack $ utmpUser utmp)
+    let display = Text.unpack $ utmpHost utmp
+    pid <- forkProcess $ do
+        setUserID (userID uentry)
+        setEnv "DISPLAY" display True
+        rawSystem "/usr/bin/notify-send" [text]
+        exitImmediately ExitSuccess
+    return True
 
 deliverTerminalMessage cw tty utmp msg = do
     mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
diff --git a/xmppServer.hs b/xmppServer.hs
index ef71380b..a406366a 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -434,16 +434,22 @@ deliverMessage state fail msg =
         if not mine then fail else do
         let to' = unsplitJID (n,h,r)
         cmap <- atomically . readTVar $ clientsByUser state
-        flip (maybe fail) n $ \n -> do
-        flip (maybe fail) (Map.lookup n cmap) $ \presence_container -> do
-        buds <- configText ConfigFiles.getBuddies n
-        from' <- do
-            flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
-            (_,trip) <- rewriteJIDForClient laddr from buds
-            return . Just $ unsplitJID trip
-        let ks = Map.keys (networkClients presence_container)
-            chans = mapMaybe (flip Map.lookup key_to_chan) ks
-        if null chans then deliverToConsole state fail msg else do
+        (from',chans,ks) <- do
+            flip (maybe $ return (Nothing,[],[])) n $ \n -> do
+            buds <- configText ConfigFiles.getBuddies n
+            from' <- do
+                flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
+                (_,trip) <- rewriteJIDForClient laddr from buds
+                return . Just $ unsplitJID trip
+            let nope = return (from',[],[])
+            flip (maybe nope) (Map.lookup n cmap) $ \presence_container -> do
+            let ks = Map.keys (networkClients presence_container)
+                chans = mapMaybe (flip Map.lookup key_to_chan) ks
+            return (from',chans,ks)
+        putStrLn $ "chan count: " ++ show (length chans)
+        let msg' = msg { stanzaTo=Just to'
+                       , stanzaFrom=from' }
+        if null chans then deliverToConsole state fail msg' else do
         forM_ chans $ \Conn { connChan=chan} -> do
         putStrLn $ "sending "++show (stanzaId msg)++" to clients "++show ks
         -- TODO: Cloning isn't really neccessary unless there are multiple
@@ -452,8 +458,7 @@ deliverMessage state fail msg =
         -- consumable stanzas and announcables use write-only broadcast
         -- channels that must be cloned in order to be consumed.
         -- For now, we are doing redundant cloning.
-        dup <- cloneStanza (msg { stanzaTo=Just to'
-                                , stanzaFrom=from' })
+        dup <- cloneStanza msg'
         sendModifiedStanzaToClient dup
                                   chan
 
-- 
cgit v1.2.3