module HLWM.IPC
(
HerbstConnection
, connect
, disconnect
, withConnection
, sendCommand
, nextHook
) where
import HLWM.IPC.Internal (HerbstEvent(..))
import qualified HLWM.IPC.Internal as IPC
import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad
import Control.Applicative
import Data.Maybe
import Control.Exception
import System.Posix.Types (Fd(..))
import Graphics.X11.Xlib
data HerbstConnection = HerbstConnection {
connection :: IPC.HerbstConnection,
commandLock :: Lock,
eventChan :: TChan HerbstEvent,
controlChan :: TChan Message,
dieVar :: TMVar ()
}
connect :: IO (Maybe HerbstConnection)
connect = IPC.connect >>= \case
Nothing -> return Nothing
Just connection -> do
commandLock <- newEmptyTMVarIO
eventChan <- newBroadcastTChanIO
controlChan <- newTChanIO
dieVar <- newEmptyTMVarIO
void $ forkIO $ xThread connection eventChan controlChan dieVar
return $ Just $ HerbstConnection {..}
disconnect :: HerbstConnection -> IO ()
disconnect HerbstConnection{..} = do
atomically $ do
lock commandLock
writeTChan controlChan Die
atomically $ takeTMVar dieVar
IPC.disconnect connection
withConnection :: (HerbstConnection -> IO a) -> IO (Maybe a)
withConnection f =
bracket connect (maybe (return ()) disconnect)
(maybe (return Nothing) (fmap Just . f))
sendCommand :: HerbstConnection -> [String] -> IO (Int, String)
sendCommand client args = do
events <- atomically $ do
lock (commandLock client)
dupTChan (eventChan client) <*
writeTChan (controlChan client) (HerbstCmd args)
res <- readBoth events Nothing Nothing
atomically $ unlock (commandLock client)
return res
where readBoth _ (Just s) (Just o) = return (o,s)
readBoth events a b = atomically (readTChan events) >>= \case
OutputEvent o | isNothing a -> readBoth events (Just o) b
StatusEvent s | isNothing b -> readBoth events a (Just s)
_ -> readBoth events a b
nextHook :: HerbstConnection -> IO [String]
nextHook client = do
chan <- atomically $ dupTChan (eventChan client)
let loop = atomically (readTChan chan) >>= \case
HookEvent res -> return res
_ -> loop
loop
data Message = HerbstCmd [String]
| Die
xThread :: IPC.HerbstConnection -> TChan HerbstEvent -> TChan Message
-> TMVar () -> IO ()
xThread con events msgs dieVar = do
(waitForFd, disconnectFd) <- threadWaitReadSTM (connectionFd con)
let loop = disconnectFd >> xThread con events msgs dieVar
atomically ((Just <$> readTChan msgs) `orElse` (waitForFd >> return Nothing)) >>= \case
Just Die -> do
disconnectFd
atomically $ putTMVar dieVar ()
Just (HerbstCmd args) -> IPC.asyncSendCommand con args >> loop
Nothing ->
let loop2 = IPC.tryRecvEvent con >>= \case
Just ev -> atomically (writeTChan events ev) >> loop2
Nothing -> loop
in loop2
type Lock = TMVar ()
lock :: TMVar () -> STM ()
lock l = putTMVar l ()
unlock :: TMVar () -> STM ()
unlock l = takeTMVar l >> return ()
connectionFd :: IPC.HerbstConnection -> Fd
connectionFd = Fd . connectionNumber . IPC.display