read environment from proc for DISPLAY and check g+w of tty

1 files changed, 37 insertions, 5 deletions

diff --git a/Presence/ConsoleWriter.hs b/Presence/ConsoleWriter.hs
index 90849727..2024131b 100644
--- a/Presence/ConsoleWriter.hs
+++ b/Presence/ConsoleWriter.hs
@@ -16,11 +16,13 @@ import Data.Monoid
 import Data.Char
 import Data.Maybe
 import System.Environment
+import System.Posix.Files ( getFileStatus, fileMode )
 import System.INotify ( initINotify, EventVariety(Modify), addWatch )
 import Data.Word      ( Word8 )
 import Data.Text      ( Text )
 import Data.Map       ( Map )
-import Data.List      ( foldl' )
+import Data.List      ( foldl', groupBy )
+import Data.Bits      ( (.&.) )
 import qualified Data.Map as Map
 import qualified Data.Traversable as Traversable
 import qualified Data.Text as Text
@@ -180,15 +182,45 @@ messageText msg = do
         ts = catMaybes [subj, msgBody choice]
     return $ Text.intercalate "\n\n" ts
 
+readEnvFile :: String -> FilePath -> IO (Maybe String)
+readEnvFile var file = fmap parse $ readFile file
+ where
+    parse xs = listToMaybe $ map (drop 1 . concat . drop 1) $ filter ofinterest bs
+     where
+        bs = map (groupBy (\_ x -> x/='=')) $ split (/='\0') xs
+        ofinterest (k:vs) | k==var = True
+        ofinterest _               = False
+
+    split pred xs = take 1 gs ++ map (drop 1) (drop 1 gs)
+     where
+        gs = groupBy (\_ x -> pred x) xs
+
 writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
 writeActiveTTY cw msg = do
-    tty <- atomically $ do
+    (tty, mbu) <- atomically $ do
                 num <- readTVar $ csActiveTTY cw
-                return $ "/dev/tty" <> tshow num
-    -- TODO: verify mode g+w
-    -- TODO: deliver to active console if not x
+                utmp <- readTVar $ csUtmp cw
+                mbu <- maybe (return Nothing) readTVar
+                        $ Map.lookup ("tty"<>tshow num) utmp
+                return ( "/dev/tty" <> tshow num
+                       , mbu )
+    flip (maybe $ return False) mbu $ \utmp -> do
+    display <- fmap (fmap Text.pack)
+        $ readEnvFile "DISPLAY" ("/proc/" ++ show (utmpPid utmp) ++ "/environ")
+    case fmap (==utmpHost utmp) display of
+        Just True -> deliverGUIMessage cw tty utmp msg
+        _ -> 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
+
+deliverTerminalMessage cw tty utmp msg = do
+    mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
+    let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w
+    if not mesgy then return False else do
+    -- TODO: deliver to active console
     return False -- return True if a message was delivered
 
 writeAllPty :: ConsoleWriter -> Stanza -> IO Bool