diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,29 @@ +# 4.1.0 + +## Breaking Changes + + * The [`BroadcastChan`][broadcast-chan] dependency has not received + Cabal revisions for a while, so is replaced with [`Control.Concurrent.STM.TChan`][tchan]. + Some types in `System.Taffybar.Hooks` and `System.Taffybar.Information.{Battery,Chrome,Crypto}` change accordingly. + +[broadcast-chan]: https://hackage.haskell.org/package/broadcast-chan +[tchan]: https://hackage.haskell.org/package/stm-2.5.1.0/docs/Control-Concurrent-STM-TChan.html + +## Improvements + + * Add icon next to window label in Windows widget. This can be configured + with [`WindowsConfig(getActiveWindowIconPixbuf)`][WindowsConfig]. + + * Taffybar now watches its CSS files with inotify. Changes to CSS + should be visible immediately after saving the file. + + If Taffybar is not running in a terminal, and the process receives + a `SIGHUP` signal, then it will restart the inotify instance and + reload the CSS files. + +[WindowsConfig]: https://hackage.haskell.org/package/taffybar-4.1.0/docs/System-Taffybar-Widget-Windows.html#t:WindowsConfig + + # 4.0.3 ## Breaking Changes diff --git a/doc/custom.md b/doc/custom.md --- a/doc/custom.md +++ b/doc/custom.md @@ -26,8 +26,7 @@ [#308 Add styling tips section to README/docs](https://github.com/taffybar/taffybar/issues/308) Appearance of Taffybar widgets can be controlled with CSS rules. These -are by default loaded from `$XDG_CONFIG_HOME/taffybar/taffybar.css`. Taffybar -must be restarted for changes in `taffybar.css` to take effect. +are by default loaded from `$XDG_CONFIG_HOME/taffybar/taffybar.css`. ### GTK Documentation @@ -44,6 +43,15 @@ interactively try CSS rules, which is immensely helpful. [inspector]: https://developer.gnome.org/documentation/tools/inspector.html + +### Reloading CSS + +Taffybar watches `taffybar.css` (and other configured CSS files) for +modification, so style changes should be visible immediately. + +But, if the file watching doesn't work for some reason, and Taffybar +is running as a daemon, a `SIGHUP` signal on the process will force it +to reload the CSS files. ### Specifying colours diff --git a/doc/install.md b/doc/install.md --- a/doc/install.md +++ b/doc/install.md @@ -7,7 +7,7 @@ Several Linux distributions package Taffybar: - [NixOS (nixpkgs)](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix) -- [arch/aur](https://aur.archlinux.org/packages/taffybar/) +- [Arch Linux [extra]](https://archlinux.org/packages/extra/x86_64/taffybar/) - [Debian (main)](https://packages.debian.org/unstable/taffybar) - [Ubuntu (universe)](https://packages.ubuntu.com/taffybar) diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs --- a/src/System/Taffybar.hs +++ b/src/System/Taffybar.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- | @@ -129,24 +130,30 @@ , taffybarDyreParams ) where +import qualified Control.Concurrent.MVar as MV import qualified Config.Dyre as Dyre import qualified Config.Dyre.Params as Dyre import Control.Exception ( finally ) +import Data.Function ( on ) import Control.Monad import qualified Data.GI.Gtk.Threading as GIThreading +import Data.List ( groupBy, sort, isPrefixOf ) import qualified Data.Text as T +import Data.Word (Word32) import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk +import qualified GI.GLib as G import Graphics.X11.Xlib.Misc ( initThreads ) import System.Directory import System.Environment.XDG.BaseDir ( getUserConfigFile ) import System.Exit ( exitFailure ) -import System.FilePath ( () ) +import System.FilePath ( (), normalise, takeDirectory, takeFileName ) +import System.FSNotify ( startManager, watchDir, stopManager, EventIsDirectory (..), Event (..) ) import qualified System.IO as IO import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Hooks -import System.Taffybar.Util ( onSigINT ) +import System.Taffybar.Util ( onSigINT, maybeHandleSigHUP, rebracket_ ) import Paths_taffybar ( getDataDir ) @@ -175,39 +182,123 @@ IO.hPutStrLn IO.stderr ("Error: " ++ err) exitFailure +-- | Locate installed vendor data file. getDataFile :: String -> IO FilePath getDataFile name = do dataDir <- getDataDir - return (dataDir name) - -startCSS :: [FilePath] -> IO Gtk.CssProvider -startCSS cssFilePaths = do - -- Override the default GTK theme path settings. This causes the - -- bar (by design) to ignore the real GTK theme and just use the - -- provided minimal theme to set the background and text colors. - -- Users can override this default. - taffybarProvider <- Gtk.cssProviderNew - - let loadIfExists filePath = - doesFileExist filePath >>= - flip when (Gtk.cssProviderLoadFromPath taffybarProvider (T.pack filePath)) - - mapM_ loadIfExists cssFilePaths - - Just scr <- Gdk.screenGetDefault - Gtk.styleContextAddProviderForScreen scr taffybarProvider 800 - return taffybarProvider + return (normalise (dataDir name)) -- | Locates full the 'FilePath' of the given Taffybar config file. -- The [XDG Base Directory](https://specifications.freedesktop.org/basedir-spec/latest/) convention is used, meaning that config files are usually in @~\/.config\/taffybar@. getTaffyFile :: String -> IO FilePath getTaffyFile = getUserConfigFile "taffybar" -getDefaultCSSPaths :: IO [FilePath] -getDefaultCSSPaths = do - defaultUserConfig <- getTaffyFile "taffybar.css" - return [defaultUserConfig] +-- | Return CSS files which should be loaded for the given config. +getCSSPaths :: TaffybarConfig -> IO [FilePath] +getCSSPaths TaffybarConfig{cssPaths} = sequence (defaultCSS:userCSS) + where + -- Vendor CSS file, which is always loaded before user's CSS. + defaultCSS = getDataFile "taffybar.css" + -- User's configured CSS files, with XDG config file being the default. + userCSS | null cssPaths = [getTaffyFile "taffybar.css"] + | otherwise = map return cssPaths +-- | Overrides the default GTK theme and settings with CSS styles from +-- the given files (if they exist). +-- +-- This causes the bar (by design) to ignore the real GTK theme and +-- just use the provided minimal theme to set the background and text +-- colors. +startCSS :: [FilePath] -> IO (IO (), Gtk.CssProvider) +startCSS = startCSS' 800 + +-- | Installs a GTK style provider at a certain priority and loads it +-- with styles from a list of CSS files (if they exist). +-- +-- This will return the 'Gtk.CssProvider' object, paired with a +-- cleanup function which can be used later to uninstall the style +-- provider. +-- +-- The priority defines how the Taffybar CSS cascades with the GTK theme, etc. +-- For your information, these are the GTK defined priorities: +-- * @GTK_STYLE_PROVIDER_PRIORITY_FALLBACK@ = 1 +-- * @GTK_STYLE_PROVIDER_PRIORITY_THEME@ = 100 +-- * @GTK_STYLE_PROVIDER_PRIORITY_SETTINGS@ = 400 +-- * @GTK_STYLE_PROVIDER_PRIORITY_APPLICATION@ = 600 +-- * @GTK_STYLE_PROVIDER_PRIORITY_USER@ = 800 +-- +-- The file @XDG_CONFIG_HOME/gtk-3.0/gtk.css@ uses priority 800. +startCSS' :: Word32 -> [FilePath] -> IO (IO (), Gtk.CssProvider) +startCSS' prio cssFilePaths = do + provider <- Gtk.cssProviderNew + mapM_ (logLoadCSSFile provider) =<< filterM doesFileExist cssFilePaths + uninstall <- install provider =<< Gdk.screenGetDefault + pure (uninstall, provider) + where + logLoadCSSFile p f = logTaffy INFO ("Loading stylesheet " ++ f) >> loadCSSFile p f + loadCSSFile p = Gtk.cssProviderLoadFromPath p . T.pack + install provider (Just scr) = do + Gtk.styleContextAddProviderForScreen scr provider prio + pure (Gtk.styleContextRemoveProviderForScreen scr provider) + install _ Nothing = pure (pure ()) + +-- | Uses 'startCSS' in a 'bracket' block to ensure that the CSS +-- provider is removed when Taffybar finishes. +-- +-- An @inotify@ watch list will be set up so that a change to any of +-- the CSS files causes the CSS provider to be reloaded. +-- +-- If Taffybar is running as a daemon, then this also installs a +-- handler on @SIGHUP@ which triggers reloading of the CSS files, and +-- recreates the inotify watcher. +withCSSReloadable :: [FilePath] -> IO () -> IO () +withCSSReloadable css action = rebracket_ (fst <$> startCSS css) $ \reload -> do + let reload' = noteReload >> reload + rebracket_ (watchCSS css reload') $ \rewatch -> do + let rewatch' = noteRewatch >> rewatch >> reload + maybeHandleSigHUP rewatch' action + where + noteReload = logTaffy NOTICE "Reloading CSS..." + noteRewatch = logTaffy NOTICE "SIGHUP received - restarting file watchers..." + +-- | Opens an @inotify@ instance and watches the directories containing +-- our CSS files. +-- +-- The given notifier function will be called shortly after one of the +-- CSS files changes. +-- +-- A cleanup function is returned which will clear the watch list and +-- close the @inotify@ instance. +watchCSS :: [FilePath] -> IO () -> IO (IO ()) +watchCSS css notifier = do + callback <- debounce 100 notifier + mgr <- startManager + cssDirs <- getDirs css + mapM_ (\(dir, fs) -> watchDir mgr dir (eventP fs) callback) cssDirs + pure (stopManager mgr) + where + getDirs = filterM (doesDirectoryExist . fst) + . filter (not . isPrefixOf "/nix/store/" . fst) + . dirGroups + . sort + dirGroups xs = [ (takeDirectory f, map takeFileName (f:fs)) + | (f:fs) <- groupBy ((==) `on` takeDirectory) xs] + eventP fs ev = eventIsDirectory ev == IsFile + && takeFileName (eventPath ev) `elem` fs + + -- inotify events arrive in batches. To avoid unnecessary reloads, + -- accumulate events in an MVar and call the notifier after a + -- short delay. + debounce msec cb = do + buffer <- MV.newMVar [] + let mainLoopCallback = do + evs <- MV.modifyMVar buffer (pure . ([],)) + unless (null evs) cb + pure G.SOURCE_REMOVE + pure $ \ev -> do + MV.modifyMVar_ buffer (pure . (ev:)) + void $ G.timeoutAdd G.PRIORITY_LOW msec mainLoopCallback + -- | Start Taffybar with the provided 'TaffybarConfig'. This function will not -- handle recompiling taffybar automatically when @taffybar.hs@ is updated. If you -- would like this feature, use 'dyreTaffybar' instead. If automatic @@ -222,15 +313,11 @@ _ <- initThreads _ <- Gtk.init Nothing GIThreading.setCurrentThreadAsGUIThread - defaultCSS <- getDataFile "taffybar.css" - cssPathsToLoad <- - if null $ cssPaths config - then getDefaultCSSPaths - else return $ cssPaths config - _ <- startCSS $ defaultCSS:cssPathsToLoad + + cssPathsToLoad <- getCSSPaths config context <- buildContext config - Gtk.main + withCSSReloadable cssPathsToLoad $ Gtk.main `finally` logTaffy DEBUG "Finished main loop" `onSigINT` do logTaffy INFO "Interrupted" diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs --- a/src/System/Taffybar/Context.hs +++ b/src/System/Taffybar/Context.hs @@ -225,7 +225,7 @@ [DBus.nameAllowReplacement, DBus.nameReplaceExisting] listenersVar <- MV.newMVar [] state <- MV.newMVar M.empty - x11Context <- getDefaultCtx >>= MV.newMVar + x11Context <- getX11Context def >>= MV.newMVar windowsVar <- MV.newMVar [] let context = Context { x11ContextVar = x11Context @@ -466,7 +466,7 @@ -- XXX: The event loop needs its own X11Context to separately handle -- communications from the X server. We deliberately avoid using the context -- from x11ContextVar here. - lift $ withDefaultCtx $ eventLoop + lift $ withX11Context def $ eventLoop (\e -> runReaderT (handleX11Event e) c) -- | Remove the listener associated with the provided "Unique" from the diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs --- a/src/System/Taffybar/Hooks.hs +++ b/src/System/Taffybar/Hooks.hs @@ -22,9 +22,10 @@ , refreshBatteriesOnPropChange ) where -import BroadcastChan import Control.Concurrent +import Control.Concurrent.STM.TChan import Control.Monad +import Control.Monad.STM (atomically) import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import qualified Data.MultiMap as MM @@ -40,13 +41,13 @@ -- | The type of the channel that provides network information in taffybar. newtype NetworkInfoChan = - NetworkInfoChan (BroadcastChan In [(String, (Rational, Rational))]) + NetworkInfoChan (TChan [(String, (Rational, Rational))]) -- | Build a 'NetworkInfoChan' that refreshes at the provided interval. buildNetworkInfoChan :: Double -> IO NetworkInfoChan buildNetworkInfoChan interval = do - chan <- newBroadcastChan - _ <- forkIO $ monitorNetworkInterfaces interval (void . writeBChan chan) + chan <- newBroadcastTChanIO + _ <- forkIO $ monitorNetworkInterfaces interval (void . atomically . writeTChan chan) return $ NetworkInfoChan chan -- | Get the 'NetworkInfoChan' from 'Context', creating it if it does not exist. diff --git a/src/System/Taffybar/Information/Battery.hs b/src/System/Taffybar/Information/Battery.hs --- a/src/System/Taffybar/Information/Battery.hs +++ b/src/System/Taffybar/Information/Battery.hs @@ -10,7 +10,7 @@ -- Portability : unportable -- -- This module provides functions for querying battery information using the --- UPower dbus, as well as a "BroadcastChan" system for allowing multiple +-- UPower dbus, as well as a broadcast "TChan" system for allowing multiple -- readers to receive 'BatteryState' updates without duplicating requests. ----------------------------------------------------------------------------- module System.Taffybar.Information.Battery @@ -21,10 +21,11 @@ , module System.Taffybar.Information.Battery ) where -import BroadcastChan import Control.Concurrent +import Control.Concurrent.STM.TChan import Control.Monad import Control.Monad.IO.Class +import Control.Monad.STM (atomically) import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Reader @@ -155,7 +156,7 @@ return $ filter isBattery paths newtype DisplayBatteryChanVar = - DisplayBatteryChanVar (BroadcastChan In BatteryInfo, MVar BatteryInfo) + DisplayBatteryChanVar (TChan BatteryInfo, MVar BatteryInfo) getDisplayBatteryInfo :: TaffyIO BatteryInfo getDisplayBatteryInfo = do @@ -175,13 +176,13 @@ getDisplayBatteryChanVar = setupDisplayBatteryChanVar defaultMonitorDisplayBatteryProperties -getDisplayBatteryChan :: TaffyIO (BroadcastChan In BatteryInfo) +getDisplayBatteryChan :: TaffyIO (TChan BatteryInfo) getDisplayBatteryChan = do DisplayBatteryChanVar (chan, _) <- getDisplayBatteryChanVar return chan updateBatteryInfo - :: BroadcastChan In BatteryInfo + :: TChan BatteryInfo -> MVar BatteryInfo -> ObjectPath -> TaffyIO () @@ -190,7 +191,7 @@ where doWrites info = batteryLogF DEBUG "Writing info %s" info >> - swapMVar var info >> void (writeBChan chan info) + swapMVar var info >> void (atomically $ writeTChan chan info) warnOfFailure = batteryLogF WARNING "Failed to update battery info %s" registerForAnyUPowerPropertiesChanged @@ -217,12 +218,12 @@ -- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object -- to returned "MVar" and "Chan" objects monitorDisplayBattery :: - [String] -> TaffyIO (BroadcastChan In BatteryInfo, MVar BatteryInfo) + [String] -> TaffyIO (TChan BatteryInfo, MVar BatteryInfo) monitorDisplayBattery propertiesToMonitor = do lift $ batteryLog DEBUG "Starting Battery Monitor" client <- asks systemDBusClient infoVar <- lift $ newMVar $ infoMapToBatteryInfo M.empty - chan <- newBroadcastChan + chan <- liftIO newBroadcastTChanIO taffyFork $ do ctx <- ask let warnOfFailedGetDevice err = diff --git a/src/System/Taffybar/Information/Chrome.hs b/src/System/Taffybar/Information/Chrome.hs --- a/src/System/Taffybar/Information/Chrome.hs +++ b/src/System/Taffybar/Information/Chrome.hs @@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Information.Chrome where -import BroadcastChan import Control.Concurrent +import Control.Concurrent.STM.TChan import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.STM (atomically) import Control.Monad.Trans.Class import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS @@ -29,14 +31,14 @@ newtype ChromeTabImageDataState = ChromeTabImageDataState - (MVar (M.Map Int ChromeTabImageData), BroadcastChan Out ChromeTabImageData) + (MVar (M.Map Int ChromeTabImageData), TChan ChromeTabImageData) getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState getChromeTabImageDataState = do ChromeFaviconServerPort port <- fromMaybe (ChromeFaviconServerPort 5000) <$> getState getStateDefault (listenForChromeFaviconUpdates port) -getChromeTabImageDataChannel :: TaffyIO (BroadcastChan Out ChromeTabImageData) +getChromeTabImageDataChannel :: TaffyIO (TChan ChromeTabImageData) getChromeTabImageDataChannel = do ChromeTabImageDataState (_, chan) <- getChromeTabImageDataState return chan @@ -51,8 +53,8 @@ listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState listenForChromeFaviconUpdates port = do infoVar <- lift $ newMVar M.empty - inChan <- newBroadcastChan - outChan <- newBChanListener inChan + inChan <- liftIO newBroadcastTChanIO + outChan <- liftIO . atomically $ dupTChan inChan _ <- lift $ forkIO $ scotty port $ post "/setTabImageData/:tabID" $ do tabID <- queryParam "tabID" @@ -70,7 +72,7 @@ in modifyMVar_ infoVar $ \currentMap -> do - _ <- writeBChan inChan chromeTabImageData + _ <- atomically $ writeTChan inChan chromeTabImageData return $ M.insert tabID chromeTabImageData currentMap Gdk.pixbufLoaderGetPixbuf loader >>= maybe (return ()) updateChannelAndMVar return $ ChromeTabImageDataState (infoVar, outChan) diff --git a/src/System/Taffybar/Information/Crypto.hs b/src/System/Taffybar/Information/Crypto.hs --- a/src/System/Taffybar/Information/Crypto.hs +++ b/src/System/Taffybar/Information/Crypto.hs @@ -17,11 +17,12 @@ ----------------------------------------------------------------------------- module System.Taffybar.Information.Crypto where -import BroadcastChan import Control.Concurrent +import Control.Concurrent.STM.TChan import Control.Exception.Enclosed (catchAny) import Control.Monad import Control.Monad.IO.Class +import Control.Monad.STM (atomically) import Data.Aeson import Data.Aeson.Types (parseMaybe) import qualified Data.Aeson.Key as Key @@ -58,7 +59,7 @@ newtype CryptoPriceInfo = CryptoPriceInfo { lastPrice :: Double } newtype CryptoPriceChannel (a :: Symbol) = - CryptoPriceChannel (BroadcastChan In CryptoPriceInfo, MVar CryptoPriceInfo) + CryptoPriceChannel (TChan CryptoPriceInfo, MVar CryptoPriceInfo) getCryptoPriceChannel :: KnownSymbol a => TaffyIO (CryptoPriceChannel a) getCryptoPriceChannel = do @@ -97,13 +98,13 @@ forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a) buildCryptoPriceChannel delay symbolToId = do let initialBackoff = delay - chan <- newBroadcastChan + chan <- liftIO newBroadcastTChanIO var <- liftIO $ newMVar $ CryptoPriceInfo 0.0 backoffVar <- liftIO $ newMVar initialBackoff let doWrites info = do _ <- swapMVar var info - _ <- writeBChan chan info + _ <- atomically $ writeTChan chan info _ <- swapMVar backoffVar initialBackoff return () diff --git a/src/System/Taffybar/Information/EWMHDesktopInfo.hs b/src/System/Taffybar/Information/EWMHDesktopInfo.hs --- a/src/System/Taffybar/Information/EWMHDesktopInfo.hs +++ b/src/System/Taffybar/Information/EWMHDesktopInfo.hs @@ -57,7 +57,7 @@ , parseWindowClasses , switchOneWorkspace , switchToWorkspace - , withDefaultCtx + , withX11Context , withEWMHIcons ) where diff --git a/src/System/Taffybar/Information/X11DesktopInfo.hs b/src/System/Taffybar/Information/X11DesktopInfo.hs --- a/src/System/Taffybar/Information/X11DesktopInfo.hs +++ b/src/System/Taffybar/Information/X11DesktopInfo.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.X11DesktopInfo @@ -21,12 +25,14 @@ module System.Taffybar.Information.X11DesktopInfo ( -- * Context - X11Context(..) - , getDefaultCtx - , withDefaultCtx + X11Context + , DisplayName(..) + , getX11Context + , withX11Context -- * Properties , X11Property + , X11PropertyT -- ** Event loop , eventLoop @@ -64,47 +70,67 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Bits (testBit, (.|.)) +import Data.Default (Default(..)) import Data.List (elemIndex) import Data.List.Split (endBy) import Data.Maybe (fromMaybe, listToMaybe) +import GHC.Generics (Generic) import Graphics.X11.Xrandr (XRRScreenResources(..), XRROutputInfo(..), xrrGetOutputInfo, xrrGetScreenResources, xrrGetOutputPrimary) import System.Taffybar.Information.SafeX11 hiding (displayName) -- | Represents a connection to an X11 display. --- Use 'getDefaultCtx' to construct one of these. +-- Use 'getX11Context' to construct one of these. data X11Context = X11Context - { contextDisplay :: Display - , _contextRoot :: Window - , atomCache :: MV.MVar [(String, Atom)] + { ctxDisplayName :: DisplayName + , ctxDisplay :: Display + , ctxRoot :: Window + , ctxAtomCache :: MV.MVar [(String, Atom)] } +-- | Specifies an X11 display to connect to. +data DisplayName = DefaultDisplay + -- ^ Use the @DISPLAY@ environment variable. + | DisplayName String + -- ^ Of the form @hostname:number.screen_number@ + deriving (Show, Read, Eq, Ord, Generic) + +instance Default DisplayName where + def = DefaultDisplay + +-- | Translate 'DisplayName' for use with 'openDisplay'. +fromDisplayName :: DisplayName -> String +fromDisplayName DefaultDisplay = "" +fromDisplayName (DisplayName displayName) = displayName + +-- | A 'ReaderT' with 'X11Context'. +type X11PropertyT m a = ReaderT X11Context m a -- | 'IO' actions with access to an 'X11Context'. -type X11Property a = ReaderT X11Context IO a +type X11Property a = X11PropertyT IO a type X11Window = Window type PropertyFetcher a = Display -> Atom -> X11Window -> IO (Maybe [a]) -- | Makes a connection to the default X11 display using --- 'getDefaultCtx' and puts the current display and root window +-- 'getX11Context' and puts the current display and root window -- objects inside a 'ReaderT' transformer for further computation. -withDefaultCtx :: X11Property a -> IO a -withDefaultCtx fun = do - ctx <- getDefaultCtx +withX11Context :: DisplayName -> X11Property a -> IO a +withX11Context dn fun = do + ctx <- getX11Context dn res <- runReaderT fun ctx - closeDisplay (contextDisplay ctx) + closeDisplay (ctxDisplay ctx) return res -- | An X11Property that returns the 'Display' object stored in the -- 'X11Context'. getDisplay :: X11Property Display -getDisplay = contextDisplay <$> ask +getDisplay = ctxDisplay <$> ask doRead :: Integral a => b -> ([a] -> b) -> PropertyFetcher a -> Maybe X11Window -> String -> X11Property b -doRead def transform windowPropFn window name = - maybe def transform <$> fetch windowPropFn window name +doRead b transform windowPropFn window name = + maybe b transform <$> fetch windowPropFn window name -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a value of type Int. If that property hasn't been set, @@ -165,7 +191,8 @@ -- | Return the 'Atom' with the given name. getAtom :: String -> X11Property Atom getAtom s = do - (X11Context d _ cacheVar) <- ask + d <- asks ctxDisplay + cacheVar <- asks ctxAtomCache a <- lift $ lookup s <$> MV.readMVar cacheVar let updateCacheAction = lift $ MV.modifyMVar cacheVar updateCache updateCache currentCache = @@ -179,7 +206,8 @@ -- subscribing to all events of this type emitted by newly created windows. eventLoop :: (Event -> IO ()) -> X11Property () eventLoop dispatch = do - (X11Context d w _) <- ask + d <- asks ctxDisplay + w <- asks ctxRoot liftIO $ do selectInput d w $ propertyChangeMask .|. substructureNotifyMask allocaXEvent $ \e -> forever $ do @@ -194,15 +222,11 @@ -- to send events that can be received by event hooks in the XMonad process and -- acted upon in that context. sendCommandEvent :: Atom -> Atom -> X11Property () -sendCommandEvent cmd arg = do - (X11Context dpy root _) <- ask - sendCustomEvent dpy cmd arg root root +sendCommandEvent cmd arg = sendCustomEvent cmd arg Nothing -- | Similar to 'sendCommandEvent', but with an argument of type 'X11Window'. sendWindowEvent :: Atom -> X11Window -> X11Property () -sendWindowEvent cmd win = do - (X11Context dpy root _) <- ask - sendCustomEvent dpy cmd cmd root win +sendWindowEvent cmd win = sendCustomEvent cmd cmd (Just win) -- | Builds a new 'X11Context' containing a connection to the default -- X11 display and its root window. @@ -210,12 +234,12 @@ -- If the X11 connection could not be opened, it will throw -- @'Control.Exception.userError' "openDisplay"@. This can occur if the -- @X -maxclients@ limit has been exceeded. -getDefaultCtx :: IO X11Context -getDefaultCtx = do - d <- openDisplay "" - w <- rootWindow d $ defaultScreen d - cache <- MV.newMVar [] - return $ X11Context d w cache +getX11Context :: DisplayName -> IO X11Context +getX11Context ctxDisplayName = do + d <- openDisplay $ fromDisplayName ctxDisplayName + ctxRoot <- rootWindow d $ defaultScreen d + ctxAtomCache <- MV.newMVar [] + return $ X11Context{ctxDisplay=d,..} -- | Apply the given function to the given window in order to obtain the X11 -- property with the given name, or Nothing if no such property can be read. @@ -225,64 +249,64 @@ -> String -- ^ Name of the property to retrieve. -> X11Property (Maybe [a]) fetch fetcher window name = do - (X11Context dpy root _) <- ask + X11Context{..} <- ask atom <- getAtom name - liftIO $ fetcher dpy atom (fromMaybe root window) + liftIO $ fetcher ctxDisplay atom (fromMaybe ctxRoot window) -- | Retrieve the @WM_HINTS@ mask assigned by the X server to the given window. fetchWindowHints :: X11Window -> X11Property WMHints fetchWindowHints window = do - (X11Context d _ _) <- ask + d <- getDisplay liftIO $ getWMHints d window -- | Emit an event of type @ClientMessage@ that can be listened to and consumed -- by XMonad event hooks. -sendCustomEvent :: Display - -> Atom - -> Atom - -> X11Window - -> X11Window +sendCustomEvent :: Atom -- ^ Command + -> Atom -- ^ Argument + -> Maybe X11Window -- ^ 'Just' a window, or 'Nothing' for the root window -> X11Property () -sendCustomEvent dpy cmd arg root win = +sendCustomEvent cmd arg win = do + X11Context{..} <- ask + let win' = fromMaybe ctxRoot win liftIO $ allocaXEvent $ \e -> do setEventType e clientMessage - setClientMessageEvent e win cmd 32 arg currentTime - sendEvent dpy root False structureNotifyMask e - sync dpy False + setClientMessageEvent e win' cmd 32 arg currentTime + sendEvent ctxDisplay ctxRoot False structureNotifyMask e + sync ctxDisplay False -- | Post the provided X11Property to taffybar's dedicated X11 thread, and wait -- for the result. The provided default value will be returned in the case of an -- error. postX11RequestSyncProp :: X11Property a -> a -> X11Property a -postX11RequestSyncProp prop def = do +postX11RequestSyncProp prop a = do c <- ask let action = runReaderT prop c - lift $ postX11RequestSyncDef def action + lift $ postX11RequestSyncDef a action -- | 'X11Property' which reflects whether or not the provided 'RROutput' is active. isActiveOutput :: XRRScreenResources -> RROutput -> X11Property Bool isActiveOutput sres output = do - (X11Context display _ _) <- ask + display <- getDisplay maybeOutputInfo <- liftIO $ xrrGetOutputInfo display sres output return $ maybe 0 xrr_oi_crtc maybeOutputInfo /= 0 -- | Return all the active RANDR outputs. getActiveOutputs :: X11Property [RROutput] getActiveOutputs = do - (X11Context display rootw _) <- ask - maybeSres <- liftIO $ xrrGetScreenResources display rootw - maybe (return []) (\sres -> filterM (isActiveOutput sres) $ xrr_sr_outputs sres) - maybeSres + X11Context{..} <- ask + liftIO (xrrGetScreenResources ctxDisplay ctxRoot) >>= \case + Just sres -> filterM (isActiveOutput sres) (xrr_sr_outputs sres) + Nothing -> return [] -- | Get the index of the primary monitor as set and ordered by Xrandr. getPrimaryOutputNumber :: X11Property (Maybe Int) getPrimaryOutputNumber = do - (X11Context display rootw _) <- ask - primary <- liftIO $ xrrGetOutputPrimary display rootw + X11Context{..} <- ask + primary <- liftIO $ xrrGetOutputPrimary ctxDisplay ctxRoot outputs <- getActiveOutputs return $ primary `elemIndex` outputs -- | Move the given 'X11Window' to the bottom of the X11 window stack. doLowerWindow :: X11Window -> X11Property () doLowerWindow window = - asks contextDisplay >>= lift . flip lowerWindow window + asks ctxDisplay >>= lift . flip lowerWindow window diff --git a/src/System/Taffybar/SimpleConfig.hs b/src/System/Taffybar/SimpleConfig.hs --- a/src/System/Taffybar/SimpleConfig.hs +++ b/src/System/Taffybar/SimpleConfig.hs @@ -42,7 +42,8 @@ -- | An ADT representing the edge of the monitor along which taffybar should be -- displayed. -data Position = Top | Bottom deriving (Show, Eq) +data Position = Top | Bottom + deriving (Show, Read, Eq, Ord, Enum, Bounded) -- | A configuration object whose interface is simpler than that of -- 'TaffybarConfig'. Unless you have a good reason to use taffybar's more @@ -186,4 +187,4 @@ -- on the primary monitor. usePrimaryMonitor :: TaffyIO [Int] usePrimaryMonitor = - return . fromMaybe 0 <$> lift (withDefaultCtx getPrimaryOutputNumber) + singleton . fromMaybe 0 <$> lift (withX11Context def getPrimaryOutputNumber) diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs --- a/src/System/Taffybar/Util.hs +++ b/src/System/Taffybar/Util.hs @@ -41,6 +41,11 @@ -- * Process control , runCommand , onSigINT + , maybeHandleSigHUP + , handlePosixSignal + -- * Resource management + , rebracket + , rebracket_ -- * Deprecated , logPrintFDebug , liftReader @@ -52,7 +57,8 @@ import Conduit import Control.Applicative import Control.Arrow ((&&&)) -import Control.Concurrent +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import qualified Control.Concurrent.MVar as MV import Control.Exception.Base import Control.Monad import Control.Monad.Trans.Maybe @@ -61,18 +67,21 @@ import Data.GI.Base.GError import Control.Exception.Enclosed (catchAny) import Data.GI.Gtk.Threading as Gtk (postGUIASync, postGUISync) +import Data.GI.Gtk.Threading (postGUIASyncWithPriority) import Data.Maybe import Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.Text as T import Data.Tuple.Sequence import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk +import qualified GI.GLib.Constants as G import Network.HTTP.Simple import System.Directory import System.Environment.XDG.BaseDir import System.Exit (ExitCode (..), exitWith) import System.FilePath.Posix +import System.IO (hIsTerminalDevice, stdout, stderr) import System.Log.Logger -import System.Posix.Signals (Signal, Handler(..), installHandler, sigINT) +import System.Posix.Signals (Signal, Handler(..), installHandler, sigHUP, sigINT) import qualified System.Process as P import Text.Printf @@ -126,17 +135,52 @@ -- environment variable is searched for the executable. runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String) runCommand cmd args = liftIO $ do - (ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args "" + (ecode, out, err) <- P.readProcessWithExitCode cmd args "" logM "System.Taffybar.Util" INFO $ printf "Running command %s with args %s" (show cmd) (show args) return $ case ecode of - ExitSuccess -> Right stdout - ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) stderr + ExitSuccess -> Right out + ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) err {-# DEPRECATED runCommandFromPath "Use runCommand instead" #-} runCommandFromPath :: MonadIO m => FilePath -> [String] -> m (Either String String) runCommandFromPath = runCommand +-- | A variant of 'bracket' which allows for reloading. +-- +-- The first parameter is an allocation function which returns a newly +-- created value of type @r@, paired with an @IO@ action which will +-- destroy that value. +-- +-- The second parameter is the action to run. It is passed a "reload" +-- function which will run the allocation function and return the +-- newly created value. +-- +-- Initially, there is no value. Reloading will cause the previous +-- value (if any) to be destroyed. When the action completes, the +-- current value (if any) will be destroyed. +rebracket :: IO (IO (), r) -> (IO r -> IO a) -> IO a +rebracket alloc action = bracket setup teardown (action . reload) + where + cleanup = fst + resource = snd + setup = MV.newMVar Nothing + teardown = maybeTeardown <=< MV.takeMVar + maybeTeardown = maybe (pure ()) cleanup + reload var = MV.modifyMVar var $ \stale -> do + maybeTeardown stale + fresh <- alloc + pure (Just fresh, resource fresh) + +-- | A variant of 'rebracket' where the resource value isn't needed. +-- +-- And because the resource value isn't needed, this variant will +-- automatically allocate the resource before running the enclosed +-- action. +rebracket_ :: IO (IO ()) -> (IO () -> IO a) -> IO a +rebracket_ alloc action = rebracket ((, ()) <$> alloc) $ + \reload -> reload >> action reload + -- | Execute the provided IO action at the provided interval. foreverWithDelay :: (MonadIO m, RealFrac d) => d -> IO () -> m ThreadId foreverWithDelay delay action = @@ -243,14 +287,40 @@ writeIORef exitStatus (Just (ExitFailure 130)) callback - withSigHandler sigINT (CatchOnce intHandler) $ do + withSigHandlerBase sigINT (CatchOnce intHandler) $ do res <- action readIORef exitStatus >>= mapM_ exitWith pure res +-- | Installs the given function as a handler for @SIGHUP@, but only +-- if this process is not running in a terminal (i.e. runnning as a +-- daemon). +-- +-- If not running as a daemon, then no handler is installed by +-- 'maybeHandleSigHUP'. The default handler for 'sigHUP' exits the +-- program, which is the correct thing to do. +maybeHandleSigHUP :: IO () -> IO a -> IO a +maybeHandleSigHUP callback action = + ifM (anyM hIsTerminalDevice [stdout, stderr]) + action + (handlePosixSignal sigHUP callback action) + +-- | Install a handler for the given POSIX 'Signal' while the given +-- @IO@ action is running, then restore the original handler. +-- +-- This function is for handling non-critical signals. +-- +-- The given callback function won't be run immediately within the +-- @sigaction@ handler, but will instead be posted to the GLib main +-- loop. +handlePosixSignal :: Signal -> IO () -> IO a -> IO a +handlePosixSignal sig cb = withSigHandlerBase sig (Catch handler) + where + handler = postGUIASyncWithPriority G.PRIORITY_HIGH_IDLE cb + -- | Install a handler for the given signal, run an 'IO' action, then -- restore the original handler. -withSigHandler :: Signal -> Handler -> IO a -> IO a -withSigHandler sig h = bracket (install h) install . const +withSigHandlerBase :: Signal -> Handler -> IO a -> IO a +withSigHandlerBase sig h = bracket (install h) install . const where install handler = installHandler sig handler Nothing diff --git a/src/System/Taffybar/Widget/Battery.hs b/src/System/Taffybar/Widget/Battery.hs --- a/src/System/Taffybar/Widget/Battery.hs +++ b/src/System/Taffybar/Widget/Battery.hs @@ -13,7 +13,7 @@ -- This module provides battery widgets that are queried using the UPower dbus -- service. To avoid duplicating all information requests for each battery -- widget displayed (if using a multi-head configuration or multiple battery --- widgets), these widgets use the "BroadcastChan" based system for receiving +-- widgets), these widgets use the broadcast "TChan" based system for receiving -- updates defined in "System.Taffybar.Information.Battery". ----------------------------------------------------------------------------- module System.Taffybar.Widget.Battery diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs --- a/src/System/Taffybar/Widget/FreedesktopNotifications.hs +++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs @@ -27,7 +27,6 @@ , notifyAreaNew ) where -import BroadcastChan import Control.Concurrent import Control.Concurrent.STM import Control.Monad ( forever, void ) @@ -64,14 +63,14 @@ , noteConfig :: NotificationConfig -- ^ The associated configuration , noteQueue :: TVar (Seq Notification) -- ^ The queue of active notifications , noteIdSource :: TVar Word32 -- ^ A source of fresh notification ids - , noteChan :: BroadcastChan In () -- ^ Writing to this channel wakes up the display thread + , noteChan :: TChan () -- ^ Writing to this channel wakes up the display thread } initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState initialNoteState wrapper l cfg = do m <- newTVarIO 1 q <- newTVarIO S.empty - ch <- newBroadcastChan + ch <- newBroadcastTChanIO return NotifyState { noteQueue = q , noteIdSource = m , noteWidget = l @@ -172,14 +171,14 @@ -------------------------------------------------------------------------------- wakeupDisplayThread :: NotifyState -> IO () -wakeupDisplayThread s = void $ writeBChan (noteChan s) () +wakeupDisplayThread s = void . atomically $ writeTChan (noteChan s) () -- | Refreshes the GUI displayThread :: NotifyState -> IO () displayThread s = do - chan <- newBChanListener (noteChan s) + chan <- atomically . dupTChan $ noteChan s forever $ do - _ <- readBChan chan + _ <- atomically $ readTChan chan ns <- readTVarIO (noteQueue s) postGUIASync $ if S.length ns == 0 diff --git a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs --- a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs +++ b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs @@ -1,25 +1,25 @@ module System.Taffybar.Widget.Generic.ChannelGraph where -import BroadcastChan import Control.Concurrent +import Control.Concurrent.STM.TChan import Control.Monad import Control.Monad.IO.Class -import Data.Foldable (traverse_) +import Control.Monad.STM (atomically) import GI.Gtk import System.Taffybar.Widget.Generic.Graph --- | Given a 'BroadcastChan' and an action to consume that broadcast chan and +-- | Given a broadcast 'TChan' and an action to consume that broadcast chan and -- turn it into graphable values, build a graph that will update as values are -- broadcast over the channel. channelGraphNew :: MonadIO m - => GraphConfig -> BroadcastChan In a -> (a -> IO [Double]) -> m GI.Gtk.Widget + => GraphConfig -> TChan a -> (a -> IO [Double]) -> m GI.Gtk.Widget channelGraphNew config chan sampleBuilder = do (graphWidget, graphHandle) <- graphNew config _ <- onWidgetRealize graphWidget $ do - ourChan <- newBChanListener chan + ourChan <- atomically $ dupTChan chan sampleThread <- forkIO $ forever $ - readBChan ourChan >>= - traverse_ (graphAddSample graphHandle <=< sampleBuilder) + atomically (readTChan ourChan) >>= + (graphAddSample graphHandle <=< sampleBuilder) void $ onWidgetUnrealize graphWidget $ killThread sampleThread return graphWidget diff --git a/src/System/Taffybar/Widget/Generic/ChannelWidget.hs b/src/System/Taffybar/Widget/Generic/ChannelWidget.hs --- a/src/System/Taffybar/Widget/Generic/ChannelWidget.hs +++ b/src/System/Taffybar/Widget/Generic/ChannelWidget.hs @@ -1,23 +1,23 @@ module System.Taffybar.Widget.Generic.ChannelWidget where -import BroadcastChan import Control.Concurrent +import Control.Concurrent.STM.TChan import Control.Monad import Control.Monad.IO.Class -import Data.Foldable (traverse_) +import Control.Monad.STM (atomically) import GI.Gtk --- | Given a widget, a 'BroadcastChan' and a function that consumes the values +-- | Given a widget, a broadcast 'TChan' and a function that consumes the values -- yielded by the channel that is in 'IO', connect the function to the --- 'BroadcastChan' on a dedicated haskell thread. +-- 'TChan' on a dedicated haskell thread. channelWidgetNew :: (MonadIO m, IsWidget w) => - w -> BroadcastChan In a -> (a -> IO ()) -> m w + w -> TChan a -> (a -> IO ()) -> m w channelWidgetNew widget channel updateWidget = do void $ onWidgetRealize widget $ do - ourChan <- newBChanListener channel + ourChan <- atomically $ dupTChan channel processingThreadId <- forkIO $ forever $ - readBChan ourChan >>= traverse_ updateWidget + atomically (readTChan ourChan) >>= updateWidget void $ onWidgetUnrealize widget $ killThread processingThreadId widgetShowAll widget return widget diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs --- a/src/System/Taffybar/Widget/Windows.hs +++ b/src/System/Taffybar/Widget/Windows.hs @@ -19,6 +19,7 @@ import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Reader +import Control.Monad.Trans.Maybe import Data.Default (Default(..)) import Data.Maybe import qualified Data.Text as T @@ -26,9 +27,11 @@ import qualified GI.Gtk as Gtk import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo -import System.Taffybar.Util +import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Generic.DynamicMenu import System.Taffybar.Widget.Util +import System.Taffybar.Widget.Workspaces (WindowIconPixbufGetter, getWindowData, defaultGetWindowIconPixbuf) +import System.Taffybar.Util data WindowsConfig = WindowsConfig { getMenuLabel :: X11Window -> TaffyIO T.Text @@ -36,6 +39,9 @@ -- the window menu. , getActiveLabel :: TaffyIO T.Text -- ^ Action to build the label text for the active window. + , getActiveWindowIconPixbuf :: Maybe WindowIconPixbufGetter + -- ^ Optional function to retrieve a pixbuf to show next to the + -- window label. } defaultGetMenuLabel :: X11Window -> TaffyIO T.Text @@ -62,6 +68,7 @@ WindowsConfig { getMenuLabel = truncatedGetMenuLabel 35 , getActiveLabel = truncatedGetActiveLabel 35 + , getActiveWindowIconPixbuf = Just defaultGetWindowIconPixbuf } instance Default WindowsConfig where @@ -71,25 +78,54 @@ -- its source of events. windowsNew :: WindowsConfig -> TaffyIO Gtk.Widget windowsNew config = do - label <- lift $ Gtk.labelNew Nothing + hbox <- lift $ Gtk.boxNew Gtk.OrientationHorizontal 0 - let setLabelTitle title = lift $ postGUIASync $ Gtk.labelSetMarkup label title - activeWindowUpdatedCallback _ = getActiveLabel config >>= setLabelTitle + refreshIcon <- case getActiveWindowIconPixbuf config of + Just getIcon -> do + (rf, icon) <- buildWindowsIcon getIcon + Gtk.boxPackStart hbox icon True True 0 + pure rf + Nothing -> pure (pure ()) - subscription <- - subscribeToPropertyEvents [ewmhActiveWindow, ewmhWMName, ewmhWMClass] - activeWindowUpdatedCallback - _ <- mapReaderT (Gtk.onWidgetUnrealize label) (unsubscribe subscription) + (setLabelTitle, label) <- buildWindowsLabel + Gtk.boxPackStart hbox label True True 0 + let refreshLabel = getActiveLabel config >>= lift . setLabelTitle - context <- ask + subscription <- subscribeToPropertyEvents + [ewmhActiveWindow, ewmhWMName, ewmhWMClass] + (const $ refreshLabel >> lift refreshIcon) - labelWidget <- Gtk.toWidget label + void $ mapReaderT (Gtk.onWidgetUnrealize hbox) (unsubscribe subscription) + + Gtk.widgetShowAll hbox + boxWidget <- Gtk.toWidget hbox + + runTaffy <- asks (flip runReaderT) menu <- dynamicMenuNew - DynamicMenuConfig { dmClickWidget = labelWidget - , dmPopulateMenu = flip runReaderT context . fillMenu config + DynamicMenuConfig { dmClickWidget = boxWidget + , dmPopulateMenu = runTaffy . fillMenu config } widgetSetClassGI menu "windows" + +buildWindowsLabel :: TaffyIO (T.Text -> IO (), Gtk.Widget) +buildWindowsLabel = do + label <- lift $ Gtk.labelNew Nothing + let setLabelTitle title = postGUIASync $ Gtk.labelSetMarkup label title + (setLabelTitle,) <$> Gtk.toWidget label + +buildWindowsIcon :: WindowIconPixbufGetter -> TaffyIO (IO (), Gtk.Widget) +buildWindowsIcon windowIconPixbufGetter = do + icon <- lift Gtk.imageNew + + runTaffy <- asks (flip runReaderT) + let getActiveWindowPixbuf size = runTaffy . runMaybeT $ do + wd <- MaybeT $ runX11Def Nothing $ + traverse (getWindowData Nothing []) =<< getActiveWindow + MaybeT $ windowIconPixbufGetter size wd + + updateImage <- autoSizeImage icon getActiveWindowPixbuf Gtk.OrientationHorizontal + (postGUIASync updateImage,) <$> Gtk.toWidget icon -- | Populate the given menu widget with the list of all currently open windows. fillMenu :: Gtk.IsMenuShell a => WindowsConfig -> a -> ReaderT Context IO () diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs --- a/src/System/Taffybar/Widget/Workspaces.hs +++ b/src/System/Taffybar/Widget/Workspaces.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings, StrictData #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Workspaces @@ -398,7 +398,7 @@ builder = widgetBuilder cfg _ <- updateVar controllersRef $ \controllers -> do - let oldRemoved = F.foldl (flip M.delete) controllers removeWorkspaces + let oldRemoved = F.foldl' (flip M.delete) controllers removeWorkspaces buildController idx = builder <$> M.lookup idx workspacesMap buildAndAddController theMap idx = maybe (return theMap) (>>= return . flip (M.insert idx) theMap) @@ -426,7 +426,7 @@ case event of PropertyEvent _ _ _ _ _ atom _ _ -> wLog DEBUG $ printf "Event %s" $ show atom - _ -> return () + _anythingElse -> return () void $ forkIO $ rateLimited event return withLog where diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: taffybar -version: 4.0.3 +version: 4.1.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD-3-Clause license-file: LICENSE @@ -27,19 +27,30 @@ flag Deprecated-Pager-Hints description: Enables the deprecated System.Taffybar.Support.PagerHints module, which has been moved to xmonad-contrib. -library +common haskell default-extensions: - TupleSections + DeriveGeneric + GeneralizedNewtypeDeriving + LambdaCase + NumericUnderscores StandaloneDeriving - MonoLocalBinds - + TupleSections default-language: Haskell2010 build-depends: base >= 4.15.0.0 && < 5 - , HStringTemplate >= 0.8 && < 0.9 + ghc-options: -Wall + +common exe + ghc-options: -rtsopts -threaded + +library + import: haskell + default-extensions: + MonoLocalBinds + + build-depends: HStringTemplate >= 0.8 && < 0.9 , X11 >= 1.5.0.1 , aeson , ansi-terminal - , broadcast-chan >= 0.2.0.2 , bytestring , conduit , containers @@ -51,6 +62,7 @@ , either >= 4.0.0.0 , enclosed-exceptions >= 1.0.0.1 , filepath + , fsnotify >= 0.4 && < 0.5 , gi-cairo-connector , gi-cairo-render , gi-gdk >=3.0.6 && <3.1 @@ -168,12 +180,11 @@ autogen-modules: Paths_taffybar cc-options: -fPIC - ghc-options: -Wall -funbox-strict-fields -fno-warn-orphans + ghc-options: -funbox-strict-fields -fno-warn-orphans executable taffybar - default-language: Haskell2010 - build-depends: base - , data-default + import: haskell, exe + build-depends: data-default , directory , hslogger , optparse-applicative @@ -185,25 +196,62 @@ hs-source-dirs: app main-is: Main.hs pkgconfig-depends: gtk+-3.0 - ghc-options: -Wall -rtsopts -threaded +common test + default-extensions: + ImportQualifiedPost + NamedFieldPuns + RecordWildCards + OverloadedStrings + ScopedTypeVariables + ghc-options: -fno-warn-orphans + +library testlib + import: haskell, test + hs-source-dirs: test/lib + exposed-modules: TestLibSpec + , System.Taffybar.Test.DBusSpec + , System.Taffybar.Test.UtilSpec + , System.Taffybar.Test.XvfbSpec + build-depends: attoparsec + , bytestring + , containers + , data-default + , dbus + , extra + , filepath + , hslogger + , hspec + , taffybar + , text + , typed-process + , unix + , unliftio + , unliftio-core + , QuickCheck >= 2 + build-tool-depends: hspec-discover:hspec-discover == 2.* + test-suite unit + import: haskell, test, exe type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - other-modules: System.Taffybar.AuthSpec - , System.Taffybar.SpecUtil - default-language: Haskell2010 - build-depends: base - , directory + hs-source-dirs: test/unit + main-is: unit-tests.hs + other-modules: UnitSpec + , System.Taffybar.AuthSpec + , System.Taffybar.ContextSpec + , System.Taffybar.Information.X11DesktopInfoSpec + , System.Taffybar.SimpleConfigSpec + build-depends: data-default , filepath + , gi-gtk , hspec , hspec-core , hspec-golden , taffybar - , temporary + , taffybar:testlib + , transformers + , QuickCheck build-tool-depends: hspec-discover:hspec-discover == 2.* - ghc-options: -Wall -rtsopts -threaded source-repository head type: git diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/System/Taffybar/AuthSpec.hs b/test/System/Taffybar/AuthSpec.hs deleted file mode 100644 --- a/test/System/Taffybar/AuthSpec.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - -module System.Taffybar.AuthSpec (spec) where - -import Data.List (intercalate) -import System.FilePath ((), (<.>)) -import Text.Printf (printf) - -import Test.Hspec -import Test.Hspec.Core.Spec (getSpecDescriptionPath) -import Test.Hspec.Golden hiding (golden) - -import System.Taffybar.Auth -import System.Taffybar.SpecUtil (withMockCommand) - -spec :: Spec -spec = aroundAll_ (withMockPass mockDb) $ describe "passGet" $ do - golden "get a password" $ show <$> passGet "hello" - golden "get a password with info" $ show <$> passGet "multiline" - golden "missing entry" $ show <$> passGet "missing" - -golden :: String -> IO String -> Spec -golden description runAction = do - path <- (++ words description) <$> getSpecDescriptionPath - it description $ - taffybarGolden (intercalate "-" path) <$> runAction - -taffybarGolden :: String -> String -> Golden String -taffybarGolden name output = Golden - { output - , encodePretty = show - , writeToFile = writeFile - , readFromFile = readFile - , goldenFile = "test/data/" name <.> "golden" - , actualFile = Nothing - , failFirstTime = True - } - -mockDb :: [MockEntry] -mockDb = [ mockEntry "hello" "xyzzy" [] - , mockEntry "multiline" "secret" [("Username", "fred"), ("silly", "")] - , fallbackEntry "" "Error: is not in the password store.\n" 1 - ] - -withMockPass :: [MockEntry] -> IO a -> IO a -withMockPass db = withMockCommand "pass" (mockScript db) - -data MockEntry = MockEntry - { passName :: String - , out :: String - , err :: String - , status :: Int - } deriving (Show, Read, Eq) - -mockEntry :: String -> String -> [(String, String)] -> MockEntry -mockEntry passName key info = - MockEntry { passName, out = passFile key info, err = "", status = 0 } - -passFile :: String -> [(String, String)] -> String -passFile key info = unlines (key:[k ++ ": " ++ v | (k, v) <- info]) - -fallbackEntry :: String -> String -> Int -> MockEntry -fallbackEntry out err status = MockEntry { passName = "", .. } - -mockScript :: [MockEntry] -> String -mockScript db = unlines ("#!/usr/bin/env bash":map makeEntry db) - where - makeEntry MockEntry{..} = printf template passName out err status - template = unlines - [ "pass_name='%s'" - , "if [ -z \"$pass_name\" -o \"$2\" = \"$pass_name\" ]; then" - , " echo -n '%s'" - , " >&2 echo '%s'" - , " exit %d" - , "fi" - ] diff --git a/test/System/Taffybar/SpecUtil.hs b/test/System/Taffybar/SpecUtil.hs deleted file mode 100644 --- a/test/System/Taffybar/SpecUtil.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -module System.Taffybar.SpecUtil - ( withMockCommand - , writeScript - , withEnv - , prependPath - ) where - -import Control.Arrow (second) -import Control.Exception (bracket) -import Control.Monad (guard, join) -import Data.List (uncons) -import System.Directory (Permissions (..), findExecutable, getPermissions, setPermissions) -import System.Environment (lookupEnv, setEnv, unsetEnv) -import System.FilePath (isRelative, takeFileName, ()) -import System.IO.Temp (withSystemTempDirectory) - --- | Run the given 'IO' action with the @PATH@ environment variable --- set up so that executing the given command name will run a --- script. -withMockCommand - :: FilePath -- ^ Name of command - should not contain slashes - -> String -- ^ Contents of script - -> IO a -- ^ Action to run with command available in search path - -> IO a -withMockCommand name content action = - withSystemTempDirectory "specutil" $ \dir -> do - writeScript (dir takeFileName name) content - withEnv [("PATH", prependPath dir)] action - --- | Write a text file, make it executable. --- It ought to have a shebang line. -writeScript :: FilePath -> String -> IO () -writeScript scriptFile content = do - content' <- patchShebangs content - writeFile scriptFile content' - p <- getPermissions scriptFile - setPermissions scriptFile (p { executable = True }) - --- | Given the text of a shell script, this replaces any relative path --- in the shebang with an absolute path, according to the current --- environment's @PATH@ variable. --- --- The only reason this exists is so that we can generate shell --- scripts containing @#!/usr/bin/env bash@ and then be able to --- execute them within a Nix build sandbox (which does not allow --- @/usr/bin/env@). -patchShebangs :: String -> IO String -patchShebangs = patchShebangs' findExe - where - findExe = fmap join . traverse findExecutable . takeRelativeFileName - - takeRelativeFileName :: FilePath -> Maybe FilePath - takeRelativeFileName fp = guard (isRelative fp) >> pure (takeFileName fp) - -patchShebangs' :: Applicative m => (FilePath -> m (Maybe FilePath)) -> String -> m String -patchShebangs' replaceExe script = case parseInterpreter script of - Just (interpreter, rest) -> do - let unparse exe = "#! " ++ exe ++ rest - maybe script unparse <$> replaceExe interpreter - Nothing -> pure script - -parseInterpreter :: String -> Maybe (String, String) -parseInterpreter (lines -> content) = do - (header, rest) <- uncons content - (interpreter, args) <- parseShebang header - pure (interpreter, unlines (args:rest)) - - where - parseShebang :: String -> Maybe (String, String) - parseShebang ('#':'!':(findInterpreter -> shebang)) = - let catArgs args = unwords ("":args) - in second catArgs <$> shebang - parseShebang _ = Nothing - - findInterpreter = uncons . dropWhile ((== "env") . takeFileName) . words - --- | Run an 'IO' action with the given environment variables set up --- according to their current value. 'Nothing' denotes an unset --- environment variable. After the 'IO' action completes, environment --- variables are restored to their previous state. -withEnv :: [(String, Maybe String -> Maybe String)] -> IO a -> IO a -withEnv mods = bracket setup teardown . const - where - setup = mapM (uncurry changeEnv) mods - teardown = mapM (uncurry putEnv) . reverse - - changeEnv name f = do - old <- lookupEnv name - putEnv name (f old) - pure (name, old) - - putEnv :: String -> Maybe String -> IO () - putEnv name = maybe (unsetEnv name) (setEnv name) - --- | Use this as a modifier function argument of 'withEnv' to ensure --- that the given directory is prepended to a search path variable. -prependPath :: FilePath -> Maybe String -> Maybe String -prependPath p = Just . (++ ":/usr/bin") . (p ++) . maybe "" (":" ++) diff --git a/test/lib/System/Taffybar/Test/DBusSpec.hs b/test/lib/System/Taffybar/Test/DBusSpec.hs new file mode 100644 --- /dev/null +++ b/test/lib/System/Taffybar/Test/DBusSpec.hs @@ -0,0 +1,293 @@ +module System.Taffybar.Test.DBusSpec + ( spec + -- * Start private D-Busses for testing + , withTestDBus + , withTestDBusInDir + , Bus(..) + , withDBusDaemon_ + , withConnectDBusDaemon + , withConnectDBusDaemon' + -- ** Using the private D-Bus + , setDBusEnv + , withBusEnv + -- ** @python-dbusmock@ Services + , withPythonDBusMock + , withTaffyMocks + -- * Utils + , withMatch + , withClient + ) where + +import Control.Monad (forM_, void, when) +import Control.Monad.IO.Unlift (MonadUnliftIO (..)) +import Data.ByteString.Char8 qualified as B8 +import Data.Function ((&)) +import Data.List (sort) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) +import Data.Int (Int64) +import DBus +import DBus.Client +import Test.Hspec +import System.FilePath ((), (<.>), takeFileName) +import System.IO (hGetLine, hClose) +import System.Process.Typed +import System.Taffybar.Test.UtilSpec (withSetEnv, logSetup, specLog, withService, getSpecLogPriority, setServiceDefaults, laxTimeout') +import UnliftIO.Directory (makeAbsolute, createDirectoryIfMissing, createFileLink) +import UnliftIO.Temporary (withSystemTempDirectory) +import UnliftIO.Exception (bracket, throwString, finally, throwIO) +import UnliftIO.MVar qualified as MV + +-- | Uses 'withDBusDaemon_' to provide both a private session bus and +-- a private system bus while the given action is running. +-- +-- The @DBUS_SESSION_BUS_ADDRESS@ and @DBUS_SYSTEM_BUS_ADDRESS@ +-- environment variables will be set to point to socket files within +-- the given directory. +-- +-- Files in the directory will be left behind after this function +-- returns. +-- +-- __Note__: Environment variables are global to the process, so be +-- careful using this with 'parallel' unit tests. +withTestDBusInDir + :: FilePath -- ^ Directory for config files and sockets. + -> IO a -> IO a +withTestDBusInDir socketDir + = withDBusDaemon_ System socketDir + . withDBusDaemon_ Session socketDir + +-- | Same as 'withTestDBusInDir', except that it creates and removes the +-- temporary directory for you. +withTestDBus :: IO a -> IO a +withTestDBus = withSystemTempDirectory "dbus-spec" . flip withTestDBusInDir + +data Bus = Session | System deriving (Show, Read, Eq, Enum) + +busName :: Bus -> String +busName Session = "session" +busName System = "system" + +busArg :: Bus -> String +busArg = ("--" ++) . busName + +envName :: Bus -> String +envName Session = "DBUS_SESSION_BUS_ADDRESS" +envName System = "DBUS_SYSTEM_BUS_ADDRESS" + +busEnv :: Bus -> Address -> (String, String) +busEnv bus addr = (envName bus, formatAddress addr) + +-- | Adjust a 'ProcessConfig' so that the child process will use the +-- given D-Bus address. +setDBusEnv :: Bus -> Address -> ProcessConfig i o e -> ProcessConfig i o e +setDBusEnv bus addr = setEnv [busEnv bus addr] + +withDBusDaemon :: Bus -> FilePath -> (Address -> IO a) -> IO a +withDBusDaemon bus socketDir action = do + cfg <- makeDBusDaemon <$> setupBusDir bus socketDir <*> getSpecLogPriority + specLog $ "withDBusDaemon " ++ show bus ++ " running: " ++ show cfg + withService cfg $ \p -> consumeAddress (getStdout p) >>= action + where + consumeAddress h = (just . parseAddress =<< hGetLine h) `finally` hClose h + just = maybe (throwString "Could not parse address from dbus-daemon") pure + + makeDBusDaemon configFile logLevel = + proc "dbus-daemon" ["--print-address", "--config-file", configFile] + & setServiceDefaults logLevel & setStdout createPipe + +-- | Start a D-Bus daemon of the given 'Bus' type, and set the +-- corresponding environment variable while running the given action. +-- +-- __Note__: Environment variables are global to the process, so be +-- careful using this with 'parallel' unit tests. A safer option could +-- be 'withConnectDBusDaemon'' and 'setBusEnv'. +withDBusDaemon_ :: Bus -> FilePath -> IO a -> IO a +withDBusDaemon_ bus socketDir action = withDBusDaemon bus socketDir $ \addr -> withBusEnv bus addr action + +-- | Same as 'withDBusDaemon', but it also provides a 'Client' +-- connection. +withConnectDBusDaemon' :: Bus -> FilePath -> (Address -> Client -> IO a) -> IO a +withConnectDBusDaemon' bus socketDir action = + withDBusDaemon bus socketDir $ \addr -> + withClient addr $ \c -> action addr c + +withConnectDBusDaemon :: Bus -> FilePath -> (Client -> IO a) -> IO a +withConnectDBusDaemon bus socketDir = withConnectDBusDaemon' bus socketDir. const + +setupBusDir :: Bus -> FilePath -> IO FilePath +setupBusDir bus socketDir = do + let busDir = socketDir busName bus + serviceDir = busDir "service.d" + configFile = busDir "config.xml" + createDirectoryIfMissing True serviceDir + forM_ [] $ \service -> + createFileLink service (serviceDir takeFileName service) + -- createFileLink "/nix/store/ygd600kkc1h3p5dgw9vjm5xnfci43v0k-upower-1.90.4/share/dbus-1/system-services/org.freedesktop.UPower.service" (serviceDir "org.freedesktop.UPower.service") + + addr <- mkAddress (socketDir busName bus <.> "socket") + writeFile configFile $ unlines + [ "" + , "" + , " " ++ busName bus ++ "" + , " " + , " " ++ addr ++ "" + , " " ++ serviceDir ++ "" + , " " + , " " + , " " + , " " + , " " + , "" + ] + pure configFile + +mkAddress :: FilePath -> IO String +mkAddress = fmap ("unix:path=" ++) . makeAbsolute + +-- | Set the @DBUS_SESSION_BUS_ADDRESS@ or @DBUS_SYSTEM_BUS_ADDRESS@ +-- environment variable according to the given bus and address. +-- +-- __Note 1__: Environment variables are global to the process, so +-- be careful using this with 'parallel' unit tests. +-- +-- __Note 2__. Using a @DBUS_SYSTEM_BUS_ADDRESS@ environment variable to set a +-- custom system bus address is supported by libdbus (therefore +-- python-dbus) and haskell-dbus, but not necessarily other libraries +-- or programs. Notably, systemd hardcodes the system bus address. +withBusEnv :: Bus -> Address -> IO a -> IO a +withBusEnv bus addr = withSetEnv [busEnv bus addr] + +withClient :: Address -> (Client -> IO a) -> IO a +withClient addr = bracket (connect addr) disconnect + +withMatch :: MonadUnliftIO m => Client -> MatchRule -> (Signal -> m ()) -> m a -> m a +withMatch client rule cb action = withRunInIO $ \run -> bracket + (addMatch client rule (run . cb)) + (removeMatch client) + (const $ run action) + +makeBusNameWaiter :: Client -> (BusName -> Bool) -> IO (IO ()) +makeBusNameWaiter client p = do + v <- MV.newEmptyMVar + h <- MV.newEmptyMVar + let cb sig = onNameOwnerChanged sig $ do + hh <- MV.takeMVar h + removeMatch client hh + MV.putMVar v () + MV.putMVar h =<< addMatch client rule cb + pure (MV.takeMVar v) + where + rule = matchAny { matchMember = Just "NameOwnerChanged" + , matchInterface = Just "org.freedesktop.DBus" + , matchSender = Just "org.freedesktop.DBus" + } + isMatch = maybe False p . fromVariant + isOwned = not . null . fromMaybe ("" :: String) . fromVariant + + onNameOwnerChanged sig next = case signalBody sig of + [name, _, owner] -> when (isMatch name && isOwned owner) next + _ -> pure () + +-- | Starts up [@python-dbusmock@](https://martinpitt.github.io/python-dbusmock/). +-- The given action will be run once the mock is ready. +withPythonDBusMock + :: Bus -- ^ @python-dbusmock@ wants to know which bus. + -> (Address, Client) -- ^ Connection to the 'Bus' + -> BusName -- ^ Name of mock service. + -> ObjectPath -- ^ Path of mock service. + -> InterfaceName -- ^ Interface of mock service. + -> IO a -> IO a +withPythonDBusMock bus (addr, client) name path interface action = do + waiter <- makeBusNameWaiter client (== name) + logLevel <- getSpecLogPriority + withService (cfg & setServiceDefaults logLevel) $ const $ + waiter *> action + where + cfg = proc "python3" args & setDBusEnv bus addr + args = ["-m", "dbusmock", busArg bus + , formatBusName name + , formatObjectPath path + , formatInterfaceName interface] + +mockAddTemplate :: Client -> BusName -> ObjectPath -> String -> [(String, Variant)] -> IO () +mockAddTemplate client dest path templ params = do + void $ call_ client (addTemplate templ params) { methodCallDestination = Just dest } + where + addTemplate t p = (methodCall path "org.freedesktop.DBus.Mock" "AddTemplate") + { methodCallBody = [toVariant t, toVariant (Map.fromList p)] } + +------------------------------------------------------------------------ + +upName :: BusName +upName = "org.freedesktop.UPower" +upPath, upDisplayDevicePath :: ObjectPath +upPath = "/org/freedesktop/UPower" +upDisplayDevicePath = objectPath_ (formatObjectPath upPath ++ "/devices/DisplayDevice") +upIface, upDeviceIface :: InterfaceName +upIface = "org.freedesktop.UPower" +upDeviceIface = interfaceName_ (formatInterfaceName upIface ++ ".Device") + +mockIconName :: String +mockIconName = "face-cool-symbolic" + +mockUPower :: Client -> IO () +mockUPower client = do + -- oh dbus, so ugly. + mockAddTemplate client upName upPath "upower" [("OnBattery", toVariant True)] + void $ call_ client (methodCall upPath "org.freedesktop.DBus.Mock" "AddAC") { methodCallBody = map toVariant ["mock_AC" :: String, "Mock AC"], methodCallDestination = Just upName } + void $ call_ client (methodCall upPath "org.freedesktop.DBus.Mock" "AddChargingBattery") { methodCallBody = map toVariant ["mock_BAT" :: String, "Mock Battery"] ++ [toVariant (30.0 :: Double), toVariant (1200 :: Int64)] , methodCallDestination = Just upName } + void $ setPropertyValue client (methodCall upDisplayDevicePath upDeviceIface "IconName") { methodCallDestination = Just upName } mockIconName + +withTaffyMocks :: IO a -> IO a +withTaffyMocks action = do + maddr <- getSystemAddress + addr <- maybe (throwIO (clientError "getSystemAddress")) pure maddr + withClient addr $ \client -> do + withPythonDBusMock System (addr, client) upName upPath upIface $ do + mockUPower client + action + +------------------------------------------------------------------------ + +spec :: Spec +spec = logSetup $ around_ (laxTimeout' 1_000_000) $ around (withSystemTempDirectory "dbus-spec") $ do + describe "withDBusDaemon org.freedesktop.DBus.Peer.Ping" $ do + forM_ [System, Session] $ \bus -> + aroundWith (flip (withConnectDBusDaemon' bus) . curry) $ do + it ("can ping private test " ++ show bus ++ " bus") $ \(_, client) -> do + (fmap methodReturnBody <$> call client ping) + `shouldReturn` Right [] + + it ("gdbus can ping private test " ++ show bus ++ " bus") $ \(addr, _) -> + readProcessStdout_ (gdbusPing bus & setDBusEnv bus addr) + `shouldReturn` "()\n" + + forM_ [System] $ \bus -> + aroundWith (flip (withConnectDBusDaemon' bus) . curry) $ + describe ("python-dbusmock " ++ show bus ++ " services") $ do + it "simple" $ \(addr, client) -> example $ + withPythonDBusMock bus (addr, client) "com.example.Foo" "/" "com.example.Foo.Manager" $ pure () + + it "UPower" $ \(addr, client) -> example $ do + withPythonDBusMock bus (addr, client) upName upPath upIface $ do + mockUPower client + models <- upowerDumpModels addr + sort models `shouldBe` ["Mock AC", "Mock Battery"] + +upowerDumpModels :: Address -> IO [String] +upowerDumpModels addr = parse <$> readProcessStdout_ cfg + where + cfg = proc "upower" ["--dump"] & setDBusEnv System addr + parse = map (B8.unpack . B8.dropSpace . B8.drop 1 . snd) + . filter ((== "model") . fst) + . map (B8.break (== ':') . B8.dropSpace) + . B8.lines + . B8.toStrict + +gdbusPing :: Bus -> ProcessConfig () () () +gdbusPing bus = proc "gdbus" ["call", "--" ++ busName bus, "--dest", "org.freedesktop.DBus", "--object-path", "/org/freedesktop/DBus", "--method", "org.freedesktop.DBus.Peer.Ping"] + +ping :: MethodCall +ping = (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus.Peer" "Ping") + { methodCallDestination = Just "org.freedesktop.DBus" } diff --git a/test/lib/System/Taffybar/Test/UtilSpec.hs b/test/lib/System/Taffybar/Test/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/lib/System/Taffybar/Test/UtilSpec.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} + +module System.Taffybar.Test.UtilSpec + ( spec + -- * Mock commands + , withMockCommand + , writeScript + -- * Environment setup + , withEnv + , withSetEnv + , prependPath + -- ** Running subprocesses + , withService + , setStdoutCond + , setStderrCond + , setServiceDefaults + , makeServiceDefaults + -- * Concurrency + , listLiveThreads + , diffLiveThreads + -- * OS Resources + , listFds + -- * Other test helpers + , tryIOMaybe + , laxTimeout + , laxTimeout' + , DodgyEq(..) + -- ** Logging for tests + , logSetup + , specLogSetup + , specLogSetupPrio + , specLog + , specLogAt + , getSpecLogPriority + , Priority(..) + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (guard, join, void, (<=<)) +import Control.Monad.IO.Unlift +import Data.Bifunctor (second) +import qualified Data.ByteString.Char8 as B8 +import Data.Either.Extra (eitherToMaybe, isLeft) +import Data.Function (on, (&)) +import Data.List (deleteFirstsBy, uncons) +import Data.Maybe (catMaybes, fromMaybe) +#if MIN_VERSION_base(4,18,0) +import GHC.Conc.Sync (ThreadId(..), ThreadStatus(..), listThreads, threadStatus, threadLabel) +#else +import GHC.Conc.Sync (ThreadId(..), ThreadStatus(..)) +#endif +import System.Exit (ExitCode(..)) +import System.FilePath (isRelative, takeFileName, ()) +import System.IO (Handle, BufferMode(..), hSetBuffering, stderr, hClose) +import System.Log.Logger (Priority(..), updateGlobalLogger, setLevel, logM, getLevel, getLogger, removeHandler, setHandlers) +import System.Log.Handler.Simple (GenericHandler(..)) +import System.Process.Typed (readProcess, proc, ProcessConfig, Process, withProcessTerm, waitExitCode, ExitCodeException (..), setStdin, nullStream, setStdout, setStderr, StreamSpec, setCloseFds, inherit, createPipe, getStdin) +import System.Posix.Files (readSymbolicLink) +import Test.Hspec +import Text.Printf (printf) +import Text.Read (readMaybe) +import UnliftIO.Async (race) +import UnliftIO.Concurrent (forkFinally, threadDelay) +import UnliftIO.Directory (Permissions (..), findExecutable, getPermissions, setPermissions, listDirectory) +import UnliftIO.Environment (lookupEnv, setEnv, unsetEnv) +import UnliftIO.Exception (bracket, evaluateDeep, throwIO, throwString, tryIO, StringException (..), try) +import qualified UnliftIO.MVar as MV +import UnliftIO.Temporary (withSystemTempDirectory) +import UnliftIO.Timeout (timeout) + +import System.Taffybar.LogFormatter (taffyLogHandler) + +-- | Run the given 'IO' action with the @PATH@ environment variable +-- set up so that executing the given command name will run a +-- script. +withMockCommand + :: FilePath -- ^ Name of command - should not contain slashes + -> String -- ^ Contents of script + -> IO a -- ^ Action to run with command available in search path + -> IO a +withMockCommand name content action = + withSystemTempDirectory "specutil" $ \dir -> do + writeScript (dir takeFileName name) content + withEnv [("PATH", prependPath dir)] action + +-- | Write a text file, make it executable. +-- It ought to have a shebang line. +writeScript :: FilePath -> String -> IO () +writeScript scriptFile content = do + content' <- patchShebangs content + writeFile scriptFile content' + p <- getPermissions scriptFile + setPermissions scriptFile (p { executable = True }) + +-- | Given the text of a shell script, this replaces any relative path +-- in the shebang with an absolute path, according to the current +-- environment's @PATH@ variable. +-- +-- The only reason this exists is so that we can generate shell +-- scripts containing @#!/usr/bin/env bash@ and then be able to +-- execute them within a Nix build sandbox (which does not allow +-- @/usr/bin/env@). +patchShebangs :: String -> IO String +patchShebangs = patchShebangs' findExe + where + findExe = fmap join . traverse findExecutable . takeRelativeFileName + + takeRelativeFileName :: FilePath -> Maybe FilePath + takeRelativeFileName fp = guard (isRelative fp) >> pure (takeFileName fp) + +patchShebangs' :: Applicative m => (FilePath -> m (Maybe FilePath)) -> String -> m String +patchShebangs' replaceExe script = case parseInterpreter script of + Just (interpreter, rest) -> do + let unparse exe = "#! " ++ exe ++ rest + maybe script unparse <$> replaceExe interpreter + Nothing -> pure script + +parseInterpreter :: String -> Maybe (String, String) +parseInterpreter (lines -> content) = do + (header, rest) <- uncons content + (interpreter, args) <- parseShebang header + pure (interpreter, unlines (args:rest)) + + where + parseShebang :: String -> Maybe (String, String) + parseShebang ('#':'!':(findInterpreter -> shebang)) = + let catArgs args = unwords ("":args) + in second catArgs <$> shebang + parseShebang _ = Nothing + + findInterpreter = uncons . dropWhile ((== "env") . takeFileName) . words + +-- | Run an 'IO' action with the given environment variables set up +-- according to their current value. 'Nothing' denotes an unset +-- environment variable. After the 'IO' action completes, environment +-- variables are restored to their previous state. +withEnv :: [(String, Maybe String -> Maybe String)] -> IO a -> IO a +withEnv mods = bracket setup teardown . const + where + setup = mapM (uncurry changeEnv) mods + teardown = mapM (uncurry putEnv) . reverse + + changeEnv name f = do + old <- lookupEnv name + putEnv name (f old) + pure (name, old) + + putEnv :: String -> Maybe String -> IO () + putEnv name = maybe (unsetEnv name) (setEnv name) + +withSetEnv :: [(String, String)] -> IO a -> IO a +withSetEnv = withEnv . map (second (const . Just)) + +-- | Use this as a modifier function argument of 'withEnv' to ensure +-- that the given directory is prepended to a search path variable. +prependPath :: FilePath -> Maybe String -> Maybe String +prependPath p = Just . (++ ":/usr/bin") . (p ++) . maybe "" (":" ++) + +listFds :: MonadIO m => m [(Int, FilePath)] +listFds = catMaybes <$> (listDirectory fdPath >>= mapM readEntry) + where + fdPath = "/proc/self/fd" + + readEntry :: MonadIO m => FilePath -> m (Maybe (Int, FilePath)) + readEntry fd = do + t <- liftIO $ tryIOMaybe $ readSymbolicLink (fdPath fd) + pure $ (,) <$> readMaybe fd <*> t + +listLiveThreads :: IO [(ThreadId, (String, Maybe ThreadStatus))] +#if MIN_VERSION_base(4,18,0) +listLiveThreads = do + threadIds <- listThreads + labels <- mapM (fmap (fromMaybe "" . join) . tryIOMaybe . threadLabel) threadIds + statuses <- mapM (tryIOMaybe . threadStatus) threadIds + let isAlive s = s /= ThreadFinished && s /= ThreadDied + pure $ filter (maybe True isAlive . snd . snd) $ zip threadIds (zip labels statuses) +#else +listLiveThreads = pure [] +#endif + +diffLiveThreads :: Eq a => [(a, b)] -> [(a, b)] -> [(a, b)] +diffLiveThreads = deleteFirstsBy ((==) `on` fst) + +tryIOMaybe :: MonadUnliftIO m => m a -> m (Maybe a) +tryIOMaybe = fmap eitherToMaybe . tryIO + +laxTimeout' :: (HasCallStack, MonadUnliftIO m) => Int -> m a -> m a +laxTimeout' n action = laxTimeout n action >>= \case + Just a -> pure a + Nothing -> expectationFailure' $ printf "Timed out after %dusec" n + +expectationFailure' :: (HasCallStack, MonadIO m) => String -> m a +expectationFailure' msg = liftIO (expectationFailure msg) >> throwString msg + +laxTimeout :: (HasCallStack, MonadUnliftIO m) => Int -> m a -> m (Maybe a) +laxTimeout n action = do + result <- MV.newEmptyMVar + void $ forkFinally (timeout n action) (MV.putMVar result) + join <$> timeout n (MV.takeMVar result >>= either throwIO pure) + +-- | A wrapper to provide 'Eq' for types which only have 'Show'. +newtype DodgyEq a = DodgyEq { unDodgyEq :: a } + deriving Show via (DodgyEq a) + +instance Eq (DodgyEq a) where + a == b = show a == show b + +------------------------------------------------------------------------ + +-- | Logger name for messages originating from specs. +specLoggerName :: String +specLoggerName = "Test" + +-- | Log a test message. +specLog :: MonadIO m => String -> m () +specLog = specLogAt INFO + +-- | Log a test message at the given level. +specLogAt :: MonadIO m => Priority -> String -> m () +specLogAt level = liftIO . logM specLoggerName level + +-- | Setup logging before running the specs. +logSetup :: HasCallStack => SpecWith a -> SpecWith a +logSetup = beforeAll_ specLogSetup + +-- | Get log levels from environment variables and set up formatters. +specLogSetup :: IO () +specLogSetup = specLogSetupPrio WARNING + +-- | Like 'specLogSetup', but with a default minimum priority. +specLogSetupPrio :: Priority -> IO () +specLogSetupPrio defaultPriority = do + updateGlobalLogger "" removeHandler + hSetBuffering stderr LineBuffering + setup "System.Taffybar" "TAFFYBAR_VERBOSE" taffyLogHandler + setup specLoggerName "TAFFYBAR_TEST_VERBOSE" (pure specLogHandler) + where + setup loggerName envVar getHandler = do + p <- fromMaybe defaultPriority <$> getEnvPriority envVar + h <- getHandler + updateGlobalLogger loggerName (setLevel p . setHandlers [h]) + +-- | A plain looking log handler, to contrast with 'taffyLogFormatter'. +specLogHandler :: GenericHandler Handle +specLogHandler = GenericHandler + { priority = DEBUG + , formatter = \_ (level, msg) _name -> return (show level ++ ": " ++ msg) + , privData = stderr + , writeFunc = \h -> B8.hPutStrLn h . B8.pack <=< evaluateDeep + , closeFunc = \_ -> return () + } + +-- | Find out the configured log level for specs. +getSpecLogPriority :: MonadIO m => m Priority +getSpecLogPriority = fromMaybe WARNING . getLevel <$> liftIO (getLogger specLoggerName) + +-- | Converts an environment variable value to a 'Priority'. +-- Numeric or textual levels are supported. +getEnvPriority :: String -> IO (Maybe Priority) +getEnvPriority = fmap (>>= toPriority) . lookupEnv + where + toPriority s = readMaybe s <|> fmap fromInt (readMaybe s) + + fromInt :: Int -> Priority + fromInt n | n >= 2 = DEBUG + | n <= 0 = WARNING + | otherwise = INFO + +-- | Like 'withProcessTerm_', except that if the process exits -- for +-- whatever reason -- before the action completes, then it's an +-- error. It will immediately cancel the action and throw an +-- 'ExitCodeException'. +withService :: MonadUnliftIO m => ProcessConfig stdin stdout stderr -> (Process stdin stdout stderr -> m a) -> m a +withService cfg action = withProcessTerm cfg $ \p -> do + either throwEarlyExitException pure =<< race (waitExitCode p) (action p) + where + throwEarlyExitException c = throwIO $ ExitCodeException c cfg' "" "" + cfg' = cfg & setStdin nullStream & setStdout nullStream & setStderr nullStream + +streamSpecCond :: Priority -> Priority -> StreamSpec any () +streamSpecCond level verbosity = if level >= verbosity then inherit else nullStream + +setStdoutCond :: Priority -> ProcessConfig i o e -> ProcessConfig i () e +setStdoutCond = setStdout . streamSpecCond DEBUG + +setStderrCond :: Priority -> ProcessConfig i o e -> ProcessConfig i o () +setStderrCond = setStderr . streamSpecCond INFO + +makeServiceDefaults :: FilePath -> [String] -> IO (ProcessConfig () () ()) +makeServiceDefaults prog args = + ($ proc prog args) . setServiceDefaults <$> getSpecLogPriority + +setServiceDefaults :: Priority -> ProcessConfig i o e -> ProcessConfig () () () +setServiceDefaults logLevel = setCloseFds True + . setStdin nullStream + . setStdoutCond logLevel + . setStderrCond logLevel + +------------------------------------------------------------------------ + +spec :: Spec +spec = do + it "withMockCommand" $ example $ + withMockCommand "blah" "#!/usr/bin/env bash\necho hello \"$@\"\n" $ do + (code, out, err) <- readProcess (proc "blah" ["arstd"]) + code `shouldBe` ExitSuccess + out `shouldBe` "hello arstd\n" + err `shouldBe` "" + + it "laxTimeout" $ example $ do + let t = 50_000 + laxTimeout t (threadDelay (t * 2)) `shouldReturn` Nothing + + describe "withService" $ around_ (laxTimeout' 100_000) $ do + let wait = const $ threadDelay maxBound + it "normal" $ example $ + withService (proc "sleep" ["60"]) (const $ pure ()) + `shouldReturn` () + it "exc" $ example $ + withService (proc "sleep" ["60"]) (const $ throwString "hello") + `shouldThrow` \(StringException msg _) -> msg == "hello" + it "early exit" $ example $ + withService "true" wait `shouldThrow` + \exc -> eceExitCode exc == ExitSuccess + it "manual exit" $ example $ + withService + (proc "cat" [] & setStdin createPipe) + (\p -> hClose (getStdin p) >> wait p) + `shouldThrow` \exc -> eceExitCode exc == ExitSuccess + it "failure" $ example $ + withService "false" wait `shouldThrow` + \exc -> eceExitCode exc /= ExitSuccess + it "error message" $ example $ do + res <- try (withService (proc "false" ["arg1", "arg2"]) wait) + res `shouldSatisfy` isLeft + either (show . eceProcessConfig) show res + `shouldBe` "Raw command: false arg1 arg2\n" diff --git a/test/lib/System/Taffybar/Test/XvfbSpec.hs b/test/lib/System/Taffybar/Test/XvfbSpec.hs new file mode 100644 --- /dev/null +++ b/test/lib/System/Taffybar/Test/XvfbSpec.hs @@ -0,0 +1,627 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module System.Taffybar.Test.XvfbSpec + ( spec + -- * Virtual X11 server for unit testing + , withXvfb + , withXdummy + , displayArg + , displayEnv + , setDefaultDisplay_ + , setDefaultDisplay + -- ** Randr + , withRandrSetup + , randrSetup + , randrTeardown + -- *** RANDR config + , RRSetup(..) + , RROutput(..) + , RROutputSettings(..) + , RRExistingMode(..) + , RRMode(..) + , RRModeName(..) + , RRModeLine(..) + , RRPosition(..) + , RRRotation(..) + , ListIndex(..) + -- ** Clients + , withXTerm + -- * Wrappers around @xprop@ command + , XPropName(..) + , xpropName + , XPropValue(..) + , xpropValue + , xpropGet + , xpropSet + , xpropRemove + , xpropList + ) where + +import Control.Applicative ((<|>)) +import Control.Monad ((<=<), void, forM_, guard) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Attoparsec.Text.Lazy hiding (takeWhile, take) +import qualified Data.Attoparsec.Text.Lazy as P +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Bifunctor (bimap, second) +import Data.Char (isPrint, isSpace) +import Data.Coerce (coerce) +import Data.Default (Default(..)) +import Data.List (findIndex, uncons, dropWhileEnd) +import Data.String (IsString(..)) +import Data.Text.Lazy.Encoding (decodeUtf8') +import qualified Data.Text.Lazy as TL +import qualified Data.Text as T +import Data.Function ((&)) +import Data.Maybe (maybeToList, mapMaybe, isJust, isNothing) +import GHC.Generics (Generic) +import System.Process.Typed +import System.IO (Handle, hClose, hGetLine) +import Text.Read (readMaybe) +import UnliftIO.Concurrent (threadDelay) +import UnliftIO.Exception (fromEitherM, throwString, bracket_) + +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import System.Taffybar.Test.UtilSpec (withSetEnv, logSetup, specLog, specLogAt, getSpecLogPriority, Priority(..), setStderrCond, setServiceDefaults, withService) +import System.Taffybar.Information.X11DesktopInfo (DisplayName(..)) + +------------------------------------------------------------------------ + +-- | Construct a 'DisplayName' for the given local display number. +displayNumber :: Int -> DisplayName +displayNumber n = DisplayName (displaySpec n) + +displaySpec :: Int -> String +displaySpec n = ":" ++ show n + +-- | Produce a @-display@ command-line option, supported by many X11 +-- programs. +displayArg :: DisplayName -> [String] +displayArg DefaultDisplay = [] +displayArg (DisplayName d) = ["-display", d] + +displayEnv :: DisplayName -> [(String, String)] +displayEnv DefaultDisplay = [] +displayEnv (DisplayName d) = [("DISPLAY", d)] + +------------------------------------------------------------------------ + +newtype XPropName = XPropName { unXPropName :: String } + deriving (Show, Read, Eq, Ord, Generic) + +-- | Construct a valid 'XPropName' from a 'String'. Any names which +-- cause problems when parsing @xprop@ output are not allowed. +xpropName :: String -> Maybe XPropName +xpropName n@(c:cs) + | c `elem` propNameStartChars && + all isPrint cs && + not (any propNameBadChars cs) = Just (XPropName n) +xpropName _ = Nothing + +-- | List of characters which are valid first characters of a property +-- name. +propNameStartChars :: [Char] +propNameStartChars = ['a'..'z'] <> ['A'..'Z'] <> ['_'] + +propNameBadChars :: Char -> Bool +propNameBadChars c = isSpace c || c `elem` ['(', ')', ':'] + +newtype XPropValue = XPropValue { unXPropValue :: String } + deriving (Show, Read, Eq, Ord, Semigroup, Monoid, Generic) + +-- | Construct a valid 'XPropValue' from a 'String'. Any values which +-- cause problems when parsing @xprop@ output are not allowed. +xpropValue :: String -> Maybe XPropValue +xpropValue n = if not (any propValueBadChars n) then Just (XPropValue n) else Nothing + +-- | Predicate on characters which cause difficulties when parsing +-- @xprop@ output. +propValueBadChars :: Char -> Bool +propValueBadChars c = c `elem` ['"','\n','\r'] || not (isPrint c) + +------------------------------------------------------------------------ + +xpropProc :: DisplayName -> [String] -> ProcessConfig () () () +xpropProc d args = proc "xprop" (displayArg d ++ args) + +xpropGet :: (HasCallStack, MonadIO m) => DisplayName -> XPropName -> m [XPropValue] +xpropGet d p = do + specLog $ "xpropGet running: " ++ show cfg + txt <- decoded $ readProcessStdout_ cfg + specLogAt DEBUG $ "xprop output:\n" ++ TL.unpack txt + either throwString pure $ parseXProp1 p txt + where + cfg = xpropProc d ["-root", unXPropName p] + decoded :: MonadIO m => m BL.ByteString -> m TL.Text + decoded = fromEitherM . fmap decodeUtf8' + +parseXProp1 :: XPropName -> TL.Text -> Either String [XPropValue] +parseXProp1 p = maybe (Left ("property " ++ show p ++ " not found")) Right . lookup p <=< parseXProp + +parseXProp :: TL.Text -> Either String [(XPropName, [XPropValue])] +parseXProp = eitherResult . parse (many' parseProp) + where + parseProp = do + n <- XPropName . T.unpack <$> parsePropName + vs <- parsePropValues <|> parseErrorMessage + pure (n, vs) + parseErrorMessage = do + void $ char ':' + skipWhile isHorizontalSpace + msg <- takeTill isEndOfLine + fail $ T.unpack msg + parsePropValues = do + t <- parsePropType + skipWhile isHorizontalSpace + void $ char '=' + skipWhile isHorizontalSpace + vs <- parsePropValue t `sepBy` parseValueSep + endOfLine + pure $ map (XPropValue . T.unpack) vs + parsePropName = P.takeWhile (\c -> c /= '(' && c /= ':') + parsePropType = char '(' *> P.takeWhile (/= ')') <* char ')' + parseValueSep = char ',' <* skipWhile isHorizontalSpace + takeUntilSep = takeTill (\c -> c == ',' || isEndOfLine c) + quotedString = quotedString' >>= unescape + quotedString' = char '"' *> P.takeWhile (/= '"') <* char '"' + unescape = pure . T.replace "\\\"" "\"" . T.replace "\\\\" "\\" + parsePropValue "CARDINAL" = takeUntilSep + parsePropValue "ATOM" = takeUntilSep + parsePropValue "STRING" = quotedString + parsePropValue "UTF8_STRING" = quotedString + parsePropValue t = fail $ "Can't parse format \"" ++ T.unpack t ++ "\"" + +xpropSet :: MonadIO m => DisplayName -> XPropName -> XPropValue -> m () +xpropSet d (XPropName p) (XPropValue v) = liftIO $ do + specLog $ "xpropSet running: " ++ show cfg + runProcess_ cfg + where + cfg = xpropProc d args + args = ["-root", "-format", p, "8u", "-set", p, v] + +xpropRemove :: MonadIO m => DisplayName -> XPropName -> m () +xpropRemove d p = do + specLog $ "xpropRemove running: " ++ show cfg + runProcess_ cfg + where + cfg = xpropProc d ["-root", "-remove", unXPropName p] + +xpropList :: MonadIO m => DisplayName -> m () +xpropList d = liftIO $ do + specLog $ "xpropList running: " ++ show cfg + runProcess_ cfg + where + cfg = xpropProc d ["-root"] + +------------------------------------------------------------------------ + +withXTerm :: (DisplayName -> IO a) -> (DisplayName -> IO a) +withXTerm action dn = do + cfg <- makeXterm <$> getSpecLogPriority + specLog $ "withXTerm running: " ++ show cfg + withProcessTerm cfg $ const $ do + threadDelay 500_000 -- give xterm some time to start + action dn + where + makeXterm v = proc "xterm" (displayArg dn) & setStderrCond v + +------------------------------------------------------------------------ + +consumeXDisplayFd :: Handle -> IO DisplayName +consumeXDisplayFd h = do + l <- readMaybe <$> hGetLine h + hClose h + d <- maybe (throwString "Failed to parse display number") (pure . displayNumber) l + specLog $ "X is on display " ++ show d + pure d + +withXserver :: String -> [String] -> Maybe Int -> (DisplayName -> IO a) -> IO a +withXserver prog args display action = do + cfg <- makeXvfb <$> getSpecLogPriority + specLog $ "withXserver running: " ++ show cfg + withService cfg $ \p -> do + d <- consumeXDisplayFd (getStdout p) + action d + where + args' = displayArgMaybe ++ ["-displayfd", "1", "-terminate", "60"] ++ args + makeXvfb logLevel = proc prog args' + & setServiceDefaults logLevel + & setStdout createPipe + + displayArgMaybe = maybeToList (fmap displaySpec display) + +withXvfb :: (DisplayName -> IO a) -> IO a +withXvfb = withXserver "Xvfb" ["-screen", "0", "1024x768x24"] Nothing + +withXdummy :: (DisplayName -> IO a) -> IO a +withXdummy = withXserver "xdummy" [] Nothing + +-- | Using the given 'DisplayName', run an action with the @DISPLAY@ +-- environment variable set. +-- +-- NB. Don't run tests in parallel if using this. Environment +-- variables are process-global. +setDefaultDisplay_ :: DisplayName -> IO a -> IO a +setDefaultDisplay_ = withSetEnv . displayEnv + +-- | Same as 'setDefaultDisplay_', except the 'DisplayName' parameter +-- is passed through to the action. +setDefaultDisplay :: DisplayName -> (DisplayName -> IO a) -> IO a +setDefaultDisplay d action = setDefaultDisplay_ d (action d) + +------------------------------------------------------------------------ + +-- | Adds a guiding phantom type annotation for indices into lists. +-- fixme: zipper rather than indices +newtype ListIndex a = ListIndex { unListIndex :: Int } + deriving (Show, Read, Eq, Ord, Enum, Num, Real, Integral, Generic) + +enumerate :: [a] -> [(ListIndex a, a)] +enumerate = zip [0..] + +bounds' :: Integral n => (n, n) -> (ListIndex a, ListIndex a) +bounds' = let f = ListIndex . fromIntegral in bimap f f + +bounds :: [a] -> (ListIndex a, ListIndex a) +bounds xs = bounds' (0, length xs - 1) + +atIndex :: [a] -> ListIndex a -> a +atIndex as (ListIndex i) = as !! i + +chooseListIndexN :: Int -> Gen (ListIndex a) +chooseListIndexN n = ListIndex <$> chooseInt (0, n - 1) + +chooseListIndex :: [a] -> Gen (ListIndex a) +chooseListIndex = chooseListIndexN . length + +------------------------------------------------------------------------ + +data RRSetup = RRSetup + { outputs :: [RROutput] + , primary :: Maybe (ListIndex RROutput) + , newModes :: [RRMode] -- unused by outputs + } deriving (Show, Read, Eq, Generic) + +instance Default RRSetup where + def = RRSetup { outputs = [def], primary = Just 0, newModes = [] } + +data RROutput = RROutput + { mode :: Maybe RRExistingMode + , settings :: RROutputSettings + , position :: RRPosition + } deriving (Show, Read, Eq, Generic) + +instance Default RROutput where + def = RROutput { mode = def, settings = def, position = def } + +rrOutputOff :: RROutput +rrOutputOff = def { settings = def { disabled = True } } + +data RROutputSettings = RROutputSettings + { disabled :: Bool + , rotate :: RRRotation + } deriving (Show, Read, Eq, Generic) + +instance Default RROutputSettings where + def = RROutputSettings { disabled = False, rotate = def } + +-- | This is an index into 'modeLines'. +newtype RRExistingMode = RRExistingMode { unRRExistingMode :: ListIndex RRMode } + deriving (Show, Read, Eq, Ord, Enum, Generic) + +instance Bounded RRExistingMode where + minBound = RRExistingMode 0 + maxBound = RRExistingMode (snd (bounds modeLines)) + +instance Default RRExistingMode where + def = minBound + +data RRMode = RRMode + { name :: RRModeName + , modeLine :: RRModeLine + } deriving (Show, Read, Eq, Generic) + +instance IsString RRMode where + fromString = uncurry RRMode . bimap (RRModeName . unquote) RRModeLine . split + where + split = second (dropWhile isSpace) . break isSpace + unquote = takeWhile (/= '"') . dropWhile (== '"') + +newtype RRModeName = RRModeName { unRRModeName :: String } + deriving (Show, Read, Eq, IsString, Generic) + +newtype RRModeLine = RRModeLine { unRRModeLine :: String } + deriving (Show, Read, Eq, IsString, Generic) + +data RRPosition = SameAs | RightOf | LeftOf | Below | Above + deriving (Show, Read, Eq, Bounded, Enum, Generic) + +instance Default RRPosition where + def = SameAs + +data RRRotation = Unrotated | RotateLeft | Inverted | RotateRight + deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic) + +instance Default RRRotation where + def = Unrotated + +-- | These 'modeLines' are pre-configured in @xdummy@. They can be +-- referred to by name ('RRExistingMode'), or used in 'Arbitrary' +-- instances to generate new modelines. +modeLines :: [RRMode] +modeLines = + [ "1280x1024 157.500 1280 1344 1504 1728 1024 1025 1028 1072 +HSync +VSync +preferred" + , "1280x1024 135.000 1280 1296 1440 1688 1024 1025 1028 1066 +HSync +VSync" + , "1280x1024 108.000 1280 1328 1440 1688 1024 1025 1028 1066 +HSync +VSync" + , "1280x960 148.500 1280 1344 1504 1728 960 961 964 1011 +HSync +VSync" + , "1280x960 108.000 1280 1376 1488 1800 960 961 964 1000 +HSync +VSync" + , "1280x800 83.500 1280 1352 1480 1680 800 803 809 831 -HSync +VSync" + , "1152x864 108.000 1152 1216 1344 1600 864 865 868 900 +HSync +VSync" + , "1280x720 74.500 1280 1344 1472 1664 720 723 728 748 -HSync +VSync" + , "1024x768 94.500 1024 1072 1168 1376 768 769 772 808 +HSync +VSync" + , "1024x768 78.750 1024 1040 1136 1312 768 769 772 800 +HSync +VSync" + , "1024x768 75.000 1024 1048 1184 1328 768 771 777 806 -HSync -VSync" + , "1024x768 65.000 1024 1048 1184 1344 768 771 777 806 -HSync -VSync" + , "1024x576 46.500 1024 1064 1160 1296 576 579 584 599 -HSync +VSync" + , "832x624 57.284 832 864 928 1152 624 625 628 667 -HSync -VSync" + , "960x540 40.750 960 992 1088 1216 540 543 548 562 -HSync +VSync" + , "800x600 56.300 800 832 896 1048 600 601 604 631 +HSync +VSync" + , "800x600 50.000 800 856 976 1040 600 637 643 666 +HSync +VSync" + , "800x600 49.500 800 816 896 1056 600 601 604 625 +HSync +VSync" + , "800x600 40.000 800 840 968 1056 600 601 605 628 +HSync +VSync" + , "800x600 36.000 800 824 896 1024 600 601 603 625 +HSync +VSync" + , "864x486 32.500 864 888 968 1072 486 489 494 506 -HSync +VSync" + , "640x480 36.000 640 696 752 832 480 481 484 509 -HSync -VSync" + , "640x480 31.500 640 656 720 840 480 481 484 500 -HSync -VSync" + , "640x480 31.500 640 664 704 832 480 489 492 520 -HSync -VSync" + , "640x480 25.175 640 656 752 800 480 490 492 525 -HSync -VSync" + , "720x400 35.500 720 756 828 936 400 401 404 446 -HSync +VSync" + , "640x400 31.500 640 672 736 832 400 401 404 445 -HSync +VSync" + , "640x350 31.500 640 672 736 832 350 382 385 445 +HSync -VSync" + ] + +xrandr :: DisplayName -> [String] -> ProcessConfig () () () +xrandr d args = proc "xrandr" (displayArg d ++ args) + +runXrandr :: DisplayName -> [String] -> IO () +runXrandr d args = do + let cfg = xrandr d args + specLog ("running: " ++ show cfg) + -- NB. void . readProcess_ instead of runProcess_ so that stderr + -- can be included in the ExitCodeException. + void $ readProcess_ cfg + +runXrandrSilent :: DisplayName -> [String] -> IO ExitCode +runXrandrSilent d args = do + let cfg = xrandr d args & setStdout nullStream & setStderr nullStream + specLog ("running: " ++ show cfg) + runProcess cfg + +withRandrSetup :: DisplayName -> RRSetup -> (IO a -> IO a) +withRandrSetup d rr = bracket_ (randrSetup d rr) (randrTeardown d rr) + +randrSetup :: DisplayName -> RRSetup -> IO () +randrSetup d rr = do + -- TODO: is it possible to smush these into one xrandr command? + forM_ rr.newModes $ \m -> + runXrandr d $ ["--newmode", coerce m.name] ++ words (coerce m.modeLine) + + forM_ (enumerate rr.outputs) $ \(i, o) -> case o.mode of + Just m -> runXrandr d ["--addmode", outputName i, modeName m] + Nothing -> pure () + + runXrandr d args + + where + args = concat (globalArgs ++ givenArgs ++ switchOffOthers rr.outputs) + globalArgs = [ ["--noprimary" | isNothing rr.primary ] ] + + givenArgs = zipWith outputArgs [0..] rr.outputs + + outputArgs :: ListIndex RROutput -> RROutput -> [String] + outputArgs i output = + [ "--output", outputName i + , "--rotate", rrRotation output.settings.rotate + ] ++ + maybe ["--preferred"] (\m -> ["--mode", modeName m]) output.mode ++ + ["--off" | output.settings.disabled ] ++ + ["--primary" | rr.primary == Just i] ++ + (if i > 0 then ["--" ++ rrPosition output.position, outputName (i - 1)] else []) + + switchOffOthers :: [RROutput] -> [[String]] + switchOffOthers os = [ ["--output", outputName i, "--off"] + | i <- [ListIndex (length os)..15] ] + +randrTeardown :: DisplayName -> RRSetup -> IO () +randrTeardown d rr = do + forM_ (enumerate rr.outputs) $ \(i, o) -> case o.mode of + Just m -> void $ runXrandrSilent d ["--delmode", outputName i, modeName m] + Nothing -> pure () + + forM_ rr.newModes $ \m -> + void $ runXrandrSilent d ["--rmmode", coerce m.name] + +rrRotation :: RRRotation -> String +rrRotation = \case + Unrotated -> "normal" + RotateLeft -> "left" + Inverted -> "inverted" + RotateRight -> "right" + +rrPosition :: RRPosition -> String +rrPosition = \case + SameAs -> "same-as" + LeftOf -> "left-of" + RightOf -> "right-of" + Above -> "above" + Below -> "below" + +-- | Find the name of the nth RANDR output. +-- Obviously this only works with @xdummy@ config. +outputName :: ListIndex RROutput -> String +outputName (ListIndex i) = "DUMMY" ++ show i + +-- | Find the name of a modeline preconfigured in @xdummy@. +modeName :: RRExistingMode -> String +modeName = unRRModeName . name . existingModeName . unRRExistingMode + where + existingModeName i = modeLines `atIndex` i + +-- | Invent a name for a new X modeline. +newModeName :: ListIndex RRModeLine -> RRModeName +newModeName (ListIndex i) = RRModeName ("newmode" ++ show i) + +------------------------------------------------------------------------ + +-- | Test the test util functions. +spec :: Spec +spec = logSetup $ do + describe "xvfb" $ aroundAll (withXvfb . withXTerm) $ do + it "xprop" $ property . prop_xprop + describe "xdummy" $ aroundAll withXdummy $ do + it "xprop" $ property . prop_xprop + it "xrandr" $ property . prop_xrandr + +------------------------------------------------------------------------ + +prop_xprop :: HasCallStack => DisplayName -> XPropName -> XPropValue -> Property +prop_xprop d name value = monadicIO $ do + xpropSet d name value + value' <- xpropGet d name + xpropRemove d name + pure $ if value /= mempty + then value' === [value] + else value' === [] + +instance Arbitrary XPropName where + arbitrary = ((:) <$> elements propNameStartChars <*> listOf arbitraryASCIIChar) `suchThatMap` xpropName + shrink = mapMaybe (xpropName . unXPropName) . genericShrink + +instance Arbitrary XPropValue where + arbitrary = fmap getPrintableString arbitrary `suchThatMap` xpropValue + shrink = mapMaybe (xpropValue . unXPropValue) . genericShrink + +------------------------------------------------------------------------ + +prop_xrandr :: HasCallStack => DisplayName -> RRSetup -> Property +prop_xrandr d rr = decorate $ monadicIO $ do + qrr <- run $ withRandrSetup d rr (randrQuery d) + let (rr', qrr') = reformat rr qrr + pure $ qrr' === rr' + where + decorate = + tabulate "Outputs" [outputName i | (i, o) <- enumerate rr.outputs, not o.settings.disabled] . + (if any ((/= Unrotated) . rotate . settings) rr.outputs then label "rotation" else id) . + (if any (isNothing . mode) rr.outputs then label "using preferred mode" else id) . + cover 50 (length rr.outputs > 1) "non-trivial" + + reformat rrs = unzip + . map (bimap snd snd) + . dropWhileEnd (not . uncurry (||) . bimap fst fst) + . zip (tuplify (backfill 16 rrs)) + + tuplify RRSetup{..} = + [ (not o.settings.disabled, (i, Just (ListIndex i) == primary)) + | (i, o) <- zip [0..] outputs ] + + backfill n rrs = rrs { outputs = rr.outputs ++ extras } + where extras = replicate (max 0 (n - length rr.outputs)) rrOutputOff + +-- | Scans output of @xrandr --query@ and returns values relevant to +-- test assertions. +randrQuery :: DisplayName -> IO [(Bool, (Int, Bool))] +randrQuery d = parseXrandr <$> readProcessStdout_ (xrandr d ["--query"]) + where + parseXrandr = mapMaybe parseOutput . BL.lines + parseOutput line = do + guard ("DUMMY" `BL.isPrefixOf` line) + let line' = BL.unpack (BL.drop 5 line) + (w, ws) <- uncons (words line') + let e = "connected" `elem` ws + n <- readMaybe w + let p = "primary" `elem` ws + return (e, (n, p)) + +instance Arbitrary RRSetup where + arbitrary = do + nOutputs <- chooseInt (1, 5) + + nNewModes <- chooseInt (1, nOutputs) + newModeLines <- vectorOf nNewModes (elements (map modeLine modeLines)) + + let newModes = [ RRMode (newModeName i) m | (i, m) <- enumerate newModeLines ] + + -- TODO: also use new modes for outputs + -- mode <- chooseListIndex newModes + + outputs <- vector nOutputs + primary <- frequency [ (5, Just <$> chooseListIndex outputs) + , (1, pure Nothing) ] + pure $ RRSetup{..} + + shrink rr = do + (primary, outputs) <- shrinkOutputs + guard $ not $ null outputs + pure $ RRSetup {newModes = [], ..} + + where + shrinkOutputs = case rr.primary of + Just p -> shrinkListIx shrink (p, rr.outputs) + Nothing -> map (Nothing,) (shrinkList shrink rr.outputs) + + -- fixme: shrink modes properly too, and adjust mode within outputs + -- shrinkModes ms = do + -- ms' <- shrinkListP shrink ms + -- pure ms' + +shrinkListIx :: (a -> [a]) -> (ListIndex a, [a]) -> [(Maybe (ListIndex a), [a])] +shrinkListIx shr (ix, xs) = map unwrap $ shrinkList (shrinkSecond shr) (wrap xs) + where + wrap = zip [0..] + unwrap ixs = let ix' = findIndex ((== ix) . fst) ixs + in (fmap ListIndex ix', map snd ixs) + + shrinkSecond :: (a -> [a]) -> (b, a) -> [(b, a)] + shrinkSecond f (b, a) = map (b,) (f a) + +instance Arbitrary RROutput where + -- Always set a mode because "--preferred" option seems dodgy + arbitrary = RROutput <$> fmap Just arbitrary <*> arbitrary <*> arbitrary + shrink o = [ RROutput m s p + | (m, s, p) <- shrink (o.mode, o.settings, o.position) + , isJust m + ] + +instance Arbitrary RROutputSettings where + -- Rotation and reflection don't seem to work for xdummy + arbitrary = RROutputSettings + <$> frequency [(5, pure False), (1, pure True)] + <*> pure Unrotated + shrink = genericShrink + +instance Arbitrary RRExistingMode where + arbitrary = RRExistingMode <$> chooseListIndex modeLines + shrink = shrinkMap (RRExistingMode . ListIndex . getPositive) (Positive . unListIndex . unRRExistingMode) + +instance Arbitrary RRPosition where + arbitrary = frequency $ map (second pure) + [ (2, SameAs) + , (1, LeftOf) + , (4, RightOf) + , (1, Above) + , (2, Below) + ] + shrink = shrinkBoundedEnum + +instance Arbitrary RRRotation where + arbitrary = frequency $ map (second pure) + [ (4, Unrotated) + , (2, Inverted) + , (1, RotateLeft) + , (1, RotateRight) + ] + shrink = shrinkBoundedEnum diff --git a/test/lib/TestLibSpec.hs b/test/lib/TestLibSpec.hs new file mode 100644 --- /dev/null +++ b/test/lib/TestLibSpec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=TestLibSpec #-} diff --git a/test/unit/System/Taffybar/AuthSpec.hs b/test/unit/System/Taffybar/AuthSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/System/Taffybar/AuthSpec.hs @@ -0,0 +1,74 @@ +module System.Taffybar.AuthSpec (spec) where + +import Data.List (intercalate) +import System.FilePath ((), (<.>)) +import Text.Printf (printf) + +import Test.Hspec +import Test.Hspec.Core.Spec (getSpecDescriptionPath) +import Test.Hspec.Golden hiding (golden) + +import System.Taffybar.Auth +import System.Taffybar.Test.UtilSpec (withMockCommand) + +spec :: Spec +spec = aroundAll_ (withMockPass mockDb) $ describe "passGet" $ do + golden "get a password" $ show <$> passGet "hello" + golden "get a password with info" $ show <$> passGet "multiline" + golden "missing entry" $ show <$> passGet "missing" + +golden :: String -> IO String -> Spec +golden description runAction = do + path <- (++ words description) <$> getSpecDescriptionPath + it description $ + taffybarGolden (intercalate "-" path) <$> runAction + +taffybarGolden :: String -> String -> Golden String +taffybarGolden name output = Golden + { output + , encodePretty = show + , writeToFile = writeFile + , readFromFile = readFile + , goldenFile = "test/data/" name <.> "golden" + , actualFile = Nothing + , failFirstTime = True + } + +mockDb :: [MockEntry] +mockDb = [ mockEntry "hello" "xyzzy" [] + , mockEntry "multiline" "secret" [("Username", "fred"), ("silly", "")] + , fallbackEntry "" "Error: is not in the password store.\n" 1 + ] + +withMockPass :: [MockEntry] -> IO a -> IO a +withMockPass db = withMockCommand "pass" (mockScript db) + +data MockEntry = MockEntry + { passName :: String + , out :: String + , err :: String + , status :: Int + } deriving (Show, Read, Eq) + +mockEntry :: String -> String -> [(String, String)] -> MockEntry +mockEntry passName key info = + MockEntry { passName, out = passFile key info, err = "", status = 0 } + +passFile :: String -> [(String, String)] -> String +passFile key info = unlines (key:[k ++ ": " ++ v | (k, v) <- info]) + +fallbackEntry :: String -> String -> Int -> MockEntry +fallbackEntry out err status = MockEntry { passName = "", .. } + +mockScript :: [MockEntry] -> String +mockScript db = unlines ("#!/usr/bin/env bash":map makeEntry db) + where + makeEntry MockEntry{..} = printf template passName out err status + template = unlines + [ "pass_name='%s'" + , "if [ -z \"$pass_name\" -o \"$2\" = \"$pass_name\" ]; then" + , " echo -n '%s'" + , " >&2 echo '%s'" + , " exit %d" + , "fi" + ] diff --git a/test/unit/System/Taffybar/ContextSpec.hs b/test/unit/System/Taffybar/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/System/Taffybar/ContextSpec.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module System.Taffybar.ContextSpec + ( spec + -- * Utils + , runTaffyDefault + -- * Abstract Config + , GenSimpleConfig(..) + , toSimpleConfig + , GenWidget(..) + , toTaffyWidget + , GenSpace(..) + , GenCssPath(..) + , toCssPaths + , GenMonitorsAction(..) + , toMonitorsAction + ) where + +import Control.Monad.Trans.Reader (runReaderT) +import Data.Default (def) +import Data.Ratio ((%)) +import GHC.Generics (Generic) +import GI.Gtk (Widget) + +import Test.Hspec hiding (context) +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import System.Taffybar.Context +import System.Taffybar.SimpleConfig +import System.Taffybar.Widget.SimpleClock (textClockNewWith) +import System.Taffybar.Widget.Workspaces (workspacesNew) + +import System.Taffybar.Test.DBusSpec (withTestDBus) +import System.Taffybar.Test.UtilSpec (logSetup) +import System.Taffybar.Test.XvfbSpec (withXdummy, setDefaultDisplay_) + +spec :: Spec +spec = logSetup $ sequential $ aroundAll_ withTestDBus $ aroundAll_ (withXdummy . flip setDefaultDisplay_) $ do + describe "Fuzz tests" $ do + prop "eval generators" prop_genSimpleConfig + xprop "TaffybarConfig" prop_taffybarConfig + +------------------------------------------------------------------------ + +runTaffyDefault :: TaffyIO a -> IO a +runTaffyDefault f = buildContext def >>= runReaderT f + +------------------------------------------------------------------------ + +-- | Represents 'SimpleTaffyConfig' in a more abstract way, so that +-- it's easier to 'show', 'shrink', 'assert', etc. +data GenSimpleConfig = GenSimpleConfig + { monitors :: GenMonitorsAction + , size :: StrutSize + , padding :: GenSpace + , position :: Position + , spacing :: GenSpace + , start :: [GenWidget] + , center :: [GenWidget] + , end :: [GenWidget] + , css :: [GenCssPath] + } deriving (Show, Eq, Generic) + +-- | Build an actual taffy config from the abstract form. +toSimpleConfig :: GenSimpleConfig -> SimpleTaffyConfig +toSimpleConfig GenSimpleConfig{..} = SimpleTaffyConfig + { monitorsAction = toMonitorsAction monitors + , barHeight = size + , barPadding = unGenSpace padding + , barPosition = position + , widgetSpacing = unGenSpace spacing + , startWidgets = map toTaffyWidget start + , centerWidgets = map toTaffyWidget center + , endWidgets = map toTaffyWidget end + , cssPaths = toCssPaths css + , startupHook = pure () -- TODO: add something + } + +toTaffyWidget :: GenWidget -> TaffyIO Widget +toTaffyWidget = \case + WorkspacesWidget -> workspacesNew def + ClockWidget -> textClockNewWith def + +toCssPaths :: [GenCssPath] -> [FilePath] +toCssPaths = map (\p -> "fixme_" ++ show p ++ ".css") + +toMonitorsAction :: GenMonitorsAction -> TaffyIO [Int] +toMonitorsAction = \case + UsePrimaryMonitor -> usePrimaryMonitor + UseAllMonitors -> useAllMonitors + UseTheseMonitors xs -> pure xs + +instance Arbitrary GenSimpleConfig where + arbitrary = GenSimpleConfig <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + shrink = genericShrink + +instance Arbitrary StrutSize where + arbitrary = oneof + [ ExactSize . getSmall . getPositive <$> arbitrary + , ScreenRatio <$> elements [ 1 % 27, 1 % 50, 1 % 2 ] -- TODO: more arbitrary + ] + shrink (ExactSize s) = ExactSize . getPositive <$> shrink (Positive (fromIntegral s)) + shrink (ScreenRatio r) = ScreenRatio <$> shrink r + +instance Arbitrary Position where + arbitrary = arbitraryBoundedEnum + shrink Top = [] + shrink Bottom = [Top] + +newtype GenSpace = GenSpace { unGenSpace :: Int } + deriving (Show, Read, Eq, Generic) + +instance Arbitrary GenSpace where + arbitrary = GenSpace . getSmall . getPositive <$> arbitrary + shrink = genericShrink + +data GenWidget = WorkspacesWidget | ClockWidget + deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic) + +instance Arbitrary GenWidget where + arbitrary = arbitraryBoundedEnum + shrink = genericShrink + +data GenCssPath = RedStyle | BlueStyle | MissingCss | FaultyCss + deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic) + +instance Arbitrary GenCssPath where + arbitrary = arbitraryBoundedEnum + shrink = genericShrink + +data GenMonitorsAction = UsePrimaryMonitor + | UseAllMonitors + | UseTheseMonitors [Int] + deriving (Show, Read, Eq, Generic) + +instance Arbitrary GenMonitorsAction where + arbitrary = oneof + [ pure UsePrimaryMonitor + , pure UseAllMonitors + , wild ] + where + -- This could be a lot meaner. + wild = do + NonNegative (Small n) <- arbitrary + pure (UseTheseMonitors [0..n]) + shrink = genericShrink + +------------------------------------------------------------------------ + +prop_genSimpleConfig :: GenSimpleConfig -> Property +prop_genSimpleConfig cfg = checkCoverage $ + cover 25 (monitors cfg == UsePrimaryMonitor) "Primary monitor only" $ + cfg === cfg + +prop_taffybarConfig :: GenSimpleConfig -> Property +prop_taffybarConfig cfg = within 1_000_000 $ monadicIO $ + pure (cfg =/= cfg) + -- Some possible assertions: + -- startupHook executed exactly once + -- css rules are applied + -- css files later in list have precedence + -- missing css => exception + -- error in css => warning and continue + -- widgets are visible + -- spacing/height/position/padding are observed + -- appears on the correct monitor diff --git a/test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs b/test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleInstances #-} + +module System.Taffybar.Information.X11DesktopInfoSpec (spec) where + +import Test.Hspec hiding (context) + +import System.Taffybar.Test.XvfbSpec (withXdummy, xpropSet, XPropName(..), XPropValue(..)) +import System.Taffybar.Information.X11DesktopInfo + +spec :: Spec +spec = around withXdummy $ describe "withX11Context" $ do + it "trivial" $ \dn -> example $ + withX11Context dn (pure ()) `shouldReturn` () + + it "getPrimaryOutputNumber" $ \dn -> example $ + withX11Context dn getPrimaryOutputNumber `shouldReturn` Just 0 + + it "read property of root window" $ \dn -> do + xpropSet dn (XPropName "_XMONAD_VISIBLE_WORKSPACES") (XPropValue "hello") + ws <- withX11Context dn (readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES") + ws `shouldBe` ["hello"] + + it "send something" $ \dn -> do + withX11Context dn $ do + atom <- getAtom "iamanatom" + sendCommandEvent atom 42 diff --git a/test/unit/System/Taffybar/SimpleConfigSpec.hs b/test/unit/System/Taffybar/SimpleConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/System/Taffybar/SimpleConfigSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module System.Taffybar.SimpleConfigSpec (spec) where + +import Data.Maybe (maybeToList) + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import System.Taffybar.ContextSpec (runTaffyDefault) +import System.Taffybar.Test.XvfbSpec (RRSetup(..), RROutput(..), RROutputSettings(..), withXdummy, setDefaultDisplay_, withRandrSetup) + +import System.Taffybar.Information.X11DesktopInfo (DisplayName(..)) +import System.Taffybar.SimpleConfig + +spec :: Spec +spec = aroundAll_ (withXdummy . flip setDefaultDisplay_) $ do + -- Pending: Can't run properties without cleaning up buildContext + xprop "useAllMonitors" prop_useAllMonitors + xprop "usePrimaryMonitor" prop_usePrimaryMonitor + +prop_useAllMonitors :: RRSetup -> Property +prop_useAllMonitors rr = monadicIO $ do + allMonitors <- run $ withRandrSetup DefaultDisplay rr $ + runTaffyDefault useAllMonitors + + let rrOutputNumbers = [ i | (i, o) <- zip [0..] rr.outputs + , not o.settings.disabled ] + + pure $ allMonitors === rrOutputNumbers + +prop_usePrimaryMonitor :: RRSetup -> Property +prop_usePrimaryMonitor rr = monadicIO $ do + primaryMonitor <- run $ withRandrSetup DefaultDisplay rr $ + runTaffyDefault usePrimaryMonitor + + let rrPrimaryMonitor = fromIntegral <$> maybeToList rr.primary + + pure $ primaryMonitor === rrPrimaryMonitor diff --git a/test/unit/UnitSpec.hs b/test/unit/UnitSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/UnitSpec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=UnitSpec #-} diff --git a/test/unit/unit-tests.hs b/test/unit/unit-tests.hs new file mode 100644 --- /dev/null +++ b/test/unit/unit-tests.hs @@ -0,0 +1,12 @@ +module Main where + +import Test.Hspec +import Test.Hspec.Runner + +import qualified UnitSpec +import qualified TestLibSpec + +main :: IO () +main = hspecWith defaultConfig $ do + UnitSpec.spec + describe "testlib Sanity Checks" TestLibSpec.spec