diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright (c) 2015, Hans-Peter Deifel +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/HerbstClient.hs b/examples/HerbstClient.hs new file mode 100644 --- /dev/null +++ b/examples/HerbstClient.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE LambdaCase,TemplateHaskell, MultiWayIf #-} + +-- | A complete re-implementation of the official herbstclient program +module Main where + +import HLWM.IPC +import System.Console.GetOpt +import Data.List +import System.Environment +import System.Exit +import System.IO + +data HCOptions = HCOpt { + newline :: Bool, + print0 :: Bool, + lastArg :: Bool, + idle :: Bool, + wait :: Bool, + count :: Int, + quiet :: Bool, + version :: Bool, + help :: Bool +} + +defOpts :: HCOptions +defOpts = HCOpt { + newline = True, + print0 = False, + lastArg = False, + idle = False, + wait = False, + count = 1, + quiet = False, + version = False, + help = False +} + +options :: [OptDescr (HCOptions -> HCOptions)] +options = + [ Option ['n'] ["no-newline"] (NoArg $ \o -> o { newline = False }) + "Do not print a newline if output does not end with a newline." + , Option ['0'] ["print0"] (NoArg $ \o -> o { print0 = True }) + "Use the null character as delimiter between the output of hooks." + , Option ['l'] ["last-arg"] (NoArg $ \o -> o { lastArg = True }) + "Print only the last argument of a hook." + , Option ['i'] ["idle"] (NoArg $ \o -> o { idle = True }) + "Wait for hooks instead of executing commands." + , Option ['w'] ["wait"] (NoArg $ \o -> o { wait = True }) + "Same as --idle but exit after first --count hooks." + , Option ['c'] ["count"] (ReqArg (\a o -> o { count = read a }) "COUNT") + "Let --wait exit after COUNT hooks were received and printed. The default of COUNT is 1." + , Option ['q'] ["quiet"] (NoArg $ \o -> o { quiet = True }) + "Do not print error messages if herbstclient cannot connect to the running herbstluftwm instance." + , Option ['v'] ["version"] (NoArg $ \o -> o { version = True }) + "Print the herbstclient version. To get the herbstluftwm version, use 'herbstclient version'." + , Option ['h'] ["help"] (NoArg $ \o -> o { help = True }) "Print this help." + ] + +usage :: String -> String +usage name = "Usage: " ++ name ++ " [OPTION...] files..." + +hcOpts :: [String] -> IO (HCOptions, [String]) +hcOpts argv = do + case getOpt Permute options argv of + (o,n,[] ) -> return (foldl (flip id) defOpts o, n) + (_,_,errs) -> ioError (userError (concat errs)) + +putStrMaybeLn :: String -> IO () +putStrMaybeLn str + | "\n" `isSuffixOf` str = putStr str + | otherwise = putStrLn str + +helpString :: String -> String +helpString name = unlines $ + [ "Usage: " ++ name ++ " [OPTION...] files..." + , " " ++ name ++ " [OPTIONS] [--wait|--idle] [FILTER ...]" + , "Send a COMMAND with optional arguments ARGS to a running herbstluftwm instance." + , "" + , usageInfo "Options:" options + , "See the man page (herbstclient(1)) for more details." + ] + +data Wait = Infinite + | Wait Int + +newtype NullPolicy = Null Bool +newtype NLPolicy = NL Bool +newtype Quiet = Quiet Bool +newtype LastArg = LastArg Bool + +withQConnection :: Quiet -> a -> (HerbstConnection -> IO a) -> IO a +withQConnection q x f = withConnection f >>= \case + Nothing -> case q of + Quiet True -> return x + Quiet False -> hPutStrLn stderr "Could not connect to server" >> return x + Just y -> return y + +waitForHooks :: Wait -> NullPolicy -> Quiet -> LastArg -> IO () +waitForHooks w nl q la = withQConnection q () (doWait w) + where doWait (Wait 0) _ = return () -- TODO handle negative values + doWait w' con = do + h <- nextHook con + case la of + LastArg True | not (null h) -> putStr (last h) + _ -> putStr $ unwords h + case nl of + Null True -> putStr "\0" + Null False -> putStr "\n" + case w' of + Infinite -> doWait Infinite con + Wait x -> doWait (Wait (x-1)) con + +send :: [String] -> NLPolicy -> Quiet -> IO ExitCode +send args nl q = withQConnection q (ExitFailure 1)$ \con -> do + (stat, ret) <- sendCommand con args + case nl of + NL False -> putStr ret + NL True -> if null ret || last ret == '\n' + then putStr ret else putStrLn ret + return $ if stat == 0 then ExitSuccess else ExitFailure stat + +main :: IO () +main = do + name <- getProgName + (opts, args) <- getArgs >>= hcOpts + if | help opts -> putStr $ helpString name + | version opts -> putStrLn "A friendly haskell implementation of herbstclient" + | idle opts -> waitForHooks Infinite (Null (print0 opts)) + (Quiet (quiet opts)) (LastArg (lastArg opts)) + | wait opts -> waitForHooks (Wait (count opts)) (Null (print0 opts)) + (Quiet (quiet opts)) (LastArg (lastArg opts)) + | otherwise -> send args (NL (newline opts)) (Quiet (quiet opts)) + >>= exitWith diff --git a/hlwm.cabal b/hlwm.cabal new file mode 100644 --- /dev/null +++ b/hlwm.cabal @@ -0,0 +1,43 @@ +name: hlwm +version: 0.1.0.0 +synopsis: Bindings to the herbstluftwm window manager +description: A client-side IPC implementation for herbstluftwm. +license: BSD2 +license-file: LICENSE +author: Hans-Peter Deifel +maintainer: +category: System +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://git.cs.fau.de/?p=lu03pevi/hlwm-haskell + +flag examples + description: Build example programs + default: False + +library + hs-source-dirs: src + other-extensions: RecordWildCards, LambdaCase, MultiWayIf, TupleSections + build-depends: base >=4.7 && <4.8, X11 >=1.6 && <1.7, transformers, monads-tf, stm, + unix + build-tools: hsc2hs + default-language: Haskell2010 + exposed-modules: HLWM.IPC, + HLWM.IPC.Internal + other-modules: Graphics.X11.Xlib.Herbst + ghc-options: -Wall + +executable hherbstclient + hs-source-dirs: examples + main-is: HerbstClient.hs + other-extensions: RecordWildCards, LambdaCase, MultiWayIf, TupleSections + build-depends: base >=4.7 && <4.8, X11 >=1.6 && <1.7, transformers, monads-tf, lens, stm, + unix, hlwm + build-tools: hsc2hs + default-language: Haskell2010 + ghc-options: -Wall -threaded + if !flag(examples) + buildable: False diff --git a/src/Graphics/X11/Xlib/Herbst.hsc b/src/Graphics/X11/Xlib/Herbst.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/X11/Xlib/Herbst.hsc @@ -0,0 +1,79 @@ +module Graphics.X11.Xlib.Herbst where + +#include +#include + +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xlib +import System.Environment + +import Foreign +import Foreign.C + +-- FIXME Some functions shouldn't return IO () but IO Bool or something +-- or throw an exception if the X-functions doesn't return success + +setClassHint :: Display -> Window -> ClassHint -> IO () +setClassHint d w ch = allocaBytes (#{size XClassHint}) $ \p -> + withCString (resName ch) $ \resName' -> + withCString (resClass ch) $ \resClass' -> do + #{poke XClassHint, res_name } p $ resName' + #{poke XClassHint, res_class } p $ resClass' + xSetClassHint d w p + + +foreign import ccall unsafe "X11/Xlib.h XSetClassHint" + xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO () + +utf8TextListToTextProperty :: Display -> [String] -> IO TextProperty +utf8TextListToTextProperty d strs = + allocaBytes (#{size XTextProperty}) $ \p -> do + cstrs <- mapM newCString strs + let len = fromIntegral $ length strs + + withArray cstrs $ \array -> + xUtf8TextListToTextProperty d array len uTF8StringStyle p + + mapM_ free cstrs + + peek p + +newtype ICCEncodingStyle = ICCEncodingStyle CInt +#{enum ICCEncodingStyle, ICCEncodingStyle, + stringStyle = XStringStyle, + compoundTextStyle = XCompoundTextStyle, + textStyle = XTextStyle, + stdICCTextStyle = XStdICCTextStyle, + uTF8StringStyle = XUTF8StringStyle +} + +foreign import ccall unsafe "X11/Xlib.h Xutf8TextListToTextProperty" + xUtf8TextListToTextProperty :: Display -> Ptr (CString) -> CInt -> ICCEncodingStyle -> (Ptr TextProperty) -> IO () + +utf8TextPropertyToTextList :: Display -> TextProperty -> IO [String] +utf8TextPropertyToTextList d tp = + alloca $ \intPtr -> + alloca $ \tpPtr -> + alloca $ \ptrPtr -> do + poke tpPtr tp + xUtf8TextPropertyToTextList d tpPtr ptrPtr intPtr + strArr <- peek ptrPtr + num <- peek intPtr + cstrs <- peekArray (fromIntegral num) strArr + strs <- mapM peekCString cstrs + freeStringList strArr + return strs + +foreign import ccall unsafe "X11/Xlib.h Xutf8TextPropertyToTextList" + xUtf8TextPropertyToTextList :: Display -> Ptr TextProperty -> (Ptr (Ptr CString)) -> (Ptr CInt) -> IO () + +openDefaultDisplay :: IO Display +openDefaultDisplay = getEnv "DISPLAY" >>= openDisplay + +setTextProperty' :: Display -> Window -> TextProperty -> Atom -> IO () +setTextProperty' d w tp a = allocaBytes (sizeOf tp) $ \p -> do + poke p tp + xSetTextProperty d w p a + +foreign import ccall unsafe "X11/Xlib.h XSetTextProperty" + xSetTextProperty :: Display -> Window -> Ptr TextProperty -> Atom -> IO () diff --git a/src/HLWM/IPC.hs b/src/HLWM/IPC.hs new file mode 100644 --- /dev/null +++ b/src/HLWM/IPC.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE LambdaCase, RecordWildCards, ScopedTypeVariables #-} + +-- | An IPC client implementation for the +-- window manager. +-- +-- See and +-- for what this is +-- all about. +-- +-- == Examples +-- Sending a command to herbstluftwm: +-- +-- >>> withConnection (\con -> sendCommand con ["echo", "foo"]) +-- Just (0,"foo\n") +-- +-- Printing 2 hooks: +-- +-- >>> withConnection (\con -> replicateM_ 2 $ unwords <$> nextHook con >>= putStrLn) +-- focus_changed 0x340004c IPC.hs - emacs +-- focus_changed 0x3200073 ROXTerm +-- Just () +-- +-- Although 'sendCommand' is synchronous, you can use it with forkIO or the +-- library: +-- +-- > withConnection $ \con -> do +-- > var <- newEmptyMVar +-- > forkIO $ sendCommand con ["echo","foo"] >>= putMVar var +-- > -- do some stuff ... +-- > -- finally read output +-- > output <- takeMVar var + +module HLWM.IPC + ( -- * Connection + HerbstConnection + , connect + , disconnect + , withConnection + -- * Commands and Hooks + , 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 + +-- | Opaque type representing the connection to the herbstluftwm server +-- +-- See 'connect' and 'disconnect'. +data HerbstConnection = HerbstConnection { + connection :: IPC.HerbstConnection, + commandLock :: Lock, + eventChan :: TChan HerbstEvent, + controlChan :: TChan Message, + dieVar :: TMVar () +} + +-- | Connect to the herbstluftwm server. +-- +-- Be sure to call 'disconnect' if you don't need the connection anymore, to +-- free any allocated resources. When in doubt, call 'withConnection'. +-- +-- Note that there must not be more than one connection open at any time! +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 {..} + +-- | Close connection to the herbstluftwm server. +-- +-- After calling this function, the 'HerbstConnection' is no longer valid and +-- must not be used anymore. +disconnect :: HerbstConnection -> IO () +disconnect HerbstConnection{..} = do + atomically $ do + lock commandLock + writeTChan controlChan Die + atomically $ takeTMVar dieVar + IPC.disconnect connection + +-- | Execute an action with a newly established 'HerbstConnection'. +-- +-- Connects to the herbstluftwm server, passes the connection on to the supplied +-- action and closes the connection again after the action has finished. +withConnection :: (HerbstConnection -> IO a) -> IO (Maybe a) +withConnection f = + bracket connect (maybe (return ()) disconnect) + (maybe (return Nothing) (fmap Just . f)) + +-- | Execute a command in the herbstluftwm server. +-- +-- Send a command consisting of a list of Strings to the server and wait for the +-- response. Herbstluftwm interprets this list as a command followed by a number +-- of arguments. Returns a tuple of the exit status and output of the called +-- command. +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 + +-- | Wait for a hook event from the server and return it. +-- +-- A hook is just an arbitrary list of strings generated by herbstluftwm or its +-- clients. +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 () -- notify caller that we died + 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 diff --git a/src/HLWM/IPC/Internal.hs b/src/HLWM/IPC/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HLWM/IPC/Internal.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE RecordWildCards, LambdaCase, MultiWayIf, TupleSections, BangPatterns, ScopedTypeVariables, Rank2Types #-} + +-- | Internal herbluftwm IPC implementation +-- +-- This is an internal module. Use only with extreme caution. +-- +-- == On event handling +-- +-- There is a single function 'recvEvent', that returns all events received by +-- herbstluftwm in order. The high-level functions 'sendCommand' and 'nextHook' +-- work by calling 'recvEvent' until they get the event they expected and +-- discarding all other events received in the meantime. This means that it is +-- not possible to call 'nextHook' and 'sendCommand' concurrently in different +-- threads. Also, when calling 'asyncSendCommand' and then 'nextHook', the +-- output of the command will likely be thrown away. +-- +-- See "HLWM.IPC" for an interface that allows concurrent calling +-- of 'nextHook' and 'sendCommand'. + +module HLWM.IPC.Internal + ( -- * Connection + HerbstConnection(..) + , connect + , disconnect + , withConnection + -- * High level interface + , sendCommand + , nextHook + -- * Event handling + , recvEvent + , tryRecvEvent + , HerbstEvent(..) + , asyncSendCommand + ) where + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xlib.Herbst +import Control.Applicative +import Foreign.C.String +import Data.Bits +import Data.Maybe +import Control.Exception + +-- | Opaque type representing the connection to the herbstluftwm server +-- +-- See 'connect' and 'disconnect'. +data HerbstConnection = HerbstConnection { + display :: Display, + atomArgs :: Atom, + atomOutput :: Atom, + atomStatus :: Atom, + root :: Window, + hooksWin :: Window, + clientWin :: Window +} + +herbstIPCArgsAtom :: String +herbstIPCArgsAtom = "_HERBST_IPC_ARGS" + +herbstIPCOutputAtom :: String +herbstIPCOutputAtom = "_HERBST_IPC_OUTPUT" + +herbstIPCStatusAtom :: String +herbstIPCStatusAtom = "_HERBST_IPC_EXIT_STATUS" + +herbstIPCClass :: String +herbstIPCClass = "HERBST_IPC_CLASS" + +herbstHookWinIdAtom :: String +herbstHookWinIdAtom = "__HERBST_HOOK_WIN_ID" + +-- | Connect to the herbstluftwm server. +-- +-- Be sure to call 'disconnect' if you don't need the connection anymore, to +-- free any allocated resources. When in doubt, call 'withConnection'. +connect :: IO (Maybe HerbstConnection) +connect = do + display <- openDefaultDisplay + + let root = defaultRootWindow display + atomArgs <- internAtom display herbstIPCArgsAtom False + atomOutput <- internAtom display herbstIPCOutputAtom False + atomStatus <- internAtom display herbstIPCStatusAtom False + + + clientWin <- createClientWindow display root + findHookWindow display root >>= \case + Just hooksWin -> flush display >> (return $ Just $ HerbstConnection {..}) + Nothing -> do + destroyClientWindow display clientWin + closeDisplay display + return Nothing + + +-- | Close connection to the herbstluftwm server. +-- +-- After calling this function, the 'HerbstConnection' is no longer valid and +-- must not be used anymore. +disconnect :: HerbstConnection -> IO () +disconnect con = do + destroyClientWindow (display con) (clientWin con) + closeDisplay (display con) + +createClientWindow :: Display -> Window -> IO Window +createClientWindow display root = do + grabServer display + + win <- createSimpleWindow display root 42 42 42 42 0 0 0 + + setClassHint display win $ + (ClassHint herbstIPCClass herbstIPCClass) + + selectInput display win propertyChangeMask + + ungrabServer display + + return win + +destroyClientWindow :: Display -> Window -> IO () +destroyClientWindow d win = destroyWindow d win + +findHookWindow :: Display -> Window -> IO (Maybe Window) +findHookWindow display root = do + atom <- internAtom display herbstHookWinIdAtom False + getWindowProperty32 display atom root >>= \case + Just (winid:_) -> do + let win = fromIntegral winid + inputMask = structureNotifyMask .|. propertyChangeMask + + selectInput display win inputMask + + return $ Just win + _ -> return Nothing + +-- | Send a command to the server, but don't wait for the response. +-- +-- Like 'sendCommand', but it's the callers responsibility to manually receive +-- the output of the command with 'recvEvent'. +-- +-- Note, that it is not possible to relate asynchronous command calls with +-- responses returned by 'recvEvent', apart from the order in which they are +-- received. +asyncSendCommand :: HerbstConnection -> [String] -> IO () +asyncSendCommand con args = do + textProp <- utf8TextListToTextProperty (display con) args + setTextProperty' (display con) (clientWin con) textProp (atomArgs con) + flush (display con) + +-- | The type of events generated by herbstluftwm. +data HerbstEvent = HookEvent [String] + | StatusEvent Int + | OutputEvent String + +-- | Read a HerbstEvent, if one is pending +tryRecvEvent :: HerbstConnection -> IO (Maybe HerbstEvent) +tryRecvEvent con = do + pending (display con) >>= \case + 0 -> return Nothing + _ -> Just <$> recvEvent con + +-- | Wait for the next HerbstEvent in the queue and return it. +recvEvent :: HerbstConnection -> IO HerbstEvent +recvEvent con = allocaXEvent eventLoop + where eventLoop :: XEventPtr -> IO HerbstEvent + eventLoop event = do + nextEvent (display con) event + getEvent event >>= \case + PropertyEvent{..} + | ev_window == (clientWin con) && ev_atom == (atomOutput con) -> + readOutput >>= cont event OutputEvent + | ev_window == (clientWin con) && ev_atom == (atomStatus con) -> + readStatus >>= cont event StatusEvent + | ev_window == (hooksWin con) && ev_propstate /= propertyDelete -> + readHook ev_atom >>= cont event HookEvent + _ -> eventLoop event + + cont :: XEventPtr -> (a -> HerbstEvent) -> Maybe a -> IO HerbstEvent + cont event f = maybe (eventLoop event) (return . f) + + readOutput :: IO (Maybe String) + readOutput = do + tp <- getTextProperty (display con) (clientWin con) (atomOutput con) + utf8str <- internAtom (display con) "UTF8_STRING" False + if tp_encoding tp == sTRING || tp_encoding tp == utf8str + then Just <$> peekCString (tp_value tp) + else return Nothing + + readStatus :: IO (Maybe Int) + readStatus = fmap (fromIntegral . head) <$> + getWindowProperty32 (display con) (atomStatus con) (clientWin con) + + readHook :: Atom -> IO (Maybe [String]) + readHook atom = do + prop <- getTextProperty (display con) (hooksWin con) atom + Just <$> utf8TextPropertyToTextList (display con) prop + +recvCommandOutput :: HerbstConnection -> IO (Int, String) +recvCommandOutput con = readBoth Nothing Nothing + where readBoth (Just s) (Just o) = return (o,s) + readBoth a b = recvEvent con >>= \case + OutputEvent o | isNothing a -> readBoth (Just o) b + StatusEvent s | isNothing b -> readBoth a (Just s) + _ -> readBoth a b + +-- | Execute a command in the herbstluftwm server. +-- +-- Send a command consisting of a list of Strings to the server and wait for the +-- response. Herbstluftwm interprets this list as a command followed by a number +-- of arguments. Returns a tuple of the exit status and output of the called +-- command. +-- +-- __Warning:__ This discards any events received from the server that are not +-- the response to the command. In particular, any hook events received while +-- waiting for the response will be thrown away. +sendCommand :: HerbstConnection -> [String] -> IO (Int, String) +sendCommand con args = do + asyncSendCommand con args + recvCommandOutput con + +-- | Wait for a hook event from the server and return it. +-- +-- A hook is just an arbitrary list of strings generated by herbstluftwm or its +-- clients. +-- +-- __Warning:__ This discards any events received from the server that are not +-- hook events. In particular, any responses to commands called by +-- 'asyncSendCommand' received while waiting for the hook will be thrown away. +nextHook :: HerbstConnection -> IO [String] +nextHook con = recvEvent con >>= \case + HookEvent r -> return r + _ -> nextHook con + +-- | Execute an action with a newly established 'HerbstConnection'. +-- +-- Connects to the herbstluftwm server, passes the connection on to the supplied +-- action and closes the connection again after the action has finished. +withConnection :: (HerbstConnection -> IO a) -> IO (Maybe a) +withConnection f = + bracket connect (maybe (return ()) disconnect) + (maybe (return Nothing) (fmap Just . f))