taffybar 4.0.3 → 4.1.0
raw patch · 33 files changed
+2071/−357 lines, 33 filesdep +QuickCheckdep +attoparsecdep +extradep −broadcast-chandep −temporarydep ~basedep ~dbusdep ~gi-gtk
Dependencies added: QuickCheck, attoparsec, extra, fsnotify, typed-process, unliftio, unliftio-core
Dependencies removed: broadcast-chan, temporary
Dependency ranges changed: base, dbus, gi-gtk, transformers
Files
- CHANGELOG.md +26/−0
- doc/custom.md +10/−2
- doc/install.md +1/−1
- src/System/Taffybar.hs +119/−32
- src/System/Taffybar/Context.hs +2/−2
- src/System/Taffybar/Hooks.hs +5/−4
- src/System/Taffybar/Information/Battery.hs +9/−8
- src/System/Taffybar/Information/Chrome.hs +8/−6
- src/System/Taffybar/Information/Crypto.hs +5/−4
- src/System/Taffybar/Information/EWMHDesktopInfo.hs +1/−1
- src/System/Taffybar/Information/X11DesktopInfo.hs +76/−52
- src/System/Taffybar/SimpleConfig.hs +3/−2
- src/System/Taffybar/Util.hs +78/−8
- src/System/Taffybar/Widget/Battery.hs +1/−1
- src/System/Taffybar/Widget/FreedesktopNotifications.hs +5/−6
- src/System/Taffybar/Widget/Generic/ChannelGraph.hs +7/−7
- src/System/Taffybar/Widget/Generic/ChannelWidget.hs +7/−7
- src/System/Taffybar/Widget/Windows.hs +48/−12
- src/System/Taffybar/Widget/Workspaces.hs +3/−3
- taffybar.cabal +69/−21
- test/Spec.hs +0/−1
- test/System/Taffybar/AuthSpec.hs +0/−77
- test/System/Taffybar/SpecUtil.hs +0/−100
- test/lib/System/Taffybar/Test/DBusSpec.hs +293/−0
- test/lib/System/Taffybar/Test/UtilSpec.hs +341/−0
- test/lib/System/Taffybar/Test/XvfbSpec.hs +627/−0
- test/lib/TestLibSpec.hs +1/−0
- test/unit/System/Taffybar/AuthSpec.hs +74/−0
- test/unit/System/Taffybar/ContextSpec.hs +172/−0
- test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs +26/−0
- test/unit/System/Taffybar/SimpleConfigSpec.hs +41/−0
- test/unit/UnitSpec.hs +1/−0
- test/unit/unit-tests.hs +12/−0
CHANGELOG.md view
@@ -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
doc/custom.md view
@@ -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
doc/install.md view
@@ -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)
src/System/Taffybar.hs view
@@ -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"
src/System/Taffybar/Context.hs view
@@ -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
src/System/Taffybar/Hooks.hs view
@@ -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.
src/System/Taffybar/Information/Battery.hs view
@@ -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 =
src/System/Taffybar/Information/Chrome.hs view
@@ -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)
src/System/Taffybar/Information/Crypto.hs view
@@ -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 ()
src/System/Taffybar/Information/EWMHDesktopInfo.hs view
@@ -57,7 +57,7 @@ , parseWindowClasses , switchOneWorkspace , switchToWorkspace- , withDefaultCtx+ , withX11Context , withEWMHIcons ) where
src/System/Taffybar/Information/X11DesktopInfo.hs view
@@ -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
src/System/Taffybar/SimpleConfig.hs view
@@ -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)
src/System/Taffybar/Util.hs view
@@ -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
src/System/Taffybar/Widget/Battery.hs view
@@ -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
src/System/Taffybar/Widget/FreedesktopNotifications.hs view
@@ -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
src/System/Taffybar/Widget/Generic/ChannelGraph.hs view
@@ -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
src/System/Taffybar/Widget/Generic/ChannelWidget.hs view
@@ -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
src/System/Taffybar/Widget/Windows.hs view
@@ -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 ()
src/System/Taffybar/Widget/Workspaces.hs view
@@ -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
taffybar.cabal view
@@ -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
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− test/System/Taffybar/AuthSpec.hs
@@ -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"- ]
− test/System/Taffybar/SpecUtil.hs
@@ -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 "" (":" ++)
+ test/lib/System/Taffybar/Test/DBusSpec.hs view
@@ -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+ [ "<!DOCTYPE busconfig PUBLIC \"-//freedesktop//DTD D-Bus Bus Configuration 1.0//EN\" \"http://www.freedesktop.org/standards/dbus/1.0/busconfig.dtd\">"+ , "<busconfig>"+ , " <type>" ++ busName bus ++ "</type>"+ , " <keep_umask/>"+ , " <listen>" ++ addr ++ "</listen>"+ , " <servicedir>" ++ serviceDir ++ "</servicedir>"+ , " <policy context=\"default\">"+ , " <allow send_destination=\"*\" eavesdrop=\"true\"/>"+ , " <allow eavesdrop=\"true\"/>"+ , " <allow own=\"*\"/>"+ , " </policy>"+ , "</busconfig>"+ ]+ 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" }
+ test/lib/System/Taffybar/Test/UtilSpec.hs view
@@ -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"
+ test/lib/System/Taffybar/Test/XvfbSpec.hs view
@@ -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
+ test/lib/TestLibSpec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=TestLibSpec #-}
+ test/unit/System/Taffybar/AuthSpec.hs view
@@ -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"+ ]
+ test/unit/System/Taffybar/ContextSpec.hs view
@@ -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
+ test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs view
@@ -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
+ test/unit/System/Taffybar/SimpleConfigSpec.hs view
@@ -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
+ test/unit/UnitSpec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=UnitSpec #-}
+ test/unit/unit-tests.hs view
@@ -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