ADD guard to ensure only one thread per PID spawns

This commit is contained in:
Nathan Dwarshuis 2020-03-25 16:18:30 -04:00
parent 7d92a35e39
commit 9e381abfd2
1 changed files with 22 additions and 8 deletions

View File

@ -1,10 +1,10 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module WorkspaceMon (fromList, runWorkspaceMon) where module WorkspaceMon (M.fromList, runWorkspaceMon) where
import SendXMsg import SendXMsg
import Data.Map as M import qualified Data.Map as M
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad
@ -24,7 +24,9 @@ import System.Process (Pid)
-- TOOD it would be really nice if the manner we used to match windows was -- TOOD it would be really nice if the manner we used to match windows was
-- the same as that in XMonad itself (eg with Query types) -- the same as that in XMonad itself (eg with Query types)
type MatchTags = Map String String type MatchTags = M.Map String String
type WatchedPIDs = MVar [Pid]
data WConf = WConf data WConf = WConf
{ display :: Display { display :: Display
@ -48,20 +50,21 @@ runWorkspaceMon :: MatchTags -> IO ()
runWorkspaceMon mts = do runWorkspaceMon mts = do
dpy <- openDisplay "" dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy root <- rootWindow dpy $ defaultScreen dpy
curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad
-- listen only for substructure change events (which includes MapNotify) -- listen only for substructure change events (which includes MapNotify)
allocaSetWindowAttributes $ \a -> do allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a changeWindowAttributes dpy root cWEventMask a
let c = WConf { display = dpy, matchTags = mts } let c = WConf { display = dpy, matchTags = mts }
_ <- allocaXEvent $ \e -> _ <- allocaXEvent $ \e ->
runW c $ forever $ handle =<< io (nextEvent dpy e >> getEvent e) runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
return () return ()
handle :: Event -> W () handle :: WatchedPIDs -> Event -> W ()
-- | assume this fires at least once when a new window is created (also could -- | assume this fires at least once when a new window is created (also could
-- use CreateNotify but that is really noisy) -- use CreateNotify but that is really noisy)
handle MapNotifyEvent { ev_window = w } = do handle curPIDs MapNotifyEvent { ev_window = w } = do
dpy <- asks display dpy <- asks display
hint <- io $ getClassHint dpy w hint <- io $ getClassHint dpy w
mts <- asks matchTags mts <- asks matchTags
@ -71,10 +74,11 @@ handle MapNotifyEvent { ev_window = w } = do
pid <- getWindowProperty32 dpy a w pid <- getWindowProperty32 dpy a w
case pid of case pid of
-- ASSUMPTION windows will only have one PID at one time -- ASSUMPTION windows will only have one PID at one time
Just [p] -> waitAndKill t $ fromIntegral p Just [p] -> let p' = fromIntegral p
in withUniquePid curPIDs p' $ waitAndKill t p'
_ -> return () _ -> return ()
handle _ = return () handle _ _ = return ()
waitAndKill :: String -> Pid -> IO () waitAndKill :: String -> Pid -> IO ()
waitAndKill tag pid = waitUntilExit pidDir waitAndKill tag pid = waitUntilExit pidDir
@ -89,3 +93,13 @@ waitAndKill tag pid = waitUntilExit pidDir
res <- doesDirectoryExist d res <- doesDirectoryExist d
if res then threadDelay 100000 >> waitUntilExit d if res then threadDelay 100000 >> waitUntilExit d
else sendXMsg Workspace tag else sendXMsg Workspace tag
withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
withUniquePid curPIDs pid f = do
pids <- readMVar curPIDs
if pid `elem` pids
then return ()
else do
modifyMVar_ curPIDs (return . (pid:))
f
modifyMVar_ curPIDs (return . filter (/=pid))