diff options
author | joe <joe@jerkface.net> | 2014-03-16 14:04:14 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2014-03-16 14:04:14 -0400 |
commit | fe3087cc86552fdccac5b90d49d998611a493a45 (patch) | |
tree | 092c07e4754bed7013a4c0adb1db28ccba1d3cef | |
parent | 0658b76ea0874d0ea789659effed102002486d01 (diff) |
Deliver messages to X via notify-send.
-rw-r--r-- | Presence/ConsoleWriter.hs | 28 | ||||
-rw-r--r-- | 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 | |||
16 | import Data.Char | 16 | import Data.Char |
17 | import Data.Maybe | 17 | import Data.Maybe |
18 | import System.Environment | 18 | import System.Environment |
19 | import System.Process ( rawSystem ) | ||
20 | import System.Exit ( ExitCode(ExitSuccess) ) | ||
21 | import System.Posix.Env ( setEnv ) | ||
22 | import System.Posix.Process ( forkProcess, exitImmediately ) | ||
23 | import System.Posix.User ( setUserID, getUserEntryForName, userID ) | ||
19 | import System.Posix.Files ( getFileStatus, fileMode ) | 24 | import System.Posix.Files ( getFileStatus, fileMode ) |
20 | import System.INotify ( initINotify, EventVariety(Modify), addWatch ) | 25 | import System.INotify ( initINotify, EventVariety(Modify), addWatch ) |
21 | import Data.Word ( Word8 ) | 26 | import Data.Word ( Word8 ) |
@@ -32,7 +37,8 @@ import qualified Network.BSD as BSD | |||
32 | import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(..) ) | 37 | import UTmp ( users2, utmp_file, UtmpRecord(..), UT_Type(..) ) |
33 | import FGConsole ( monitorTTY ) | 38 | import FGConsole ( monitorTTY ) |
34 | import XMPPServer ( Stanza, makePresenceStanza, JabberShow(..), stanzaType | 39 | import XMPPServer ( Stanza, makePresenceStanza, JabberShow(..), stanzaType |
35 | , LangSpecificMessage(..), msgLangMap, cloneStanza ) | 40 | , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom ) |
41 | import ControlMaybe ( handleIO_ ) | ||
36 | import ClientState | 42 | import ClientState |
37 | 43 | ||
38 | data ConsoleWriter = ConsoleWriter | 44 | data ConsoleWriter = ConsoleWriter |
@@ -197,6 +203,7 @@ readEnvFile var file = fmap parse $ readFile file | |||
197 | 203 | ||
198 | writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool | 204 | writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool |
199 | writeActiveTTY cw msg = do | 205 | writeActiveTTY cw msg = do |
206 | putStrLn $ "writeActiveTTY" | ||
200 | (tty, mbu) <- atomically $ do | 207 | (tty, mbu) <- atomically $ do |
201 | num <- readTVar $ csActiveTTY cw | 208 | num <- readTVar $ csActiveTTY cw |
202 | utmp <- readTVar $ csUtmp cw | 209 | utmp <- readTVar $ csUtmp cw |
@@ -212,9 +219,22 @@ writeActiveTTY cw msg = do | |||
212 | _ -> deliverTerminalMessage cw tty utmp msg | 219 | _ -> deliverTerminalMessage cw tty utmp msg |
213 | 220 | ||
214 | deliverGUIMessage cw tty utmp msg = do | 221 | deliverGUIMessage cw tty utmp msg = do |
215 | -- TODO: deliver to active x (notify-send of libnotify package) | 222 | text <- do |
216 | -- chpst seems neccessary for notify-send to work | 223 | t <- messageText msg |
217 | return False | 224 | return $ Text.unpack |
225 | $ case stanzaFrom msg of | ||
226 | Just from -> from <> ": " <> t | ||
227 | Nothing -> t | ||
228 | putStrLn $ "deliverGUI: " ++ text | ||
229 | handleIO_ (return False) $ do | ||
230 | uentry <- getUserEntryForName (Text.unpack $ utmpUser utmp) | ||
231 | let display = Text.unpack $ utmpHost utmp | ||
232 | pid <- forkProcess $ do | ||
233 | setUserID (userID uentry) | ||
234 | setEnv "DISPLAY" display True | ||
235 | rawSystem "/usr/bin/notify-send" [text] | ||
236 | exitImmediately ExitSuccess | ||
237 | return True | ||
218 | 238 | ||
219 | deliverTerminalMessage cw tty utmp msg = do | 239 | deliverTerminalMessage cw tty utmp msg = do |
220 | mode <- fmap fileMode (getFileStatus $ Text.unpack tty) | 240 | 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 = | |||
434 | if not mine then fail else do | 434 | if not mine then fail else do |
435 | let to' = unsplitJID (n,h,r) | 435 | let to' = unsplitJID (n,h,r) |
436 | cmap <- atomically . readTVar $ clientsByUser state | 436 | cmap <- atomically . readTVar $ clientsByUser state |
437 | flip (maybe fail) n $ \n -> do | 437 | (from',chans,ks) <- do |
438 | flip (maybe fail) (Map.lookup n cmap) $ \presence_container -> do | 438 | flip (maybe $ return (Nothing,[],[])) n $ \n -> do |
439 | buds <- configText ConfigFiles.getBuddies n | 439 | buds <- configText ConfigFiles.getBuddies n |
440 | from' <- do | 440 | from' <- do |
441 | flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do | 441 | flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do |
442 | (_,trip) <- rewriteJIDForClient laddr from buds | 442 | (_,trip) <- rewriteJIDForClient laddr from buds |
443 | return . Just $ unsplitJID trip | 443 | return . Just $ unsplitJID trip |
444 | let ks = Map.keys (networkClients presence_container) | 444 | let nope = return (from',[],[]) |
445 | chans = mapMaybe (flip Map.lookup key_to_chan) ks | 445 | flip (maybe nope) (Map.lookup n cmap) $ \presence_container -> do |
446 | if null chans then deliverToConsole state fail msg else do | 446 | let ks = Map.keys (networkClients presence_container) |
447 | chans = mapMaybe (flip Map.lookup key_to_chan) ks | ||
448 | return (from',chans,ks) | ||
449 | putStrLn $ "chan count: " ++ show (length chans) | ||
450 | let msg' = msg { stanzaTo=Just to' | ||
451 | , stanzaFrom=from' } | ||
452 | if null chans then deliverToConsole state fail msg' else do | ||
447 | forM_ chans $ \Conn { connChan=chan} -> do | 453 | forM_ chans $ \Conn { connChan=chan} -> do |
448 | putStrLn $ "sending "++show (stanzaId msg)++" to clients "++show ks | 454 | putStrLn $ "sending "++show (stanzaId msg)++" to clients "++show ks |
449 | -- TODO: Cloning isn't really neccessary unless there are multiple | 455 | -- TODO: Cloning isn't really neccessary unless there are multiple |
@@ -452,8 +458,7 @@ deliverMessage state fail msg = | |||
452 | -- consumable stanzas and announcables use write-only broadcast | 458 | -- consumable stanzas and announcables use write-only broadcast |
453 | -- channels that must be cloned in order to be consumed. | 459 | -- channels that must be cloned in order to be consumed. |
454 | -- For now, we are doing redundant cloning. | 460 | -- For now, we are doing redundant cloning. |
455 | dup <- cloneStanza (msg { stanzaTo=Just to' | 461 | dup <- cloneStanza msg' |
456 | , stanzaFrom=from' }) | ||
457 | sendModifiedStanzaToClient dup | 462 | sendModifiedStanzaToClient dup |
458 | chan | 463 | chan |
459 | 464 | ||