taffybar-4.1.1/0000755000000000000000000000000007346545000011504 5ustar0000000000000000taffybar-4.1.1/CHANGELOG.md0000644000000000000000000004515307346545000013325 0ustar0000000000000000# 4.1.1 ## Improvements * Add [`pollingLabelWithVariableDelayAndRefresh`][pollingLabelWithVariableDelayAndRefresh]. The [`WttrIn`][WttrIn] widget uses this. [pollingLabelWithVariableDelayAndRefresh]: https://hackage.haskell.org/package/taffybar-4.1.1/docs/System-Taffybar-Widget-Generic-PollingLabel.html#v:pollingLabelWithVariableDelayAndRefresh [WttrIn]: https://hackage.haskell.org/package/taffybar-4.1.1/docs/System-Taffybar-Widget-WttrIn.html ## Breaking Changes * Use version-named package build dependencies. Users building their configurations with Stack or Nix may need to do likewise. That is, change: - `gi-gtk` → `gi-gtk3` - `gi-gdk` → `gi-gdk3` - `gi-gdkx11` → `gi-gdkx113` * Taffybar is tested with GHC versions 9.8 and 9.10. Other versions may or may not work. # 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 * Taffybar is tested with GHC versions >= 9.2 && < 9.10. Other versions may or may not work. * The following symbols have been deprecated (not removed): - `System.Taffybar.SimpleConfig.toTaffyConfig` - Use [`toTaffybarConfig`][toTaffybarConfig] instead. - `System.Taffybar.Support.PagerHints` - Use the [`XMonad.Hooks.TaffybarPagerHints`][TaffybarPagerHints] module instead. - `System.Taffybar.Util`: * `liftReader` - Use [`Control.Monad.Trans.Reader.mapReaderT`][mapReaderT] instead. * `logPrintFDebug` - Use [`logPrintF`][logPrintF] instead. * `(??)` - Use `f <*> pure a` instead. * `runCommandFromPath` - Use [`runCommand`][runCommand] instead. [toTaffybarConfig]: https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-SimpleConfig.html#v:toTaffybarConfig [TaffybarPagerHints]: https://hackage.haskell.org/package/xmonad-contrib-0.18.1/docs/XMonad-Hooks-TaffybarPagerHints.html [mapReaderT]: https://hackage.haskell.org/package/transformers-0.6.1.0/docs/Control-Monad-Trans-Reader.html#v:mapReaderT [logPrintF]: https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-Util.html#v:logPrintF [runCommand]: https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-Util.html#v:runCommand ## Improvements * Revise and expand documentation. * Some code cleanups such as applying HLint suggestions, fixing compiler warnings, cleaning module imports. * The Nix code for `flake.nix` was streamlined, because upstream nixpkgs already contains the necessary derivation overrides. ## Bug Fixes * Fix handling of Ctrl-C. * Improve logging in [`System.Taffybar.Information.Battery`](https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-Information-Battery.html) and [`System.Taffybar.WindowIcon`](https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-WindowIcon.html). # 4.0.2 * Taffybar can now build with GHC 9.6. * Allow building with Scotty 0.22. * Drop unused `ConfigFile` dependency. # 4.0.1 ## Improvements * Taffybar can now build with GHC 9.4. * Adds a `flake.nix`. ## Bug Fixes * `Gtk.widgetShowAll` is run on the widget created by `cryptoPriceLabelWithIcon`, so that it shows up by default. * Fix misleading precision of rgba() parameters in `taffybar.css`. * Remove `cryptocurrency` Cabal flag, which is now unnecessary. # 4.0.0 ## Breaking Changes * `simpleTaffybar` now starts taffybar using `startTaffybar` instead of `dyreTaffybar`. Use `simpleDyreTaffybar` to start taffybar with `dyreTaffybar` as before. * The `cssPath` fields in 'SimpleTaffyConfig' and 'TaffybarConfig' have been renamed to `cssPaths` and have type `[FilePath]` instead of `Maybe Filepath`. * The module `System.Taffybar.Widget.Decorators` has been removed. The functions that were in that module can now be found in `System.Taffybar.Widget.Util`. * The `barHeight` property of `SimpleTaffyConfig` is now a `StrutSize`. This means that in addition to specifying an exact pixel count for the height of taffybar, it is also possible to specify a fraction of the screen that it should occupy. See the docs for `StrutSize` for more details. ## New Features * A new module `System.Taffybar.Widget.Crypto` that contains widgets that display the prices of crypto assets with icons was added. * `textBatteryNewLabelAction` provides a version of the text battery widget to which a custom label updater function can be provided. * The textual battery widget now applies classes according to its charge level that can be used to style the battery text with css. * A generalized interface to the text battery widget that accepts an arbitrary update function is available at `textBatteryNewLabelAction`. * New workspace widget builder `buildLabelOverlayController` that overlays the workspace label on top of the the workspace icons. * It is now possible to customize the player widgets of the MPRIS2 Widget by using the new function `mpris2NewWithConfig`. * Classes are added to the MPRIS2 Widget to indicate whether or not it has visible player children. * The default MPRIS2 player widget now sends the play pause message to the relevant player when clicked. * New `pollingGraphNewWithTooltip` that allows to specify a tooltip. * New `networkGraphNewWith` that allows to configure a tooltip format, scaling and network interfaces via function. * New `showMemoryInfo` exposed from `MemoryMonitor` that can be used to format tooltips. * Swap variables are added to `MemoryMonitor`. * Many types have `Default` instances. * Window titles are shown on hover. * Allow sorting workspace window icons by _NET_CLIENT_LIST_STACKING. ## Changes * Graph labels are now overlayed on top of the graph instead of placed beside them. * MPRIS2 Widgets will remain visible when their players are in the paused state. * `getSongInfo` now doesn't automatically return `Nothing` when `xesam:artist` is missing. This makes the MPRIS2 Widget display in more situations than before. * Network graph will have a tooltip by default. * The SNI Tray will respect `ItemIsMenu` property to handle mouse left click. ## Bug Fixes * Center widgets will now properly expand vertically. * Errors, including icon missing from theme errors, in workspace pixbuf getters are now handled gracefully. * A workaround to properly display the chrome icon in MPRIS was added. # 3.3.0 ## Bug Fixes * Compatibility with newer versions of GHC. ## New Features * A wttr.in widget was added. * Make memoryAvailable action available inside the Text MemoryMonitor widget. * The SNI Tray supports triggering Activate and SecondaryActivate on icons. * Better formatting for Text MemoryMonitor Widget # 3.2.2 ## Bug Fixes * Solve space leaks on `updateSamples` and `getDeviceUpDown` (#472). * Prevent crash when using mpris2New and librsvg is not available (#478). * Fixed compilation issues that appear when using ghc 8.8. # 3.2.1 ## Bug Fixes * The workspaces widget now listens on the additional EWMH properties that it needs to in order to properly update things when the active window changes. This problem likely only emerged recently because xmonad has recently become much more conservative about emitting change events (#454). * The workspaces widget listens for changes to window geometry (similar to above) (#456). # 3.2.0 ## New Features * The Layout widget can now be styled with the css class "layout-label". * A new polling label function `pollingLabelWithVariableDelay` that allows for variable poll times was added. * A new widget `System.Taffybar.Widget.SimpleCommandButton` was added. * Taffybar now outputs colorized and annotated logs by default. ## Breaking Changes * The file specified in the cssPath parameter in config is now used instead of, rather than in addition to the default user config file. * All parameters are now passed to `textClockNewWith` as part of the ClockConfig it receives. A new mechanism for rounded variable polling should allow the clock to always remain accurate (to the precision selected by the user) without having a very high polling rate, thus reducing CPU usage. * The polling label functions no longer accept a default text parameter. ## Miscellaneous * Battery updates are only triggered when a more limited number of UPower properties are changed. This can be customized by manually calling `setupDisplayBatteryChanVar` as a hook. ## Bug Fixes * Calendar pops up below bar without hiding any other widget #261. * Avoid failing when parsing XDG Desktop files with unrecognized application type, which previously resulted in "Prelude.read: no parse" #447. * Use XDG data dir so that taffybar dbus toggling functions correctly when taffybar is installed in a location that is not writable by the user. This is the case with nix when it is installed in the nix store #452. # 3.1.2 ## Updates * Weather now uses new uris and https (Kirill Zaborsky) * Bump the version of gi-gdkpixbuf, this fixes nixpkgs compilation # 3.1.0 ## New Features * A new module Chrome which makes it so that Workspaces can display the favicons of the website that the chrome window is currently visiting. # 3.0.0 ## Breaking Changes * Taffybar has replaced gtk2hs with gi-gtk everywhere. All widgets must now be created with gi-gtk. # 2.0.0 ## Breaking Changes * An entirely new config system has been put in place. TaffybarConfig now lives in System.Taffybar.Context, but for most users, System.Taffybar.SimpleConfig is the configuration interface that should be used. * The main entry point to taffybar is now dyreTaffybar instead of defaultTaffybar. * All widget constructors provided to both config systems must now be of type `TaffyIO Gtk.Widget`. If you have an existing `IO Gtk.Widget` you can convert it using liftIO. All widgets provided by taffybar are now of type `MonadIO m => m Gtk.Widget`, or specialized to `TaffyIO Gtk.Widgets`. * The `graphBackgroundColor` and `graphBorderColor` fields are now RGBA quadruples instead of RGB triples. * Module removals: - WorkspaceSwitcher: Workspaces is much more abstract and makes this widget redundant. - Pager: The Context module solves the problem that Pager solved in a much more general way. It also makes it so that the user doesn't even need to know about the Pager component at all. - TaffyPager: Since you no longer need to explicitly initialize a Pager, it's not really very hard to simply add the (Workspaces, Layout, Windows) triple to your config any more. - XMonadLog: This module has long been deprecated * Module moves: - Everything in System.Information has been moved to System.Information.Taffybar - All Widgets that were found in System.Taffybar have been moved to System.Taffybar.Widget - The helper widgets that were previously located in System.Taffybar.Widgets have been moved to System.Taffybar.Widget.Generic * Module renames: - WorkspaceHUD -> Workspaces - WindowSwitcher -> Windows - LayoutSwitcher -> Layout - ToggleMonitors -> DBus.Toggle * Module deprecations: - System.Taffybar.Widget.Systray (Use SNITray instead) - System.Taffybar.Widget.NetMonitor (Use System.Taffybar.Widget.Text.NetworkMonitor instead) * Many widgets have subtle interface changes that may break existing configurations. ## New Features * Widgets can now be placed in the center of taffybar with the `centerWidgets` configuration parameter. * taffybar is now transparent by default, but you will need to use a compositor for transparency to work. https://github.com/chjj/compton is recommended. If you do not want a transparent taffybar set a background color on the class `TaffyBox` in taffybar.css. * StatusNotifierItem support has been added to taffybar in the SNITray module. * Monitor configuration changes are handled automatically. Unfortunately the bar must be completely recreated when this happens. * New network monitor widgets `System.Taffybar.Widget.Text.NetworkMonitor` and `System.Taffybar.Widget.NetworkGraph` were added. * All widgets are now exported in `System.Taffybar.Widget`, which should eliminate the need to import widgets explicitly. # 1.0.2 ## Bug Fixes * Fix long standing memory leak that was caused by a failure to free memory allocated for gtk pixbufs. * Widgets unregister from X11 event listening. # 1.0.0 ## Breaking Changes * Migrate from Gtk2 to Gtk3, which replaces rc theming with css theming (Ivan Malison) ## New Features * Support for taffybar on multiple monitors (Ivan Malison) * D-Bus toggling of taffybar per monitor (Ivan Malison) * A new workspace switcher widget called WorkspaceHUD (Ivan Malison) * Support for multiple batteries via ``batteryContextsNew`` (Edd Steel) * Add support for IO actions to configure vertical bar widgets * Images in WorkspaceSwitcher - images are taken from EWMH via \_NET\_WM_ICON (Elliot Wolk) * Preliminary support for i3wm (Saksham Sharma) * Support for multiple network interfaces in NetMonitor (Robert Klotzner) * Add a pager config field that configures the construction of window switcher titles (Ivan Malison) * Quick start script for installing from git with stack (Ivan Malison) * Add a volume widget (Nick Hu and Abdul Sattar) * Add available memory field to MemoryInfo (Will Price) * The freedesktop.org notifications widget now allows for notifications to never expire and can handle multiple notifications at once. In particular the default formatter now shows the number of pending notifications (Daniel Oliveira) * Battery bar is more informative (Samshak Sharma) * Network monitor speeds are auto formatted to use the most appropriate units (TeXitoi) * A new freedesktop.org menu widget (u11gh) ...and many smaller tweaks. ## Bug Fixes * Fixes for outdated weather information sources * Various styling fixes in the gtkrc code * Share a single X11Connection between all components to fix the `user error (openDisplay)` error (Ivan Malison) * Call initThreads at startup. This fixes ```taffybar-linux-x86_64: xcb_io.c:259: poll_for_event: Assertion `!xcb_xlib_threads_sequence_lost' failed.``` (Ivan Malison) * Add an eventBox to window switcher to allow setting its background (Ivan Malison) * #105 Prevent taffybar from crashing when two windows are closed simultaneously, or when taffybar otherwise requests data about a window that no longer exists. # 0.4.6 * Fix a longstanding bug in loading .rc files (Peder Stray) * Add support for scrolling in the workspace switcher (Saksham Sharma) * Improve default formatting of empty workspaces in the pager (Saksham Sharma) * Relax gtk version bounds # 0.4.5 * GHC 7.10 compat # 0.4.4 * Fix compilation with gtk 0.13.1 # 0.4.3 * Try again to fix the network dependency # 0.4.2 * Expand the version range for time * Depend on network-uri instead of network # 0.4.1 * Make the clock react to time zone changes # 0.4.0 ## Features * Resize the bar when the screen configuration changes (Robert Helgesson) * Support bypassing `dyre` by exposing `taffybarMain` (Christian Hoener zu Siederdissen) * Textual CPU and memory monitors (Zakhar Voit) * A new window switcher menu in the pager (José Alfredo Romero L) * Dynamic workspace support in the workspace switcher (Nick Hu) * More configurable network monitor (Arseniy Seroka) * New widget: text-based command runner (Arseniy Seroka) * The Graph widget supports lines graphs (via graphDataStyles) (Joachim Breitner) * Compile with gtk2hs 0.13 ## Bug Fixes * Reduce wakeups by tweaking the default GHC RTS options (Joachim Breitner) * UTF8 fixes (Nathan Maxson) * Various fixes to EWMH support (José Alfredo Romero L) ## Deprecations The `XMonadLog` module is deprecated. This module let taffybar display XMonad desktop information through a dbus connection. The EWMH desktop support by José Alfredo Romero L is better in every way, so that (through TaffyPager) is the recommended replacement. Upgrading should be straightforward. # 0.3.0: * A new pager (System.Taffybar.TaffyPager) from José A. Romero L. This pager is a drop-in replacement for the dbus-based XMonadLog widget. It communicates via X atoms and EWMH like a real pager. It even supports changing workspaces by clicking on them. I recommend this over the old widget. * Added an MPRIS2 widget (contributed by Igor Babuschkin) * Ported to use the newer merged dbus library instead of dbus-client/dbus-core (contributed by CJ van den Berg) * Finally have the calendar widget pop up over the date/time widget (contributed by José A. Romero) * GHC 7.6 compatibility * Vertical bars can now have dynamic background colors (suggested by Elliot Wolk) * Bug fixes # 0.2.1: * More robust strut handling for multiple monitors of different sizes (contributed by Morgan Gibson) * New widgets from José A. Romero (network monitor, fs monitor, another CPU monitor) * Allow the bar widget to grow vertically (also contributed by José A. Romero) # 0.2.0: * Add some more flexible formatting options for the XMonadLog widget (contributed by cnervi). * Make the PollingLabel more robust with an exception handler for IOExceptions * Added more documentation for a few widgets # 0.1.3: * Depend on gtk 0.12.1+ to be able to build under ghc 7.2 * Fix the background colors in the calendar so that it follows the GTK theme instead of the bar-specific color settings * Fix the display of non-ASCII window titles in the XMonad log applet (assuming you use the dbusLog function) * Add a horrible hack to force the bar to not resize to be larger than the screen due to notifications or long window titles # 0.1.2: * Readable widget for freedesktop notifications * Fixed a few potential deadlocks on startup * Use the GTK+ rc-file styling system for colors instead of hard coding them taffybar-4.1.1/LICENSE0000644000000000000000000000301507346545000012510 0ustar0000000000000000Copyright (c) (2011-2019), Tristan Ravitch, Ivan Malison All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Tristan Ravitch nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. taffybar-4.1.1/README.md0000644000000000000000000001020507346545000012761 0ustar0000000000000000# Taffybar [![Build Status](https://github.com/taffybar/taffybar/actions/workflows/nix.yml/badge.svg)](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [![Hackage](https://img.shields.io/hackage/v/taffybar.svg?logo=haskell&label=taffybar)](https://hackage.haskell.org/package/taffybar) [![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) [![Stackage LTS](http://stackage.org/package/taffybar/badge/lts)](http://stackage.org/lts/package/taffybar) [![Stackage Nightly](http://stackage.org/package/taffybar/badge/nightly)](http://stackage.org/nightly/package/taffybar) [![Matrix Chat](https://img.shields.io/matrix/taffybar:matrix.org)](https://matrix.to/#/#taffybar:matrix.org) [![Gitter Chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) [![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) ## Summary Taffybar is a desktop information bar, intended primarily for use with [XMonad][], though it can also function alongside other EWMH compliant window managers. It is similar in spirit to [xmobar][], but it differs in that it gives up some simplicity for a reasonable helping of [GTK 3][] eye candy. [![Screenshot](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png)](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png) [GTK 3]: https://www.gtk.org/ [XMonad]: https://xmonad.org/ [dwm]: https://dwm.suckless.org/ [xmobar]: https://codeberg.org/xmobar/xmobar [gi-gtk]: https://hackage.haskell.org/package/gi-gtk [Haskell]: https://www.haskell.org/ [GHC]: https://www.haskell.org/ghc/ ## Taffybar is a library As with window managers like [XMonad][] and [dwm][], Taffybar is most appropriately described as a library that allows you to build an executable that is customized to your tastes. Like [xmobar][] and [XMonad][], Taffybar is configured in [Haskell][]. Taffybar has a reasonably useful default configuration built in. To use a different configuration, however, you must install a Haskell compiler ([GHC][]) that can compile your [`taffybar.hs`](https://github.com/taffybar/taffybar/blob/master/example/taffybar.hs) source file. You then select from [the list of available widgets][widgets] for functionality to add to your Taffybar. If the widget you need doesn't exist, then create your own with GTK. [widgets]: http://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget.html ## Documentation * [**Installation**][install] Taffybar can be installed from Linux distribution packages, or compiled from source. * [**Configuration** (and compilation)][config] Taffybar can recompile itself from `taffybar.hs`, similar to how [XMonad][] recompiles itself from `xmonad.hs`. There are a number of ways to compile your configuration. * [**Customization**][custom] Taffybar has a library of functions and widgets for collecting and displaying information. Many aspects of the bar's appearance can be changed using CSS. * [**Running**][run] Taffybar is one component of a desktop environment. To work correctly, it requires other desktop components and system services. * [**FAQ**][faq] Assorted information. * [**Contributing**][contrib] [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) [![Easy Issues](https://img.shields.io/github/issues/taffybar/taffybar/easy.svg)](https://github.com/taffybar/taffybar/labels/easy) Taffybar desperately needs contributors. There is plenty to do; enquire within. [install]: https://github.com/taffybar/taffybar/blob/master/doc/install.md [config]: https://github.com/taffybar/taffybar/blob/master/doc/config.md [custom]: https://github.com/taffybar/taffybar/blob/master/doc/custom.md [run]: https://github.com/taffybar/taffybar/blob/master/doc/run.md [faq]: https://github.com/taffybar/taffybar/blob/master/doc/faq.md [contrib]: https://github.com/taffybar/taffybar/blob/master/doc/contrib.md taffybar-4.1.1/app/0000755000000000000000000000000007346545000012264 5ustar0000000000000000taffybar-4.1.1/app/Main.hs0000644000000000000000000000311707346545000013506 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | This is just a stub executable that uses dyre to read the config file and -- recompile itself. module Main ( main ) where import Data.Default (def) import Data.Semigroup ((<>)) import Data.Version import Options.Applicative import System.Directory import System.Log.Logger import System.Taffybar import System.Taffybar.Context import System.Taffybar.Example import Text.Printf import Paths_taffybar (version) logP :: Parser Priority logP = option auto ( long "log-level" <> short 'l' <> help "Set the log level" <> metavar "LEVEL" <> value WARNING ) versionOption :: Parser (a -> a) versionOption = infoOption (printf "taffybar %s" $ showVersion version) ( long "version" <> help "Show the version number of taffybar" ) main :: IO () main = do logLevel <- execParser $ info (helper <*> versionOption <*> logP) ( fullDesc <> progDesc "Start taffybar, recompiling if necessary" ) logger <- getLogger "System.Taffybar" saveGlobalLogger $ setLevel logLevel logger taffyFilepath <- getTaffyFile "taffybar.hs" configurationExists <- doesFileExist taffyFilepath if configurationExists -- XXX: The configuration record here does not get used, this just calls in to dyre. then dyreTaffybar def else do logM "System.Taffybar" WARNING ( printf "No taffybar configuration file found at %s." taffyFilepath ++ " Starting with example configuration." ) startTaffybar exampleTaffybarConfig taffybar-4.1.1/dbus-xml/0000755000000000000000000000000007346545000013237 5ustar0000000000000000taffybar-4.1.1/dbus-xml/org.freedesktop.UPower.Device.xml0000644000000000000000000000450307346545000021502 0ustar0000000000000000 taffybar-4.1.1/dbus-xml/org.freedesktop.UPower.xml0000644000000000000000000000173507346545000020310 0ustar0000000000000000 taffybar-4.1.1/dbus-xml/org.mpris.MediaPlayer2.Player.xml0000644000000000000000000000217307346545000021414 0ustar0000000000000000 taffybar-4.1.1/dbus-xml/org.mpris.MediaPlayer2.xml0000644000000000000000000000053607346545000020162 0ustar0000000000000000 taffybar-4.1.1/doc/0000755000000000000000000000000007346545000012251 5ustar0000000000000000taffybar-4.1.1/doc/config.md0000644000000000000000000001142007346545000014036 0ustar0000000000000000# Configuration (and compilation) [dyre]: https://github.com/willdonnelly/dyre There are broadly three ways of building your configuration: 1. [Install](./install.md) Taffybar, use the default configuration (i.e. absent `taffybar.hs`) and don't compile anything yourself. 2. Let [Dyre][] handle compilation of `taffybar.hs`. 3. Compile your Taffybar executable some other way. Typically this would be done with the "Project Approach" (see below). ## Before installing Taffybar's [installation procedure](./install.md) varies depending your chosen option. For example, it's not always necessary to install the `taffybar` executable globally using a distro package or `cabal install taffybar`. Read this section so you can understand what all of that means before you decide how you want to install Taffybar. ## Comparison | | **Dyre** | **Not Dyre** | | ------------------------ | -------- | ------------- | | Config file location | `$XDG_CONFIG_HOME/taffybar/taffybar.hs` | Anywhere | | Automatic reloading | Yes | No | | Multiple modules | No | Yes | | Boilerplate code/config | Little | Some | | Entry point | [`dyreTaffybar`][dyreTaffybar] | [`startTaffybar`][startTaffybar] | | Installation environment | Global | Project-local | [dyreTaffybar]: https://hackage.haskell.org/package/taffybar-4.0.2/docs/System-Taffybar.html#v:dyreTaffybar [startTaffybar]: https://hackage.haskell.org/package/taffybar-4.0.2/docs/System-Taffybar.html#v:startTaffybar ## Entry point ### `dyreTaffybar` (Dyre) Dyre simply calls `ghc` directly to compile the config file. Any Haskell packages used by the config (e.g. `taffybar`, `xmonad-contrib`) must be installed and available to `ghc-pkg`. Usually this means with a global Haskell installation. The [`dyreTaffybar`][dyreTaffybar] entry point to Taffybar uses the [Dyre library][dyre] to automatically recompile your configuration whenever it detects that it has changed. The binary that is distributed with Taffybar does nothing more than call this entry point. The main downside of this approach is that it does not allow the user to use any sort of project files for their configuration, and they must have any packages that are necessary for compilation of their configuration available in their global ghc environment. ### `startTaffybar` (not Dyre) Not using Dyre, you can compile your Taffybar configuration the same way you compile other Haskell projects that you work on. The user binary will _not_ be automatically recompiled when source files change. The [`startTaffybar`][startTaffybar] entry point simply starts Taffybar with the given configuration. The advantage of using `startTaffybar` directly is that you can use that in the `main` function of a Cabal project. ## The Project Approach The "project approach" to configuring and installing Taffybar involves maintaining a small Haskell project that produces the `taffybar` binary. With this approach, you can build your Taffybar using proper build tools rather than just `ghc -o taffybar taffybar.hs ...`, which is essentially what [Dyre][] uses. The "Main" disadvantage of Dyre is that you can't easily split your configuration into multiple modules. It is recommended that you use [this example `my-taffybar.cabal`][example-cabal] as a template. In that example, the user's configuration resides in the file `taffybar.hs` within the same directory, but that can be changed as needed. [example-cabal]: https://github.com/taffybar/taffybar/blob/master/example/my-taffybar.cabal ### Main Example: [Main](https://github.com/taffybar/taffybar/blob/master/example/taffybar.hs) The `Main` module and any other module(s) listed in the `.cabal` file are therefore your configuration. Your `main` function needs to call the `startTaffybar` entrypoint with a `TaffybarConfig` value. See [Customization](./custom.md) for further information. ### Build tool examples Use your chosen build tool to compile the `taffybar` executable of your configuration. The build tool can then install `taffybar` to a system location such as `/usr/local/bin`. #### Cabal Example: [`my-taffybar.cabal`][example-cabal] Run `cabal install` within the project to install the executable. #### Stack Example: [`stack.yaml`](https://github.com/taffybar/taffybar/blob/master/example/stack.yaml) With Stack, you will also need to maintain a `stack.yaml` file in addition to the `.cabal` file. When choosing a "resolver" for `stack.yaml`, the latest [LTS Haskell](https://www.stackage.org/lts) is usually a good choice. Run `stack install` within the project to install the executable. #### Nix Example derivation: [`default.nix`](https://github.com/taffybar/taffybar/blob/master/example/default.nix). This could be installed into your Nix user environment with `nix-env -i -f default.nix`. taffybar-4.1.1/doc/contrib.md0000644000000000000000000000047007346545000014234 0ustar0000000000000000# Contributing If you want to help, but don't know where to get started you can check out these issue labels: - [Help Wanted](https://github.com/taffybar/taffybar/labels/help%20wanted) - [Easy](https://github.com/taffybar/taffybar/labels/easy) taffybar-4.1.1/doc/custom.md0000644000000000000000000000551107346545000014107 0ustar0000000000000000# Customization For details about the library modules for configuring your Taffybar, see the [full documentation][hackage]. [hackage]: https://hackage.haskell.org/package/taffybar [gi-gtk]: https://hackage.haskell.org/package/gi-gtk - [`taffybar` package documentation][hackage] - `System.Taffybar` - [`gi-gtk` package documentation][gi-gtk] - `GI.Gtk` ## Config file location Taffybar uses the directory `$XDG_CONFIG_HOME/taffybar/`. As per the [XDG Base Directory Specification][basedir-spec], an unset or empty `XDG_CONFIG_HOME` environment variable is taken to mean `~/.config`. [basedir-spec]: https://specifications.freedesktop.org/basedir-spec/latest/#variables ## `TaffybarConfig` Be aware that the `TaffybarConfig` value required by `dyreTaffybar`/`startTaffybar` is normally constructed via a [`SimpleConfig`](https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-SimpleConfig.html#t:SimpleTaffyConfig) value and [`toTaffybarConfig`](https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-SimpleConfig.html#v:toTaffybarConfig). ## CSS [#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`. ### GTK Documentation CSS styling is a feature of GTK. It uses a limited version of CSS, so the following articles from the GTK documentation are useful: - [CSS in GTK](https://docs.gtk.org/gtk3/css-overview.html) - [GTK CSS Properties](https://docs.gtk.org/gtk3/css-properties.html) ### GTK Inspector Run Taffybar with the environment variable `GTK_DEBUG=interactive` to enable the [GTK Inspector][inspector]. This will let you figure out CSS class names of widgets. The GTK Inspector also lets you 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 Note that the first three parameters of `rgba()` are integers in the range 0—255, but the fourth is a float in the range 0.0—1.0. For example: ```css .taffy-box { background-color: rgba(255, 250, 205, 0.3); } ``` ### Adding CSS classes to Taffybar widgets Use [`System.Taffybar.Util.widgetSetClassGI`][widgetSetClassGI] to add a CSS class to a widget in your Taffybar config. This can be used for example to apply different styling to widgets of the same type. [widgetSetClassGI]: https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget-Util.html#v:widgetSetClassGI taffybar-4.1.1/doc/faq.md0000644000000000000000000000037607346545000013350 0ustar0000000000000000# FAQ For the time being, Taffybar's frequently asked questions page lives in [issue #332 - Add a FAQ section to README/Docs/Wiki](https://github.com/taffybar/taffybar/issues/332). Some of this information is collected in [Running Taffybar](./run.md). taffybar-4.1.1/doc/index.md0000644000000000000000000001020507346545000013700 0ustar0000000000000000# Taffybar [![Build Status](https://github.com/taffybar/taffybar/actions/workflows/nix.yml/badge.svg)](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [![Hackage](https://img.shields.io/hackage/v/taffybar.svg?logo=haskell&label=taffybar)](https://hackage.haskell.org/package/taffybar) [![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) [![Stackage LTS](http://stackage.org/package/taffybar/badge/lts)](http://stackage.org/lts/package/taffybar) [![Stackage Nightly](http://stackage.org/package/taffybar/badge/nightly)](http://stackage.org/nightly/package/taffybar) [![Matrix Chat](https://img.shields.io/matrix/taffybar:matrix.org)](https://matrix.to/#/#taffybar:matrix.org) [![Gitter Chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) [![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) ## Summary Taffybar is a desktop information bar, intended primarily for use with [XMonad][], though it can also function alongside other EWMH compliant window managers. It is similar in spirit to [xmobar][], but it differs in that it gives up some simplicity for a reasonable helping of [GTK 3][] eye candy. [![Screenshot](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png)](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png) [GTK 3]: https://www.gtk.org/ [XMonad]: https://xmonad.org/ [dwm]: https://dwm.suckless.org/ [xmobar]: https://codeberg.org/xmobar/xmobar [gi-gtk]: https://hackage.haskell.org/package/gi-gtk [Haskell]: https://www.haskell.org/ [GHC]: https://www.haskell.org/ghc/ ## Taffybar is a library As with window managers like [XMonad][] and [dwm][], Taffybar is most appropriately described as a library that allows you to build an executable that is customized to your tastes. Like [xmobar][] and [XMonad][], Taffybar is configured in [Haskell][]. Taffybar has a reasonably useful default configuration built in. To use a different configuration, however, you must install a Haskell compiler ([GHC][]) that can compile your [`taffybar.hs`](https://github.com/taffybar/taffybar/blob/master/example/taffybar.hs) source file. You then select from [the list of available widgets][widgets] for functionality to add to your Taffybar. If the widget you need doesn't exist, then create your own with GTK. [widgets]: http://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget.html ## Documentation * [**Installation**][install] Taffybar can be installed from Linux distribution packages, or compiled from source. * [**Configuration** (and compilation)][config] Taffybar can recompile itself from `taffybar.hs`, similar to how [XMonad][] recompiles itself from `xmonad.hs`. There are a number of ways to compile your configuration. * [**Customization**][custom] Taffybar has a library of functions and widgets for collecting and displaying information. Many aspects of the bar's appearance can be changed using CSS. * [**Running**][run] Taffybar is one component of a desktop environment. To work correctly, it requires other desktop components and system services. * [**FAQ**][faq] Assorted information. * [**Contributing**][contrib] [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) [![Easy Issues](https://img.shields.io/github/issues/taffybar/taffybar/easy.svg)](https://github.com/taffybar/taffybar/labels/easy) Taffybar desperately needs contributors. There is plenty to do; enquire within. [install]: https://github.com/taffybar/taffybar/blob/master/doc/install.md [config]: https://github.com/taffybar/taffybar/blob/master/doc/config.md [custom]: https://github.com/taffybar/taffybar/blob/master/doc/custom.md [run]: https://github.com/taffybar/taffybar/blob/master/doc/run.md [faq]: https://github.com/taffybar/taffybar/blob/master/doc/faq.md [contrib]: https://github.com/taffybar/taffybar/blob/master/doc/contrib.md taffybar-4.1.1/doc/install.md0000644000000000000000000000617107346545000014246 0ustar0000000000000000# Installation - [#535 - Fix up README](https://github.com/taffybar/taffybar/issues/535) ## Distribution Packaging Several Linux distributions package Taffybar: - [NixOS (nixpkgs)](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix) - [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) Of these, only the NixOS distribution is officially supported by the maintainers. Using any of the others would be pretty similar to using a bare Cabal installation of Taffybar. ### NixOS Package If you wish to use the NixOS package, make sure that you are using the top-level [`pkgs.taffybar`](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix) and not simply `pkgs.haskellPackages.taffybar`. The top-level package (`pkgs.taffybar`) provides an environment for Dyre containing `ghc` and libraries for compiling the configuration. If you need to add additional Haskell dependencies, then override the `packages` parameter. For example: ```nix pkgs.taffybar.override { packages = hp: [ hp.xmonad-contrib hp.dbus ]; } ``` It is also possible to use Taffybar on NixOS without using this module, for example by using `pkgs.haskellPackages.taffybar` as a library in another package (see [Configuration (and compilation)](./config.md)). ### Debian/Ubuntu On Debian/Ubuntu the `taffybar` package contains the executable only. Install the `libghc-taffybar-dev` package to get the `System.Taffybar` Haskell library. The development package `libghc-taffybar-dev` should also pull in the GHC compiler and other system dependencies such as the `libgtk-3-dev` package. Therefore it is useful to have, even if you intend to install Taffybar from source and not use distribution binaries. # Installation from source ## Prerequisites If not using a distribution package of Taffybar which handles getting all the necessary development libraries for you, then you will need to install all of Taffybar's non-Haskell dependencies manually. ### System Dependencies Start by making sure you have installed everything that is needed for [haskell-gi](https://github.com/haskell-gi/haskell-gi). Taffybar also needs the equivalent of [`libdbusmenu-gtk3-dev`](https://packages.debian.org/sid/libdbusmenu-gtk3-dev) and [`libgirepository1.0-dev`](https://packages.debian.org/sid/libgirepository-1.0-dev) on Debian. You can also get some idea of what the necessary dependencies are by looking at the `nix` section of the [`stack.yaml`](https://github.com/taffybar/taffybar/blob/master/stack.yaml) file in the Taffybar repository. ### Haskell Compiler For the greatest chance of success, use one of the GHC versions listed in [`taffybar.cabal` (tested-with)](https://github.com/taffybar/taffybar/blob/master/taffybar.cabal). Currently, GHC 9.6 is a good choice. ## Cabal Once the prerequisites are in place, Cabal installation is a simple matter of installing [Taffybar from Hackage](https://hackage.haskell.org/package/taffybar): ``` cabal install taffybar ``` taffybar-4.1.1/doc/run.md0000644000000000000000000001432607346545000013405 0ustar0000000000000000# Running Taffybar Being a desktop component, Taffybar has various runtime dependencies, depending on your configuration. ## X11 Compisitor Run an X11 compositor such as [Picom][] for transparency and rounded window corners. This is optional and Taffybar looks fine without these features. [Picom]: https://picom.app/ ## XMonad Example: [`xmonad.hs`](https://github.com/taffybar/taffybar/blob/master/example/xmonad.hs) Your XMonad configuration should have: 1. [`XMonad.Hooks.ManageDocks.docks`][ManageDocks] - so that Taffybar windows are managed like docks 2. [`XMonad.Hooks.ManageDocks.avoidStruts`][ManageDocks] - so that other windows don't cover Taffybar. 1. [`XMonad.Hooks.EwmhDesktops.ewmh`][EwmhDesktops] - so that Taffybar knows about workspaces and windows managed by XMonad. 2. [`XMonad.Hooks.TaffybarPagerHints.pagerHints`][TaffybarPagerHints] - so that Taffybar knows about the current layout used by XMonad, and which workspaces are visible. [ManageDocks]: https://hackage.haskell.org/package/xmonad-contrib/docs/XMonad-Hooks-ManageDocks.html [EwmhDesktops]: https://hackage.haskell.org/package/xmonad-contrib/docs/XMonad-Hooks-EwmhDesktops.html [TaffybarPagerHints]: https://hackage.haskell.org/package/xmonad-contrib/docs/XMonad-Hooks-TaffybarPagerHints.html ## D-Bus Taffybar connects to both the system bus and session bus. These days it would be a rare Linux system which doesn't have a working D-Bus _system bus_. However there can sometimes be problems configuring the per-user _session bus_. Ensure that: 1. The D-Bus session bus (i.e. `dbus-daemon` or `dbus-broker`) is running for the user, or is able to be socket-activated. If you are using `gnome-session` then D-Bus is guaranteed to be running. 2. The `taffybar` process has the `DBUS_SESSION_BUS_ADDRESS` environment variable set correctly. It can happen that Taffybar doesn't have `DBUS_SESSION_BUS_ADDRESS` if it is started from an `xsession` script before `dbus-launch`. Or it can happen if Taffybar is running as a `systemd --user` service, and the service gets started before `DBUS_SESSION_BUS_ADDRESS` is imported into the systemd manager environment. ## Battery Status [UPower][] is required for [`System.Taffybar.Information.Battery`][Battery]. To test that it's running and working, run: ``` $ upower -i /org/freedesktop/UPower/devices/DisplayDevice power supply: yes updated: Sun 13 Oct 2024 09:13:24 (35002 seconds ago) has history: no has statistics: no battery present: yes state: fully-charged warning-level: none energy: 49.9776 Wh energy-full: 49.9776 Wh energy-rate: 0.0076 W charge-cycles: N/A percentage: 100% icon-name: 'battery-full-charged-symbolic' ``` ### Incorrect battery state? If the battery icon is not updating or the battery state is not reported correctly (e.g. [issue #330](https://github.com/taffybar/taffybar/issues/330), you could try a workaround: 1. Run UPower with the `--debug` option added. 2. Apply [`System.Taffybar.Hooks.withBatteryRefresh`][withBatteryRefresh] to your `TaffybarConfig`. [Battery]: https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Information-Battery.html [withBatteryRefresh]: https://hackage.haskell.org/package/taffybar-4.0.2/docs/System-Taffybar-Hooks.html#v:withBatteryRefresh [UPower]: https://upower.freedesktop.org/ ## System Tray Run [`status-notifier-watcher`](https://github.com/taffybar/status-notifier-item) to track registration/deregistration of [StatusNotifierItem (SNI)][sni] tray icons. This is an implementation of the StatusNotifierWatcher interface which runs separately to Taffybar, so that tray icons can survive restarts of Taffybar. [`System.Taffybar.Widget.SNITray.sniTrayNew`][SNITray] uses D-Bus to ask StatusNotifierWatcher for the list of tray icons. Therefore, if using [SNITray][], ensure that `status-notifier-watcher` is started before Taffybar. [sni]: https://www.freedesktop.org/wiki/Specifications/StatusNotifierItem/ [SNITray]: https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget-SNITray.html ### Network Manager Tray Icon (`nm-applet`) `nm-applet` needs to be started with the `--indicator` option so that it registers with the StatusNotifierWatcher. If using XDG autostart, then edit the `Exec=` line of [`nm-applet.desktop`](https://gitlab.gnome.org/GNOME/network-manager-applet/-/blob/main/nm-applet.desktop.in?ref_type=heads) in `~/.config/autostart`. (Sometimes a `nm-applet --sm-disable` option is mentioned. This option is not needed [1](https://askubuntu.com/a/525273), [2](https://mail.gnome.org/archives/networkmanager-list/2011-May/msg00141.html).) ## NixOS ### GDK pixbuf loaders cache Under NixOS, it's not possible to have a global mutable file such as `/usr/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache`. So graphical applications using `gdk-pixbuf` on NixOS need to have the environment variable `GDK_PIXBUF_MODULE_FILE` set according to the system configuration, _and_ available in the process execution environment _before_ they are started. Applications started from within `gnome-session`, being child processes of it, will naturally have `GDK_PIXBUF_MODULE_FILE` in their process environment. Applications run as `systemd --user` services will not necesarily have any environment variables at all. So if you run Taffybar as a `systemd --user` service, then add this to your NixOS configuration: ```nix services.xserver.displayManager.importedVariables = [ "GDK_PIXBUF_MODULE_FILE" ] ``` If using home-manager, and the option [`services.taffybar.enable`](https://github.com/nix-community/home-manager/blob/master/modules/services/taffybar.nix), this is done for you. ### `XDG_DATA_DIRS` For loading of desktop entry files and icons, Taffybar needs to be run with a correctly configured `XDG_DATA_DIRS` environment variable. If you run Taffybar as a `systemd --user` service, the the correct value of `XDG_DATA_DIRS` needs to be imported into the service manager environment, _before_ `taffybar.service` is started. If using home-manager and the option [`xsession.enable`](https://github.com/nix-community/home-manager/blob/master/modules/xsession.nix), this is done for you. taffybar-4.1.1/icons/0000755000000000000000000000000007346545000012617 5ustar0000000000000000taffybar-4.1.1/icons/play.svg0000644000000000000000000000173207346545000014310 0ustar0000000000000000 taffybar-4.1.1/src/System/0000755000000000000000000000000007346545000013557 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar.hs0000644000000000000000000003304707346545000015660 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable ----------------------------------------------------------------------------- module System.Taffybar ( -- | Taffybar is a system status bar meant for use with window managers like -- "XMonad" and i3wm. Taffybar is somewhat similar to xmobar, but it opts to use -- more heavy weight GUI in the form of GTK rather than the mostly textual -- approach favored by the latter. This allows it to provide features like an -- SNI system tray, and a workspace widget with window icons. -- -- * Configuration -- | -- The interface that Taffybar provides to the end user is roughly as follows: -- you give Taffybar a list of ('TaffyIO' actions that build) GTK widgets and -- it renders them in a horizontal bar for you (taking care of ugly details -- like reserving strut space so that window managers don't put windows over -- it). -- -- The config file in which you specify the GTK widgets to render is just a -- Haskell source file which is used to produce a custom executable with the -- desired set of widgets. This approach requires that Taffybar be installed -- as a Haskell library (not merely as an executable), and that the GHC -- compiler be available for recompiling the configuration. The upshot of this -- approach is that Taffybar's behavior and widget set are not limited to the -- set of widgets provided by the library, because custom code and widgets can -- be provided to Taffybar for instantiation and execution. -- -- The following code snippet is a simple example of what a Taffybar -- configuration might look like (also see "System.Taffybar.Example"): -- -- > {-# LANGUAGE OverloadedStrings #-} -- > import Data.Default (def) -- > import System.Taffybar -- > import System.Taffybar.Information.CPU -- > import System.Taffybar.SimpleConfig -- > import System.Taffybar.Widget -- > import System.Taffybar.Widget.Generic.Graph -- > import System.Taffybar.Widget.Generic.PollingGraph -- > -- > cpuCallback = do -- > (_, systemLoad, totalLoad) <- cpuLoad -- > return [ totalLoad, systemLoad ] -- > -- > main = do -- > let cpuCfg = def -- > { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)] -- > , graphLabel = Just "cpu" -- > } -- > clock = textClockNewWith def -- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback -- > workspaces = workspacesNew def -- > simpleConfig = def -- > { startWidgets = [ workspaces ] -- > , endWidgets = [ sniTrayNew, clock, cpu ] -- > } -- > simpleTaffybar simpleConfig -- -- This configuration creates a bar with four widgets. On the left is a widget -- that shows information about the workspace configuration. The rightmost -- widget is the system tray, with a clock and then a CPU graph. -- -- The CPU widget plots two graphs on the same widget: total CPU use in green -- and then system CPU use in a kind of semi-transparent purple on top of the -- green. -- -- It is important to note that the widget lists are __not__ @'GI.Gtk.Widget'@. They are -- actually @'TaffyIO' 'GI.Gtk.Widget'@ since the bar needs to construct them after -- performing some GTK initialization. getTaffyFile -- ** Colors -- -- | Although Taffybar is based on GTK, it ignores your GTK theme. The default -- theme that it uses lives at -- https://github.com/taffybar/taffybar/blob/master/taffybar.css You can alter -- this theme by editing @~\/.config\/taffybar\/taffybar.css@ to your liking. -- For an idea of the customizations you can make, see -- . -- * Taffybar and DBus -- -- | Taffybar has a strict dependency on "DBus", so you must ensure that the DBus daemon is -- started before starting Taffybar. -- -- * If you start your window manager using a graphical login manager like @gdm@ -- or @kdm@, DBus should be started automatically for you. -- -- * If you start xmonad with a different graphical login manager that does -- not start DBus for you automatically, put the line -- @eval \`dbus-launch --auto-syntax\`@ into your @~\/.xsession@ *before* xmonad and taffybar are -- started. This command sets some environment variables that the two must -- agree on. -- -- * If you start xmonad via @startx@ or a similar command, add the -- above command to @~\/.xinitrc@ -- -- * System tray compatability -- -- "System.Taffybar.Widget.SNITray" only supports the newer -- StatusNotifierItem (SNI) protocol; older xembed applets will not work. -- AppIndicator is also a valid implementation of SNI. -- -- Additionally, this module does not handle recognising new tray applets. -- Instead it is necessary to run status-notifier-watcher from the -- [status-notifier-item](https://github.com/taffybar/status-notifier-item) -- package early on system startup. -- In case this is not possible, the alternative widget -- 'System.Taffybar.Widget.SNITray.sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is available, but -- this may not necessarily be able to pick up everything. -- * Starting , startTaffybar -- ** Using Dyre , dyreTaffybar , dyreTaffybarMain , 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 ( (), 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, maybeHandleSigHUP, rebracket_ ) import Paths_taffybar ( getDataDir ) -- | The parameters that are passed to Dyre when taffybar is invoked with -- 'dyreTaffybar'. taffybarDyreParams = (Dyre.newParams "taffybar" dyreTaffybarMain showError) { Dyre.ghcOpts = ["-threaded", "-rtsopts"] , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"] } -- | Use Dyre to configure and start Taffybar. This will automatically recompile -- Taffybar whenever there are changes to your @taffybar.hs@ configuration file. dyreTaffybar :: TaffybarConfig -> IO () dyreTaffybar = Dyre.wrapMain taffybarDyreParams showError :: TaffybarConfig -> String -> TaffybarConfig showError cfg msg = cfg { errorMsg = Just msg } -- | The main function that Dyre should run. This is used in 'taffybarDyreParams'. dyreTaffybarMain :: TaffybarConfig -> IO () dyreTaffybarMain cfg = case errorMsg cfg of Nothing -> startTaffybar cfg Just err -> do IO.hPutStrLn IO.stderr ("Error: " ++ err) exitFailure -- | Locate installed vendor data file. getDataFile :: String -> IO FilePath getDataFile name = do dataDir <- getDataDir 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" -- | 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 -- recompilation is handled by another mechanism such as stack or a custom user -- script or not desired for some reason, it is perfectly fine (and probably -- better) to use this function. startTaffybar :: TaffybarConfig -> IO () startTaffybar config = do updateGlobalLogger "" removeHandler setTaffyLogFormatter "System.Taffybar" setTaffyLogFormatter "StatusNotifier" _ <- initThreads _ <- Gtk.init Nothing GIThreading.setCurrentThreadAsGUIThread cssPathsToLoad <- getCSSPaths config context <- buildContext config withCSSReloadable cssPathsToLoad $ Gtk.main `finally` logTaffy DEBUG "Finished main loop" `onSigINT` do logTaffy INFO "Interrupted" exitTaffybar context logTaffy DEBUG "Exited normally" logTaffy :: Priority -> String -> IO () logTaffy = logM "System.Taffybar" taffybar-4.1.1/src/System/Taffybar/0000755000000000000000000000000007346545000015315 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/Auth.hs0000644000000000000000000000150107346545000016547 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Auth where import Control.Monad.IO.Class import Data.Maybe import System.Taffybar.Util import Text.Regex fieldRegex :: Regex fieldRegex = mkRegexWithOpts "^(.*?): *(.*?)$" True True passGet :: MonadIO m => String -> m (Either String (String, [(String, String)])) passGet credentialName = (>>= getPassComponents . lines) <$> runPassShow where runPassShow = runCommand "pass" ["show", credentialName] getPassComponents [] = Left "pass show command produced no output" getPassComponents (key:rest) = Right (key, buildEntries rest) buildEntries = mapMaybe buildEntry . mapMaybe (matchRegex fieldRegex) buildEntry [fieldName, fieldValue] = Just (fieldName, fieldValue) buildEntry _ = Nothing taffybar-4.1.1/src/System/Taffybar/Context.hs0000644000000000000000000004625107346545000017305 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ImpredicativeTypes #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Context -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- The "System.Taffybar.Context" module provides the core functionality of the -- taffybar library. It gets its name from the 'Context' record, which stores -- runtime information and objects, which are used by many of the widgets that -- taffybar provides. 'Context' is typically accessed through the 'Reader' -- interface of 'TaffyIO'. ----------------------------------------------------------------------------- module System.Taffybar.Context ( -- * Configuration TaffybarConfig(..) , defaultTaffybarConfig , appendHook -- ** Bars , BarConfig(..) , BarConfigGetter , showBarId -- * Taffy monad , Taffy , TaffyIO -- ** Context , Context(..) , buildContext , buildEmptyContext -- ** Context State , getState , getStateDefault , putState -- * Control , refreshTaffyWindows , exitTaffybar -- * X11 , runX11 , runX11Def -- ** Event subscription , subscribeToAll , subscribeToPropertyEvents , unsubscribe -- * Threading , taffyFork ) where import Control.Arrow ((&&&), (***)) import Control.Concurrent (forkIO) import qualified Control.Concurrent.MVar as MV import Control.Exception.Enclosed (catchAny) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import qualified DBus.Client as DBus import Data.Data import Data.Default (Default(..)) import Data.GI.Base.ManagedPtr (unsafeCastTo) import Data.Int import Data.List import qualified Data.Map as M import qualified Data.Text as T import Data.Tuple.Select import Data.Tuple.Sequence import Data.Unique import qualified GI.Gdk import qualified GI.GdkX11 as GdkX11 import GI.GdkX11.Objects.X11Window import qualified GI.Gtk as Gtk import Graphics.UI.GIGtkStrut import StatusNotifier.TransparentWindow import System.Log.Logger (Priority(..), logM) import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util import System.Taffybar.Widget.Util import Text.Printf import Unsafe.Coerce logIO :: Priority -> String -> IO () logIO = logM "System.Taffybar.Context" logC :: MonadIO m => Priority -> String -> m () logC p = liftIO . logIO p -- | 'Taffy' is a monad transformer that provides 'ReaderT' for 'Context'. type Taffy m v = ReaderT Context m v -- | 'TaffyIO' is 'IO' wrapped with a 'ReaderT' providing 'Context'. This is the -- type of most widgets and callback in Taffybar. type TaffyIO v = ReaderT Context IO v type Listener = Event -> Taffy IO () type SubscriptionList = [(Unique, Listener)] data Value = forall t. Typeable t => Value t fromValue :: forall t. Typeable t => Value -> Maybe t fromValue (Value v) = if typeOf v == typeRep (Proxy :: Proxy t) then Just $ unsafeCoerce v else Nothing -- | 'BarConfig' specifies the configuration for a single taffybar window. data BarConfig = BarConfig { -- | The strut configuration to use for the bar strutConfig :: StrutConfig -- | The amount of spacing in pixels between bar widgets , widgetSpacing :: Int32 -- | Constructors for widgets that should be placed at the beginning of the bar. , startWidgets :: [TaffyIO Gtk.Widget] -- | Constructors for widgets that should be placed in the center of the bar. , centerWidgets :: [TaffyIO Gtk.Widget] -- | Constructors for widgets that should be placed at the end of the bar. , endWidgets :: [TaffyIO Gtk.Widget] -- | A unique identifier for the bar, that can be used e.g. when toggling. , barId :: Unique } instance Eq BarConfig where a == b = barId a == barId b type BarConfigGetter = TaffyIO [BarConfig] -- | 'TaffybarConfig' provides an advanced interface for configuring taffybar. -- Through the 'getBarConfigsParam', it is possible to specify different -- taffybar configurations depending on the number of monitors present, and even -- to specify different taffybar configurations for each monitor. data TaffybarConfig = TaffybarConfig { -- | An optional dbus client to use. dbusClientParam :: Maybe DBus.Client -- | Hooks that should be executed at taffybar startup. , startupHook :: TaffyIO () -- | A 'TaffyIO' action that returns a list of 'BarConfig' where each element -- describes a taffybar window that should be spawned. , getBarConfigsParam :: BarConfigGetter -- | A list of 'FilePath' each of which should be loaded as css files at -- startup. , cssPaths :: [FilePath] -- | A field used (only) by dyre to provide an error message. , errorMsg :: Maybe String } -- | Append the provided 'TaffyIO' hook to the 'startupHook' of the given -- 'TaffybarConfig'. appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig appendHook hook config = config { startupHook = startupHook config >> hook } -- | Default values for a 'TaffybarConfig'. Not usuable without at least -- properly setting 'getBarConfigsParam'. defaultTaffybarConfig :: TaffybarConfig defaultTaffybarConfig = TaffybarConfig { dbusClientParam = Nothing , startupHook = return () , getBarConfigsParam = return [] , cssPaths = [] , errorMsg = Nothing } instance Default TaffybarConfig where def = defaultTaffybarConfig -- | A "Context" value holds all of the state associated with a single running -- instance of taffybar. It is typically accessed from a widget constructor -- through the "TaffyIO" monad transformer stack. data Context = Context { -- | The X11Context that will be used to service X11Property requests. x11ContextVar :: MV.MVar X11Context -- | The handlers which will be evaluated against incoming X11 events. , listeners :: MV.MVar SubscriptionList -- | A collection of miscellaneous pieces of state which are keyed by their -- types. Most new pieces of state should go here, rather than in a new field -- in 'Context'. State stored here is typically accessed through -- 'getStateDefault'. , contextState :: MV.MVar (M.Map TypeRep Value) -- | Used to track the windows that taffybar is currently controlling, and -- which 'BarConfig' objects they are associated with. , existingWindows :: MV.MVar [(BarConfig, Gtk.Window)] -- | The shared user session 'DBus.Client'. , sessionDBusClient :: DBus.Client -- | The shared system session 'DBus.Client'. , systemDBusClient :: DBus.Client -- | The action that will be evaluated to get the bar configs associated with -- each active monitor taffybar should run on. , getBarConfigs :: BarConfigGetter -- | Populated with the BarConfig that resulted in the creation of a given -- widget, when its constructor is called. This lets widgets access thing like -- who their neighbors are. Note that the value of 'contextBarConfig' is -- different for widgets belonging to bar windows on different monitors. , contextBarConfig :: Maybe BarConfig } -- | Build the "Context" for a taffybar process. buildContext :: TaffybarConfig -> IO Context buildContext TaffybarConfig { dbusClientParam = maybeDBus , getBarConfigsParam = barConfigGetter , startupHook = startup } = do logIO DEBUG "Building context" dbusC <- maybe DBus.connectSession return maybeDBus sDBusC <- DBus.connectSystem _ <- DBus.requestName dbusC "org.taffybar.Bar" [DBus.nameAllowReplacement, DBus.nameReplaceExisting] listenersVar <- MV.newMVar [] state <- MV.newMVar M.empty x11Context <- getX11Context def >>= MV.newMVar windowsVar <- MV.newMVar [] let context = Context { x11ContextVar = x11Context , listeners = listenersVar , contextState = state , sessionDBusClient = dbusC , systemDBusClient = sDBusC , getBarConfigs = barConfigGetter , existingWindows = windowsVar , contextBarConfig = Nothing } _ <- runMaybeT $ MaybeT GI.Gdk.displayGetDefault >>= (lift . GI.Gdk.displayGetDefaultScreen) >>= (lift . flip GI.Gdk.afterScreenMonitorsChanged -- XXX: We have to do a force refresh here because there is no -- way to reliably move windows, since the window manager can do -- whatever it pleases. (runReaderT forceRefreshTaffyWindows context)) flip runReaderT context $ do logC DEBUG "Starting X11 Handler" startX11EventHandler logC DEBUG "Running startup hook" startup logC DEBUG "Queing build windows command" refreshTaffyWindows logIO DEBUG "Context build finished" return context -- | Build an empty taffybar context. This function is mostly useful for -- invoking functions that yield 'TaffyIO' values in a testing setting (e.g. in -- a repl). buildEmptyContext :: IO Context buildEmptyContext = buildContext def -- | Format the 'barId' as a numeric string. showBarId :: BarConfig -> String showBarId = show . hashUnique . barId buildBarWindow :: Context -> BarConfig -> IO Gtk.Window buildBarWindow context barConfig = do let thisContext = context { contextBarConfig = Just barConfig } logC INFO $ printf "Building window for Taffybar(id=%s) with %s" (showBarId barConfig) (show $ strutConfig barConfig) window <- Gtk.windowNew Gtk.WindowTypeToplevel void $ Gtk.onWidgetDestroy window $ do let bId = showBarId barConfig logC INFO $ printf "Window for Taffybar(id=%s) destroyed" bId MV.modifyMVar_ (existingWindows context) (pure . filter ((/=) window . sel2)) logC DEBUG $ printf "Window for Taffybar(id=%s) unregistered" bId box <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $ widgetSpacing barConfig _ <- widgetSetClassGI box "taffy-box" centerBox <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $ widgetSpacing barConfig _ <- widgetSetClassGI centerBox "center-box" Gtk.widgetSetVexpand centerBox True Gtk.setWidgetValign centerBox Gtk.AlignFill Gtk.setWidgetHalign centerBox Gtk.AlignCenter Gtk.boxSetCenterWidget box (Just centerBox) setupStrutWindow (strutConfig barConfig) window Gtk.containerAdd window box _ <- widgetSetClassGI window "taffy-window" let addWidgetWith widgetAdd (count, buildWidget) = runReaderT buildWidget thisContext >>= widgetAdd count addToStart count widget = do _ <- widgetSetClassGI widget $ T.pack $ printf "left-%d" (count :: Int) Gtk.boxPackStart box widget False False 0 addToEnd count widget = do _ <- widgetSetClassGI widget $ T.pack $ printf "right-%d" (count :: Int) Gtk.boxPackEnd box widget False False 0 addToCenter count widget = do _ <- widgetSetClassGI widget $ T.pack $ printf "center-%d" (count :: Int) Gtk.boxPackStart centerBox widget False False 0 logIO DEBUG "Building start widgets" mapM_ (addWidgetWith addToStart) $ zip [1..] (startWidgets barConfig) logIO DEBUG "Building center widgets" mapM_ (addWidgetWith addToCenter) $ zip [1..] (centerWidgets barConfig) logIO DEBUG "Building end widgets" mapM_ (addWidgetWith addToEnd) $ zip [1..] (endWidgets barConfig) makeWindowTransparent window logIO DEBUG "Showing window" Gtk.widgetShow window Gtk.widgetShow box Gtk.widgetShow centerBox runX11Context context () $ void $ runMaybeT $ do gdkWindow <- MaybeT $ Gtk.widgetGetWindow window xid <- GdkX11.x11WindowGetXid =<< liftIO (unsafeCastTo X11Window gdkWindow) logC DEBUG $ printf "Lowering X11 window %s" $ show xid lift $ doLowerWindow (fromIntegral xid) return window -- | Use the "barConfigGetter" field of "Context" to get the set of taffybar -- windows that should active. Will avoid recreating windows if there is already -- a window with the appropriate geometry and "BarConfig". refreshTaffyWindows :: TaffyIO () refreshTaffyWindows = mapReaderT postGUIASync $ do logC DEBUG "Refreshing windows" ctx <- ask windowsVar <- asks existingWindows let rebuildWindows currentWindows = flip runReaderT ctx $ do barConfigs <- join $ asks getBarConfigs let currentConfigs = map sel1 currentWindows newConfs = filter (`notElem` currentConfigs) barConfigs (remainingWindows, removedWindows) = partition ((`elem` barConfigs) . sel1) currentWindows setPropertiesFromPair (barConf, window) = setupStrutWindow (strutConfig barConf) window newWindowPairs <- lift $ do logIO DEBUG $ printf "removedWindows: %s" $ show $ map (strutConfig . sel1) removedWindows logIO DEBUG $ printf "remainingWindows: %s" $ show $ map (strutConfig . sel1) remainingWindows logIO DEBUG $ printf "newWindows: %s" $ show $ map strutConfig newConfs logIO DEBUG $ printf "barConfigs: %s" $ show $ map strutConfig barConfigs logIO DEBUG "Removing windows" mapM_ (Gtk.widgetDestroy . sel2) removedWindows -- TODO: This should actually use the config that is provided from -- getBarConfigs so that the strut properties of the window can be -- altered. logIO DEBUG "Updating strut properties for existing windows" mapM_ setPropertiesFromPair remainingWindows logIO DEBUG "Constructing new windows" mapM (sequenceT . ((return :: a -> IO a) &&& buildBarWindow ctx)) newConfs return $ newWindowPairs ++ remainingWindows lift $ MV.modifyMVar_ windowsVar rebuildWindows logC DEBUG "Finished refreshing windows" return () -- | Unconditionally delete all existing Taffybar top-level windows. removeTaffyWindows :: TaffyIO () removeTaffyWindows = asks existingWindows >>= liftIO . MV.readMVar >>= deleteWindows where deleteWindows = mapM_ (sequenceT . (msg *** del)) msg :: BarConfig -> TaffyIO () msg barConfig = logC INFO $ printf "Destroying window for Taffybar(id=%s)" (showBarId barConfig) del :: Gtk.Window -> TaffyIO () del = Gtk.widgetDestroy -- | Forcibly refresh taffybar windows, even if there are existing windows that -- correspond to the uniques in the bar configs yielded by 'barConfigGetter'. forceRefreshTaffyWindows :: TaffyIO () forceRefreshTaffyWindows = removeTaffyWindows >> refreshTaffyWindows -- | Destroys all top-level windows belonging to Taffybar, then -- requests the GTK main loop to exit. -- -- This ensures that the windows disappear promptly. For GTK windows -- to be destroyed, the main loop still needs to be running. exitTaffybar :: Context -> IO () exitTaffybar ctx = do postGUIASync $ runReaderT removeTaffyWindows ctx Gtk.mainQuit asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b asksContextVar getter = asks getter >>= lift . MV.readMVar -- | Run a function needing an X11 connection in 'TaffyIO'. runX11 :: X11Property a -> TaffyIO a runX11 action = asksContextVar x11ContextVar >>= lift . runReaderT action -- | Use 'runX11' together with 'postX11RequestSyncProp' on the provided -- property. Return the provided default if 'Nothing' is returned -- 'postX11RequestSyncProp'. runX11Def :: a -> X11Property a -> TaffyIO a runX11Def dflt prop = runX11 $ postX11RequestSyncProp prop dflt runX11Context :: MonadIO m => Context -> a -> X11Property a -> m a runX11Context context dflt prop = liftIO $ runReaderT (runX11Def dflt prop) context -- | Get a state value by type from the 'contextState' field of 'Context'. getState :: forall t. Typeable t => Taffy IO (Maybe t) getState = do stateMap <- asksContextVar contextState let maybeValue = M.lookup (typeRep (Proxy :: Proxy t)) stateMap return $ maybeValue >>= fromValue -- | Like "putState", but avoids aquiring a lock if the value is already in the -- map. getStateDefault :: Typeable t => Taffy IO t -> Taffy IO t getStateDefault defaultGetter = getState >>= maybe (putState defaultGetter) return -- | Get a value of the type returned by the provided action from the the -- current taffybar state, unless the state does not exist, in which case the -- action will be called to populate the state map. putState :: forall t. Typeable t => Taffy IO t -> Taffy IO t putState getValue = do contextVar <- asks contextState ctx <- ask lift $ MV.modifyMVar contextVar $ \contextStateMap -> let theType = typeRep (Proxy :: Proxy t) currentValue = M.lookup theType contextStateMap insertAndReturn value = (M.insert theType (Value value) contextStateMap, value) in flip runReaderT ctx $ maybe (insertAndReturn <$> getValue) (return . (contextStateMap,)) (currentValue >>= fromValue) -- | A version of 'forkIO' in 'TaffyIO'. taffyFork :: ReaderT r IO () -> ReaderT r IO () taffyFork = void . mapReaderT forkIO startX11EventHandler :: Taffy IO () startX11EventHandler = taffyFork $ do c <- ask -- 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 $ withX11Context def $ eventLoop (\e -> runReaderT (handleX11Event e) c) -- | Remove the listener associated with the provided "Unique" from the -- collection of listeners. unsubscribe :: Unique -> Taffy IO () unsubscribe identifier = do listenersVar <- asks listeners lift $ MV.modifyMVar_ listenersVar $ return . filter ((== identifier) . fst) -- | Subscribe to all incoming events on the X11 event loop. The returned -- "Unique" value can be used to unregister the listener using "unsuscribe". subscribeToAll :: Listener -> Taffy IO Unique subscribeToAll listener = do identifier <- lift newUnique listenersVar <- asks listeners let -- XXX: This type annotation probably has something to do with the warnings -- that occur without MonoLocalBinds, but it still seems to be necessary addListener :: SubscriptionList -> SubscriptionList addListener = ((identifier, listener):) lift $ MV.modifyMVar_ listenersVar (return . addListener) return identifier -- | Subscribe to X11 "PropertyEvent"s where the property changed is in the -- provided list. subscribeToPropertyEvents :: [String] -> Listener -> Taffy IO Unique subscribeToPropertyEvents eventNames listener = do eventAtoms <- mapM (runX11 . getAtom) eventNames let filteredListener event@PropertyEvent { ev_atom = atom } = when (atom `elem` eventAtoms) $ catchAny (listener event) (const $ return ()) filteredListener _ = return () subscribeToAll filteredListener handleX11Event :: Event -> Taffy IO () handleX11Event event = asksContextVar listeners >>= mapM_ applyListener where applyListener :: (Unique, Listener) -> Taffy IO () applyListener (_, listener) = taffyFork $ listener event taffybar-4.1.1/src/System/Taffybar/DBus.hs0000644000000000000000000000115007346545000016503 0ustar0000000000000000module System.Taffybar.DBus ( module System.Taffybar.DBus.Toggle , appendHook , startTaffyLogServer , withLogServer , withToggleServer ) where import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import System.Log.DBus.Server import System.Taffybar.Context import System.Taffybar.DBus.Toggle startTaffyLogServer :: TaffyIO () startTaffyLogServer = asks sessionDBusClient >>= lift . startLogServer withLogServer :: TaffybarConfig -> TaffybarConfig withLogServer = appendHook startTaffyLogServer withToggleServer :: TaffybarConfig -> TaffybarConfig withToggleServer = handleDBusToggles taffybar-4.1.1/src/System/Taffybar/DBus/Client/0000755000000000000000000000000007346545000017370 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/DBus/Client/MPRIS2.hs0000644000000000000000000000076207346545000020705 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module System.Taffybar.DBus.Client.MPRIS2 where import System.Taffybar.DBus.Client.Util import System.FilePath import System.Taffybar.DBus.Client.Params generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $ "dbus-xml" "org.mpris.MediaPlayer2.xml" generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $ "dbus-xml" "org.mpris.MediaPlayer2.Player.xml" taffybar-4.1.1/src/System/Taffybar/DBus/Client/Params.hs0000644000000000000000000000365307346545000021156 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE OverloadedStrings #-} module System.Taffybar.DBus.Client.Params where import DBus import DBus.Generation import Language.Haskell.TH import System.Taffybar.DBus.Client.Util playerGenerationParams :: GenerationParams playerGenerationParams = defaultGenerationParams { genTakeSignalErrorHandler = True , genObjectPath = Just "/org/mpris/MediaPlayer2" } -- | The base object path for the UPower interface uPowerBaseObjectPath :: ObjectPath uPowerBaseObjectPath = "/org/freedesktop/UPower" -- | The name of the power daemon bus uPowerBusName :: BusName uPowerBusName = "org.freedesktop.UPower" uPowerDeviceInterfaceName :: InterfaceName uPowerDeviceInterfaceName = "org.freedesktop.UPower.Device" uPowerGenerationParams :: GenerationParams uPowerGenerationParams = defaultGenerationParams { genTakeSignalErrorHandler = True , genBusName = Just uPowerBusName } data BatteryType = BatteryTypeUnknown | BatteryTypeLinePower | BatteryTypeBatteryType | BatteryTypeUps | BatteryTypeMonitor | BatteryTypeMouse | BatteryTypeKeyboard | BatteryTypePda | BatteryTypePhone deriving (Show, Ord, Eq, Enum) data BatteryState = BatteryStateUnknown | BatteryStateCharging | BatteryStateDischarging | BatteryStateEmpty | BatteryStateFullyCharged | BatteryStatePendingCharge | BatteryStatePendingDischarge deriving (Show, Ord, Eq, Enum) data BatteryTechnology = BatteryTechnologyUnknown | BatteryTechnologyLithiumIon | BatteryTechnologyLithiumPolymer | BatteryTechnologyLithiumIronPhosphate | BatteryTechnologyLeadAcid | BatteryTechnologyNickelCadmium | BatteryTechnologyNickelMetalHydride deriving (Show, Ord, Eq, Enum) batteryTypeForName :: GetTypeForName batteryTypeForName name = const $ case name of "Type" -> yes ''BatteryType "State" -> yes ''BatteryState "Technology" -> yes ''BatteryTechnology _ -> Nothing where yes = Just . ConT taffybar-4.1.1/src/System/Taffybar/DBus/Client/UPower.hs0000644000000000000000000000100307346545000021137 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module System.Taffybar.DBus.Client.UPower where import DBus.Generation import System.FilePath import System.Taffybar.DBus.Client.Params import System.Taffybar.DBus.Client.Util generateClientFromFile defaultRecordGenerationParams { recordName = Just "UPowerInfo" , recordPrefix = "upi" } uPowerGenerationParams { genObjectPath = Just uPowerBaseObjectPath } False $ "dbus-xml" "org.freedesktop.UPower.xml" taffybar-4.1.1/src/System/Taffybar/DBus/Client/UPowerDevice.hs0000644000000000000000000000067707346545000022277 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module System.Taffybar.DBus.Client.UPowerDevice where import System.FilePath import System.Taffybar.DBus.Client.Params import System.Taffybar.DBus.Client.Util generateClientFromFile defaultRecordGenerationParams { recordName = Just "BatteryInfo" , recordPrefix = "battery" , recordTypeForName = batteryTypeForName } uPowerGenerationParams False $ "dbus-xml" "org.freedesktop.UPower.Device.xml" taffybar-4.1.1/src/System/Taffybar/DBus/Client/Util.hs0000644000000000000000000000634107346545000020645 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} module System.Taffybar.DBus.Client.Util where import Control.Monad (forM) import DBus.Generation import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I import qualified Data.Char as Char import Data.Coerce import Data.Maybe import Language.Haskell.TH import StatusNotifier.Util (getIntrospectionObjectFromFile) deriveShowAndEQ :: [DerivClause] deriveShowAndEQ = [DerivClause Nothing [ConT ''Eq, ConT ''Show]] buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec buildDataFromNameTypePairs name pairs = DataD [] name [] Nothing [RecC name (map mkVarBangType pairs)] deriveShowAndEQ where mkVarBangType (fieldName, fieldType) = (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, fieldType) standaloneDeriveEqShow :: Name -> [Dec] standaloneDeriveEqShow _ = [] type GetTypeForName = String -> T.Type -> Maybe Type data RecordGenerationParams = RecordGenerationParams { recordName :: Maybe String , recordPrefix :: String , recordTypeForName :: GetTypeForName } defaultRecordGenerationParams :: RecordGenerationParams defaultRecordGenerationParams = RecordGenerationParams { recordName = Nothing , recordPrefix = "_" , recordTypeForName = const $ const Nothing } generateGetAllRecord :: RecordGenerationParams -> GenerationParams -> I.Interface -> Q [Dec] generateGetAllRecord RecordGenerationParams { recordName = recordNameString , recordPrefix = prefix , recordTypeForName = getTypeForName } GenerationParams { getTHType = getArgType } I.Interface { I.interfaceName = interfaceName , I.interfaceProperties = properties } = do let theRecordName = maybe (mkName $ map Char.toUpper $ filter Char.isLetter $ coerce interfaceName) mkName recordNameString let getPairFromProperty I.Property { I.propertyName = propName , I.propertyType = propType } = ( mkName $ prefix ++ propName , fromMaybe (getArgType propType) $ getTypeForName propName propType ) getAllRecord = buildDataFromNameTypePairs theRecordName $ map getPairFromProperty properties return $ getAllRecord:standaloneDeriveEqShow theRecordName generateClientFromFile :: RecordGenerationParams -> GenerationParams -> Bool -> FilePath -> Q [Dec] generateClientFromFile recordGenerationParams params useObjectPath filepath = do object <- getIntrospectionObjectFromFile filepath "/" let actualObjectPath = I.objectPath object realParams = if useObjectPath then params {genObjectPath = Just actualObjectPath} else params (<++>) = liftA2 (++) fmap concat $ forM (I.objectInterfaces object) $ \interface -> do generateGetAllRecord recordGenerationParams params interface <++> generateClient realParams interface <++> generateSignalsFromInterface realParams interface taffybar-4.1.1/src/System/Taffybar/DBus/0000755000000000000000000000000007346545000016152 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/DBus/Toggle.hs0000644000000000000000000001447207346545000017737 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.DBus.Toggle -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This module provides a dbus interface that allows users to toggle the display -- of taffybar on each monitor while it is running. ----------------------------------------------------------------------------- module System.Taffybar.DBus.Toggle ( handleDBusToggles ) where import qualified Control.Concurrent.MVar as MV import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import DBus import DBus.Client import Data.Int import qualified Data.Map as M import Data.Maybe import qualified GI.Gdk as Gdk import Graphics.UI.GIGtkStrut import System.Directory import System.FilePath.Posix import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Util import Text.Printf import Text.Read ( readMaybe ) -- $usage -- -- To use this module, import it in your taffybar.hs and wrap your config with -- the 'handleDBusToggles' function: -- -- > main = dyreTaffybar $ handleDBusToggles myConfig -- -- To toggle taffybar on the monitor that is currently active, issue the -- following command: -- -- > dbus-send --print-reply=literal --dest=taffybar.toggle /taffybar/toggle taffybar.toggle.toggleCurrent logIO :: System.Log.Logger.Priority -> String -> IO () logIO = logM "System.Taffybar.DBus.Toggle" logT :: MonadIO m => System.Log.Logger.Priority -> String -> m () logT p = liftIO . logIO p getActiveMonitorNumber :: MaybeT IO Int getActiveMonitorNumber = do display <- MaybeT Gdk.displayGetDefault seat <- lift $ Gdk.displayGetDefaultSeat display device <- MaybeT $ Gdk.seatGetPointer seat lift $ do (_, x, y) <- Gdk.deviceGetPosition device Gdk.displayGetMonitorAtPoint display x y >>= getMonitorNumber getMonitorNumber :: Gdk.Monitor -> IO Int getMonitorNumber monitor = do display <- Gdk.monitorGetDisplay monitor monitorCount <- Gdk.displayGetNMonitors display monitors <- mapM (Gdk.displayGetMonitor display) [0..(monitorCount-1)] monitorGeometry <- Gdk.getMonitorGeometry monitor let equalsMonitor (Just other, _) = do otherGeometry <- Gdk.getMonitorGeometry other case (otherGeometry, monitorGeometry) of (Nothing, Nothing) -> return True (Just g1, Just g2) -> Gdk.rectangleEqual g1 g2 _ -> return False equalsMonitor _ = return False snd . fromMaybe (Nothing, 0) . listToMaybe <$> filterM equalsMonitor (zip monitors [0..]) taffybarTogglePath :: ObjectPath taffybarTogglePath = "/taffybar/toggle" taffybarToggleInterface :: InterfaceName taffybarToggleInterface = "taffybar.toggle" toggleStateFile :: IO FilePath toggleStateFile = ( "toggle_state.dat") <$> taffyStateDir newtype TogglesMVar = TogglesMVar (MV.MVar (M.Map Int Bool)) getTogglesVar :: TaffyIO TogglesMVar getTogglesVar = getStateDefault $ lift (TogglesMVar <$> MV.newMVar M.empty) toggleBarConfigGetter :: BarConfigGetter -> BarConfigGetter toggleBarConfigGetter getConfigs = do barConfigs <- getConfigs TogglesMVar enabledVar <- getTogglesVar numToEnabled <- lift $ MV.readMVar enabledVar let isEnabled monNumber = fromMaybe True $ M.lookup monNumber numToEnabled isConfigEnabled = isEnabled . fromIntegral . fromMaybe 0 . strutMonitor . strutConfig return $ filter isConfigEnabled barConfigs exportTogglesInterface :: TaffyIO () exportTogglesInterface = do TogglesMVar enabledVar <- getTogglesVar ctx <- ask lift $ taffyStateDir >>= createDirectoryIfMissing True stateFile <- lift toggleStateFile let toggleTaffyOnMon fn mon = flip runReaderT ctx $ do lift $ MV.modifyMVar_ enabledVar $ \numToEnabled -> do let current = fromMaybe True $ M.lookup mon numToEnabled result = M.insert mon (fn current) numToEnabled logIO DEBUG $ printf "Toggle state before: %s, after %s" (show numToEnabled) (show result) catch (writeFile stateFile (show result)) $ \e -> logIO WARNING $ printf "Unable to write to toggle state file %s, error: %s" (show stateFile) (show (e :: SomeException)) return result refreshTaffyWindows toggleTaffy = do num <- runMaybeT getActiveMonitorNumber toggleTaffyOnMon not $ fromMaybe 0 num takeInt :: (Int -> a) -> (Int32 -> a) takeInt = (. fromIntegral) client <- asks sessionDBusClient let interface = defaultInterface { interfaceName = taffybarToggleInterface , interfaceMethods = [ autoMethod "toggleCurrent" toggleTaffy , autoMethod "toggleOnMonitor" $ takeInt $ toggleTaffyOnMon not , autoMethod "hideOnMonitor" $ takeInt $ toggleTaffyOnMon (const False) , autoMethod "showOnMonitor" $ takeInt $ toggleTaffyOnMon (const True) , autoMethod "refresh" $ runReaderT refreshTaffyWindows ctx , autoMethod "exit" $ exitTaffybar ctx ] } lift $ do _ <- requestName client "taffybar.toggle" [nameAllowReplacement, nameReplaceExisting] export client taffybarTogglePath interface dbusTogglesStartupHook :: TaffyIO () dbusTogglesStartupHook = do TogglesMVar enabledVar <- getTogglesVar logT DEBUG "Loading toggle state" lift $ do stateFilepath <- toggleStateFile filepathExists <- doesFileExist stateFilepath mStartingMap <- if filepathExists then readMaybe <$> readFile stateFilepath else return Nothing MV.modifyMVar_ enabledVar $ const $ return $ fromMaybe M.empty mStartingMap logT DEBUG "Exporting toggles interface" exportTogglesInterface handleDBusToggles :: TaffybarConfig -> TaffybarConfig handleDBusToggles config = config { getBarConfigsParam = toggleBarConfigGetter $ getBarConfigsParam config , startupHook = startupHook config >> dbusTogglesStartupHook } taffybar-4.1.1/src/System/Taffybar/Example.hs0000644000000000000000000000612507346545000017250 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Example -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable ----------------------------------------------------------------------------- module System.Taffybar.Example where -- XXX: in an actual taffybar.hs configuration file, you will need the module -- name to be Main, and you would need to have a main function defined at the -- top level, e.g. -- -- > main = dyreTaffybar exampleTaffybarConfig import Data.Default (def) import System.Taffybar.Context (TaffybarConfig(..)) import System.Taffybar.Hooks import System.Taffybar.Information.CPU import System.Taffybar.Information.Memory import System.Taffybar.SimpleConfig import System.Taffybar.Widget import System.Taffybar.Widget.Generic.PollingGraph transparent, yellow1, yellow2, green1, green2, taffyBlue :: (Double, Double, Double, Double) transparent = (0.0, 0.0, 0.0, 0.0) yellow1 = (0.9453125, 0.63671875, 0.2109375, 1.0) yellow2 = (0.9921875, 0.796875, 0.32421875, 1.0) green1 = (0, 1, 0, 1) green2 = (1, 0, 1, 0.5) taffyBlue = (0.129, 0.588, 0.953, 1) myGraphConfig, netCfg, memCfg, cpuCfg :: GraphConfig myGraphConfig = def { graphPadding = 0 , graphBorderWidth = 0 , graphWidth = 75 , graphBackgroundColor = transparent } netCfg = myGraphConfig { graphDataColors = [yellow1, yellow2] , graphLabel = Just "net" } memCfg = myGraphConfig { graphDataColors = [taffyBlue] , graphLabel = Just "mem" } cpuCfg = myGraphConfig { graphDataColors = [green1, green2] , graphLabel = Just "cpu" } memCallback :: IO [Double] memCallback = do mi <- parseMeminfo return [memoryUsedRatio mi] cpuCallback :: IO [Double] cpuCallback = do (_, systemLoad, totalLoad) <- cpuLoad return [totalLoad, systemLoad] exampleTaffybarConfig :: TaffybarConfig exampleTaffybarConfig = let myWorkspacesConfig = def { minIcons = 1 , widgetGap = 0 , showWorkspaceFn = hideEmpty } workspaces = workspacesNew myWorkspacesConfig cpu = pollingGraphNew cpuCfg 0.5 cpuCallback mem = pollingGraphNew memCfg 1 memCallback net = networkGraphNew netCfg Nothing clock = textClockNewWith def layout = layoutNew def windowsW = windowsNew def -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher -- for a better way to set up the sni tray tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt myConfig = def { startWidgets = workspaces : map (>>= buildContentsBox) [ layout, windowsW ] , endWidgets = map (>>= buildContentsBox) [ batteryIconNew , clock , tray , cpu , mem , net , mpris2New ] , barPosition = Top , barPadding = 10 , barHeight = ExactSize 50 , widgetSpacing = 0 } in withLogServer $ withToggleServer $ toTaffybarConfig myConfig taffybar-4.1.1/src/System/Taffybar/Hooks.hs0000644000000000000000000000700307346545000016734 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Hooks -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This module provides various startup hooks that can be added to -- 'TaffybarConfig'. ----------------------------------------------------------------------------- module System.Taffybar.Hooks ( module System.Taffybar.DBus , module System.Taffybar.Hooks , ChromeTabImageData(..) , getChromeTabImageDataChannel , getChromeTabImageDataTable , getX11WindowToChromeTabId , refreshBatteriesOnPropChange ) where 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 import System.Log.Logger import System.Taffybar.Context import System.Taffybar.DBus import System.Taffybar.Information.Battery import System.Taffybar.Information.Chrome import System.Taffybar.Information.Network import System.Environment.XDG.DesktopEntry import System.Taffybar.LogFormatter import System.Taffybar.Util -- | The type of the channel that provides network information in taffybar. newtype NetworkInfoChan = NetworkInfoChan (TChan [(String, (Rational, Rational))]) -- | Build a 'NetworkInfoChan' that refreshes at the provided interval. buildNetworkInfoChan :: Double -> IO NetworkInfoChan buildNetworkInfoChan interval = do chan <- newBroadcastTChanIO _ <- forkIO $ monitorNetworkInterfaces interval (void . atomically . writeTChan chan) return $ NetworkInfoChan chan -- | Get the 'NetworkInfoChan' from 'Context', creating it if it does not exist. getNetworkChan :: TaffyIO NetworkInfoChan getNetworkChan = getStateDefault $ lift $ buildNetworkInfoChan 2.0 -- | Set the log formatter used in the taffybar process setTaffyLogFormatter :: String -> IO () setTaffyLogFormatter loggerName = do handler <- taffyLogHandler updateGlobalLogger loggerName $ setHandlers [handler] -- | Add 'refreshBatteriesOnPropChange' to the 'startupHook' of the -- provided 'TaffybarConfig'. Use this if your system has issues with -- the battery widget not updating or reporting the incorrect state. -- -- This function 'withBatteryRefresh' is __not normally needed__ -- because the battery widget already subscribes to updates from -- UPower, and UPower usually works correctly. withBatteryRefresh :: TaffybarConfig -> TaffybarConfig withBatteryRefresh = appendHook refreshBatteriesOnPropChange -- | Load the 'DesktopEntry' cache from 'Context' state. getDirectoryEntriesByClassName :: TaffyIO (MM.MultiMap String DesktopEntry) getDirectoryEntriesByClassName = getStateDefault readDirectoryEntriesDefault -- | Update the 'DesktopEntry' cache every 60 seconds. updateDirectoryEntriesCache :: TaffyIO () updateDirectoryEntriesCache = ask >>= \ctx -> void $ lift $ foreverWithDelay (60 :: Double) $ flip runReaderT ctx $ void $ putState readDirectoryEntriesDefault -- | Read 'DesktopEntry' values into a 'MM.Multimap', where they are indexed by -- the class name specified in the 'DesktopEntry'. readDirectoryEntriesDefault :: TaffyIO (MM.MultiMap String DesktopEntry) readDirectoryEntriesDefault = lift $ indexDesktopEntriesByClassName <$> getDirectoryEntriesDefault taffybar-4.1.1/src/System/Taffybar/Information/0000755000000000000000000000000007346545000017602 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/Information/Battery.hs0000644000000000000000000002661207346545000021557 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.Battery -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This module provides functions for querying battery information using the -- 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 ( BatteryInfo(..) , BatteryState(..) , BatteryTechnology(..) , BatteryType(..) , module System.Taffybar.Information.Battery ) where 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 import DBus import DBus.Client import DBus.Internal.Types (Serial(..)) import qualified DBus.TH as DBus import Data.Int import Data.List import Data.Map ( Map ) import qualified Data.Map as M import Data.Maybe import Data.Text ( Text ) import Data.Word import System.Log.Logger import System.Taffybar.Context import System.Taffybar.DBus.Client.Params import System.Taffybar.DBus.Client.UPower import System.Taffybar.DBus.Client.UPowerDevice import System.Taffybar.Util batteryLogPath :: String batteryLogPath = "System.Taffybar.Information.Battery" batteryLog :: MonadIO m => Priority -> String -> m () batteryLog priority = liftIO . logM batteryLogPath priority batteryLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m () batteryLogF = logPrintF batteryLogPath -- | The DBus path prefix where UPower enumerates its objects. uPowerDevicesPath :: ObjectPath uPowerDevicesPath = objectPath_ (formatObjectPath uPowerBaseObjectPath ++ "/devices") -- | The prefix of name of battery devices path. UPower generates the object -- path as "battery" + "_" + basename of the sysfs object. batteryPrefix :: String batteryPrefix = formatObjectPath uPowerDevicesPath ++ "/battery_" -- | Determine if a power source is a battery. isBattery :: ObjectPath -> Bool isBattery = isPrefixOf batteryPrefix . formatObjectPath -- | A helper to read the variant contents of a dict with a default -- value. readDict :: (IsVariant a) => Map Text Variant -> Text -> a -> a readDict dict key dflt = fromMaybe dflt $ do variant <- M.lookup key dict fromVariant variant -- | Read the variant contents of a dict which is of an unknown integral type. readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int readDictIntegral dict key dflt = fromMaybe (fromIntegral dflt) $ do v <- M.lookup key dict case variantType v of TypeWord8 -> return $ fromIntegral (f v :: Word8) TypeWord16 -> return $ fromIntegral (f v :: Word16) TypeWord32 -> return $ fromIntegral (f v :: Word32) TypeWord64 -> return $ fromIntegral (f v :: Word64) TypeInt16 -> return $ fromIntegral (f v :: Int16) TypeInt32 -> return $ fromIntegral (f v :: Int32) TypeInt64 -> return $ fromIntegral (f v :: Int64) _ -> Nothing where f :: (Num a, IsVariant a) => Variant -> a f = fromMaybe (fromIntegral dflt) . fromVariant -- XXX: Remove this once it is exposed in haskell-dbus dummyMethodError :: MethodError dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch" -- | Query the UPower daemon about information on a specific battery. -- If some fields are not actually present, they may have bogus values -- here. Don't bet anything critical on it. getBatteryInfo :: ObjectPath -> TaffyIO (Either MethodError BatteryInfo) getBatteryInfo battPath = asks systemDBusClient >>= \client -> lift $ runExceptT $ do reply <- ExceptT $ getAllProperties client $ (methodCall battPath uPowerDeviceInterfaceName "FakeMethod") { methodCallDestination = Just uPowerBusName } dict <- ExceptT $ return $ maybeToEither dummyMethodError $ listToMaybe (methodReturnBody reply) >>= fromVariant return $ infoMapToBatteryInfo dict infoMapToBatteryInfo :: Map Text Variant -> BatteryInfo infoMapToBatteryInfo dict = BatteryInfo { batteryNativePath = readDict dict "NativePath" "" , batteryVendor = readDict dict "Vendor" "" , batteryModel = readDict dict "Model" "" , batterySerial = readDict dict "Serial" "" , batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0 , batteryPowerSupply = readDict dict "PowerSupply" False , batteryHasHistory = readDict dict "HasHistory" False , batteryHasStatistics = readDict dict "HasStatistics" False , batteryOnline = readDict dict "Online" False , batteryEnergy = readDict dict "Energy" 0.0 , batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0 , batteryEnergyFull = readDict dict "EnergyFull" 0.0 , batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0 , batteryEnergyRate = readDict dict "EnergyRate" 0.0 , batteryVoltage = readDict dict "Voltage" 0.0 , batteryTimeToEmpty = readDict dict "TimeToEmpty" 0 , batteryTimeToFull = readDict dict "TimeToFull" 0 , batteryPercentage = readDict dict "Percentage" 0.0 , batteryIsPresent = readDict dict "IsPresent" False , batteryState = toEnum $ readDictIntegral dict "State" 0 , batteryIsRechargeable = readDict dict "IsRechargable" True , batteryCapacity = readDict dict "Capacity" 0.0 , batteryTechnology = toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0 , batteryUpdateTime = readDict dict "UpdateTime" 0 , batteryLuminosity = readDict dict "Luminosity" 0.0 , batteryTemperature = readDict dict "Temperature" 0.0 , batteryWarningLevel = readDict dict "WarningLevel" 0 , batteryBatteryLevel = readDict dict "BatteryLevel" 0 , batteryIconName = readDict dict "IconName" "" } getBatteryPaths :: TaffyIO (Either MethodError [ObjectPath]) getBatteryPaths = do client <- asks systemDBusClient liftIO $ runExceptT $ do paths <- ExceptT $ enumerateDevices client return $ filter isBattery paths newtype DisplayBatteryChanVar = DisplayBatteryChanVar (TChan BatteryInfo, MVar BatteryInfo) getDisplayBatteryInfo :: TaffyIO BatteryInfo getDisplayBatteryInfo = do DisplayBatteryChanVar (_, theVar) <- getDisplayBatteryChanVar lift $ readMVar theVar defaultMonitorDisplayBatteryProperties :: [String] defaultMonitorDisplayBatteryProperties = [ "IconName", "State", "Percentage" ] -- | Start the monitoring of the display battery, and setup the associated -- channel and mvar for the current state. setupDisplayBatteryChanVar :: [String] -> TaffyIO DisplayBatteryChanVar setupDisplayBatteryChanVar properties = getStateDefault $ DisplayBatteryChanVar <$> monitorDisplayBattery properties getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar getDisplayBatteryChanVar = setupDisplayBatteryChanVar defaultMonitorDisplayBatteryProperties getDisplayBatteryChan :: TaffyIO (TChan BatteryInfo) getDisplayBatteryChan = do DisplayBatteryChanVar (chan, _) <- getDisplayBatteryChanVar return chan updateBatteryInfo :: TChan BatteryInfo -> MVar BatteryInfo -> ObjectPath -> TaffyIO () updateBatteryInfo chan var path = getBatteryInfo path >>= lift . either warnOfFailure doWrites where doWrites info = batteryLogF DEBUG "Writing info %s" info >> swapMVar var info >> void (atomically $ writeTChan chan info) warnOfFailure = batteryLogF WARNING "Failed to update battery info %s" registerForAnyUPowerPropertiesChanged :: (Signal -> String -> Map String Variant -> [String] -> IO ()) -> ReaderT Context IO SignalHandler registerForAnyUPowerPropertiesChanged = registerForUPowerPropertyChanges [] registerForUPowerPropertyChanges :: [String] -> (Signal -> String -> Map String Variant -> [String] -> IO ()) -> ReaderT Context IO SignalHandler registerForUPowerPropertyChanges properties signalHandler = do client <- asks systemDBusClient lift $ DBus.registerForPropertiesChanged client matchAny { matchInterface = Just uPowerDeviceInterfaceName , matchPathNamespace = Just uPowerDevicesPath } handleIfPropertyMatches where handleIfPropertyMatches rawSignal n propertiesMap l = let propertyPresent prop = M.member prop propertiesMap in when (any propertyPresent properties || null properties) $ signalHandler rawSignal n propertiesMap l -- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object -- to returned "MVar" and "Chan" objects monitorDisplayBattery :: [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 <- liftIO newBroadcastTChanIO taffyFork $ do ctx <- ask let warnOfFailedGetDevice err = batteryLogF WARNING "Failure getting DisplayBattery: %s" err >> return "/org/freedesktop/UPower/devices/DisplayDevice" displayPath <- lift $ getDisplayDevice client >>= either warnOfFailedGetDevice return let doUpdate = updateBatteryInfo chan infoVar displayPath signalCallback _ _ changedProps _ = do batteryLogF DEBUG "Battery changed properties: %s" changedProps runReaderT doUpdate ctx _ <- registerForUPowerPropertyChanges propertiesToMonitor signalCallback doUpdate return (chan, infoVar) -- | Call "refreshAllBatteries" whenever the BatteryInfo for the DisplayDevice -- is updated. This handles cases where there is a race between the signal that -- something is updated and the update actually being visible. See -- https://github.com/taffybar/taffybar/issues/330 for more details. refreshBatteriesOnPropChange :: TaffyIO () refreshBatteriesOnPropChange = ask >>= \ctx -> let updateIfRealChange _ _ changedProps _ = flip runReaderT ctx $ when (any ((`notElem` ["UpdateTime", "Voltage"]) . fst) $ M.toList changedProps) $ lift (threadDelay 1000000) >> refreshAllBatteries in void $ registerForAnyUPowerPropertiesChanged updateIfRealChange -- | Request a refresh of all UPower batteries. This is only needed if UPower's -- refresh mechanism is not working properly. refreshAllBatteries :: TaffyIO () refreshAllBatteries = do client <- asks systemDBusClient let doRefresh path = batteryLogF DEBUG "Refreshing battery: %s" path >> refresh client path eerror <- runExceptT $ ExceptT getBatteryPaths >>= liftIO . mapM doRefresh -- NB. The Refresh() method is only available if the UPower daemon -- was started in debug mode. So ignore any errors about the method -- not being implemented. let logRefreshError e = unless (methodErrorName e == errorUnknownMethod) $ batteryLogF ERROR "Failed to refresh battery: %s" e logGetPathsError = batteryLogF ERROR "Failed to get battery paths %s" void $ either logGetPathsError (mapM_ $ either logRefreshError return) eerror taffybar-4.1.1/src/System/Taffybar/Information/CPU.hs0000644000000000000000000000167407346545000020575 0ustar0000000000000000module System.Taffybar.Information.CPU ( cpuLoad ) where import Control.Concurrent ( threadDelay ) import System.IO ( IOMode(ReadMode), openFile, hGetLine, hClose ) procData :: IO [Double] procData = do h <- openFile "/proc/stat" ReadMode firstLine <- hGetLine h length firstLine `seq` return () hClose h return (procParser firstLine) procParser :: String -> [Double] procParser = map read . drop 1 . words truncVal :: Double -> Double truncVal v | isNaN v || v < 0.0 = 0.0 | otherwise = v -- | Return a pair with (user time, system time, total time) (read -- from /proc/stat). The function waits for 50 ms between samples. cpuLoad :: IO (Double, Double, Double) cpuLoad = do a <- procData threadDelay 50000 b <- procData let dif = zipWith (-) b a tot = sum dif pct = map (/ tot) dif user = sum $ take 2 pct system = pct !! 2 t = user + system return (truncVal user, truncVal system, truncVal t) taffybar-4.1.1/src/System/Taffybar/Information/CPU2.hs0000644000000000000000000000525507346545000020656 0ustar0000000000000000{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.CPU2 -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Provides information about used CPU times, obtained from parsing the -- @\/proc\/stat@ file using some of the facilities included in the -- "System.Taffybar.Information.StreamInfo" module. -- And also provides information about the temperature of cores. -- (Now supports only physical cpu). -- ----------------------------------------------------------------------------- module System.Taffybar.Information.CPU2 where import Control.Monad import Data.List import Data.Maybe import Safe import System.Directory import System.FilePath import System.Taffybar.Information.StreamInfo -- | Returns a list of 5 to 7 elements containing all the values available for -- the given core (or all of them aggregated, if "cpu" is passed). getCPUInfo :: String -> IO [Int] getCPUInfo = getParsedInfo "/proc/stat" parse parse :: String -> [(String, [Int])] parse = mapMaybe (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines tuplize :: [String] -> Maybe (String, [Int]) tuplize s = do cpu <- s `atMay` 0 return (cpu, map (readDef (-1)) (tailSafe s)) -- | Returns a two-element list containing relative system and user times -- calculated using two almost simultaneous samples of the @\/proc\/stat@ file -- for the given core (or all of them aggregated, if \"cpu\" is passed). getCPULoad :: String -> IO [Double] getCPULoad cpu = do load <- getLoad 0.05 $ getCPUInfo cpu case load of l0:l1:l2:_ -> return [ l0 + l1, l2 ] _ -> return [] -- | Get the directory in which core temperature files are kept. getCPUTemperatureDirectory :: IO FilePath getCPUTemperatureDirectory = (baseDir ) . fromMaybe "hwmon0" . find (isPrefixOf "hwmon") <$> listDirectory baseDir where baseDir = "/" "sys" "bus" "platform" "devices" "coretemp.0" "hwmon" readCPUTempFile :: FilePath -> IO Double readCPUTempFile cpuTempFilePath = (/ 1000) . read <$> readFile cpuTempFilePath getAllTemperatureFiles :: FilePath -> IO [FilePath] getAllTemperatureFiles temperaturesDirectory = filter (liftM2 (&&) (isPrefixOf "temp") (isSuffixOf "input")) <$> listDirectory temperaturesDirectory getCPUTemperatures :: IO [(String, Double)] getCPUTemperatures = do dir <- getCPUTemperatureDirectory let mkPair filename = (filename,) <$> readCPUTempFile (dir filename) getAllTemperatureFiles dir >>= mapM mkPair taffybar-4.1.1/src/System/Taffybar/Information/Chrome.hs0000644000000000000000000001075107346545000021357 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Information.Chrome where 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 import qualified Data.Map as M import Data.Maybe import qualified GI.GLib as Gdk import qualified GI.GdkPixbuf as Gdk import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Information.SafeX11 import Text.Read hiding (lift) import Text.Regex import Web.Scotty logIO :: System.Log.Logger.Priority -> String -> IO () logIO = logM "System.Taffybar.Information.Chrome" data ChromeTabImageData = ChromeTabImageData { tabImageData :: Gdk.Pixbuf , tabImageDataId :: Int } newtype ChromeTabImageDataState = ChromeTabImageDataState (MVar (M.Map Int ChromeTabImageData), TChan ChromeTabImageData) getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState getChromeTabImageDataState = do ChromeFaviconServerPort port <- fromMaybe (ChromeFaviconServerPort 5000) <$> getState getStateDefault (listenForChromeFaviconUpdates port) getChromeTabImageDataChannel :: TaffyIO (TChan ChromeTabImageData) getChromeTabImageDataChannel = do ChromeTabImageDataState (_, chan) <- getChromeTabImageDataState return chan getChromeTabImageDataTable :: TaffyIO (MVar (M.Map Int ChromeTabImageData)) getChromeTabImageDataTable = do ChromeTabImageDataState (table, _) <- getChromeTabImageDataState return table newtype ChromeFaviconServerPort = ChromeFaviconServerPort Int listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState listenForChromeFaviconUpdates port = do infoVar <- lift $ newMVar M.empty inChan <- liftIO newBroadcastTChanIO outChan <- liftIO . atomically $ dupTChan inChan _ <- lift $ forkIO $ scotty port $ post "/setTabImageData/:tabID" $ do tabID <- queryParam "tabID" imageData <- LBS.toStrict <$> body when (BS.length imageData > 0) $ lift $ do loader <- Gdk.pixbufLoaderNew Gdk.pixbufLoaderWriteBytes loader =<< Gdk.bytesNew (Just imageData) Gdk.pixbufLoaderClose loader let updateChannelAndMVar pixbuf = let chromeTabImageData = ChromeTabImageData { tabImageData = pixbuf , tabImageDataId = tabID } in modifyMVar_ infoVar $ \currentMap -> do _ <- atomically $ writeTChan inChan chromeTabImageData return $ M.insert tabID chromeTabImageData currentMap Gdk.pixbufLoaderGetPixbuf loader >>= maybe (return ()) updateChannelAndMVar return $ ChromeTabImageDataState (infoVar, outChan) newtype X11WindowToChromeTabId = X11WindowToChromeTabId (MVar (M.Map X11Window Int)) getX11WindowToChromeTabId :: TaffyIO X11WindowToChromeTabId getX11WindowToChromeTabId = getStateDefault $ X11WindowToChromeTabId <$> maintainX11WindowToChromeTabId maintainX11WindowToChromeTabId :: TaffyIO (MVar (M.Map X11Window Int)) maintainX11WindowToChromeTabId = do startTabMap <- updateTabMap M.empty tabMapVar <- lift $ newMVar startTabMap let handleEvent PropertyEvent { ev_window = window } = do title <- runX11Def "" $ getWindowTitle window lift $ modifyMVar_ tabMapVar $ \currentMap -> do let newMap = addTabIdEntry currentMap (window, title) logIO DEBUG (show newMap) return newMap handleEvent _ = return () _ <- subscribeToPropertyEvents [ewmhWMName] handleEvent return tabMapVar tabIDRegex :: Regex tabIDRegex = mkRegexWithOpts "[|]%([0-9]*)%[|]" True True getTabIdFromTitle :: String -> Maybe Int getTabIdFromTitle title = matchRegex tabIDRegex title >>= listToMaybe >>= readMaybe addTabIdEntry :: M.Map X11Window Int -> (X11Window, String) -> M.Map X11Window Int addTabIdEntry theMap (win, title) = maybe theMap ((flip $ M.insert win) theMap) $ getTabIdFromTitle title updateTabMap :: M.Map X11Window Int -> TaffyIO (M.Map X11Window Int) updateTabMap tabMap = runX11Def tabMap $ do wins <- getWindows titles <- mapM getWindowTitle wins let winsWithTitles = zip wins titles return $ foldl addTabIdEntry tabMap winsWithTitles taffybar-4.1.1/src/System/Taffybar/Information/Crypto.hs0000644000000000000000000001363707346545000021430 0ustar0000000000000000{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.Crypto -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This module provides utility functions for retrieving data about crypto -- assets. ----------------------------------------------------------------------------- module System.Taffybar.Information.Crypto where 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 import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.UTF8 as BS import qualified Data.Map as M import Data.Maybe import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import GHC.TypeLits import Network.HTTP.Simple hiding (Proxy) import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Util import Text.Printf getSymbolToCoinGeckoId :: MonadIO m => m (M.Map Text Text) getSymbolToCoinGeckoId = do let uri = "https://api.coingecko.com/api/v3/coins/list?include_platform=false" request = parseRequest_ uri bodyText <- liftIO $ catchAny (getResponseBody <$> httpLBS request) $ \e -> do liftIO $ logM "System.Taffybar.Information.Crypto" WARNING $ printf "Error fetching coins list from coin gecko %s" $ show e return "" let coinInfos :: [CoinGeckoInfo] coinInfos = fromMaybe [] $ decode bodyText return $ M.fromList $ map (\CoinGeckoInfo { identifier = theId, symbol = theSymbol } -> (theSymbol, theId)) coinInfos newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map Text Text) newtype CryptoPriceInfo = CryptoPriceInfo { lastPrice :: Double } newtype CryptoPriceChannel (a :: Symbol) = CryptoPriceChannel (TChan CryptoPriceInfo, MVar CryptoPriceInfo) getCryptoPriceChannel :: KnownSymbol a => TaffyIO (CryptoPriceChannel a) getCryptoPriceChannel = do -- XXX: This is a gross hack that is needed to avoid deadlock symbolToId <- getStateDefault $ SymbolToCoinGeckoId <$> getSymbolToCoinGeckoId getStateDefault $ buildCryptoPriceChannel (60.0 :: Double) symbolToId data CoinGeckoInfo = CoinGeckoInfo { identifier :: Text, symbol :: Text } deriving (Show) instance FromJSON CoinGeckoInfo where parseJSON = withObject "CoinGeckoInfo" (\v -> CoinGeckoInfo <$> v .: "id" <*> v .: "symbol") logCrypto :: MonadIO m => Priority -> String -> m () logCrypto p = liftIO . logM "System.Taffybar.Information.Crypto" p resolveSymbolPair :: KnownSymbol a => Proxy a -> SymbolToCoinGeckoId -> Either String (Text, Text) resolveSymbolPair sym symbolToId = do (symbolName, inCurrency) <- parseSymbolPair (symbolVal sym) cgIdentifier <- lookupSymbolCoinGeckoId symbolToId symbolName pure (cgIdentifier, inCurrency) where parseSymbolPair :: String -> Either String (Text, Text) parseSymbolPair symbolPair = case T.splitOn "-" (T.toLower $ T.pack symbolPair) of [symbolName, inCurrency] | not (T.null inCurrency) -> Right (symbolName, inCurrency) _ -> Left $ printf "Type parameter \"%s\" does not match the form \"ASSET-CURRENCY\"" symbolPair lookupSymbolCoinGeckoId :: SymbolToCoinGeckoId -> Text -> Either String Text lookupSymbolCoinGeckoId (SymbolToCoinGeckoId m) symbolName = maybeToEither (printf "Symbol \"%s\" not found in coin gecko list" (T.unpack symbolName)) (M.lookup symbolName m) buildCryptoPriceChannel :: forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a) buildCryptoPriceChannel delay symbolToId = do let initialBackoff = delay chan <- liftIO newBroadcastTChanIO var <- liftIO $ newMVar $ CryptoPriceInfo 0.0 backoffVar <- liftIO $ newMVar initialBackoff let doWrites info = do _ <- swapMVar var info _ <- atomically $ writeTChan chan info _ <- swapMVar backoffVar initialBackoff return () case resolveSymbolPair (Proxy :: Proxy a) symbolToId of Left err -> logCrypto WARNING err Right (cgIdentifier, inCurrency) -> void $ foreverWithVariableDelay $ catchAny (liftIO $ getLatestPrice cgIdentifier inCurrency >>= maybe (return ()) (doWrites . CryptoPriceInfo) >> return delay) $ \e -> do logCrypto WARNING $ printf "Error when fetching crypto price: %s" (show e) modifyMVar backoffVar $ \current -> return (min (current * 2) delay, current) return $ CryptoPriceChannel (chan, var) getLatestPrice :: MonadIO m => Text -> Text -> m (Maybe Double) getLatestPrice tokenId inCurrency = do let uri = printf "https://api.coingecko.com/api/v3/simple/price?ids=%s&vs_currencies=%s" tokenId inCurrency request = parseRequest_ uri bodyText <- getResponseBody <$> httpLBS request return $ decode bodyText >>= parseMaybe ((.: Key.fromText tokenId) >=> (.: Key.fromText inCurrency)) getCryptoMeta :: MonadIO m => String -> String -> m LBS.ByteString getCryptoMeta cmcAPIKey symbolName = do let headers = [("X-CMC_PRO_API_KEY", BS.fromString cmcAPIKey)] :: RequestHeaders uri = printf "https://pro-api.coinmarketcap.com/v1/cryptocurrency/info?symbol=%s" symbolName request = setRequestHeaders headers $ parseRequest_ uri getResponseBody <$> httpLBS request taffybar-4.1.1/src/System/Taffybar/Information/DiskIO.hs0000644000000000000000000000311507346545000021260 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.DiskIO -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Provides information about read/write operations in a given disk or -- partition, obtained from parsing the @\/proc\/diskstats@ file with some -- of the facilities included in the "System.Taffybar.Information.StreamInfo" module. ----------------------------------------------------------------------------- module System.Taffybar.Information.DiskIO ( getDiskTransfer ) where import Data.Maybe ( mapMaybe ) import Safe ( atMay, headMay, readDef ) import System.Taffybar.Information.StreamInfo ( getParsedInfo, getTransfer ) -- | Returns a two-element list containing the speed of transfer for read and -- write operations performed in the given disk\/partition (e.g. \"sda\", -- \"sda1\"). getDiskTransfer :: String -> IO [Double] getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk -- | Returns the list of all the values available in @\/proc\/diskstats@ -- for the given disk or partition. getDiskInfo :: String -> IO [Int] getDiskInfo = getParsedInfo "/proc/diskstats" parse parse :: String -> [(String, [Int])] parse = mapMaybe (tuplize . drop 2 . words) . lines tuplize :: [String] -> Maybe (String, [Int]) tuplize s = do device <- headMay s used <- s `atMay` 3 capacity <- s `atMay` 7 return (device, [readDef (-1) used, readDef (-1) capacity]) taffybar-4.1.1/src/System/Taffybar/Information/EWMHDesktopInfo.hs0000644000000000000000000002342707346545000023054 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.EWMHDesktopInfo -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Functions to access data provided by the X11 desktop via EWHM hints. This -- module requires that the EwmhDesktops hook from the XMonadContrib project -- be installed in your @~\/.xmonad\/xmonad.hs@ configuration: -- -- > import XMonad -- > import XMonad.Hooks.EwmhDesktops (ewmh) -- > -- > main = xmonad $ ewmh $ ... -- ----------------------------------------------------------------------------- module System.Taffybar.Information.EWMHDesktopInfo ( EWMHIcon(..) , EWMHIconData , WorkspaceId(..) , X11Window , allEWMHProperties , ewmhActiveWindow , ewmhClientList , ewmhClientListStacking , ewmhCurrentDesktop , ewmhDesktopNames , ewmhNumberOfDesktops , ewmhStateHidden , ewmhWMClass , ewmhWMDesktop , ewmhWMIcon , ewmhWMName , ewmhWMName2 , ewmhWMState , ewmhWMStateHidden , focusWindow , getActiveWindow , getCurrentWorkspace , getVisibleWorkspaces , getWindowClass , getWindowIconsData , getWindowMinimized , getWindowState , getWindowStateProperty , getWindowTitle , getWindows , getWindowsStacking , getWorkspace , getWorkspaceNames , isWindowUrgent , parseWindowClasses , switchOneWorkspace , switchToWorkspace , withX11Context , withEWMHIcons ) where import Control.Monad ((>=>)) import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.List import Data.List.Split import Data.Maybe import Data.Tuple import Data.Word import Foreign.ForeignPtr import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import System.Log.Logger import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo logHere :: MonadIO m => Priority -> String -> m () logHere p = liftIO . logM "System.Taffybar.Information.EWMHDesktopInfo" p newtype WorkspaceId = WorkspaceId Int deriving (Show, Read, Ord, Eq) -- A super annoying detail of the XGetWindowProperty interface is that: "If the -- returned format is 32, the returned data is represented as a long array and -- should be cast to that type to obtain the elements." This means that even -- though only the 4 least significant bits will ever contain any data, the -- array that is returned from X11 can have a larger word size. This means that -- we need to manipulate the underlying data in annoying ways to pass it to gtk -- appropriately. type PixelsWordType = Word64 type EWMHProperty = String ewmhActiveWindow, ewmhClientList, ewmhClientListStacking, ewmhCurrentDesktop, ewmhDesktopNames, ewmhNumberOfDesktops, ewmhStateHidden, ewmhWMDesktop, ewmhWMStateHidden, ewmhWMClass, ewmhWMState, ewmhWMIcon, ewmhWMName, ewmhWMName2 :: EWMHProperty ewmhActiveWindow = "_NET_ACTIVE_WINDOW" ewmhClientList = "_NET_CLIENT_LIST" ewmhClientListStacking = "_NET_CLIENT_LIST_STACKING" ewmhCurrentDesktop = "_NET_CURRENT_DESKTOP" ewmhDesktopNames = "_NET_DESKTOP_NAMES" ewmhNumberOfDesktops = "_NET_NUMBER_OF_DESKTOPS" ewmhStateHidden = "_NET_WM_STATE_HIDDEN" ewmhWMClass = "WM_CLASS" ewmhWMDesktop = "_NET_WM_DESKTOP" ewmhWMIcon = "_NET_WM_ICON" ewmhWMName = "_NET_WM_NAME" ewmhWMName2 = "WM_NAME" ewmhWMState = "_NET_WM_STATE" ewmhWMStateHidden = "_NET_WM_STATE_HIDDEN" allEWMHProperties :: [EWMHProperty] allEWMHProperties = [ ewmhActiveWindow , ewmhClientList , ewmhClientListStacking , ewmhCurrentDesktop , ewmhDesktopNames , ewmhNumberOfDesktops , ewmhStateHidden , ewmhWMClass , ewmhWMDesktop , ewmhWMIcon , ewmhWMName , ewmhWMName2 , ewmhWMState , ewmhWMStateHidden ] type EWMHIconData = (ForeignPtr PixelsWordType, Int) data EWMHIcon = EWMHIcon { ewmhWidth :: Int , ewmhHeight :: Int , ewmhPixelsARGB :: Ptr PixelsWordType } deriving (Show, Eq) getWindowStateProperty :: String -> X11Window -> X11Property Bool getWindowStateProperty property window = not . null <$> getWindowState window [property] getWindowState :: X11Window -> [String] -> X11Property [String] getWindowState window request = do let getAsLong s = fromIntegral <$> getAtom s integers <- mapM getAsLong request properties <- fetch getWindowProperty32 (Just window) ewmhWMState let integerToString = zip integers request present = intersect integers $ fromMaybe [] properties presentStrings = map (`lookup` integerToString) present return $ catMaybes presentStrings -- | Get a bool reflecting whether window with provided X11Window is minimized -- or not. getWindowMinimized :: X11Window -> X11Property Bool getWindowMinimized = getWindowStateProperty ewmhStateHidden -- | Retrieve the index of the current workspace in the desktop, starting from -- 0. getCurrentWorkspace :: X11Property WorkspaceId getCurrentWorkspace = WorkspaceId <$> readAsInt Nothing ewmhCurrentDesktop -- | Retrieve the indexes of all currently visible workspaces -- with the active workspace at the head of the list. getVisibleWorkspaces :: X11Property [WorkspaceId] getVisibleWorkspaces = do vis <- getVisibleTags allNames <- map swap <$> getWorkspaceNames cur <- getCurrentWorkspace return $ cur : mapMaybe (`lookup` allNames) vis -- | Return a list with the names of all the workspaces currently -- available. getWorkspaceNames :: X11Property [(WorkspaceId, String)] getWorkspaceNames = go <$> readAsListOfString Nothing ewmhDesktopNames where go = zip [WorkspaceId i | i <- [0..]] -- | Ask the window manager to switch to the workspace with the given -- index, starting from 0. switchToWorkspace :: WorkspaceId -> X11Property () switchToWorkspace (WorkspaceId idx) = do cmd <- getAtom ewmhCurrentDesktop sendCommandEvent cmd (fromIntegral idx) -- | Move one workspace up or down from the current workspace switchOneWorkspace :: Bool -> Int -> X11Property () switchOneWorkspace dir end = do cur <- getCurrentWorkspace switchToWorkspace $ if dir then getPrev cur end else getNext cur end -- | Check for corner case and switch one workspace up getPrev :: WorkspaceId -> Int -> WorkspaceId getPrev (WorkspaceId idx) end | idx > 0 = WorkspaceId $ idx-1 | otherwise = WorkspaceId end -- | Check for corner case and switch one workspace down getNext :: WorkspaceId -> Int -> WorkspaceId getNext (WorkspaceId idx) end | idx < end = WorkspaceId $ idx+1 | otherwise = WorkspaceId 0 -- | Get the title of the given X11 window. getWindowTitle :: X11Window -> X11Property String getWindowTitle window = do let w = Just window prop <- readAsString w ewmhWMName case prop of "" -> readAsString w ewmhWMName2 _ -> return prop -- | Get the class of the given X11 window. getWindowClass :: X11Window -> X11Property String getWindowClass window = readAsString (Just window) ewmhWMClass parseWindowClasses :: String -> [String] parseWindowClasses = filter (not . null) . splitOn "\NUL" -- | Get EWMHIconData for the given X11Window getWindowIconsData :: X11Window -> X11Property (Maybe EWMHIconData) getWindowIconsData window = do dpy <- getDisplay atom <- getAtom ewmhWMIcon lift $ rawGetWindowPropertyBytes 32 dpy atom window -- | Operate on the data contained in 'EWMHIconData' in the easier to interact -- with format offered by 'EWMHIcon'. This function is much like -- 'withForeignPtr' in that the 'EWMHIcon' values that are provided to the -- callable argument should not be kept around in any way, because it can not be -- guaranteed that the finalizer for the memory to which those icon objects -- point will not be executed, after the call to 'withEWMHIcons' completes. withEWMHIcons :: EWMHIconData -> ([EWMHIcon] -> IO a) -> IO a withEWMHIcons (fptr, size) action = withForeignPtr fptr (parseIcons size >=> action) -- | Split icon raw integer data into EWMHIcons. Each icon raw data is an -- integer for width, followed by height, followed by exactly (width*height) -- ARGB pixels, optionally followed by the next icon. -- -- XXX: This function should not be made public, because its return value contains -- (sub)pointers whose allocation we do not control. parseIcons :: Int -> Ptr PixelsWordType -> IO [EWMHIcon] parseIcons 0 _ = return [] parseIcons totalSize arr = do iwidth <- fromIntegral <$> peek arr iheight <- fromIntegral <$> peekElemOff arr 1 let pixelsPtr = advancePtr arr 2 thisSize = iwidth * iheight newArr = advancePtr pixelsPtr thisSize thisIcon = EWMHIcon { ewmhWidth = iwidth , ewmhHeight = iheight , ewmhPixelsARGB = pixelsPtr } getRes newSize | newSize < 0 = logHere ERROR "Attempt to recurse on negative value in parseIcons" >> return [] | otherwise = (thisIcon :) <$> parseIcons newSize newArr getRes $ totalSize - fromIntegral (thisSize + 2) -- | Get the window that currently has focus if such a window exists. getActiveWindow :: X11Property (Maybe X11Window) getActiveWindow = find (> 0) <$> readAsListOfWindow Nothing ewmhActiveWindow -- | Return a list of all @X11Window@s, sorted by initial mapping order, oldest to newest. getWindows :: X11Property [X11Window] getWindows = readAsListOfWindow Nothing ewmhClientList -- | Return a list of all @X11Window@s, sorted in stacking order, bottom-to-top. getWindowsStacking :: X11Property [X11Window] getWindowsStacking = readAsListOfWindow Nothing ewmhClientListStacking -- | Return the index (starting from 0) of the workspace on which the given -- window is being displayed. getWorkspace :: X11Window -> X11Property WorkspaceId getWorkspace window = WorkspaceId <$> readAsInt (Just window) ewmhWMDesktop -- | Ask the window manager to give focus to the given window. focusWindow :: X11Window -> X11Property () focusWindow wh = do cmd <- getAtom ewmhActiveWindow sendWindowEvent cmd (fromIntegral wh) taffybar-4.1.1/src/System/Taffybar/Information/MPRIS2.hs0000644000000000000000000000535707346545000021124 0ustar0000000000000000{-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.MPRIS2 -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- ----------------------------------------------------------------------------- module System.Taffybar.Information.MPRIS2 where import Control.Applicative import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import qualified DBus import qualified DBus.Client as DBus import qualified DBus.Internal.Types as DBus import qualified DBus.TH as DBus import Data.Coerce import Data.List import qualified Data.Map as M import Data.Maybe import System.Log.Logger import System.Taffybar.DBus.Client.MPRIS2 import Text.Printf data NowPlaying = NowPlaying { npTitle :: String , npArtists :: [String] , npStatus :: String , npBusName :: DBus.BusName } deriving (Show, Eq) eitherToMaybeWithLog :: (MonadIO m, Show a1) => Either a1 a2 -> m (Maybe a2) eitherToMaybeWithLog (Right v) = return $ Just v eitherToMaybeWithLog (Left e) = liftIO $ do logM "System.Taffybar.Information.MPRIS2" WARNING $ printf "Got error: %s" $ show e return Nothing getNowPlayingInfo :: MonadIO m => DBus.Client -> m [NowPlaying] getNowPlayingInfo client = fmap (fromMaybe []) $ eitherToMaybeWithLog =<< liftIO (runExceptT $ do allBusNames <- ExceptT $ DBus.listNames client let mediaPlayerBusNames = filter (isPrefixOf "org.mpris.MediaPlayer2.") allBusNames getSongData _busName = runMaybeT $ do let busName = coerce _busName metadataMap <- MaybeT $ getMetadata client busName >>= eitherToMaybeWithLog (title, artists) <- MaybeT $ return $ getSongInfo metadataMap status <- MaybeT $ getPlaybackStatus client busName >>= eitherToMaybeWithLog return NowPlaying { npTitle = title , npArtists = artists , npStatus = status , npBusName = busName } lift $ catMaybes <$> mapM getSongData mediaPlayerBusNames) getSongInfo :: M.Map String DBus.Variant -> Maybe (String, [String]) getSongInfo songData = do let lookupVariant k = M.lookup k songData >>= DBus.fromVariant artists <- lookupVariant "xesam:artist" <|> pure [] title <- lookupVariant "xesam:title" return (title, artists) taffybar-4.1.1/src/System/Taffybar/Information/Memory.hs0000644000000000000000000000433307346545000021411 0ustar0000000000000000module System.Taffybar.Information.Memory ( MemoryInfo(..), parseMeminfo ) where toMB :: String -> Double toMB size = (read size :: Double) / 1024 data MemoryInfo = MemoryInfo { memoryTotal :: Double , memoryFree :: Double , memoryBuffer :: Double , memoryCache :: Double , memorySwapTotal :: Double , memorySwapFree :: Double , memorySwapUsed :: Double -- swapTotal - swapFree , memorySwapUsedRatio :: Double -- swapUsed / swapTotal , memoryAvailable :: Double -- An estimate of how much memory is available , memoryRest :: Double -- free + buffer + cache , memoryUsed :: Double -- total - rest , memoryUsedRatio :: Double -- used / total } emptyMemoryInfo :: MemoryInfo emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0 0 0 0 0 0 parseLines :: [String] -> MemoryInfo -> MemoryInfo parseLines (line:rest) memInfo = parseLines rest newMemInfo where newMemInfo = case words line of (label:size:_) -> case label of "MemTotal:" -> memInfo { memoryTotal = toMB size } "MemFree:" -> memInfo { memoryFree = toMB size } "MemAvailable:" -> memInfo { memoryAvailable = toMB size } "Buffers:" -> memInfo { memoryBuffer = toMB size } "Cached:" -> memInfo { memoryCache = toMB size } "SwapTotal:" -> memInfo { memorySwapTotal = toMB size } "SwapFree:" -> memInfo { memorySwapFree = toMB size } _ -> memInfo _ -> memInfo parseLines _ memInfo = memInfo parseMeminfo :: IO MemoryInfo parseMeminfo = do s <- readFile "/proc/meminfo" let m = parseLines (lines s) emptyMemoryInfo rest = memoryFree m + memoryBuffer m + memoryCache m used = memoryTotal m - rest usedRatio = used / memoryTotal m swapUsed = memorySwapTotal m - memorySwapFree m swapUsedRatio = swapUsed / memorySwapTotal m return m { memoryRest = rest , memoryUsed = used , memoryUsedRatio = usedRatio , memorySwapUsed = swapUsed , memorySwapUsedRatio = swapUsedRatio } taffybar-4.1.1/src/System/Taffybar/Information/Network.hs0000644000000000000000000001176607346545000021602 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.Network -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Provides information about network traffic over selected interfaces, -- obtained from parsing the @\/proc\/net\/dev@ file using some of the -- facilities provided by the "System.Taffybar.Information.StreamInfo" module. -- ----------------------------------------------------------------------------- module System.Taffybar.Information.Network where import qualified Control.Concurrent.MVar as MV import Control.Exception (catch, SomeException) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.Maybe ( mapMaybe ) import Data.Time.Clock import Data.Time.Clock.System import Safe ( atMay, initSafe, readDef ) import System.Taffybar.Information.StreamInfo ( getParsedInfo ) import System.Taffybar.Util networkInfoFile :: FilePath networkInfoFile = "/proc/net/dev" -- | Returns a two-element list containing the current number of bytes received -- and transmitted via the given network interface (e.g. \"wlan0\"), according -- to the contents of the @\/proc\/dev\/net@ file. getNetInfo :: String -> IO (Maybe [Int]) getNetInfo iface = runMaybeT $ do isInterfaceUp iface handleFailure $ getParsedInfo networkInfoFile parseDevNet' iface parseDevNet' :: String -> [(String, [Int])] parseDevNet' input = map makeList $ parseDevNet input where makeList (a, (u, d)) = (a, [u, d]) parseDevNet :: String -> [(String, (Int, Int))] parseDevNet = mapMaybe (getDeviceUpDown . words) . drop 2 . lines getDeviceUpDown :: [String] -> Maybe (String, (Int, Int)) getDeviceUpDown s = do dev <- initSafe <$> s `atMay` 0 down <- readDef (-1) <$> s `atMay` 1 up <- readDef (-1) <$> s `atMay` out dev `seq` down `seq` up `seq` return (dev, (down, up)) where out = length s - 8 -- Nothing if interface does not exist or is down isInterfaceUp :: String -> MaybeT IO () isInterfaceUp iface = do state <- handleFailure $ readFile $ "/sys/class/net/" ++ iface ++ "/operstate" case state of 'u' : _ -> return () _ -> mzero handleFailure :: IO a -> MaybeT IO a handleFailure action = MaybeT $ catch (Just <$> action) eToNothing where eToNothing :: SomeException -> IO (Maybe a) eToNothing _ = pure Nothing getDeviceSamples :: IO (Maybe [TxSample]) getDeviceSamples = runMaybeT $ handleFailure $ do contents <- readFile networkInfoFile length contents `seq` return () time <- liftIO getSystemTime let mkSample (device, (up, down)) = TxSample { sampleUp = up , sampleDown = down , sampleTime = time , sampleDevice = device } return $ map mkSample $ parseDevNet contents data TxSample = TxSample { sampleUp :: Int , sampleDown :: Int , sampleTime :: SystemTime , sampleDevice :: String } deriving (Show, Eq) monitorNetworkInterfaces :: RealFrac a1 => a1 -> ([(String, (Rational, Rational))] -> IO ()) -> IO () monitorNetworkInterfaces interval onUpdate = void $ do samplesVar <- MV.newMVar [] let sampleToSpeeds (device, (s1, s2)) = (device, getSpeed s1 s2) doOnUpdate samples = do let speedInfo = map sampleToSpeeds samples onUpdate speedInfo return samples doUpdate = MV.modifyMVar_ samplesVar (updateSamples >=> doOnUpdate) foreverWithDelay interval doUpdate updateSamples :: [(String, (TxSample, TxSample))] -> IO [(String, (TxSample, TxSample))] updateSamples currentSamples = do let getLast sample@TxSample { sampleDevice = device } = maybe sample fst $ lookup device currentSamples getSamplePair sample@TxSample { sampleDevice = device } = let lastSample = getLast sample in lastSample `seq` (device, (sample, lastSample)) maybe currentSamples (map getSamplePair) <$> getDeviceSamples getSpeed :: TxSample -> TxSample -> (Rational, Rational) getSpeed TxSample { sampleUp = thisUp , sampleDown = thisDown , sampleTime = thisTime } TxSample { sampleUp = lastUp , sampleDown = lastDown , sampleTime = lastTime } = let intervalDiffTime = diffUTCTime (systemToUTCTime thisTime) (systemToUTCTime lastTime) intervalRatio = if intervalDiffTime == 0 then 0 else toRational $ 1 / intervalDiffTime in ( fromIntegral (thisDown - lastDown) * intervalRatio , fromIntegral (thisUp - lastUp) * intervalRatio ) sumSpeeds :: [(Rational, Rational)] -> (Rational, Rational) sumSpeeds = foldr1 sumOne where sumOne (d1, u1) (d2, u2) = (d1 + d2, u1 + u2) taffybar-4.1.1/src/System/Taffybar/Information/SafeX11.hs0000644000000000000000000001716007346545000021313 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances, InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-} {-# OPTIONS_GHC -Wno-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.SafeX11 -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable ----------------------------------------------------------------------------- module System.Taffybar.Information.SafeX11 ( module Graphics.X11.Xlib , module Graphics.X11.Xlib.Extras , getWMHints , getWindowProperty8 , getWindowProperty16 , getWindowProperty32 , postX11RequestSyncDef , rawGetWindowPropertyBytes , safeGetGeometry ) where import Control.Concurrent import Control.Exception import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.Either.Combinators import Data.Typeable import Foreign hiding (void) import Foreign.C.Types import GHC.ForeignPtr import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras hiding (rawGetWindowProperty, getWindowProperty8, getWindowProperty16, getWindowProperty32, xGetWMHints, getWMHints, refreshKeyboardMapping) import System.IO.Unsafe import System.Log.Logger import System.Timeout import Text.Printf logHere :: Priority -> String -> IO () logHere = logM "System.Taffybar.Information.SafeX11" foreign import ccall safe "XlibExtras.h XGetWMHints" safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints) foreign import ccall interruptible "XlibExtras.h XGetWindowProperty" safeXGetWindowProperty :: Display -> Window -> Atom -> CLong -> CLong -> Bool -> Atom -> Ptr Atom -> Ptr CInt -> Ptr CULong -> Ptr CULong -> Ptr (Ptr CUChar) -> IO Status rawGetWindowPropertyBytes :: Storable a => Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int)) rawGetWindowPropertyBytes bits d atom w = alloca $ \actual_type_return -> alloca $ \actual_format_return -> alloca $ \nitems_return -> alloca $ \bytes_after_return -> alloca $ \prop_return -> do ret <- postX11RequestSync $ safeXGetWindowProperty d w atom 0 0xFFFFFFFF False anyPropertyType actual_type_return actual_format_return nitems_return bytes_after_return prop_return if fromRight (-1) ret /= 0 then return Nothing else do prop_ptr <- peek prop_return actual_format <- fromIntegral `fmap` peek actual_format_return nitems <- fromIntegral `fmap` peek nitems_return getprop prop_ptr nitems actual_format where getprop prop_ptr nitems actual_format | actual_format == 0 = return Nothing -- Property not found | actual_format /= bits = xFree prop_ptr >> return Nothing | otherwise = do ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr) return $ Just (ptr, nitems) data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable) instance Exception SafeX11Exception data IORequest = forall a. IORequest { ioAction :: IO a , ioResponse :: Chan (Either SafeX11Exception a) } {-# NOINLINE requestQueue #-} requestQueue :: Chan IORequest requestQueue = unsafePerformIO newChan {-# NOINLINE x11Thread #-} x11Thread :: ThreadId x11Thread = unsafePerformIO $ forkIO startHandlingX11Requests withErrorHandler :: XErrorHandler -> IO a -> IO a withErrorHandler new_handler action = do handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0) original <- _xSetErrorHandler handler res <- action _ <- _xSetErrorHandler original return res deriving instance Show ErrorEvent startHandlingX11Requests :: IO () startHandlingX11Requests = withErrorHandler handleError handleX11Requests where handleError _ xerrptr = do ee <- getErrorEvent xerrptr logHere WARNING $ printf "Handling X11 error with error handler: %s" $ show ee handleX11Requests :: IO () handleX11Requests = do IORequest {ioAction = action, ioResponse = responseChannel} <- readChan requestQueue res <- catch (maybe (Left SafeX11Exception) Right <$> timeout 500000 action) (\e -> do logHere WARNING $ printf "Handling X11 error with catch: %s" $ show (e :: IOException) return $ Left SafeX11Exception) writeChan responseChannel res handleX11Requests return () postX11RequestSync :: IO a -> IO (Either SafeX11Exception a) postX11RequestSync action = do let postAndWait = do responseChannel <- newChan :: IO (Chan (Either SafeX11Exception a)) writeChan requestQueue IORequest {ioAction = action, ioResponse = responseChannel} readChan responseChannel currentTID <- myThreadId if currentTID == x11Thread then Right <$> action else postAndWait postX11RequestSyncDef :: a -> IO a -> IO a postX11RequestSyncDef def action = fromRight def <$> postX11RequestSync action rawGetWindowProperty :: Storable a => Int -> Display -> Atom -> Window -> IO (Maybe [a]) rawGetWindowProperty bits d atom w = runMaybeT $ do (ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w lift $ withForeignPtr ptr $ peekArray count getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar]) getWindowProperty8 = rawGetWindowProperty 8 getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort]) getWindowProperty16 = rawGetWindowProperty 16 getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong]) getWindowProperty32 = rawGetWindowProperty 32 getWMHints :: Display -> Window -> IO WMHints getWMHints dpy w = do p <- safeXGetWMHints dpy w if p == nullPtr then return $ WMHints 0 False 0 0 0 0 0 0 0 else do x <- peek p; _ <- xFree p; return x safeGetGeometry :: Display -> Drawable -> IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt) safeGetGeometry display d = outParameters7 (throwIfZero "getGeometry") $ xGetGeometry display d outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) => (IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) -> IO (a,b,c,d,e,f,g) outParameters7 check fn = alloca $ \ a_return -> alloca $ \ b_return -> alloca $ \ c_return -> alloca $ \ d_return -> alloca $ \ e_return -> alloca $ \ f_return -> alloca $ \ g_return -> do check (fn a_return b_return c_return d_return e_return f_return g_return) a <- peek a_return b <- peek b_return c <- peek c_return d <- peek d_return e <- peek e_return f <- peek f_return g <- peek g_return return (a,b,c,d,e,f,g) foreign import ccall safe "HsXlib.h XGetGeometry" xGetGeometry :: Display -> Drawable -> Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension -> Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status taffybar-4.1.1/src/System/Taffybar/Information/StreamInfo.hs0000644000000000000000000000635407346545000022215 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.StreamInfo -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Generic code to poll any of the many data files maintained by the kernel in -- POSIX systems. Provides methods for applying a custom parsing function to the -- contents of the file and to calculate differentials across one or more values -- provided via the file. -- -------------------------------------------------------------------------------- module System.Taffybar.Information.StreamInfo ( getParsedInfo , getLoad , getAccLoad , getTransfer ) where import Control.Concurrent ( threadDelay ) import Data.IORef import Data.Maybe ( fromMaybe ) -- | Apply the given parser function to the file under the given path to produce -- a lookup map, then use the given selector as key to extract from it the -- desired value. getParsedInfo :: FilePath -> (String -> [(String, [a])]) -> String -> IO [a] getParsedInfo path parser selector = do file <- readFile path length file `seq` return () return (fromMaybe [] $ lookup selector $ parser file) truncVal :: (RealFloat a) => a -> a truncVal v | isNaN v || v < 0.0 = 0.0 | otherwise = v -- | Convert the given list of Integer to a list of the ratios of each of its -- elements against their sum. toRatioList :: (Integral a, RealFloat b) => [a] -> [b] toRatioList deltas = map truncVal ratios where total = fromIntegral $ sum deltas ratios = map ((/total) . fromIntegral) deltas -- | Execute the given action twice with the given delay in-between and return -- the difference between the two samples. probe :: (Num a, RealFrac b) => IO [a] -> b -> IO [a] probe action delay = do a <- action threadDelay $ round (delay * 1e6) b <- action return $ zipWith (-) b a -- | Execute the given action once and return the difference between the -- obtained sample and the one contained in the given IORef. accProbe :: (Num a) => IO [a] -> IORef [a] -> IO [a] accProbe action sample = do a <- readIORef sample b <- action writeIORef sample b return $ zipWith (-) b a -- | Probe the given action and, interpreting the result as a variation in time, -- return the speed of change of its values. getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b] getTransfer interval action = do deltas <- probe action interval return $ map (truncVal . (/interval) . fromIntegral) deltas -- | Probe the given action and return the relative variation of each of the -- obtained values against the whole, where the whole is calculated as the sum -- of all the values in the probe. getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b] getLoad interval action = toRatioList <$> probe action interval -- | Similar to getLoad, but execute the given action only once and use the -- given IORef to calculate the result and to save the current value, so it -- can be reused in the next call. getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b] getAccLoad sample action = toRatioList <$> accProbe action sample taffybar-4.1.1/src/System/Taffybar/Information/X11DesktopInfo.hs0000644000000000000000000002741407346545000022665 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.X11DesktopInfo -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan Malison -- Stability : unstable -- Portability : unportable -- -- Low-level functions to access data provided by the X11 desktop via window -- properties. One of them ('getVisibleTags') depends on the -- 'XMonad.Hooks.TaffybarPagerHints.pagerHints' hook -- being installed in your @~\/.xmonad\/xmonad.hs@ configuration: -- -- > import XMonad.Hooks.TaffybarPagerHints (pagerHints) -- > -- > main = xmonad $ ewmh $ pagerHints $ ... -- ----------------------------------------------------------------------------- module System.Taffybar.Information.X11DesktopInfo ( -- * Context X11Context , DisplayName(..) , getX11Context , withX11Context -- * Properties , X11Property , X11PropertyT -- ** Event loop , eventLoop -- ** Context getters , getDisplay , getAtom -- ** Basic properties of windows , X11Window , PropertyFetcher , fetch , readAsInt , readAsListOfInt , readAsListOfString , readAsListOfWindow , readAsString -- ** Getters , isWindowUrgent , getPrimaryOutputNumber , getVisibleTags -- ** Operations , doLowerWindow , postX11RequestSyncProp , sendCommandEvent , sendWindowEvent ) where import Codec.Binary.UTF8.String as UTF8 import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class 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 'getX11Context' to construct one of these. data X11Context = X11Context { 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 = X11PropertyT IO a type X11Window = Window type PropertyFetcher a = Display -> Atom -> X11Window -> IO (Maybe [a]) -- | Makes a connection to the default X11 display using -- 'getX11Context' and puts the current display and root window -- objects inside a 'ReaderT' transformer for further computation. withX11Context :: DisplayName -> X11Property a -> IO a withX11Context dn fun = do ctx <- getX11Context dn res <- runReaderT fun ctx closeDisplay (ctxDisplay ctx) return res -- | An X11Property that returns the 'Display' object stored in the -- 'X11Context'. getDisplay :: X11Property Display getDisplay = ctxDisplay <$> ask doRead :: Integral a => b -> ([a] -> b) -> PropertyFetcher a -> Maybe X11Window -> String -> X11Property b 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, -- then return -1. readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property Int readAsInt = doRead (-1) (maybe (-1) fromIntegral . listToMaybe) getWindowProperty32 -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a list of Ints. If that property hasn't been set, then -- return an empty list. readAsListOfInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property [Int] readAsListOfInt = doRead [] (map fromIntegral) getWindowProperty32 -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a String. If the property hasn't been set, then return -- an empty string. readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property String readAsString = doRead "" (UTF8.decode . map fromIntegral) getWindowProperty8 -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a list of Strings. If the property hasn't been set, -- then return an empty list. readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property [String] readAsListOfString = doRead [] parse getWindowProperty8 where parse = endBy "\0" . UTF8.decode . map fromIntegral -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a list of X11 Window IDs. If the property hasn't been -- set, then return an empty list. readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property [X11Window] readAsListOfWindow = doRead [] (map fromIntegral) getWindowProperty32 -- | Determine whether the \"urgent\" flag is set in the WM_HINTS of the given -- window. isWindowUrgent :: X11Window -> X11Property Bool isWindowUrgent window = do hints <- fetchWindowHints window return $ testBit (wmh_flags hints) urgencyHintBit -- | Retrieve the value of the special @_XMONAD_VISIBLE_WORKSPACES@ -- hint set by the 'XMonad.Hooks.TaffybarPagerHints.pagerHints' hook -- provided by [xmonad-contrib]("XMonad.Hooks.TaffybarPagerHints") -- (see module documentation for instructions on how to do this), or -- an empty list of strings if the @pagerHints@ hook is not available. getVisibleTags :: X11Property [String] getVisibleTags = readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES" -- | Return the 'Atom' with the given name. getAtom :: String -> X11Property Atom getAtom s = do d <- asks ctxDisplay cacheVar <- asks ctxAtomCache a <- lift $ lookup s <$> MV.readMVar cacheVar let updateCacheAction = lift $ MV.modifyMVar cacheVar updateCache updateCache currentCache = do atom <- internAtom d s False return ((s, atom):currentCache, atom) maybe updateCacheAction return a -- | Spawn a new thread and listen inside it to all incoming events, invoking -- the given function to every event of type @MapNotifyEvent@ that arrives, and -- subscribing to all events of this type emitted by newly created windows. eventLoop :: (Event -> IO ()) -> X11Property () eventLoop dispatch = do d <- asks ctxDisplay w <- asks ctxRoot liftIO $ do selectInput d w $ propertyChangeMask .|. substructureNotifyMask allocaXEvent $ \e -> forever $ do event <- nextEvent d e >> getEvent e case event of MapNotifyEvent { ev_window = window } -> selectInput d window propertyChangeMask _ -> return () dispatch event -- | Emit a \"command\" event with one argument for the X server. This is used -- 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 = sendCustomEvent cmd arg Nothing -- | Similar to 'sendCommandEvent', but with an argument of type 'X11Window'. sendWindowEvent :: Atom -> X11Window -> X11Property () sendWindowEvent cmd win = sendCustomEvent cmd cmd (Just win) -- | Builds a new 'X11Context' containing a connection to the default -- X11 display and its root window. -- -- 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. 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. fetch :: (Integral a) => PropertyFetcher a -- ^ Function to use to retrieve the property. -> Maybe X11Window -- ^ Window to read from. Nothing means the root Window. -> String -- ^ Name of the property to retrieve. -> X11Property (Maybe [a]) fetch fetcher window name = do X11Context{..} <- ask atom <- getAtom name 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 d <- getDisplay liftIO $ getWMHints d window -- | Emit an event of type @ClientMessage@ that can be listened to and consumed -- by XMonad event hooks. sendCustomEvent :: Atom -- ^ Command -> Atom -- ^ Argument -> Maybe X11Window -- ^ 'Just' a window, or 'Nothing' for the root window -> X11Property () 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 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 a = do c <- ask let action = runReaderT prop c lift $ postX11RequestSyncDef a action -- | 'X11Property' which reflects whether or not the provided 'RROutput' is active. isActiveOutput :: XRRScreenResources -> RROutput -> X11Property Bool isActiveOutput sres output = do 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{..} <- 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{..} <- 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 ctxDisplay >>= lift . flip lowerWindow window taffybar-4.1.1/src/System/Taffybar/Information/XDG/0000755000000000000000000000000007346545000020224 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/Information/XDG/Protocol.hs0000644000000000000000000002246207346545000022367 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.XDG.Protocol -- Copyright : 2017 Ulf Jasper -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ulf Jasper -- Stability : unstable -- Portability : unportable -- -- Implementation of version 1.1 of the XDG "Desktop Menu -- Specification", see -- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html ---- specification, see -- See also 'MenuWidget'. -- ----------------------------------------------------------------------------- module System.Taffybar.Information.XDG.Protocol ( XDGMenu(..) , DesktopEntryCondition(..) , getApplicationEntries , getDirectoryDirs , getPreferredLanguages , getXDGDesktop , getXDGMenuFilenames , matchesCondition , readXDGMenu ) where import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Data.Char (toLower) import Data.List import Data.Maybe import qualified Debug.Trace as D import GHC.IO.Encoding import Safe (headMay) import System.Directory import System.Environment import System.Environment.XDG.DesktopEntry import System.FilePath.Posix import System.Log.Logger import System.Posix.Files import System.Taffybar.Util import Text.XML.Light import Text.XML.Light.Helpers getXDGMenuPrefix :: IO (Maybe String) getXDGMenuPrefix = lookupEnv "XDG_MENU_PREFIX" -- | Find filename(s) of the application menu(s). getXDGMenuFilenames :: Maybe String -- ^ Overrides the value of the environment variable -- XDG_MENU_PREFIX. Specifies the prefix for the menu (e.g. -- 'Just "mate-"'). -> IO [FilePath] getXDGMenuFilenames mMenuPrefix = do configDirs <- liftA2 (:) (getXdgDirectory XdgConfig "") (getXdgDirectoryList XdgConfigDirs) maybePrefix <- (mMenuPrefix <|>) <$> getXDGMenuPrefix let maybeAddDash t = if last t == '-' then t else t ++ "-" dashedPrefix = maybe "" maybeAddDash maybePrefix return $ map ( "menus" dashedPrefix ++ "applications.menu") configDirs -- | XDG Menu, cf. "Desktop Menu Specification". data XDGMenu = XDGMenu { xmAppDir :: Maybe String , xmDefaultAppDirs :: Bool -- Use $XDG_DATA_DIRS/applications , xmDirectoryDir :: Maybe String , xmDefaultDirectoryDirs :: Bool -- Use $XDG_DATA_DIRS/desktop-directories , xmLegacyDirs :: [String] , xmName :: String , xmDirectory :: String , xmOnlyUnallocated :: Bool , xmDeleted :: Bool , xmInclude :: Maybe DesktopEntryCondition , xmExclude :: Maybe DesktopEntryCondition , xmSubmenus :: [XDGMenu] , xmLayout :: [XDGLayoutItem] } deriving (Show) data XDGLayoutItem = XliFile String | XliSeparator | XliMenu String | XliMerge String deriving(Show) -- | Return a list of all available desktop entries for a given xdg menu. getApplicationEntries :: [String] -- ^ Preferred languages -> XDGMenu -> IO [DesktopEntry] getApplicationEntries langs xm = do defEntries <- if xmDefaultAppDirs xm then do dataDirs <- getXDGDataDirs concat <$> mapM (listDesktopEntries ".desktop" . ( "applications")) dataDirs else return [] return $ sortBy (\de1 de2 -> compare (map toLower (deName langs de1)) (map toLower (deName langs de2))) defEntries -- | Parse menu. parseMenu :: Element -> Maybe XDGMenu parseMenu elt = let appDir = getChildData "AppDir" elt defaultAppDirs = isJust $ getChildData "DefaultAppDirs" elt directoryDir = getChildData "DirectoryDir" elt defaultDirectoryDirs = isJust $ getChildData "DefaultDirectoryDirs" elt name = fromMaybe "Name?" $ getChildData "Name" elt dir = fromMaybe "Dir?" $ getChildData "Directory" elt onlyUnallocated = case ( getChildData "OnlyUnallocated" elt , getChildData "NotOnlyUnallocated" elt) of (Nothing, Nothing) -> False -- ?! (Nothing, Just _) -> False (Just _, Nothing) -> True (Just _, Just _) -> False -- ?! deleted = False -- FIXME include = parseConditions "Include" elt exclude = parseConditions "Exclude" elt layout = parseLayout elt subMenus = fromMaybe [] $ mapChildren "Menu" elt parseMenu in Just XDGMenu { xmAppDir = appDir , xmDefaultAppDirs = defaultAppDirs , xmDirectoryDir = directoryDir , xmDefaultDirectoryDirs = defaultDirectoryDirs , xmLegacyDirs = [] , xmName = name , xmDirectory = dir , xmOnlyUnallocated = onlyUnallocated , xmDeleted = deleted , xmInclude = include , xmExclude = exclude , xmSubmenus = subMenus , xmLayout = layout -- FIXME } -- | Parse Desktop Entry conditions for Include/Exclude clauses. parseConditions :: String -> Element -> Maybe DesktopEntryCondition parseConditions key elt = case findChild (unqual key) elt of Nothing -> Nothing Just inc -> doParseConditions (elChildren inc) where doParseConditions :: [Element] -> Maybe DesktopEntryCondition doParseConditions [] = Nothing doParseConditions [e] = parseSingleItem e doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts parseSingleItem e = case qName (elName e) of "Category" -> Just $ Category $ strContent e "Filename" -> Just $ Filename $ strContent e "And" -> Just $ And $ mapMaybe parseSingleItem $ elChildren e "Or" -> Just $ Or $ mapMaybe parseSingleItem $ elChildren e "Not" -> Not <$> (parseSingleItem =<< listToMaybe (elChildren e)) unknown -> D.trace ("Unknown Condition item: " ++ unknown) Nothing -- | Combinable conditions for Include and Exclude statements. data DesktopEntryCondition = Category String | Filename String | Not DesktopEntryCondition | And [DesktopEntryCondition] | Or [DesktopEntryCondition] | All | None deriving (Read, Show, Eq) parseLayout :: Element -> [XDGLayoutItem] parseLayout elt = case findChild (unqual "Layout") elt of Nothing -> [] Just lt -> mapMaybe parseLayoutItem (elChildren lt) where parseLayoutItem :: Element -> Maybe XDGLayoutItem parseLayoutItem e = case qName (elName e) of "Separator" -> Just XliSeparator "Filename" -> Just $ XliFile $ strContent e unknown -> D.trace ("Unknown layout item: " ++ unknown) Nothing -- | Determine whether a desktop entry fulfils a condition. matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool matchesCondition de (Category cat) = deHasCategory de cat matchesCondition de (Filename fn) = fn == deFilename de matchesCondition de (Not cond) = not $ matchesCondition de cond matchesCondition de (And conds) = all (matchesCondition de) conds matchesCondition de (Or conds) = any (matchesCondition de) conds matchesCondition _ All = True matchesCondition _ None = False -- | Determine locale language settings getPreferredLanguages :: IO [String] getPreferredLanguages = do mLcMessages <- lookupEnv "LC_MESSAGES" lang <- case mLcMessages of Nothing -> lookupEnv "LANG" -- FIXME? Just lm -> return (Just lm) case lang of Nothing -> return [] Just l -> return $ let woEncoding = takeWhile (/= '.') l (language, _cm) = span (/= '_') woEncoding (country, _m) = span (/= '@') (drop 1 _cm) modifier = drop 1 _m in dgl language country modifier where dgl "" "" "" = [] dgl l "" "" = [l] dgl l c "" = [l ++ "_" ++ c, l] dgl l "" m = [l ++ "@" ++ m, l] dgl l c m = [l ++ "_" ++ c ++ "@" ++ m, l ++ "_" ++ c, l ++ "@" ++ m] -- | Determine current Desktop getXDGDesktop :: IO String getXDGDesktop = do mCurDt <- lookupEnv "XDG_CURRENT_DESKTOP" return $ fromMaybe "???" mCurDt -- | Return desktop directories getDirectoryDirs :: IO [FilePath] getDirectoryDirs = do dataDirs <- getXDGDataDirs filterM (fileExist . ( "desktop-directories")) dataDirs -- | Fetch menus and desktop entries and assemble the XDG menu. readXDGMenu :: Maybe String -> IO (Maybe (XDGMenu, [DesktopEntry])) readXDGMenu mMenuPrefix = do setLocaleEncoding utf8 filenames <- getXDGMenuFilenames mMenuPrefix headMay . catMaybes <$> traverse maybeMenu filenames -- | Load and assemble the XDG menu from a specific file, if it exists. maybeMenu :: FilePath -> IO (Maybe (XDGMenu, [DesktopEntry])) maybeMenu filename = ifM (doesFileExist filename) (do contents <- readFile filename langs <- getPreferredLanguages runMaybeT $ do m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu des <- lift $ getApplicationEntries langs m return (m, des)) (do logM "System.Taffybar.Information.XDG.Protocol" WARNING $ "Menu file '" ++ filename ++ "' does not exist!" return Nothing) taffybar-4.1.1/src/System/Taffybar/LogFormatter.hs0000644000000000000000000000307107346545000020257 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.LogFormatter -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable ----------------------------------------------------------------------------- module System.Taffybar.LogFormatter where import System.Console.ANSI import System.Log.Formatter import System.Log.Handler.Simple import System.Log.Logger import Text.Printf import System.IO setColor :: Color -> String setColor color = setSGRCode [SetColor Foreground Vivid color] priorityToColor :: Priority -> Color priorityToColor CRITICAL = Red priorityToColor ALERT = Red priorityToColor EMERGENCY = Red priorityToColor ERROR = Red priorityToColor WARNING = Yellow priorityToColor NOTICE = Magenta priorityToColor INFO = Blue priorityToColor DEBUG = Green reset :: String reset = setSGRCode [Reset] colorize :: Color -> String -> String colorize color txt = setColor color <> txt <> reset taffyLogFormatter :: LogFormatter a taffyLogFormatter _ (level, msg) name = return $ printf "%s %s - %s" colorizedPriority colorizedName msg where priorityColor = priorityToColor level colorizedPriority = colorize priorityColor ("[" <> show level <> "]") colorizedName = colorize Green name taffyLogHandler :: IO (GenericHandler Handle) taffyLogHandler = setFormatter <$> streamHandler stderr DEBUG where setFormatter h = h { formatter = taffyLogFormatter } taffybar-4.1.1/src/System/Taffybar/SimpleConfig.hs0000644000000000000000000001532507346545000020236 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.SimpleConfig -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This module defines a simpler, but less flexible config system than the one -- offered in "System.Taffybar.Context". ----------------------------------------------------------------------------- module System.Taffybar.SimpleConfig ( SimpleTaffyConfig(..) , Position(..) , defaultSimpleTaffyConfig , simpleDyreTaffybar , simpleTaffybar , toTaffyConfig , toTaffybarConfig , useAllMonitors , usePrimaryMonitor , StrutSize(..) ) where import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.Trans.Class import Data.Default (Default(..)) import Data.List import Data.Maybe import Data.Unique import qualified GI.Gtk as Gtk import GI.Gdk import Graphics.UI.GIGtkStrut import System.Taffybar.Information.X11DesktopInfo import System.Taffybar import qualified System.Taffybar.Context as BC (BarConfig(..), TaffybarConfig(..)) import System.Taffybar.Context hiding (TaffybarConfig(..), BarConfig(..)) import System.Taffybar.Util -- | An ADT representing the edge of the monitor along which taffybar should be -- displayed. 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 -- advanced interface, you should stick to using this one. data SimpleTaffyConfig = SimpleTaffyConfig { -- | The monitor number to put the bar on (default: 'usePrimaryMonitor') monitorsAction :: TaffyIO [Int] -- | Number of pixels to reserve for the bar (default: 30) , barHeight :: StrutSize -- | Number of additional pixels to reserve for the bar strut (default: 0) , barPadding :: Int -- | The position of the bar on the screen (default: 'Top') , barPosition :: Position -- | The number of pixels between widgets (default: 5) , widgetSpacing :: Int -- | Widget constructors whose outputs are placed at the beginning of the bar , startWidgets :: [TaffyIO Gtk.Widget] -- | Widget constructors whose outputs are placed in the center of the bar , centerWidgets :: [TaffyIO Gtk.Widget] -- | Widget constructors whose outputs are placed at the end of the bar , endWidgets :: [TaffyIO Gtk.Widget] -- | List of paths to CSS stylesheets that should be loaded at startup. , cssPaths :: [FilePath] -- | Hook to run at taffybar startup. , startupHook :: TaffyIO () } -- | Sensible defaults for most of the fields of 'SimpleTaffyConfig'. You'll -- need to specify the widgets you want in the bar with 'startWidgets', -- 'centerWidgets' and 'endWidgets'. defaultSimpleTaffyConfig :: SimpleTaffyConfig defaultSimpleTaffyConfig = SimpleTaffyConfig { monitorsAction = useAllMonitors , barHeight = ScreenRatio $ 1 / 27 , barPadding = 0 , barPosition = Top , widgetSpacing = 5 , startWidgets = [] , centerWidgets = [] , endWidgets = [] , cssPaths = [] , startupHook = return () } instance Default SimpleTaffyConfig where def = defaultSimpleTaffyConfig -- | Convert a 'SimpleTaffyConfig' into a 'StrutConfig' that can be used with -- gtk-strut. toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig toStrutConfig SimpleTaffyConfig { barHeight = height , barPadding = padding , barPosition = pos } monitor = defaultStrutConfig { strutHeight = height , strutYPadding = fromIntegral padding , strutXPadding = fromIntegral padding , strutAlignment = Center , strutMonitor = Just $ fromIntegral monitor , strutPosition = case pos of Top -> TopPos Bottom -> BottomPos } toBarConfig :: SimpleTaffyConfig -> Int -> IO BC.BarConfig toBarConfig config monitor = do let strutConfig = toStrutConfig config monitor barId <- newUnique return BC.BarConfig { BC.strutConfig = strutConfig , BC.widgetSpacing = fromIntegral $ widgetSpacing config , BC.startWidgets = startWidgets config , BC.centerWidgets = centerWidgets config , BC.endWidgets = endWidgets config , BC.barId = barId } newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)]) {-# DEPRECATED toTaffyConfig "Use toTaffybarConfig instead" #-} toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig toTaffyConfig = toTaffybarConfig -- | Convert a 'SimpleTaffyConfig' into a 'BC.TaffybarConfig' that can be used -- with 'startTaffybar' or 'dyreTaffybar'. toTaffybarConfig :: SimpleTaffyConfig -> BC.TaffybarConfig toTaffybarConfig conf = def { BC.getBarConfigsParam = configGetter , BC.cssPaths = cssPaths conf , BC.startupHook = startupHook conf } where configGetter = do SimpleBarConfigs configsVar <- getStateDefault $ lift (SimpleBarConfigs <$> MV.newMVar []) monitorNumbers <- monitorsAction conf let lookupWithIndex barConfigs monitorNumber = (monitorNumber, lookup monitorNumber barConfigs) lookupAndUpdate barConfigs = do let (alreadyPresent, toCreate) = partition (isJust . snd) $ map (lookupWithIndex barConfigs) monitorNumbers alreadyPresentConfigs = mapMaybe snd alreadyPresent newlyCreated <- mapM (forkM return (toBarConfig conf) . fst) toCreate let result = map snd newlyCreated ++ alreadyPresentConfigs return (barConfigs ++ newlyCreated, result) lift $ MV.modifyMVar configsVar lookupAndUpdate -- | Start taffybar using dyre with a 'SimpleTaffybarConfig'. simpleDyreTaffybar :: SimpleTaffyConfig -> IO () simpleDyreTaffybar conf = dyreTaffybar $ toTaffybarConfig conf -- | Start taffybar with a 'SimpleTaffybarConfig'. simpleTaffybar :: SimpleTaffyConfig -> IO () simpleTaffybar conf = startTaffybar $ toTaffybarConfig conf getMonitorCount :: IO Int getMonitorCount = fromIntegral <$> (screenGetDefault >>= maybe (return 0) (screenGetDisplay >=> displayGetNMonitors)) -- | Supply this value for 'monitorsAction' to display the taffybar window on -- all monitors. useAllMonitors :: TaffyIO [Int] useAllMonitors = lift $ do count <- getMonitorCount return [0..count-1] -- | Supply this value for 'monitorsAction' to display the taffybar window only -- on the primary monitor. usePrimaryMonitor :: TaffyIO [Int] usePrimaryMonitor = singleton . fromMaybe 0 <$> lift (withX11Context def getPrimaryOutputNumber) taffybar-4.1.1/src/System/Taffybar/Support/0000755000000000000000000000000007346545000016771 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/Support/PagerHints.hs0000644000000000000000000000773707346545000021407 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Support.PagerHints -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : deprecated -- Portability : unportable -- -- Complements the "XMonad.Hooks.EwmhDesktops" with two additional hints -- not contemplated by the EWMH standard: -- -- [@_XMONAD_CURRENT_LAYOUT@] Contains a UTF-8 string with the name of the -- windows layout currently used in the active workspace. -- -- [@_XMONAD_VISIBLE_WORKSPACES@] Contains a list of UTF-8 strings with the -- names of all the workspaces that are currently showed in a secondary -- display, or an empty list if in the current installation there's only -- one monitor. -- -- The first hint can be set directly on the root window of the default -- display, or indirectly via X11 events with an atom of the same -- name. This allows both to track any changes that occur in the layout of -- the current workspace, as well as to have it changed automatically by -- just sending a custom event to the hook. -- -- The second one should be considered read-only, and is set every time -- XMonad calls its log hooks. -- ----------------------------------------------------------------------------- module System.Taffybar.Support.PagerHints {-# DEPRECATED "Use XMonad.Hooks.TaffybarPagerHints instead" #-} ( -- * Usage -- $usage pagerHints ) where import Codec.Binary.UTF8.String (encode) import Control.Monad import Data.Monoid import Foreign.C.Types (CInt) import XMonad import qualified XMonad.StackSet as W -- $usage -- -- You can use this module with the following in your @xmonad.hs@ file: -- -- > import System.Taffybar.Support.PagerHints (pagerHints) -- > -- > main = xmonad $ ewmh $ pagerHints $ defaultConfig -- > ... -- | The \"Current Layout\" custom hint. xLayoutProp :: X Atom xLayoutProp = getAtom "_XMONAD_CURRENT_LAYOUT" -- | The \"Visible Workspaces\" custom hint. xVisibleProp :: X Atom xVisibleProp = getAtom "_XMONAD_VISIBLE_WORKSPACES" -- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom -- hints to the given config. pagerHints :: XConfig a -> XConfig a pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook , logHook = logHook c +++ pagerHintsLogHook } where x +++ y = x `mappend` y -- | Update the current values of both custom hints. pagerHintsLogHook :: X () pagerHintsLogHook = do withWindowSet (setCurrentLayout . description . W.layout . W.workspace . W.current) withWindowSet (setVisibleWorkspaces . map (W.tag . W.workspace) . W.visible) -- | Set the value of the \"Current Layout\" custom hint to the one given. setCurrentLayout :: String -> X () setCurrentLayout l = withDisplay $ \dpy -> do r <- asks theRoot a <- xLayoutProp c <- getAtom "UTF8_STRING" let l' = map fromIntegral (encode l) io $ changeProperty8 dpy r a c propModeReplace l' -- | Set the value of the \"Visible Workspaces\" hint to the one given. setVisibleWorkspaces :: [String] -> X () setVisibleWorkspaces vis = withDisplay $ \dpy -> do r <- asks theRoot a <- xVisibleProp c <- getAtom "UTF8_STRING" let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis io $ changeProperty8 dpy r a c propModeReplace vis' -- | Handle all \"Current Layout\" events received from pager widgets, and -- set the current layout accordingly. pagerHintsEventHook :: Event -> X All pagerHintsEventHook ClientMessageEvent { ev_message_type = mt, ev_data = d } = withWindowSet $ \_ -> do a <- xLayoutProp when (mt == a) $ sendLayoutMessage d return (All True) pagerHintsEventHook _ = return (All True) -- | Request a change in the current layout by sending an internal message -- to XMonad. sendLayoutMessage :: [CInt] -> X () sendLayoutMessage evData = case evData of [] -> return () x:_ -> if x < 0 then sendMessage FirstLayout else sendMessage NextLayout taffybar-4.1.1/src/System/Taffybar/Util.hs0000644000000000000000000002537207346545000016577 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Util -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable ----------------------------------------------------------------------------- module System.Taffybar.Util ( -- * Configuration taffyStateDir -- * GTK concurrency , module Gtk -- * GLib , catchGErrorsAsLeft -- * Logging , logPrintF -- * Text , truncateString , truncateText -- * Resources , downloadURIToPath , getPixbufFromFilePath , safePixbufNewFromFile -- * Logic Combinators , (<||>) , (<|||>) , forkM , ifM , anyM , maybeTCombine , maybeToEither -- * Control , foreverWithVariableDelay , foreverWithDelay -- * Process control , runCommand , onSigINT , maybeHandleSigHUP , handlePosixSignal -- * Resource management , rebracket , rebracket_ -- * Deprecated , logPrintFDebug , liftReader , liftActionTaker , (??) , runCommandFromPath ) where import Conduit import Control.Applicative import Control.Arrow ((&&&)) 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 import Control.Monad.Trans.Reader import Data.Either.Combinators 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, sigHUP, sigINT) import qualified System.Process as P import Text.Printf taffyStateDir :: IO FilePath taffyStateDir = getUserDataDir "taffybar" {-# DEPRECATED liftReader "Use Control.Monad.Trans.Reader.mapReaderT instead" #-} liftReader :: Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b liftReader = mapReaderT logPrintF :: (MonadIO m, Show t) => String -> Priority -> String -> t -> m () logPrintF logPath priority format toPrint = liftIO $ logM logPath priority $ printf format $ show toPrint {-# DEPRECATED logPrintFDebug "Use logPrintF instead" #-} logPrintFDebug :: (MonadIO m, Show t) => String -> String -> t -> m () logPrintFDebug path = logPrintF path DEBUG infixl 4 ?? (??) :: Functor f => f (a -> b) -> a -> f b fab ?? a = fmap ($ a) fab {-# INLINE (??) #-} {-# DEPRECATED (??) "Use @f <*> pure a@ instead" #-} ifM :: Monad m => m Bool -> m a -> m a -> m a ifM cond whenTrue whenFalse = cond >>= (\bool -> if bool then whenTrue else whenFalse) forkM :: Monad m => (c -> m a) -> (c -> m b) -> c -> m (a, b) forkM a b = sequenceT . (a &&& b) maybeToEither :: b -> Maybe a -> Either b a maybeToEither = flip maybe Right . Left truncateString :: Int -> String -> String truncateString n incoming | length incoming <= n = incoming | otherwise = take n incoming ++ "…" truncateText :: Int -> T.Text -> T.Text truncateText n incoming | T.length incoming <= n = incoming | otherwise = T.append (T.take n incoming) "…" -- | Run the provided command with the provided arguments. -- -- If the command filename does not contain a slash, then the @PATH@ -- environment variable is searched for the executable. runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String) runCommand cmd args = liftIO $ do (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 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 = foreverWithVariableDelay $ safeAction >> return delay where safeAction = catchAny action $ \e -> logPrintF "System.Taffybar.Util" WARNING "Error in foreverWithDelay %s" e -- | Execute the provided IO action, and use the value it returns to decide how -- long to wait until executing it again. The value returned by the action is -- interpreted as a number of seconds. foreverWithVariableDelay :: (MonadIO m, RealFrac d) => IO d -> m ThreadId foreverWithVariableDelay action = liftIO $ forkIO $ action >>= delayThenAction where delayThenAction delay = threadDelay (floor $ delay * 1000000) >> action >>= delayThenAction liftActionTaker :: (Monad m) => ((a -> m a) -> m b) -> (a -> ReaderT c m a) -> ReaderT c m b liftActionTaker actionTaker action = do ctx <- ask lift $ actionTaker $ flip runReaderT ctx . action maybeTCombine :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) maybeTCombine a b = runMaybeT $ MaybeT a <|> MaybeT b infixl 3 <||> (<||>) :: Monad m => (t -> m (Maybe a)) -> (t -> m (Maybe a)) -> t -> m (Maybe a) a <||> b = combineOptions where combineOptions v = maybeTCombine (a v) (b v) infixl 3 <|||> (<|||>) :: Monad m => (t -> t1 -> m (Maybe a)) -> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a) a <|||> b = combineOptions where combineOptions v v1 = maybeTCombine (a v v1) (b v v1) catchGErrorsAsLeft :: IO a -> IO (Either GError a) catchGErrorsAsLeft action = catch (Right <$> action) (return . Left) catchGErrorsAsNothing :: IO a -> IO (Maybe a) catchGErrorsAsNothing = fmap rightToMaybe . catchGErrorsAsLeft safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf) safePixbufNewFromFile = handleResult . catchGErrorsAsNothing . Gdk.pixbufNewFromFile where #if MIN_VERSION_gi_gdkpixbuf(2,0,26) handleResult = fmap join #else handleResult = id #endif getPixbufFromFilePath :: FilePath -> IO (Maybe Gdk.Pixbuf) getPixbufFromFilePath filepath = do result <- safePixbufNewFromFile filepath when (isNothing result) $ logM "System.Taffybar.WindowIcon" WARNING $ printf "Failed to load icon from filepath %s" filepath return result downloadURIToPath :: Request -> FilePath -> IO () downloadURIToPath uri filepath = createDirectoryIfMissing True directory >> runConduitRes (httpSource uri getResponseBody .| sinkFile filepath) where (directory, _) = splitFileName filepath anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool anyM _ [] = return False anyM p (x:xs) = do q <- p x if q then return True else anyM p xs -- | Installs a useful posix signal handler for 'sigINT' (i.e. Ctrl-C) -- for cases when the 'Control.Exception.UserInterrupt' exception gets -- swallowed within a main loop, preventing the program from exiting. -- -- The given callback should be a command which causes the main loop -- action to exit. For example: -- -- > Gtk.main `onSigINT` Gtk.mainQuit -- -- If the signal handler was invoked, the program will exit with -- status 130 after the main loop action returns. onSigINT :: IO a -- ^ The main loop 'IO' action -> IO () -- ^ Callback for @SIGINT@ -> IO a onSigINT action callback = do exitStatus <- newIORef Nothing let intHandler = do writeIORef exitStatus (Just (ExitFailure 130)) callback 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. withSigHandlerBase :: Signal -> Handler -> IO a -> IO a withSigHandlerBase sig h = bracket (install h) install . const where install handler = installHandler sig handler Nothing taffybar-4.1.1/src/System/Taffybar/Widget.hs0000644000000000000000000000552707346545000017105 0ustar0000000000000000{-# LANGUAGE CPP #-} module System.Taffybar.Widget ( module System.Taffybar.Widget.Util -- * "System.Taffybar.Widget.Battery" , module System.Taffybar.Widget.Battery -- * "System.Taffybar.Widget.CPUMonitor" , module System.Taffybar.Widget.CPUMonitor -- * "System.Taffybar.Widget.CommandRunner" , module System.Taffybar.Widget.CommandRunner #ifdef WIDGET_CRYPTO -- * "System.Taffybar.Widget.Crypto" , module System.Taffybar.Widget.Crypto #endif -- * "System.Taffybar.Widget.DiskIOMonitor" , module System.Taffybar.Widget.DiskIOMonitor -- * "System.Taffybar.Widget.FSMonitor" , module System.Taffybar.Widget.FSMonitor -- * "System.Taffybar.Widget.FreedesktopNotifications" , module System.Taffybar.Widget.FreedesktopNotifications -- * "System.Taffybar.Widget.Layout" , module System.Taffybar.Widget.Layout -- * "System.Taffybar.Widget.MPRIS2" , module System.Taffybar.Widget.MPRIS2 -- * "System.Taffybar.Widget.NetworkGraph" , module System.Taffybar.Widget.NetworkGraph -- * "System.Taffybar.Widget.SNITray" , module System.Taffybar.Widget.SNITray -- * "System.Taffybar.Widget.SimpleClock" , module System.Taffybar.Widget.SimpleClock -- * "System.Taffybar.Widget.SimpleCommandButton" , module System.Taffybar.Widget.SimpleCommandButton -- * "System.Taffybar.Widget.Text.CPUMonitor" , module System.Taffybar.Widget.Text.CPUMonitor -- * "System.Taffybar.Widget.Text.MemoryMonitor" , module System.Taffybar.Widget.Text.MemoryMonitor -- * "System.Taffybar.Widget.Text.NetworkMonitor" , module System.Taffybar.Widget.Text.NetworkMonitor -- * "System.Taffybar.Widget.Weather" , module System.Taffybar.Widget.Weather -- * "System.Taffybar.Widget.Windows" , module System.Taffybar.Widget.Windows -- * "System.Taffybar.Widget.Workspaces" , module System.Taffybar.Widget.Workspaces -- * "System.Taffybar.Widget.XDGMenu.MenuWidget" , module System.Taffybar.Widget.XDGMenu.MenuWidget ) where import System.Taffybar.Widget.Battery import System.Taffybar.Widget.CPUMonitor import System.Taffybar.Widget.CommandRunner #ifdef WIDGET_CRYPTO import System.Taffybar.Widget.Crypto #endif import System.Taffybar.Widget.DiskIOMonitor import System.Taffybar.Widget.FSMonitor import System.Taffybar.Widget.FreedesktopNotifications import System.Taffybar.Widget.Layout import System.Taffybar.Widget.MPRIS2 import System.Taffybar.Widget.NetworkGraph import System.Taffybar.Widget.SNITray import System.Taffybar.Widget.SimpleClock import System.Taffybar.Widget.SimpleCommandButton import System.Taffybar.Widget.Text.CPUMonitor import System.Taffybar.Widget.Text.MemoryMonitor import System.Taffybar.Widget.Text.NetworkMonitor import System.Taffybar.Widget.Util import System.Taffybar.Widget.Weather import System.Taffybar.Widget.Windows import System.Taffybar.Widget.Workspaces import System.Taffybar.Widget.XDGMenu.MenuWidget taffybar-4.1.1/src/System/Taffybar/Widget/0000755000000000000000000000000007346545000016540 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/Widget/Battery.hs0000644000000000000000000001546007346545000020514 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Battery -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- 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 broadcast "TChan" based system for receiving -- updates defined in "System.Taffybar.Information.Battery". ----------------------------------------------------------------------------- module System.Taffybar.Widget.Battery ( batteryIconNew , textBatteryNew , textBatteryNewWithLabelAction ) where import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Data.Default (Default(..)) import Data.Int (Int64) import qualified Data.Text as T import GI.Gtk as Gtk import StatusNotifier.Tray (scalePixbufToSize) import System.Taffybar.Context import System.Taffybar.Information.Battery import System.Taffybar.Util import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Generic.ChannelWidget import System.Taffybar.Widget.Util hiding (themeLoadFlags) import Text.Printf import Text.StringTemplate -- | Just the battery info that will be used for display (this makes combining -- several easier). data BatteryWidgetInfo = BWI { seconds :: Maybe Int64 , percent :: Int , status :: String } deriving (Eq, Show) -- | Format a duration expressed as seconds to hours and minutes formatDuration :: Maybe Int64 -> String formatDuration Nothing = "" formatDuration (Just secs) = let minutes = secs `div` 60 hours = minutes `div` 60 minutes' = minutes `mod` 60 in printf "%02d:%02d" hours minutes' getBatteryWidgetInfo :: BatteryInfo -> BatteryWidgetInfo getBatteryWidgetInfo info = let battPctNum :: Int battPctNum = floor (batteryPercentage info) battTime :: Maybe Int64 battTime = case batteryState info of BatteryStateCharging -> Just $ batteryTimeToFull info BatteryStateDischarging -> Just $ batteryTimeToEmpty info _ -> Nothing battStatus :: String battStatus = case batteryState info of BatteryStateCharging -> "Charging" BatteryStateDischarging -> "Discharging" _ -> "✔" in BWI {seconds = battTime, percent = battPctNum, status = battStatus} -- | Given (maybe summarized) battery info and format: provides the string to display formatBattInfo :: BatteryWidgetInfo -> String -> T.Text formatBattInfo info fmt = let tpl = newSTMP fmt tpl' = setManyAttrib [ ("percentage", (show . percent) info) , ("time", formatDuration (seconds info)) , ("status", status info) ] tpl in render tpl' -- | A simple textual battery widget. The displayed format is specified format -- string where $percentage$ is replaced with the percentage of battery -- remaining and $time$ is replaced with the time until the battery is fully -- charged/discharged. textBatteryNew :: String -> TaffyIO Widget textBatteryNew format = textBatteryNewWithLabelAction labelSetter where labelSetter label info = do setBatteryStateClasses def label info labelSetMarkup label $ formatBattInfo (getBatteryWidgetInfo info) format data BatteryClassesConfig = BatteryClassesConfig { batteryHighThreshold :: Double , batteryLowThreshold :: Double , batteryCriticalThreshold :: Double } defaultBatteryClassesConfig :: BatteryClassesConfig defaultBatteryClassesConfig = BatteryClassesConfig { batteryHighThreshold = 80 , batteryLowThreshold = 20 , batteryCriticalThreshold = 5 } instance Default BatteryClassesConfig where def = defaultBatteryClassesConfig setBatteryStateClasses :: MonadIO m => BatteryClassesConfig -> Gtk.Label -> BatteryInfo -> m () setBatteryStateClasses config label info = do case batteryState info of BatteryStateCharging -> addClassIfMissing "charging" label >> removeClassIfPresent "discharging" label BatteryStateDischarging -> addClassIfMissing "discharging" label >> removeClassIfPresent "charging" label _ -> removeClassIfPresent "charging" label >> removeClassIfPresent "discharging" label classIf "high" $ percentage >= batteryHighThreshold config classIf "low" $ percentage <= batteryLowThreshold config classIf "critical" $ percentage <= batteryCriticalThreshold config where percentage = batteryPercentage info classIf klass condition = if condition then addClassIfMissing klass label else removeClassIfPresent klass label -- | Like `textBatteryNew` but provides a more general way to update the label -- widget. The argument provided is an action that is used to update the text -- label given a 'BatteryInfo' object describing the state of the battery. textBatteryNewWithLabelAction :: (Gtk.Label -> BatteryInfo -> TaffyIO ()) -> TaffyIO Widget textBatteryNewWithLabelAction labelSetter = do chan <- getDisplayBatteryChan ctx <- ask liftIO $ do label <- labelNew Nothing let updateWidget = postGUIASync . flip runReaderT ctx . labelSetter label void $ onWidgetRealize label $ runReaderT getDisplayBatteryInfo ctx >>= updateWidget toWidget =<< channelWidgetNew label chan updateWidget themeLoadFlags :: [IconLookupFlags] themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin] batteryIconNew :: TaffyIO Widget batteryIconNew = do chan <- getDisplayBatteryChan ctx <- ask liftIO $ do image <- imageNew styleCtx <- widgetGetStyleContext =<< toWidget image defaultTheme <- iconThemeGetDefault let getCurrentBatteryIconNameString = T.pack . batteryIconName <$> runReaderT getDisplayBatteryInfo ctx extractPixbuf info = fst <$> iconInfoLoadSymbolicForContext info styleCtx setIconForSize size = do name <- getCurrentBatteryIconNameString iconThemeLookupIcon defaultTheme name size themeLoadFlags >>= traverse extractPixbuf >>= traverse (scalePixbufToSize size OrientationHorizontal) updateImage <- autoSizeImage image setIconForSize OrientationHorizontal toWidget =<< channelWidgetNew image chan (const $ postGUIASync updateImage) taffybar-4.1.1/src/System/Taffybar/Widget/CPUMonitor.hs0000644000000000000000000000316107346545000021074 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.CPUMonitor -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Simple CPU monitor that uses a PollingGraph to visualize variations in the -- user and system CPU times in one selected core, or in all cores available. -- -------------------------------------------------------------------------------- module System.Taffybar.Widget.CPUMonitor where import Control.Monad.IO.Class import Data.IORef import qualified GI.Gtk import System.Taffybar.Information.CPU2 (getCPUInfo) import System.Taffybar.Information.StreamInfo (getAccLoad) import System.Taffybar.Widget.Generic.PollingGraph -- | Creates a new CPU monitor. This is a PollingGraph fed by regular calls to -- getCPUInfo, associated to an IORef used to remember the values yielded by the -- last call to this function. cpuMonitorNew :: MonadIO m => GraphConfig -- ^ Configuration data for the Graph. -> Double -- ^ Polling period (in seconds). -> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\"). -> m GI.Gtk.Widget cpuMonitorNew cfg interval cpu = liftIO $ do info <- getCPUInfo cpu sample <- newIORef info pollingGraphNew cfg interval $ probe sample cpu probe :: IORef [Int] -> String -> IO [Double] probe sample cpuName = do load <- getAccLoad sample $ getCPUInfo cpuName case load of l0:l1:l2:_ -> return [ l0 + l1, l2 ] -- user, system _ -> return [] taffybar-4.1.1/src/System/Taffybar/Widget/CommandRunner.hs0000644000000000000000000000344107346545000021646 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.CommandRunner -- Copyright : (c) Arseniy Seroka -- License : BSD3-style (see LICENSE) -- -- Maintainer : Arseniy Seroka -- Stability : unstable -- Portability : unportable -- -- Simple function which runs user defined command and -- returns it's output in PollingLabel widget -------------------------------------------------------------------------------- module System.Taffybar.Widget.CommandRunner ( commandRunnerNew ) where import Control.Monad.IO.Class import qualified GI.Gtk import System.Log.Logger import System.Taffybar.Util import System.Taffybar.Widget.Generic.PollingLabel import Text.Printf import qualified Data.Text as T -- | Creates a new command runner widget. This is a 'PollingLabel' fed by -- regular calls to command given by argument. The results of calling this -- function are displayed as string. commandRunnerNew :: MonadIO m => Double -- ^ Polling period (in seconds). -> String -- ^ Command to execute. Should be in $PATH or an absolute path -> [String] -- ^ Command argument. May be @[]@ -> T.Text -- ^ If command fails this will be displayed. -> m GI.Gtk.Widget commandRunnerNew interval cmd args defaultOutput = pollingLabelNew interval $ runCommandWithDefault cmd args defaultOutput runCommandWithDefault :: FilePath -> [String] -> T.Text -> IO T.Text runCommandWithDefault cmd args def = T.filter (/= '\n') <$> (runCommand cmd args >>= either logError (return . T.pack)) where logError err = logM "System.Taffybar.Widget.CommandRunner" ERROR (printf "Got error in CommandRunner %s" err) >> return def taffybar-4.1.1/src/System/Taffybar/Widget/Crypto.hs0000644000000000000000000001407507346545000020363 0ustar0000000000000000{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Crypto -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This module provides widgets for tracking the price of crypto currency -- assets. ----------------------------------------------------------------------------- module System.Taffybar.Widget.Crypto where import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Aeson import Data.Aeson.Types import qualified Data.Aeson.Key as Key import qualified Data.ByteString.Lazy as LBS import Data.Maybe import Data.Proxy import qualified Data.Text import GHC.TypeLits import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk import Network.HTTP.Simple hiding (Proxy) import System.FilePath.Posix import System.Taffybar.Context import System.Taffybar.Information.Crypto hiding (symbol) import System.Taffybar.Util import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Generic.ChannelWidget import System.Taffybar.WindowIcon import Text.Printf -- | Extends 'cryptoPriceLabel' with an icon corresponding to the symbol of the -- purchase crypto that will appear to the left of the price label. See the -- docstring for 'getCryptoPixbuf' for details about how this icon is retrieved. -- Note that automatic icon retrieval requires a coinmarketcap api key to be set -- at taffybar startup. As with 'cryptoPriceLabel', this function must be -- invoked with a type application with the type string that expresses the -- symbol of the relevant token and the underlying currency in which its price -- should be expressed. See the docstring of 'cryptoPriceLabel' for details -- about the exact format that this string should take. cryptoPriceLabelWithIcon :: forall a. KnownSymbol a => TaffyIO Gtk.Widget cryptoPriceLabelWithIcon = do label <- cryptoPriceLabel @a let symbolPair = symbolVal (Proxy :: Proxy a) symbol = takeWhile (/= '-') symbolPair hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0 ctx <- ask let refresh = const $ flip runReaderT ctx $ fromMaybe <$> pixBufFromColor 10 0 <*> getCryptoPixbuf symbol image <- autoSizeImageNew refresh Gtk.OrientationHorizontal Gtk.containerAdd hbox image Gtk.containerAdd hbox label Gtk.widgetShowAll hbox Gtk.toWidget hbox newtype CMCAPIKey = CMCAPIKey String -- | Set the coinmarketcap.com api key that will be used for retrieving crypto -- icons that are not cached. This should occur before any attempts to retrieve -- crypto icons happen. The easiest way to call this appropriately is to set it -- as a 'startupHook'. setCMCAPIKey :: String -> TaffyIO CMCAPIKey setCMCAPIKey key = getStateDefault $ return $ CMCAPIKey key -- | Build a label that will reflect the price of some token in some currency in -- the coingecko API. This function accepts these valuesas a type parameter with -- kind 'String' of the form `(symbol for asset being purchased)-(currency the -- price should be expressed in)`. For example, the product string for the price -- of bitcoin quoted in U.S. dollars is "BTC-USD". You can invoke this function -- by enabling the TypeApplications language extension and passing the string -- associated with the asset that you want to track as follows: -- -- > cryptoPriceLabel @"BTC-USD" cryptoPriceLabel :: forall a. KnownSymbol a => TaffyIO Gtk.Widget cryptoPriceLabel = getCryptoPriceChannel @a >>= cryptoPriceLabel' cryptoPriceLabel' :: CryptoPriceChannel a -> TaffyIO Gtk.Widget cryptoPriceLabel' (CryptoPriceChannel (chan, var)) = do label <- Gtk.labelNew Nothing let updateWidget CryptoPriceInfo { lastPrice = cryptoPrice } = postGUIASync $ Gtk.labelSetMarkup label $ Data.Text.pack $ show cryptoPrice void $ Gtk.onWidgetRealize label $ readMVar var >>= updateWidget Gtk.toWidget =<< channelWidgetNew label chan updateWidget cryptoIconsDir :: IO FilePath cryptoIconsDir = ( "crypto_icons") <$> taffyStateDir pathForCryptoSymbol :: String -> IO FilePath pathForCryptoSymbol symbol = ( printf "%s.png" symbol) <$> cryptoIconsDir -- | Retrieve a pixbuf image corresponding to the provided crypto symbol. The -- image used will be retrieved from the file with the name `(pricesymbol).png` -- from the directory defined by 'cryptoIconsDir'. If a file is not found there -- and an an api key for coinmarketcap.com has been set using 'setCMCAPIKey', an -- icon will be automatically be retrieved from coinmarketcap.com. getCryptoPixbuf :: String -> TaffyIO (Maybe Gdk.Pixbuf) getCryptoPixbuf = getCryptoIconFromCache <||> getCryptoIconFromCMC getCryptoIconFromCache :: MonadIO m => String -> m (Maybe Gdk.Pixbuf) getCryptoIconFromCache symbol = liftIO $ pathForCryptoSymbol symbol >>= safePixbufNewFromFile getCryptoIconFromCMC :: String -> TaffyIO (Maybe Gdk.Pixbuf) getCryptoIconFromCMC symbol = runMaybeT $ do CMCAPIKey cmcAPIKey <- MaybeT getState MaybeT $ lift $ getCryptoIconFromCMC' cmcAPIKey symbol getCryptoIconFromCMC' :: String -> String -> IO (Maybe Gdk.Pixbuf) getCryptoIconFromCMC' cmcAPIKey symbol = do jsonText <- getCryptoMeta cmcAPIKey symbol let uri = getIconURIFromJSON symbol jsonText >>= parseRequest . Data.Text.unpack path <- pathForCryptoSymbol symbol maybe (return ()) (`downloadURIToPath` path) uri safePixbufNewFromFile path getIconURIFromJSON :: String -> LBS.ByteString -> Maybe Data.Text.Text getIconURIFromJSON symbol jsonText = decode jsonText >>= parseMaybe ((.: "data") >=> (.: Key.fromString symbol) >=> (.: "logo")) taffybar-4.1.1/src/System/Taffybar/Widget/DiskIOMonitor.hs0000644000000000000000000000305607346545000021572 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.DiskIOMonitor -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Simple Disk IO monitor that uses a PollingGraph to visualize the speed of -- read/write operations in one selected disk or partition. -- -------------------------------------------------------------------------------- module System.Taffybar.Widget.DiskIOMonitor ( dioMonitorNew ) where import Control.Monad.IO.Class import qualified GI.Gtk import System.Taffybar.Information.DiskIO ( getDiskTransfer ) import System.Taffybar.Widget.Generic.PollingGraph ( GraphConfig, pollingGraphNew ) -- | Creates a new disk IO monitor widget. This is a 'PollingGraph' fed by -- regular calls to 'getDiskTransfer'. The results of calling this function -- are normalized to the maximum value of the obtained probe (either read or -- write transfer). dioMonitorNew :: MonadIO m => GraphConfig -- ^ Configuration data for the Graph. -> Double -- ^ Polling period (in seconds). -> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\"). -> m GI.Gtk.Widget dioMonitorNew cfg pollSeconds = pollingGraphNew cfg pollSeconds . probeDisk probeDisk :: String -> IO [Double] probeDisk disk = do transfer <- getDiskTransfer disk let top = foldr max 1.0 transfer return $ map (/top) transfer taffybar-4.1.1/src/System/Taffybar/Widget/FSMonitor.hs0000644000000000000000000000324507346545000020760 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.FSMonitor -- Copyright : (c) José A. Romero L. -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. -- Stability : unstable -- Portability : unportable -- -- Simple text widget that monitors the current usage of selected disk -- partitions by regularly parsing the output of the df command in Linux -- systems. -- ----------------------------------------------------------------------------- module System.Taffybar.Widget.FSMonitor ( fsMonitorNew ) where import Control.Monad.IO.Class import qualified GI.Gtk import System.Process ( readProcess ) import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) import qualified Data.Text as T -- | Creates a new filesystem monitor widget. It contains one 'PollingLabel' -- that displays the data returned by the df command. The usage level of all -- requested partitions is extracted in one single operation. fsMonitorNew :: MonadIO m => Double -- ^ Polling interval (in seconds, e.g. 500) -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"]) -> m GI.Gtk.Widget fsMonitorNew interval fsList = liftIO $ do label <- pollingLabelNew interval $ showFSInfo fsList GI.Gtk.widgetShowAll label GI.Gtk.toWidget label showFSInfo :: [String] -> IO T.Text showFSInfo fsList = do fsOut <- readProcess "df" ("-kP":fsList) "" let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut return $ T.pack $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss taffybar-4.1.1/src/System/Taffybar/Widget/FreedesktopNotifications.hs0000644000000000000000000002477507346545000024120 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This widget listens on DBus for freedesktop notifications -- (). Currently it is -- somewhat ugly, but the format is somewhat configurable. -- -- The widget only displays one notification at a time and -- notifications are cancellable. -- -- The notificationDaemon thread handles new notifications -- and cancellation requests, adding or removing the notification -- to or from the queue. It additionally starts a timeout thread -- for each notification added to queue. -- -- The display thread blocks idling until it is awakened to refresh the GUI -- -- A timeout thread is associated with a notification id. -- It sleeps until the specific timeout and then removes every notification -- with that id from the queue module System.Taffybar.Widget.FreedesktopNotifications ( Notification(..) , NotificationConfig(..) , defaultNotificationConfig , notifyAreaNew ) where import Control.Concurrent import Control.Concurrent.STM import Control.Monad ( forever, void ) import Control.Monad.IO.Class import DBus import DBus.Client import Data.Default ( Default(..) ) import Data.Foldable import Data.Int ( Int32 ) import Data.Map ( Map ) import Data.Sequence ( Seq, (|>), viewl, ViewL(..) ) import qualified Data.Sequence as S import Data.Text ( Text ) import qualified Data.Text as T import Data.Word ( Word32 ) import GI.GLib (markupEscapeText) import GI.Gtk import qualified GI.Pango as Pango import System.Taffybar.Util -- | A simple structure representing a Freedesktop notification data Notification = Notification { noteAppName :: Text , noteReplaceId :: Word32 , noteSummary :: Text , noteBody :: Text , noteExpireTimeout :: Maybe Int32 , noteId :: Word32 } deriving (Show, Eq) data NotifyState = NotifyState { noteWidget :: Label , noteContainer :: Widget , noteConfig :: NotificationConfig -- ^ The associated configuration , noteQueue :: TVar (Seq Notification) -- ^ The queue of active notifications , noteIdSource :: TVar Word32 -- ^ A source of fresh notification ids , 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 <- newBroadcastTChanIO return NotifyState { noteQueue = q , noteIdSource = m , noteWidget = l , noteContainer = wrapper , noteConfig = cfg , noteChan = ch } -- | Removes every notification with id 'nId' from the queue notePurge :: NotifyState -> Word32 -> IO () notePurge s nId = atomically . modifyTVar' (noteQueue s) $ S.filter ((nId /=) . noteId) -- | Removes the first (oldest) notification from the queue noteNext :: NotifyState -> IO () noteNext s = atomically $ modifyTVar' (noteQueue s) aux where aux queue = case viewl queue of EmptyL -> S.empty _ :< ns -> ns -- | Generates a fresh notification id noteFreshId :: NotifyState -> IO Word32 noteFreshId NotifyState { noteIdSource } = atomically $ do nId <- readTVar noteIdSource writeTVar noteIdSource (succ nId) return nId -------------------------------------------------------------------------------- -- | Handles a new notification notify :: NotifyState -> Text -- ^ Application name -> Word32 -- ^ Replaces id -> Text -- ^ App icon -> Text -- ^ Summary -> Text -- ^ Body -> [Text] -- ^ Actions -> Map Text Variant -- ^ Hints -> Int32 -- ^ Expires timeout (milliseconds) -> IO Word32 notify s appName replaceId _ summary body _ _ timeout = do realId <- if replaceId == 0 then noteFreshId s else return replaceId let configTimeout = notificationMaxTimeout (noteConfig s) realTimeout = if timeout <= 0 -- Gracefully handle out of spec negative values then configTimeout else case configTimeout of Nothing -> Just timeout Just maxTimeout -> Just (min maxTimeout timeout) escapedSummary <- markupEscapeText summary (-1) escapedBody <- markupEscapeText body (-1) let n = Notification { noteAppName = appName , noteReplaceId = replaceId , noteSummary = escapedSummary , noteBody = escapedBody , noteExpireTimeout = realTimeout , noteId = realId } -- Either add the new note to the queue or replace an existing note if their ids match atomically $ do queue <- readTVar $ noteQueue s writeTVar (noteQueue s) $ case S.findIndexL (\n_ -> noteId n == noteId n_) queue of Nothing -> queue |> n Just index -> S.update index n queue startTimeoutThread s n wakeupDisplayThread s return realId -- | Handles user cancellation of a notification closeNotification :: NotifyState -> Word32 -> IO () closeNotification s nId = do notePurge s nId wakeupDisplayThread s notificationDaemon :: (AutoMethod f1, AutoMethod f2) => f1 -> f2 -> IO () notificationDaemon onNote onCloseNote = do client <- connectSession _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting] export client "/org/freedesktop/Notifications" interface where getServerInformation :: IO (Text, Text, Text, Text) getServerInformation = return ("haskell-notification-daemon", "nochair.net", "0.0.1", "1.1") getCapabilities :: IO [Text] getCapabilities = return ["body", "body-markup"] interface = defaultInterface { interfaceName = "org.freedesktop.Notifications" , interfaceMethods = [ autoMethod "GetServerInformation" getServerInformation , autoMethod "GetCapabilities" getCapabilities , autoMethod "CloseNotification" onCloseNote , autoMethod "Notify" onNote ] } -------------------------------------------------------------------------------- wakeupDisplayThread :: NotifyState -> IO () wakeupDisplayThread s = void . atomically $ writeTChan (noteChan s) () -- | Refreshes the GUI displayThread :: NotifyState -> IO () displayThread s = do chan <- atomically . dupTChan $ noteChan s forever $ do _ <- atomically $ readTChan chan ns <- readTVarIO (noteQueue s) postGUIASync $ if S.length ns == 0 then widgetHide (noteContainer s) else do labelSetMarkup (noteWidget s) $ formatMessage (noteConfig s) (toList ns) widgetShowAll (noteContainer s) where formatMessage NotificationConfig {..} ns = T.take notificationMaxLength $ notificationFormatter ns -------------------------------------------------------------------------------- startTimeoutThread :: NotifyState -> Notification -> IO () startTimeoutThread s Notification {..} = case noteExpireTimeout of Nothing -> return () Just timeout -> void $ forkIO $ do threadDelay (fromIntegral timeout * 10^(3 :: Int)) notePurge s noteId wakeupDisplayThread s -------------------------------------------------------------------------------- data NotificationConfig = NotificationConfig { notificationMaxTimeout :: Maybe Int32 -- ^ Maximum time that a notification will be displayed (in seconds). Default: None , notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 100 , notificationFormatter :: [Notification] -> T.Text -- ^ Function used to format notifications, takes the notifications from first to last } defaultFormatter :: [Notification] -> T.Text defaultFormatter [] = "" defaultFormatter (n:ns) = let count = length ns + 1 prefix = if count == 1 then "" else "(" <> T.pack (show count) <> ") " msg = if T.null (noteBody n) then noteSummary n else noteSummary n <> ": " <> noteBody n in "" <> prefix <> "" <> msg -- | The default formatter is one of -- * Summary : Body -- * Summary -- * (N) Summary : Body -- * (N) Summary -- depending on the presence of a notification body, and where N is the number of queued notifications. defaultNotificationConfig :: NotificationConfig defaultNotificationConfig = NotificationConfig { notificationMaxTimeout = Nothing , notificationMaxLength = 100 , notificationFormatter = defaultFormatter } instance Default NotificationConfig where def = defaultNotificationConfig -- | Create a new notification area with the given configuration. notifyAreaNew :: MonadIO m => NotificationConfig -> m Widget notifyAreaNew cfg = liftIO $ do frame <- frameNew Nothing box <- boxNew OrientationHorizontal 3 textArea <- labelNew (Nothing :: Maybe Text) button <- eventBoxNew sep <- separatorNew OrientationHorizontal bLabel <- labelNew (Nothing :: Maybe Text) widgetSetName bLabel "NotificationCloseButton" labelSetMarkup bLabel "×" labelSetMaxWidthChars textArea (fromIntegral $ notificationMaxLength cfg) labelSetEllipsize textArea Pango.EllipsizeModeEnd containerAdd button bLabel boxPackStart box textArea True True 0 boxPackStart box sep False False 0 boxPackStart box button False False 0 containerAdd frame box widgetHide frame w <- toWidget frame s <- initialNoteState w textArea cfg _ <- onWidgetButtonReleaseEvent button (userCancel s) realizableWrapper <- boxNew OrientationHorizontal 0 boxPackStart realizableWrapper frame False False 0 widgetShow realizableWrapper -- We can't start the dbus listener thread until we are in the GTK -- main loop, otherwise things are prone to lock up and block -- infinitely on an mvar. Bad stuff - only start the dbus thread -- after the fake invisible wrapper widget is realized. void $ onWidgetRealize realizableWrapper $ do void $ forkIO (displayThread s) notificationDaemon (notify s) (closeNotification s) -- Don't show the widget by default - it will appear when needed toWidget realizableWrapper where -- | Close the current note and pull up the next, if any userCancel s _ = do noteNext s wakeupDisplayThread s return True taffybar-4.1.1/src/System/Taffybar/Widget/Generic/0000755000000000000000000000000007346545000020114 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs0000644000000000000000000001533107346545000023161 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Widget.Generic.AutoSizeImage where import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class import Data.Int import Data.Maybe import qualified Data.Text as T import qualified GI.Gdk as Gdk import GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk import StatusNotifier.Tray (scalePixbufToSize) import System.Log.Logger import System.Taffybar.Util import System.Taffybar.Widget.Util import Text.Printf imageLog :: Priority -> String -> IO () imageLog = logM "System.Taffybar.Widget.Generic.AutoSizeImage" borderFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border] borderFunctions = [ Gtk.styleContextGetPadding , Gtk.styleContextGetMargin , Gtk.styleContextGetBorder ] data BorderInfo = BorderInfo { borderTop :: Int16 , borderBottom :: Int16 , borderLeft :: Int16 , borderRight :: Int16 } deriving (Show, Eq) borderInfoZero :: BorderInfo borderInfoZero = BorderInfo 0 0 0 0 borderWidth, borderHeight :: BorderInfo -> Int16 borderWidth borderInfo = borderLeft borderInfo + borderRight borderInfo borderHeight borderInfo = borderTop borderInfo + borderBottom borderInfo toBorderInfo :: (MonadIO m) => Gtk.Border -> m BorderInfo toBorderInfo border = BorderInfo <$> Gtk.getBorderTop border <*> Gtk.getBorderBottom border <*> Gtk.getBorderLeft border <*> Gtk.getBorderRight border addBorderInfo :: BorderInfo -> BorderInfo -> BorderInfo addBorderInfo (BorderInfo t1 b1 l1 r1) (BorderInfo t2 b2 l2 r2) = BorderInfo (t1 + t2) (b1 + b2) (l1 + l2) (r1 + r2) -- | Get the total size of the border (the sum of its assigned margin, border -- and padding values) that will be drawn for a widget as a "BorderInfo" record. getBorderInfo :: (MonadIO m, Gtk.IsWidget a) => a -> m BorderInfo getBorderInfo widget = liftIO $ do stateFlags <- Gtk.widgetGetStateFlags widget styleContext <- Gtk.widgetGetStyleContext widget let getBorderInfoFor borderFn = borderFn styleContext stateFlags >>= toBorderInfo combineBorderInfo lastSum fn = addBorderInfo lastSum <$> getBorderInfoFor fn foldM combineBorderInfo borderInfoZero borderFunctions -- | Get the actual allocation for a "Gtk.Widget", accounting for the size of -- its CSS assined margin, border and padding values. getContentAllocation :: (MonadIO m, Gtk.IsWidget a) => a -> BorderInfo -> m Gdk.Rectangle getContentAllocation widget borderInfo = do allocation <- Gtk.widgetGetAllocation widget currentWidth <- Gdk.getRectangleWidth allocation currentHeight <- Gdk.getRectangleHeight allocation currentX <- Gdk.getRectangleX allocation currentY <- Gdk.getRectangleX allocation Gdk.setRectangleWidth allocation $ max 1 $ currentWidth - fromIntegral (borderWidth borderInfo) Gdk.setRectangleHeight allocation $ max 1 $ currentHeight - fromIntegral (borderHeight borderInfo) Gdk.setRectangleX allocation $ currentX + fromIntegral (borderLeft borderInfo) Gdk.setRectangleY allocation $ currentY + fromIntegral (borderTop borderInfo) return allocation -- | Automatically update the "Gdk.Pixbuf" of a "Gtk.Image" using the provided -- action whenever the "Gtk.Image" is allocated. Returns an action that forces a -- refresh of the image through the provided action. autoSizeImage :: MonadIO m => Gtk.Image -> (Int32 -> IO (Maybe Gdk.Pixbuf)) -> Gtk.Orientation -> m (IO ()) autoSizeImage image getPixbuf orientation = liftIO $ do case orientation of Gtk.OrientationHorizontal -> Gtk.widgetSetVexpand image True _ -> Gtk.widgetSetHexpand image True _ <- widgetSetClassGI image "auto-size-image" lastAllocation <- MV.newMVar 0 -- XXX: Gtk seems to report information about padding etc inconsistently, -- which is why we look it up once, at startup. This means that we won't -- properly react to changes to these values, which could be a pretty nasty -- gotcha for someone down the line. :( borderInfo <- getBorderInfo image let setPixbuf force allocation = do _width <- Gdk.getRectangleWidth allocation _height <- Gdk.getRectangleHeight allocation let width = max 1 $ _width - fromIntegral (borderWidth borderInfo) height = max 1 $ _height - fromIntegral (borderHeight borderInfo) size = case orientation of Gtk.OrientationHorizontal -> height _ -> width previousSize <- MV.readMVar lastAllocation when (size /= previousSize || force) $ do MV.modifyMVar_ lastAllocation $ const $ return size pixbuf <- getPixbuf size pbWidth <- fromMaybe 0 <$> traverse Gdk.getPixbufWidth pixbuf pbHeight <- fromMaybe 0 <$> traverse Gdk.getPixbufHeight pixbuf let pbSize = case orientation of Gtk.OrientationHorizontal -> pbHeight _ -> pbWidth logLevel = if pbSize <= size then DEBUG else WARNING imageLog logLevel $ printf "Allocating image: size %s, width %s, \ \ height %s, aw: %s, ah: %s, pbw: %s pbh: %s" (show size) (show width) (show height) (show _width) (show _height) (show pbWidth) (show pbHeight) Gtk.imageSetFromPixbuf image pixbuf postGUIASync $ Gtk.widgetQueueResize image _ <- Gtk.onWidgetSizeAllocate image $ setPixbuf False return $ Gtk.widgetGetAllocation image >>= setPixbuf True -- | Make a new "Gtk.Image" and call "autoSizeImage" on it. Automatically scale -- the "Gdk.Pixbuf" returned from the provided getter to the appropriate size -- using "scalePixbufToSize". autoSizeImageNew :: MonadIO m => (Int32 -> IO Gdk.Pixbuf) -> Gtk.Orientation -> m Gtk.Image autoSizeImageNew getPixBuf orientation = do image <- Gtk.imageNew void $ autoSizeImage image (\size -> Just <$> (getPixBuf size >>= scalePixbufToSize size orientation)) orientation return image -- | Make a new "Gtk.MenuItem" that has both a label and an icon. imageMenuItemNew :: MonadIO m => T.Text -> (Int32 -> IO (Maybe Gdk.Pixbuf)) -> m Gtk.MenuItem imageMenuItemNew labelText pixbufGetter = do box <- Gtk.boxNew Gtk.OrientationHorizontal 0 label <- Gtk.labelNew $ Just labelText image <- Gtk.imageNew void $ autoSizeImage image pixbufGetter Gtk.OrientationHorizontal item <- Gtk.menuItemNew Gtk.containerAdd box image Gtk.containerAdd box label Gtk.containerAdd item box Gtk.widgetSetHalign box Gtk.AlignStart Gtk.widgetSetHalign image Gtk.AlignStart Gtk.widgetSetValign box Gtk.AlignFill return item taffybar-4.1.1/src/System/Taffybar/Widget/Generic/ChannelGraph.hs0000644000000000000000000000171307346545000023004 0ustar0000000000000000module System.Taffybar.Widget.Generic.ChannelGraph where import Control.Concurrent import Control.Concurrent.STM.TChan import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM (atomically) import GI.Gtk import System.Taffybar.Widget.Generic.Graph -- | 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 -> TChan a -> (a -> IO [Double]) -> m GI.Gtk.Widget channelGraphNew config chan sampleBuilder = do (graphWidget, graphHandle) <- graphNew config _ <- onWidgetRealize graphWidget $ do ourChan <- atomically $ dupTChan chan sampleThread <- forkIO $ forever $ atomically (readTChan ourChan) >>= (graphAddSample graphHandle <=< sampleBuilder) void $ onWidgetUnrealize graphWidget $ killThread sampleThread return graphWidget taffybar-4.1.1/src/System/Taffybar/Widget/Generic/ChannelWidget.hs0000644000000000000000000000151407346545000023165 0ustar0000000000000000module System.Taffybar.Widget.Generic.ChannelWidget where import Control.Concurrent import Control.Concurrent.STM.TChan import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM (atomically) import GI.Gtk -- | 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 -- 'TChan' on a dedicated haskell thread. channelWidgetNew :: (MonadIO m, IsWidget w) => w -> TChan a -> (a -> IO ()) -> m w channelWidgetNew widget channel updateWidget = do void $ onWidgetRealize widget $ do ourChan <- atomically $ dupTChan channel processingThreadId <- forkIO $ forever $ atomically (readTChan ourChan) >>= updateWidget void $ onWidgetUnrealize widget $ killThread processingThreadId widgetShowAll widget return widget taffybar-4.1.1/src/System/Taffybar/Widget/Generic/DynamicMenu.hs0000644000000000000000000000160307346545000022661 0ustar0000000000000000module System.Taffybar.Widget.Generic.DynamicMenu where import Control.Monad.IO.Class import qualified GI.Gtk as Gtk data DynamicMenuConfig = DynamicMenuConfig { dmClickWidget :: Gtk.Widget , dmPopulateMenu :: Gtk.Menu -> IO () } dynamicMenuNew :: MonadIO m => DynamicMenuConfig -> m Gtk.Widget dynamicMenuNew DynamicMenuConfig { dmClickWidget = clickWidget , dmPopulateMenu = populateMenu } = do button <- Gtk.menuButtonNew menu <- Gtk.menuNew Gtk.containerAdd button clickWidget Gtk.menuButtonSetPopup button $ Just menu _ <- Gtk.onButtonPressed button $ emptyMenu menu >> populateMenu menu Gtk.widgetShowAll button Gtk.toWidget button emptyMenu :: (Gtk.IsContainer a, MonadIO m) => a -> m () emptyMenu menu = Gtk.containerForeach menu $ \item -> Gtk.containerRemove menu item >> Gtk.widgetDestroy item taffybar-4.1.1/src/System/Taffybar/Widget/Generic/Graph.hs0000644000000000000000000002172607346545000021521 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | This is a graph widget inspired by the widget of the same name in Awesome -- (the window manager). It plots a series of data points similarly to a bar -- graph. This version must be explicitly fed data with 'graphAddSample'. For a -- more automated version, see "System.Taffybar.Widgets.Generic.PollingGraph". -- -- Like Awesome, this graph can plot multiple data sets in one widget. The data -- sets are plotted in the order provided by the caller. -- -- Note: all of the data fed to this widget should be in the range [0,1]. module System.Taffybar.Widget.Generic.Graph ( -- * Types GraphHandle , GraphConfig(..) , GraphDirection(..) , GraphStyle(..) -- * Functions , graphNew , graphAddSample , defaultGraphConfig ) where import Control.Concurrent import Control.Monad ( when ) import Control.Monad.IO.Class import Data.Default ( Default(..) ) import Data.Sequence ( Seq(..), (<|), viewl, ViewL(..) ) import qualified Data.Sequence as S import qualified Data.Text as T import qualified GI.Cairo.Render as C import GI.Cairo.Render.Connector import qualified GI.Cairo.Render.Matrix as M import qualified GI.Gtk as Gtk import System.Taffybar.Util import System.Taffybar.Widget.Util newtype GraphHandle = GH (MVar GraphState) data GraphState = GraphState { graphIsBootstrapped :: Bool , graphHistory :: [Seq Double] , graphCanvas :: Gtk.DrawingArea , graphConfig :: GraphConfig } data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq) -- 'RGBA' represents a color with a transparency. type RGBA = (Double, Double, Double, Double) -- | The style of the graph. Generally, you will want to draw all 'Area' graphs -- first, and then all 'Line' graphs. data GraphStyle = Area -- ^ Thea area below the value is filled | Line -- ^ The values are connected by a line (one pixel wide) -- | The configuration options for the graph. The padding is the number of -- pixels reserved as blank space around the widget in each direction. data GraphConfig = GraphConfig { -- | Number of pixels of padding on each side of the graph widget graphPadding :: Int -- | The background color of the graph (default black) , graphBackgroundColor :: RGBA -- | The border color drawn around the graph (default gray) , graphBorderColor :: RGBA -- | The width of the border (default 1, use 0 to disable the border) , graphBorderWidth :: Int -- | Colors for each data set (default cycles between red, green and blue) , graphDataColors :: [RGBA] -- | How to draw each data point (default @repeat Area@) , graphDataStyles :: [GraphStyle] -- | The number of data points to retain for each data set (default 20) , graphHistorySize :: Int -- | May contain Pango markup (default @Nothing@) , graphLabel :: Maybe T.Text -- | The width (in pixels) of the graph widget (default 50) , graphWidth :: Int -- | The direction in which the graph will move as time passes (default LEFT_TO_RIGHT) , graphDirection :: GraphDirection } defaultGraphConfig :: GraphConfig defaultGraphConfig = GraphConfig { graphPadding = 2 , graphBackgroundColor = (0.0, 0.0, 0.0, 1.0) , graphBorderColor = (0.5, 0.5, 0.5, 1.0) , graphBorderWidth = 1 , graphDataColors = cycle [(1, 0, 0, 0), (0, 1, 0, 0), (0, 0, 1, 0)] , graphDataStyles = repeat Area , graphHistorySize = 20 , graphLabel = Nothing , graphWidth = 50 , graphDirection = LEFT_TO_RIGHT } instance Default GraphConfig where def = defaultGraphConfig -- | Add a data point to the graph for each of the tracked data sets. There -- should be as many values in the list as there are data sets. graphAddSample :: GraphHandle -> [Double] -> IO () graphAddSample (GH mv) rawData = do s <- readMVar mv let drawArea = graphCanvas s histSize = graphHistorySize (graphConfig s) histsAndNewVals = zip pcts (graphHistory s) newHists = case graphHistory s of [] -> map S.singleton pcts _ -> map (\(p,h) -> S.take histSize $ p <| h) histsAndNewVals when (graphIsBootstrapped s) $ do modifyMVar_ mv (\s' -> return s' { graphHistory = newHists }) postGUIASync $ Gtk.widgetQueueDraw drawArea where pcts = map (clamp 0 1) rawData clamp :: Double -> Double -> Double -> Double clamp lo hi d = max lo $ min hi d outlineData :: (Double -> Double) -> Double -> Double -> C.Render () outlineData pctToY xStep pct = do (curX,_) <- C.getCurrentPoint C.lineTo (curX + xStep) (pctToY pct) renderFrameAndBackground :: GraphConfig -> Int -> Int -> C.Render () renderFrameAndBackground cfg w h = do let (backR, backG, backB, backA) = graphBackgroundColor cfg (frameR, frameG, frameB, frameA) = graphBorderColor cfg pad = graphPadding cfg fpad = fromIntegral pad fw = fromIntegral w fh = fromIntegral h -- Draw the requested background C.setSourceRGBA backR backG backB backA C.rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad) C.fill -- Draw a frame around the widget area (unless equal to background color, -- which likely means the user does not want a frame) when (graphBorderWidth cfg > 0) $ do let p = fromIntegral (graphBorderWidth cfg) C.setLineWidth p C.setSourceRGBA frameR frameG frameB frameA C.rectangle (fpad + (p / 2)) (fpad + (p / 2)) (fw - 2 * fpad - p) (fh - 2 * fpad - p) C.stroke renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> C.Render () renderGraph hists cfg w h xStep = do renderFrameAndBackground cfg w h C.setLineWidth 0.1 let pad = fromIntegral $ graphPadding cfg let framePad = fromIntegral $ graphBorderWidth cfg -- Make the new origin be inside the frame and then scale the drawing area so -- that all operations in terms of width and height are inside the drawn -- frame. C.translate (pad + framePad) (pad + framePad) let xS = (fromIntegral w - 2 * pad - 2 * framePad) / fromIntegral w yS = (fromIntegral h - 2 * pad - 2 * framePad) / fromIntegral h C.scale xS yS -- If right-to-left direction is requested, apply an horizontal inversion -- transformation with an offset to the right equal to the width of the -- widget. when (graphDirection cfg == RIGHT_TO_LEFT) $ C.transform $ M.Matrix (-1) 0 0 1 (fromIntegral w) 0 let pctToY pct = fromIntegral h * (1 - pct) renderDataSet hist color style = case viewl hist of EmptyL -> return () _oneSample :< Empty -> return () newestSample :< hist' -> do let (r, g, b, a) = color originY = pctToY newestSample originX = 0 C.setSourceRGBA r g b a C.moveTo originX originY mapM_ (outlineData pctToY xStep) hist' case style of Area -> do (endX, _) <- C.getCurrentPoint C.lineTo endX (fromIntegral h) C.lineTo 0 (fromIntegral h) C.fill Line -> do C.setLineWidth 1.0 C.stroke sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg) (graphDataStyles cfg) drawBorder :: MVar GraphState -> Gtk.DrawingArea -> C.Render () drawBorder mv drawArea = do (w, h) <- widgetGetAllocatedSize drawArea s <- liftIO $ readMVar mv let cfg = graphConfig s renderFrameAndBackground cfg w h liftIO $ modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True }) return () drawGraph :: MVar GraphState -> Gtk.DrawingArea -> C.Render () drawGraph mv drawArea = do (w, h) <- widgetGetAllocatedSize drawArea drawBorder mv drawArea s <- liftIO $ readMVar mv let hist = graphHistory s cfg = graphConfig s histSize = graphHistorySize cfg -- Subtract 1 here since the first data point doesn't require -- any movement in the X direction xStep = fromIntegral w / fromIntegral (histSize - 1) case hist of [] -> renderFrameAndBackground cfg w h _ -> renderGraph hist cfg w h xStep graphNew :: MonadIO m => GraphConfig -> m (Gtk.Widget, GraphHandle) graphNew cfg = liftIO $ do drawArea <- Gtk.drawingAreaNew mv <- newMVar GraphState { graphIsBootstrapped = False , graphHistory = [] , graphCanvas = drawArea , graphConfig = cfg } Gtk.widgetSetSizeRequest drawArea (fromIntegral $ graphWidth cfg) (-1) _ <- Gtk.onWidgetDraw drawArea $ \ctx -> renderWithContext (drawGraph mv drawArea) ctx >> return True box <- Gtk.boxNew Gtk.OrientationHorizontal 1 Gtk.widgetSetVexpand drawArea True Gtk.widgetSetVexpand box True Gtk.boxPackStart box drawArea True True 0 widget <- case graphLabel cfg of Nothing -> Gtk.toWidget box Just labelText -> do overlay <- Gtk.overlayNew label <- Gtk.labelNew Nothing Gtk.labelSetMarkup label labelText Gtk.containerAdd overlay box Gtk.overlayAddOverlay overlay label Gtk.toWidget overlay Gtk.widgetShowAll widget return (widget, GH mv) taffybar-4.1.1/src/System/Taffybar/Widget/Generic/Icon.hs0000644000000000000000000000760007346545000021343 0ustar0000000000000000-- | This is a simple static image widget, and a polling image widget that -- updates its contents by calling a callback at a set interval. module System.Taffybar.Widget.Generic.Icon ( iconImageWidgetNew , iconImageWidgetNewFromName , pollingIconImageWidgetNew , pollingIconImageWidgetNewFromName ) where import Control.Concurrent ( forkIO, threadDelay ) import qualified Data.Text as T import Control.Exception as E import Control.Monad ( forever, void ) import Control.Monad.IO.Class import GI.Gtk import System.Taffybar.Util -- | Create a new widget that displays a static image -- -- > iconImageWidgetNew path -- -- returns a widget with icon at @path@. iconImageWidgetNew :: MonadIO m => FilePath -> m Widget iconImageWidgetNew path = liftIO $ imageNewFromFile path >>= putInBox -- | Create a new widget that displays a static image -- -- > iconWidgetNewFromName name -- -- returns a widget with the icon named @name@. Icon -- names are sourced from the current GTK theme. iconImageWidgetNewFromName :: MonadIO m => T.Text -> m Widget iconImageWidgetNewFromName name = liftIO $ imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu) >>= putInBox -- | Create a new widget that updates itself at regular intervals. The -- function -- -- > pollingIconImageWidgetNew path interval cmd -- -- returns a widget with initial icon at @path@. The widget -- forks a thread to update its contents every @interval@ seconds. -- The command should return a FilePath of a valid icon. -- -- If the IO action throws an exception, it will be swallowed and the -- label will not update until the update interval expires. pollingIconImageWidgetNew :: MonadIO m => FilePath -- ^ Initial file path of the icon -> Double -- ^ Update interval (in seconds) -> IO FilePath -- ^ Command to run to get the input filepath -> m Widget pollingIconImageWidgetNew path interval cmd = pollingIcon interval cmd (imageNewFromFile path) (\image path' -> imageSetFromFile image (Just path')) -- | Create a new widget that updates itself at regular intervals. The -- function -- -- > pollingIconImageWidgetNewFromName name interval cmd -- -- returns a widget with initial icon whose name is @name@. The widget -- forks a thread to update its contents every @interval@ seconds. -- The command should return the name of a valid icon. -- -- If the IO action throws an exception, it will be swallowed and the -- label will not update until the update interval expires. pollingIconImageWidgetNewFromName :: MonadIO m => T.Text -- ^ Icon Name -> Double -- ^ Update interval (in seconds) -> IO T.Text -- ^ Command to run update the icon name -> m Widget pollingIconImageWidgetNewFromName name interval cmd = pollingIcon interval cmd (imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu)) (\image name' -> imageSetFromIconName image (Just name') $ fromIntegral $ fromEnum IconSizeMenu) -- | Creates a polling icon. pollingIcon :: MonadIO m => Double -- ^ Update Interval (in seconds) -> IO name -- ^ IO action that updates image's icon-name/filepath -> IO Image -- ^ MonadIO action that creates the initial image. -> (Image -> name -> IO b) -- ^ MonadIO action that updates the image. -> m Widget -- ^ Polling Icon pollingIcon interval doUpdateName doInitImage doSetImage = liftIO $ do image <- doInitImage _ <- onWidgetRealize image $ do _ <- forkIO $ forever $ do let tryUpdate = liftIO $ do name' <- doUpdateName postGUIASync $ void $ doSetImage image name' E.catch tryUpdate ignoreIOException threadDelay $ floor (interval * 1000000) return () putInBox image putInBox :: IsWidget child => child -> IO Widget putInBox icon = do box <- boxNew OrientationHorizontal 0 boxPackStart box icon False False 0 widgetShowAll box toWidget box ignoreIOException :: IOException -> IO () ignoreIOException _ = return () taffybar-4.1.1/src/System/Taffybar/Widget/Generic/PollingBar.hs0000644000000000000000000000223407346545000022502 0ustar0000000000000000-- | Like the vertical bar, but this widget automatically updates -- itself with a callback at fixed intervals. module System.Taffybar.Widget.Generic.PollingBar ( -- * Types VerticalBarHandle, BarConfig(..), BarDirection(..), -- * Constructors and accessors pollingBarNew, verticalBarFromCallback, defaultBarConfig ) where import Control.Concurrent import Control.Exception.Enclosed ( tryAny ) import qualified GI.Gtk import System.Taffybar.Widget.Util ( backgroundLoop ) import Control.Monad.IO.Class import System.Taffybar.Widget.Generic.VerticalBar verticalBarFromCallback :: MonadIO m => BarConfig -> IO Double -> m GI.Gtk.Widget verticalBarFromCallback cfg action = liftIO $ do (drawArea, h) <- verticalBarNew cfg _ <- GI.Gtk.onWidgetRealize drawArea $ backgroundLoop $ do esample <- tryAny action traverse (verticalBarSetPercent h) esample return drawArea pollingBarNew :: MonadIO m => BarConfig -> Double -> IO Double -> m GI.Gtk.Widget pollingBarNew cfg pollSeconds action = liftIO $ verticalBarFromCallback cfg $ action <* delay where delay = threadDelay $ floor (pollSeconds * 1000000) taffybar-4.1.1/src/System/Taffybar/Widget/Generic/PollingGraph.hs0000644000000000000000000000277607346545000023052 0ustar0000000000000000-- | A variant of the Graph widget that automatically updates itself -- with a callback at a fixed interval. module System.Taffybar.Widget.Generic.PollingGraph ( -- * Types GraphHandle, GraphConfig(..), GraphDirection(..), GraphStyle(..), -- * Constructors and accessors pollingGraphNew, pollingGraphNewWithTooltip, defaultGraphConfig ) where import Control.Concurrent import qualified Control.Exception.Enclosed as E import Control.Monad import Control.Monad.IO.Class import qualified Data.Text as T import GI.Gtk import System.Taffybar.Util import System.Taffybar.Widget.Generic.Graph pollingGraphNewWithTooltip :: MonadIO m => GraphConfig -> Double -> IO ([Double], Maybe T.Text) -> m GI.Gtk.Widget pollingGraphNewWithTooltip cfg pollSeconds action = liftIO $ do (graphWidget, graphHandle) <- graphNew cfg _ <- onWidgetRealize graphWidget $ do sampleThread <- foreverWithDelay pollSeconds $ do esample <- E.tryAny action case esample of Left _ -> return () Right (sample, tooltipStr) -> do graphAddSample graphHandle sample widgetSetTooltipMarkup graphWidget tooltipStr void $ onWidgetUnrealize graphWidget $ killThread sampleThread return graphWidget pollingGraphNew :: MonadIO m => GraphConfig -> Double -> IO [Double] -> m GI.Gtk.Widget pollingGraphNew cfg pollSeconds action = pollingGraphNewWithTooltip cfg pollSeconds $ fmap (, Nothing) action taffybar-4.1.1/src/System/Taffybar/Widget/Generic/PollingLabel.hs0000644000000000000000000000666407346545000023030 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This is a simple text widget that updates its contents by calling -- a callback at a set interval. module System.Taffybar.Widget.Generic.PollingLabel where import Control.Concurrent import Control.Exception.Enclosed as E import Control.Monad import Control.Monad.IO.Class import qualified Data.Text as T import GI.Gtk import qualified GI.Gdk as Gdk import System.Log.Logger import System.Taffybar.Util import System.Taffybar.Widget.Util import Text.Printf -- | Create a new widget that updates itself at regular intervals. The -- function -- -- > pollingLabelNew initialString cmd interval -- -- returns a widget with initial text @initialString@. The widget forks a thread -- to update its contents every @interval@ seconds. The command should return a -- string with any HTML entities escaped. This is not checked by the function, -- since Pango markup shouldn't be escaped. Proper input sanitization is up to -- the caller. -- -- If the IO action throws an exception, it will be swallowed and the label will -- not update until the update interval expires. pollingLabelNew :: MonadIO m => Double -- ^ Update interval (in seconds) -> IO T.Text -- ^ Command to run to get the input string -> m GI.Gtk.Widget pollingLabelNew interval cmd = pollingLabelNewWithTooltip interval $ (, Nothing) <$> cmd pollingLabelNewWithTooltip :: MonadIO m => Double -- ^ Update interval (in seconds) -> IO (T.Text, Maybe T.Text) -- ^ Command to run to get the input string -> m GI.Gtk.Widget pollingLabelNewWithTooltip interval action = pollingLabelWithVariableDelay $ withInterval <$> action where withInterval (a, b) = (a, b, interval) pollingLabelWithVariableDelay :: MonadIO m => IO (T.Text, Maybe T.Text, Double) -> m GI.Gtk.Widget pollingLabelWithVariableDelay action = pollingLabelWithVariableDelayAndRefresh action False -- TODO: Customize the delay and message on mouse click pollingLabelWithVariableDelayAndRefresh :: MonadIO m => IO (T.Text, Maybe T.Text, Double) -> Bool -- ^ Whether to refresh the label on mouse click -> m GI.Gtk.Widget pollingLabelWithVariableDelayAndRefresh action refreshOnClick = liftIO $ do grid <- gridNew label <- labelNew Nothing ebox <- eventBoxNew when refreshOnClick $ void $ onWidgetButtonPressEvent ebox $ onClick [Gdk.EventTypeButtonPress] $ do postGUIASync $ labelSetMarkup label "Refreshing..." forkIO $ do newLavelStr <- E.tryAny action >>= \case Left _ -> return "Error" Right (_labelStr, _, _) -> return _labelStr postGUIASync $ labelSetMarkup label newLavelStr let updateLabel (labelStr, tooltipStr, delay) = do postGUIASync $ do labelSetMarkup label labelStr widgetSetTooltipMarkup label tooltipStr logM "System.Taffybar.Widget.Generic.PollingLabel" DEBUG $ printf "Polling label delay was %s" $ show delay return delay updateLabelHandlingErrors = E.tryAny action >>= either (const $ return 1) updateLabel _ <- onWidgetRealize label $ do sampleThread <- foreverWithVariableDelay updateLabelHandlingErrors void $ onWidgetUnrealize label $ killThread sampleThread vFillCenter label vFillCenter grid containerAdd grid label containerAdd ebox grid widgetShowAll ebox toWidget ebox taffybar-4.1.1/src/System/Taffybar/Widget/Generic/VerticalBar.hs0000644000000000000000000001417207346545000022653 0ustar0000000000000000-- | A vertical bar that can plot data in the range [0, 1]. The -- colors are configurable. module System.Taffybar.Widget.Generic.VerticalBar ( -- * Types VerticalBarHandle, BarConfig(..), BarDirection(..), -- * Accessors/Constructors verticalBarNew, verticalBarSetPercent, defaultBarConfig, defaultBarConfigIO ) where import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import qualified GI.Cairo.Render as C import GI.Cairo.Render.Connector import GI.Gtk hiding (widgetGetAllocatedSize) import System.Taffybar.Util import System.Taffybar.Widget.Util newtype VerticalBarHandle = VBH (MVar VerticalBarState) data VerticalBarState = VerticalBarState { barIsBootstrapped :: Bool , barPercent :: Double , barCanvas :: DrawingArea , barConfig :: BarConfig } data BarDirection = HORIZONTAL | VERTICAL data BarConfig = BarConfig { -- | Color of the border drawn around the widget barBorderColor :: (Double, Double, Double) -- | The background color of the widget , barBackgroundColor :: Double -> (Double, Double, Double) -- | A function to determine the color of the widget for the current data point , barColor :: Double -> (Double, Double, Double) -- | Number of pixels of padding around the widget , barPadding :: Int , barWidth :: Int , barDirection :: BarDirection} | BarConfigIO { barBorderColorIO :: IO (Double, Double, Double) , barBackgroundColorIO :: Double -> IO (Double, Double, Double) , barColorIO :: Double -> IO (Double, Double, Double) , barPadding :: Int , barWidth :: Int , barDirection :: BarDirection} -- | A default bar configuration. The color of the active portion of -- the bar must be specified. defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig defaultBarConfig c = BarConfig { barBorderColor = (0.5, 0.5, 0.5) , barBackgroundColor = const (0, 0, 0) , barColor = c , barPadding = 2 , barWidth = 15 , barDirection = VERTICAL } defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig defaultBarConfigIO c = BarConfigIO { barBorderColorIO = return (0.5, 0.5, 0.5) , barBackgroundColorIO = \_ -> return (0, 0, 0) , barColorIO = c , barPadding = 2 , barWidth = 15 , barDirection = VERTICAL } verticalBarSetPercent :: VerticalBarHandle -> Double -> IO () verticalBarSetPercent (VBH mv) pct = do s <- readMVar mv let drawArea = barCanvas s when (barIsBootstrapped s) $ do modifyMVar_ mv (\s' -> return s' { barPercent = clamp 0 1 pct }) postGUIASync $ widgetQueueDraw drawArea clamp :: Double -> Double -> Double -> Double clamp lo hi d = max lo $ min hi d liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double) liftedBackgroundColor bc pct = case bc of BarConfig { barBackgroundColor = bcolor } -> return (bcolor pct) BarConfigIO { barBackgroundColorIO = bcolor } -> bcolor pct liftedBorderColor :: BarConfig -> IO (Double, Double, Double) liftedBorderColor bc = case bc of BarConfig { barBorderColor = border } -> return border BarConfigIO { barBorderColorIO = border } -> border liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double) liftedBarColor bc pct = case bc of BarConfig { barColor = c } -> return (c pct) BarConfigIO { barColorIO = c } -> c pct renderFrame_ :: Double -> BarConfig -> Int -> Int -> C.Render () renderFrame_ pct cfg width height = do let fwidth = fromIntegral width fheight = fromIntegral height -- Now draw the user's requested background, respecting padding (bgR, bgG, bgB) <- C.liftIO $ liftedBackgroundColor cfg pct let pad = barPadding cfg fpad = fromIntegral pad C.setSourceRGB bgR bgG bgB C.rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad) C.fill -- Now draw a nice frame (frameR, frameG, frameB) <- C.liftIO $ liftedBorderColor cfg C.setSourceRGB frameR frameG frameB C.setLineWidth 1.0 C.rectangle (fpad + 0.5) (fpad + 0.5) (fwidth - 2 * fpad - 1) (fheight - 2 * fpad - 1) C.stroke renderBar :: Double -> BarConfig -> Int -> Int -> C.Render () renderBar pct cfg width height = do let direction = barDirection cfg activeHeight = case direction of VERTICAL -> pct * fromIntegral height HORIZONTAL -> fromIntegral height activeWidth = case direction of VERTICAL -> fromIntegral width HORIZONTAL -> pct * fromIntegral width newOrigin = case direction of VERTICAL -> fromIntegral height - activeHeight HORIZONTAL -> 0 pad = barPadding cfg renderFrame_ pct cfg width height -- After we draw the frame, transform the coordinate space so that -- we only draw within the frame. C.translate (fromIntegral pad + 1) (fromIntegral pad + 1) let xS = fromIntegral (width - 2 * pad - 2) / fromIntegral width yS = fromIntegral (height - 2 * pad - 2) / fromIntegral height C.scale xS yS (r, g, b) <- C.liftIO $ liftedBarColor cfg pct C.setSourceRGB r g b C.translate 0 newOrigin C.rectangle 0 0 activeWidth activeHeight C.fill drawBar :: MVar VerticalBarState -> DrawingArea -> C.Render () drawBar mv drawArea = do (w, h) <- widgetGetAllocatedSize drawArea s <- liftIO $ do s <- readMVar mv modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True }) return s renderBar (barPercent s) (barConfig s) w h verticalBarNew :: MonadIO m => BarConfig -> m (GI.Gtk.Widget, VerticalBarHandle) verticalBarNew cfg = liftIO $ do drawArea <- drawingAreaNew mv <- newMVar VerticalBarState { barIsBootstrapped = False , barPercent = 0 , barCanvas = drawArea , barConfig = cfg } widgetSetSizeRequest drawArea (fromIntegral $ barWidth cfg) (-1) _ <- onWidgetDraw drawArea $ \ctx -> renderWithContext (drawBar mv drawArea) ctx >> return True box <- boxNew OrientationHorizontal 1 boxPackStart box drawArea True True 0 widgetShowAll box giBox <- toWidget box return (giBox, VBH mv) taffybar-4.1.1/src/System/Taffybar/Widget/Layout.hs0000644000000000000000000000760007346545000020354 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Layout -- Copyright : (c) Ivan Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan Malison -- Stability : unstable -- Portability : unportable -- -- Simple text widget that shows the XMonad layout used in the currently active -- workspace, and that allows to change it by clicking with the mouse: -- left-click to switch to the next layout in the list, right-click to switch to -- the first one (as configured in @xmonad.hs@) ----------------------------------------------------------------------------- module System.Taffybar.Widget.Layout ( -- * Usage -- $usage LayoutConfig(..) , defaultLayoutConfig , layoutNew ) where import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Default (Default(..)) import qualified Data.Text as T import qualified GI.Gtk as Gtk import GI.Gdk import System.Taffybar.Context import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util import System.Taffybar.Widget.Util -- $usage -- -- This widget requires that the "XMonad.Hooks.TaffybarPagerHints" hook be -- installed in your @xmonad.hs@: -- -- > import XMonad.Hooks.TaffybarPagerHints (pagerHints) -- > main = do -- > xmonad $ ewmh $ pagerHints $ defaultConfig -- > ... -- -- Once you've properly configured @xmonad.hs@, you can use the widget in -- your @taffybar.hs@ file: -- -- > import System.Taffybar.Widget.Layout -- > main = do -- > let los = layoutSwitcherNew def -- -- now you can use @los@ as any other Taffybar widget. newtype LayoutConfig = LayoutConfig { formatLayout :: T.Text -> TaffyIO T.Text } defaultLayoutConfig :: LayoutConfig defaultLayoutConfig = LayoutConfig return instance Default LayoutConfig where def = defaultLayoutConfig -- | Name of the X11 events to subscribe, and of the hint to look for for -- the name of the current layout. xLayoutProp :: String xLayoutProp = "_XMONAD_CURRENT_LAYOUT" -- | Create a new Layout widget that will use the given Pager as -- its source of events. layoutNew :: LayoutConfig -> TaffyIO Gtk.Widget layoutNew config = do ctx <- ask label <- lift $ Gtk.labelNew (Nothing :: Maybe T.Text) _ <- widgetSetClassGI label "layout-label" -- This callback is run in a separate thread and needs to use -- postGUIASync let callback _ = mapReaderT postGUIASync $ do layout <- runX11Def "" $ readAsString Nothing xLayoutProp markup <- formatLayout config (T.pack layout) lift $ Gtk.labelSetMarkup label markup subscription <- subscribeToPropertyEvents [xLayoutProp] callback do ebox <- Gtk.eventBoxNew Gtk.containerAdd ebox label _ <- Gtk.onWidgetButtonPressEvent ebox $ dispatchButtonEvent ctx Gtk.widgetShowAll ebox _ <- Gtk.onWidgetUnrealize ebox $ flip runReaderT ctx $ unsubscribe subscription Gtk.toWidget ebox -- | Call 'switch' with the appropriate argument (1 for left click, -1 for -- right click), depending on the click event received. dispatchButtonEvent :: Context -> EventButton -> IO Bool dispatchButtonEvent context btn = do pressType <- getEventButtonType btn buttonNumber <- getEventButtonButton btn case pressType of EventTypeButtonPress -> case buttonNumber of 1 -> runReaderT (runX11Def () (switch 1)) context >> return True 2 -> runReaderT (runX11Def () (switch (-1))) context >> return True _ -> return False _ -> return False -- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be -- intercepted by the PagerHints hook, which in turn can instruct XMonad to -- switch to a different layout. switch :: Int -> X11Property () switch n = do cmd <- getAtom xLayoutProp sendCommandEvent cmd (fromIntegral n) taffybar-4.1.1/src/System/Taffybar/Widget/MPRIS2.hs0000644000000000000000000002515007346545000020053 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.MPRIS2 -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This is a "Now Playing" widget that listens for MPRIS2 events on DBus. You -- can find the MPRIS2 specification here at -- (). ----------------------------------------------------------------------------- module System.Taffybar.Widget.MPRIS2 where import Control.Arrow import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import DBus import DBus.Client import qualified DBus.TH as DBus import Data.Default (Default(..)) import Data.GI.Base.Overloading (IsDescendantOf) import Data.Int import Data.List import qualified Data.Map as M import qualified Data.Text as T import qualified GI.GLib as G import GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk import System.Environment.XDG.DesktopEntry import System.Log.Logger import System.Taffybar.Context import qualified System.Taffybar.DBus.Client.MPRIS2 as MPRIS2DBus import System.Taffybar.Information.MPRIS2 import System.Taffybar.Util import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Util import System.Taffybar.WindowIcon import Text.Printf mprisLog :: (MonadIO m, Show t) => Priority -> String -> t -> m () mprisLog = logPrintF "System.Taffybar.Widget.MPRIS2" -- | A type representing a function that produces an IO action that adds the -- provided widget to some container. type WidgetAdder a m = (IsDescendantOf Gtk.Widget a , MonadIO m , Gtk.GObject a ) => a -> m () -- | The type of a customization function that is used to update a widget with -- the provided now playing info. The type a should be the internal state used -- for the widget (typically just references to the child widgets that may need -- to be updated ). When the provided value is nothing, it means that the widget -- does not exist yet and it should be instantiated. When the provided -- NowPlaying value is Nothing, the dbus client is no longer, and typically the -- widget should be hidden. type UpdateMPRIS2PlayerWidget a = (forall w. WidgetAdder w IO) -> Maybe a -> Maybe NowPlaying -> TaffyIO a -- | Configuration for an MPRIS2 Widget data MPRIS2Config a = MPRIS2Config { -- | A function that will be used to wrap the outer MPRIS2 grid widget mprisWidgetWrapper :: Gtk.Widget -> IO Gtk.Widget -- | This function will be called to instantiate and update the player widgets -- of each dbus player client. See the docstring for `UpdateMPRIS2PlayerWidget` -- for more details. , updatePlayerWidget :: UpdateMPRIS2PlayerWidget a } defaultMPRIS2Config :: MPRIS2Config MPRIS2PlayerWidget defaultMPRIS2Config = MPRIS2Config { mprisWidgetWrapper = return , updatePlayerWidget = simplePlayerWidget def } data MPRIS2PlayerWidget = MPRIS2PlayerWidget { playerLabel :: Gtk.Label , playerWidget :: Gtk.Widget } data SimpleMPRIS2PlayerConfig = SimpleMPRIS2PlayerConfig { setNowPlayingLabel :: NowPlaying -> IO T.Text , showPlayerWidgetFn :: NowPlaying -> IO Bool } defaultPlayerConfig :: SimpleMPRIS2PlayerConfig defaultPlayerConfig = SimpleMPRIS2PlayerConfig { setNowPlayingLabel = playingText 20 30 , showPlayerWidgetFn = \NowPlaying { npStatus = status } -> return $ status /= "Stopped" } instance Default SimpleMPRIS2PlayerConfig where def = defaultPlayerConfig makeExcept :: String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b makeExcept errorString actionBuilder = ExceptT . fmap (maybeToEither errorString) . actionBuilder loadIconAtSize :: Client -> BusName -> Int32 -> IO Gdk.Pixbuf loadIconAtSize client busName size = let failure err = mprisLog WARNING "Failed to load default image: %s" err >> pixBufFromColor size 0 loadDefault = loadIcon size "play.svg" >>= either failure return logErrorAndLoadDefault err = mprisLog WARNING "Failed to get MPRIS icon: %s" err >> mprisLog WARNING "MPRIS failure for: %s" busName >> loadDefault chromeSpecialCase l@(Left _) = if "chrom" `isInfixOf` formatBusName busName then Right "google-chrome" else l chromeSpecialCase x = x in either logErrorAndLoadDefault return =<< runExceptT (ExceptT (left show . chromeSpecialCase <$> MPRIS2DBus.getDesktopEntry client busName) >>= makeExcept "Failed to get desktop entry" getDirectoryEntryDefault >>= makeExcept "Failed to get image" (getImageForDesktopEntry size)) -- | This is the default player widget constructor that is used to build mpris -- widgets. It provides only an icon and NowPlaying text. simplePlayerWidget :: SimpleMPRIS2PlayerConfig -> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget simplePlayerWidget _ _ (Just p@MPRIS2PlayerWidget { playerWidget = widget }) Nothing = lift $ Gtk.widgetHide widget >> return p simplePlayerWidget c addToParent Nothing np@(Just NowPlaying { npBusName = busName }) = do ctx <- ask client <- asks sessionDBusClient lift $ do mprisLog DEBUG "Building widget for %s" busName image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal playerBox <- Gtk.gridNew label <- Gtk.labelNew Nothing ebox <- Gtk.eventBoxNew _ <- Gtk.onWidgetButtonPressEvent ebox $ const $ MPRIS2DBus.playPause client busName >> return True Gtk.containerAdd playerBox image Gtk.containerAdd playerBox label Gtk.containerAdd ebox playerBox vFillCenter playerBox addToParent ebox Gtk.widgetSetVexpand playerBox True Gtk.widgetSetName playerBox $ T.pack $ formatBusName busName Gtk.widgetShowAll ebox Gtk.widgetHide ebox widget <- Gtk.toWidget ebox let widgetData = MPRIS2PlayerWidget { playerLabel = label, playerWidget = widget } flip runReaderT ctx $ simplePlayerWidget c addToParent (Just widgetData) np simplePlayerWidget config _ (Just w@MPRIS2PlayerWidget { playerLabel = label , playerWidget = widget }) (Just nowPlaying) = lift $ do mprisLog DEBUG "Setting state %s" nowPlaying Gtk.labelSetMarkup label =<< setNowPlayingLabel config nowPlaying shouldShow <- showPlayerWidgetFn config nowPlaying if shouldShow then Gtk.widgetShowAll widget else Gtk.widgetHide widget return w simplePlayerWidget _ _ _ _ = mprisLog WARNING "widget update called with no widget or %s" ("nowplaying" :: String) >> return undefined -- | Construct a new MPRIS2 widget using the `simplePlayerWidget` constructor. mpris2New :: TaffyIO Gtk.Widget mpris2New = mpris2NewWithConfig defaultMPRIS2Config -- | Construct a new MPRIS2 widget with the provided configuration. mpris2NewWithConfig :: MPRIS2Config a -> TaffyIO Gtk.Widget mpris2NewWithConfig config = ask >>= \ctx -> asks sessionDBusClient >>= \client -> lift $ do grid <- Gtk.gridNew outerWidget <- Gtk.toWidget grid >>= mprisWidgetWrapper config vFillCenter grid playerWidgetsVar <- MV.newMVar M.empty let updateWidget = updatePlayerWidget config updatePlayerWidgets nowPlayings playerWidgets = do let updateWidgetFromNP np@NowPlaying { npBusName = busName } = (busName,) <$> updateWidget (Gtk.containerAdd grid) (M.lookup busName playerWidgets) (Just np) activeBusNames = map npBusName nowPlayings existingBusNames = M.keys playerWidgets inactiveBusNames = existingBusNames \\ activeBusNames callForNoPlayingAvailable busName = updateWidget (Gtk.containerAdd grid) (M.lookup busName playerWidgets) Nothing -- Invoke the widgets with no NowPlaying so they can hide etc. mapM_ callForNoPlayingAvailable inactiveBusNames -- Update all the other widgets updatedWidgets <- M.fromList <$> mapM updateWidgetFromNP nowPlayings return $ M.union updatedWidgets playerWidgets updatePlayerWidgetsVar nowPlayings = postGUISync $ MV.modifyMVar_ playerWidgetsVar $ flip runReaderT ctx . updatePlayerWidgets nowPlayings setPlayingClass = do anyVisible <- anyM Gtk.widgetIsVisible =<< Gtk.containerGetChildren grid if anyVisible then do addClassIfMissing "visible-children" outerWidget removeClassIfPresent "no-visible-children" outerWidget else do addClassIfMissing "no-visible-children" outerWidget removeClassIfPresent "visible-children" outerWidget doUpdate = do nowPlayings <- getNowPlayingInfo client updatePlayerWidgetsVar nowPlayings setPlayingClass signalCallback _ _ _ _ = doUpdate propMatcher = matchAny { matchPath = Just "/org/mpris/MediaPlayer2" } handleNameOwnerChanged _ name _ _ = do playerWidgets <- MV.readMVar playerWidgetsVar busName <- parseBusName name when (busName `M.member` playerWidgets) doUpdate _ <- Gtk.onWidgetRealize grid $ do updateHandler <- DBus.registerForPropertiesChanged client propMatcher signalCallback nameHandler <- DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged doUpdate void $ Gtk.onWidgetUnrealize grid $ removeMatch client updateHandler >> removeMatch client nameHandler Gtk.widgetShow grid setPlayingClass return outerWidget -- | Generate now playing text with the artist truncated to a maximum given by -- the first provided int, and the song title truncated to a maximum given by -- the second provided int. playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} = G.markupEscapeText formattedText (-1) where truncatedTitle = truncateString songMax title formattedText = T.pack $ if null artists then truncatedTitle else printf "%s - %s" (truncateString artistMax $ intercalate "," artists) truncatedTitle taffybar-4.1.1/src/System/Taffybar/Widget/NetworkGraph.hs0000644000000000000000000000640707346545000021516 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.NetworkGraph -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This module provides a channel based network graph widget. ----------------------------------------------------------------------------- module System.Taffybar.Widget.NetworkGraph where import Data.Default (Default(..)) import Data.Foldable (for_) import qualified GI.Gtk import GI.Gtk.Objects.Widget (widgetSetTooltipMarkup) import System.Taffybar.Context import System.Taffybar.Hooks import System.Taffybar.Information.Network import System.Taffybar.Util (postGUIASync) import System.Taffybar.Widget.Generic.ChannelGraph import System.Taffybar.Widget.Generic.ChannelWidget import System.Taffybar.Widget.Generic.Graph import System.Taffybar.Widget.Text.NetworkMonitor -- | 'NetworkGraphConfig' configures the network graph widget. data NetworkGraphConfig = NetworkGraphConfig { networkGraphGraphConfig :: GraphConfig -- ^ The configuration of the graph itself. -- | A tooltip format string, together with the precision that should be used -- for numbers in the string. , networkGraphTooltipFormat :: Maybe (String, Int) -- | A function to scale the y axis of the network config. The default is -- `logBase $ 2 ** 32`. , networkGraphScale :: Double -> Double -- | A filter function that determines whether a given interface will be -- included in the network stats. , interfacesFilter :: String -> Bool } -- | Default configuration paramters for the network graph. defaultNetworkGraphConfig :: NetworkGraphConfig defaultNetworkGraphConfig = NetworkGraphConfig { networkGraphGraphConfig = def , networkGraphTooltipFormat = Just (defaultNetFormat, 3) , networkGraphScale = logBase $ 2 ** 32 , interfacesFilter = const True } instance Default NetworkGraphConfig where def = defaultNetworkGraphConfig -- | 'networkGraphNew' instantiates a network graph widget from a 'GraphConfig' -- and a list of interfaces. networkGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO GI.Gtk.Widget networkGraphNew config interfaces = networkGraphNewWith def { networkGraphGraphConfig = config , interfacesFilter = maybe (const True) (flip elem) interfaces } -- | 'networkGraphNewWith' instantiates a network graph widget from a -- 'NetworkGraphConfig'. networkGraphNewWith :: NetworkGraphConfig -> TaffyIO GI.Gtk.Widget networkGraphNewWith config = do NetworkInfoChan chan <- getNetworkChan let getUpDown = sumSpeeds . map snd . filter (interfacesFilter config . fst) toSample (up, down) = map (networkGraphScale config . fromRational) [up, down] sampleBuilder = return . toSample . getUpDown widget <- channelGraphNew (networkGraphGraphConfig config) chan sampleBuilder for_ (networkGraphTooltipFormat config) $ \(format, precision) -> channelWidgetNew widget chan $ \speedInfo -> let (up, down) = sumSpeeds $ map snd speedInfo tooltip = showInfo format precision (fromRational down, fromRational up) in postGUIASync $ widgetSetTooltipMarkup widget $ Just tooltip return widget taffybar-4.1.1/src/System/Taffybar/Widget/SNITray.hs0000644000000000000000000000700507346545000020367 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.SNITray -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable -- -- This module exports functions for the construction of -- StatusNotifierItem/AppIndicator tray widgets, supplied by the -- "StatusNotifier.Tray" module from the gtk-sni-tray library. These widgets do -- not support the older XEMBED protocol, although bridges like -- xembed-sni-proxy do allow sni trays to provide limited support for XEMBED -- tray icons. -- -- Unless 'sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is used it is -- necessary to run status-notifier-watcher from the -- [status-notifier-item](https://github.com/taffybar/status-notifier-item) -- package before starting taffybar when using the functions defined in this -- module. Using 'sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is -- generally not recommended, because it can lead to issues with the -- registration of tray icons if taffybar crashes/restarts, or if tray icon -- providing applications are ever started before taffybar. ----------------------------------------------------------------------------- module System.Taffybar.Widget.SNITray ( TrayParams , module System.Taffybar.Widget.SNITray ) where import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import qualified GI.Gtk import qualified StatusNotifier.Host.Service as H import StatusNotifier.Tray import System.Posix.Process import System.Taffybar.Context import System.Taffybar.Widget.Util import Text.Printf -- | Build a new StatusNotifierItem tray that will share a host with any other -- trays that are constructed automatically sniTrayNew :: TaffyIO GI.Gtk.Widget sniTrayNew = sniTrayNewFromParams defaultTrayParams -- | Build a new StatusNotifierItem tray from the provided 'TrayParams'. sniTrayNewFromParams :: TrayParams -> TaffyIO GI.Gtk.Widget sniTrayNewFromParams params = getTrayHost False >>= sniTrayNewFromHostParams params -- | Build a new StatusNotifierItem tray from the provided 'TrayParams' and -- 'H.Host'. sniTrayNewFromHostParams :: TrayParams -> H.Host -> TaffyIO GI.Gtk.Widget sniTrayNewFromHostParams params host = do client <- asks sessionDBusClient lift $ do tray <- buildTray host client params _ <- widgetSetClassGI tray "sni-tray" GI.Gtk.widgetShowAll tray GI.Gtk.toWidget tray -- | Build a new StatusNotifierItem tray that also starts its own watcher, -- without depending on status-notifier-icon. This will not register applets -- started before the watcher is started. sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO GI.Gtk.Widget sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt = getTrayHost True >>= sniTrayNewFromHostParams defaultTrayParams -- | Get a 'H.Host' from 'TaffyIO' internal state, that can be used to construct -- SNI tray widgets. The boolean parameter determines whether or not a watcher -- will be started the first time 'getTrayHost' is invoked. getTrayHost :: Bool -> TaffyIO H.Host getTrayHost startWatcher = getStateDefault $ do pid <- lift getProcessID client <- asks sessionDBusClient Just host <- lift $ H.build H.defaultParams { H.dbusClient = Just client , H.uniqueIdentifier = printf "taffybar-%s" $ show pid , H.startWatcher = startWatcher } return host taffybar-4.1.1/src/System/Taffybar/Widget/SimpleClock.hs0000644000000000000000000001263107346545000021304 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Widget.SimpleClock ( textClockNew , textClockNewWith , defaultClockConfig , ClockConfig(..) , ClockUpdateStrategy(..) ) where import Control.Monad.IO.Class import Data.Default ( Default(..) ) import Data.Maybe import qualified Data.Text as T import Data.Time.Calendar ( toGregorian ) import qualified Data.Time.Clock as Clock import Data.Time.Format import Data.Time.LocalTime import qualified Data.Time.Locale.Compat as L import qualified GI.Gdk as Gdk import GI.Gtk import System.Taffybar.Widget.Generic.PollingLabel import System.Taffybar.Widget.Util -- | This module implements a very simple text-based clock widget. The widget -- also toggles a calendar widget when clicked. This calendar is not fancy at -- all and has no data backend. makeCalendar :: IO TimeZone -> IO Window makeCalendar tzfn = do container <- windowNew WindowTypeToplevel cal <- calendarNew containerAdd container cal _ <- onWidgetShow container $ resetCalendarDate cal tzfn -- Hide the calendar instead of destroying it _ <- onWidgetDeleteEvent container $ \_ -> widgetHide container >> return True return container resetCalendarDate :: Calendar -> IO TimeZone -> IO () resetCalendarDate cal tzfn = do tz <- tzfn current <- Clock.getCurrentTime let (y,m,d) = toGregorian $ localDay $ utcToLocalTime tz current calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y) calendarSelectDay cal (fromIntegral d) toggleCalendar :: IsWidget w => w -> Window -> IO Bool toggleCalendar w c = do isVis <- widgetGetVisible c if isVis then widgetHide c else do attachPopup w "Calendar" c displayPopup w c return True -- | Create the widget. I recommend passing @Nothing@ for the TimeLocale -- parameter. The format string can include Pango markup -- (). textClockNew :: MonadIO m => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget textClockNew userLocale format interval = textClockNewWith cfg where cfg = def { clockTimeLocale = userLocale , clockFormatString = format , clockUpdateStrategy = ConstantInterval interval } data ClockUpdateStrategy = ConstantInterval Double | RoundedTargetInterval Int Double deriving (Eq, Ord, Show) data ClockConfig = ClockConfig { clockTimeZone :: Maybe TimeZone , clockTimeLocale :: Maybe L.TimeLocale , clockFormatString :: String , clockUpdateStrategy :: ClockUpdateStrategy } deriving (Eq, Ord, Show) -- | A clock configuration that defaults to the current locale defaultClockConfig :: ClockConfig defaultClockConfig = ClockConfig { clockTimeZone = Nothing , clockTimeLocale = Nothing , clockFormatString = "%a %b %_d %r" , clockUpdateStrategy = RoundedTargetInterval 5 0.0 } instance Default ClockConfig where def = defaultClockConfig -- | A configurable text-based clock widget. It currently allows for -- a configurable time zone through the 'ClockConfig'. -- -- See also 'textClockNew'. textClockNewWith :: MonadIO m => ClockConfig -> m Widget textClockNewWith ClockConfig { clockTimeZone = userZone , clockTimeLocale = userLocale , clockFormatString = formatString , clockUpdateStrategy = updateStrategy } = liftIO $ do let getTZ = maybe getCurrentTimeZone return userZone locale = fromMaybe L.defaultTimeLocale userLocale let getUserZonedTime = utcToZonedTime <$> getTZ <*> Clock.getCurrentTime doTimeFormat zonedTime = T.pack $ formatTime locale formatString zonedTime getRoundedTimeAndNextTarget = do zonedTime <- getUserZonedTime return $ case updateStrategy of ConstantInterval interval -> (doTimeFormat zonedTime, Nothing, interval) RoundedTargetInterval roundSeconds offset -> let roundSecondsDiffTime = fromIntegral roundSeconds addTheRound = addLocalTime roundSecondsDiffTime localTime = zonedTimeToLocalTime zonedTime ourLocalTimeOfDay = localTimeOfDay localTime seconds = round $ todSec ourLocalTimeOfDay secondsFactor = seconds `div` roundSeconds displaySeconds = secondsFactor * roundSeconds baseLocalTimeOfDay = ourLocalTimeOfDay { todSec = fromIntegral displaySeconds } ourLocalTime = localTime { localTimeOfDay = baseLocalTimeOfDay } roundedLocalTime = if seconds `mod` roundSeconds > roundSeconds `div` 2 then addTheRound ourLocalTime else ourLocalTime roundedZonedTime = zonedTime { zonedTimeToLocalTime = roundedLocalTime } nextTarget = addTheRound ourLocalTime amountToWait = realToFrac $ diffLocalTime nextTarget localTime in (doTimeFormat roundedZonedTime, Nothing, amountToWait - offset) label <- pollingLabelWithVariableDelay getRoundedTimeAndNextTarget ebox <- eventBoxNew containerAdd ebox label eventBoxSetVisibleWindow ebox False cal <- makeCalendar getTZ _ <- onWidgetButtonPressEvent ebox $ onClick [Gdk.EventTypeButtonPress] $ toggleCalendar label cal widgetShowAll ebox toWidget ebox taffybar-4.1.1/src/System/Taffybar/Widget/SimpleCommandButton.hs0000644000000000000000000000265707346545000023032 0ustar0000000000000000-------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.SimpleCommandButton -- Copyright : (c) Ulf Jasper -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ulf Jasper -- Stability : unstable -- Portability : unportable -- -- Simple button which runs a user defined command when being clicked -------------------------------------------------------------------------------- module System.Taffybar.Widget.SimpleCommandButton ( -- * Usage -- $usage simpleCommandButtonNew) where import Control.Monad (void) import Control.Monad.IO.Class import GI.Gtk import System.Process import qualified Data.Text as T -- $usage -- -- In order to use this widget add the following line to your -- @taffybar.hs@ file: -- -- > import System.Taffybar.Widget -- > main = do -- > let cmdButton = simpleCommandButtonNew "Hello World!" "xterm -e \"echo Hello World!; read x\"" -- -- Now you can use @cmdButton@ like any other Taffybar widget. -- | Creates a new simple command button. simpleCommandButtonNew :: MonadIO m => T.Text -- ^ Contents of the button's label. -> T.Text -- ^ Command to execute. Should be in $PATH or an absolute path -> m Widget simpleCommandButtonNew txt cmd = do button <- buttonNewWithLabel txt void $ onButtonClicked button $ void $ spawnCommand $ T.unpack cmd toWidget button taffybar-4.1.1/src/System/Taffybar/Widget/Text/0000755000000000000000000000000007346545000017464 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/Widget/Text/CPUMonitor.hs0000644000000000000000000000226407346545000022023 0ustar0000000000000000module System.Taffybar.Widget.Text.CPUMonitor (textCpuMonitorNew) where import Control.Monad.IO.Class ( MonadIO ) import Text.Printf ( printf ) import qualified Text.StringTemplate as ST import System.Taffybar.Information.CPU import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) import qualified GI.Gtk -- | Creates a simple textual CPU monitor. It updates once every polling -- period (in seconds). textCpuMonitorNew :: MonadIO m => String -- ^ Format. You can use variables: $total$, $user$, $system$ -> Double -- ^ Polling period (in seconds) -> m GI.Gtk.Widget textCpuMonitorNew fmt period = do label <- pollingLabelNew period callback GI.Gtk.toWidget label where callback = do (userLoad, systemLoad, totalLoad) <- cpuLoad let pct = formatPercent . (* 100) let template = ST.newSTMP fmt let template' = ST.setManyAttrib [ ("user", pct userLoad), ("system", pct systemLoad), ("total", pct totalLoad) ] template return $ ST.render template' formatPercent :: Double -> String formatPercent = printf "%.2f" taffybar-4.1.1/src/System/Taffybar/Widget/Text/MemoryMonitor.hs0000644000000000000000000000442307346545000022643 0ustar0000000000000000module System.Taffybar.Widget.Text.MemoryMonitor (textMemoryMonitorNew, showMemoryInfo) where import Control.Monad.IO.Class ( MonadIO ) import qualified Data.Text as T import qualified Text.StringTemplate as ST import System.Taffybar.Information.Memory import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) import qualified GI.Gtk import Text.Printf ( printf ) -- | Creates a simple textual memory monitor. It updates once every polling -- period (in seconds). textMemoryMonitorNew :: MonadIO m => String -- ^ Format. You can use variables: "used", "total", "free", "buffer", -- "cache", "rest", "available", "swapUsed", "swapTotal", "swapFree". -> Double -- ^ Polling period in seconds. -> m GI.Gtk.Widget textMemoryMonitorNew fmt period = do label <- pollingLabelNew period (showMemoryInfo fmt 3 <$> parseMeminfo) GI.Gtk.toWidget label showMemoryInfo :: String -> Int -> MemoryInfo -> T.Text showMemoryInfo fmt prec info = let template = ST.newSTMP fmt labels = [ "used" , "total" , "free" , "buffer" , "cache" , "rest" , "available" , "swapUsed" , "swapTotal" , "swapFree" ] actions = [ memoryUsed , memoryTotal , memoryFree , memoryBuffer , memoryCache , memoryRest , memoryAvailable , memorySwapUsed , memorySwapTotal , memorySwapFree ] actions' = map (toAuto prec .) actions stats = [f info | f <- actions'] template' = ST.setManyAttrib (zip labels stats) template in ST.render template' toAuto :: Int -> Double -> String toAuto prec value = printf "%.*f%s" p v unit where value' = max 0 value mag :: Int mag = if value' == 0 then 0 else max 0 $ min 2 $ floor $ logBase 1024 value' v = value' / 1024 ** fromIntegral mag unit = case mag of 0 -> "MiB" 1 -> "GiB" 2 -> "TiB" _ -> "??B" -- unreachable p :: Int p = max 0 $ floor $ fromIntegral prec - logBase 10 v taffybar-4.1.1/src/System/Taffybar/Widget/Text/NetworkMonitor.hs0000644000000000000000000000456707346545000023035 0ustar0000000000000000module System.Taffybar.Widget.Text.NetworkMonitor where import Control.Monad import Control.Monad.Trans.Class import qualified Data.Text as T import GI.Gtk import System.Taffybar.Context import System.Taffybar.Hooks import System.Taffybar.Information.Network import System.Taffybar.Util import System.Taffybar.Widget.Generic.ChannelWidget import Text.Printf import Text.StringTemplate defaultNetFormat :: String defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$" showInfo :: String -> Int -> (Double, Double) -> T.Text showInfo template prec (incomingb, outgoingb) = let attribs = [ ("inB", show incomingb) , ("inKB", toKB prec incomingb) , ("inMB", toMB prec incomingb) , ("inAuto", toAuto prec incomingb) , ("outB", show outgoingb) , ("outKB", toKB prec outgoingb) , ("outMB", toMB prec outgoingb) , ("outAuto", toAuto prec outgoingb) ] in render . setManyAttrib attribs $ newSTMP template toKB :: Int -> Double -> String toKB prec = setDigits prec . (/1024) toMB :: Int -> Double -> String toMB prec = setDigits prec . (/ (1024 * 1024)) setDigits :: Int -> Double -> String setDigits dig = printf format where format = "%." ++ show dig ++ "f" toAuto :: Int -> Double -> String toAuto prec value = printf "%.*f%s" p v unit where value' = max 0 value mag :: Int mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value' v = value' / 1024 ** fromIntegral mag unit = case mag of 0 -> "B/s" 1 -> "KiB/s" 2 -> "MiB/s" 3 -> "GiB/s" 4 -> "TiB/s" _ -> "??B/s" -- unreachable p :: Int p = max 0 $ floor $ fromIntegral prec - logBase 10 v networkMonitorNew :: String -> Maybe [String] -> TaffyIO GI.Gtk.Widget networkMonitorNew template interfaces = do NetworkInfoChan chan <- getNetworkChan let filterFn = maybe (const True) (flip elem) interfaces label <- lift $ labelNew Nothing void $ channelWidgetNew label chan $ \speedInfo -> let (up, down) = sumSpeeds $ map snd $ filter (filterFn . fst) speedInfo labelString = showInfo template 3 (fromRational down, fromRational up) in postGUIASync $ labelSetMarkup label labelString toWidget label taffybar-4.1.1/src/System/Taffybar/Widget/Util.hs0000644000000000000000000002011207346545000020005 0ustar0000000000000000{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Util -- Copyright : (c) Ivan Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan Malison -- Stability : unstable -- Portability : unportable -- -- Utility functions to facilitate building GTK interfaces. -- ----------------------------------------------------------------------------- module System.Taffybar.Widget.Util where import Control.Concurrent ( forkIO ) import Control.Monad import Control.Monad.IO.Class import Data.Bifunctor ( first ) import Data.Functor ( ($>) ) import Data.GI.Base.Overloading (IsDescendantOf) import Data.Int import qualified Data.Text as T import qualified GI.Gdk as D import qualified GI.GdkPixbuf.Objects.Pixbuf as GI import qualified GI.GdkPixbuf.Objects.Pixbuf as PB import GI.Gtk as Gtk import StatusNotifier.Tray (scalePixbufToSize) import System.Environment.XDG.DesktopEntry import System.FilePath.Posix import System.Taffybar.Util import Text.Printf import Paths_taffybar ( getDataDir ) -- | Execute the given action as a response to any of the given types -- of mouse button clicks. onClick :: [D.EventType] -- ^ Types of button clicks to listen to. -> IO a -- ^ Action to execute. -> D.EventButton -> IO Bool onClick triggers action btn = do click <- D.getEventButtonType btn if click `elem` triggers then action >> return True else return False -- | Attach the given widget as a popup with the given title to the -- given window. The newly attached popup is not shown initially. Use -- the 'displayPopup' function to display it. attachPopup :: (Gtk.IsWidget w, Gtk.IsWindow wnd) => w -- ^ The widget to set as popup. -> T.Text -- ^ The title of the popup. -> wnd -- ^ The window to attach the popup to. -> IO () attachPopup widget title window = do windowSetTitle window title windowSetTypeHint window D.WindowTypeHintTooltip windowSetSkipTaskbarHint window True windowSetSkipPagerHint window True transient <- getWindow windowSetTransientFor window transient windowSetKeepAbove window True windowStick window where getWindow :: IO (Maybe Window) getWindow = do windowGType <- glibType @Window Just ancestor <- Gtk.widgetGetAncestor widget windowGType castTo Window ancestor -- | Display the given popup widget (previously prepared using the -- 'attachPopup' function) immediately beneath (or above) the given -- window. displayPopup :: (Gtk.IsWidget w, Gtk.IsWidget wnd, Gtk.IsWindow wnd) => w -- ^ The popup widget. -> wnd -- ^ The window the widget was attached to. -> IO () displayPopup widget window = do windowSetPosition window WindowPositionMouse (x, y ) <- windowGetPosition window (_, natReq) <- widgetGetPreferredSize =<< widgetGetToplevel widget y' <- getRequisitionHeight natReq widgetShowAll window if y > y' then windowMove window x (y - y') else windowMove window x y' widgetGetAllocatedSize :: (Gtk.IsWidget self, MonadIO m) => self -> m (Int, Int) widgetGetAllocatedSize widget = do w <- Gtk.widgetGetAllocatedWidth widget h <- Gtk.widgetGetAllocatedHeight widget return (fromIntegral w, fromIntegral h) -- | Creates markup with the given foreground and background colors and the -- given contents. colorize :: String -- ^ Foreground color. -> String -- ^ Background color. -> String -- ^ Contents. -> String colorize fg bg = printf "%s" (attr ("fg" :: String) fg :: String) (attr ("bg" :: String) bg :: String) where attr name value | null value = "" | otherwise = printf " %scolor=\"%s\"" name value backgroundLoop :: IO a -> IO () backgroundLoop = void . forkIO . forever drawOn :: Gtk.IsWidget object => object -> IO () -> IO object drawOn drawArea action = Gtk.onWidgetRealize drawArea action $> drawArea widgetSetClassGI :: (Gtk.IsWidget b, MonadIO m) => b -> T.Text -> m b widgetSetClassGI widget klass = Gtk.widgetGetStyleContext widget >>= flip Gtk.styleContextAddClass klass >> return widget themeLoadFlags :: [Gtk.IconLookupFlags] themeLoadFlags = [ Gtk.IconLookupFlagsGenericFallback , Gtk.IconLookupFlagsUseBuiltin ] getImageForDesktopEntry :: Int32 -> DesktopEntry -> IO (Maybe GI.Pixbuf) getImageForDesktopEntry size de = getImageForMaybeIconName (T.pack <$> deIcon de) size getImageForMaybeIconName :: Maybe T.Text -> Int32 -> IO (Maybe GI.Pixbuf) getImageForMaybeIconName mIconName size = join <$> traverse (`getImageForIconName` size) mIconName getImageForIconName :: T.Text -> Int32 -> IO (Maybe GI.Pixbuf) getImageForIconName iconName size = maybeTCombine (loadPixbufByName size iconName) (getPixbufFromFilePath (T.unpack iconName) >>= traverse (scalePixbufToSize size Gtk.OrientationHorizontal)) loadPixbufByName :: Int32 -> T.Text -> IO (Maybe GI.Pixbuf) loadPixbufByName size name = do iconTheme <- Gtk.iconThemeGetDefault hasIcon <- Gtk.iconThemeHasIcon iconTheme name if hasIcon then Gtk.iconThemeLoadIcon iconTheme name size themeLoadFlags else return Nothing alignCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m () alignCenter widget = Gtk.setWidgetValign widget Gtk.AlignCenter >> Gtk.setWidgetHalign widget Gtk.AlignCenter vFillCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m () vFillCenter widget = Gtk.widgetSetVexpand widget True >> Gtk.setWidgetValign widget Gtk.AlignFill >> Gtk.setWidgetHalign widget Gtk.AlignCenter pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO (Either String PB.Pixbuf) pixbufNewFromFileAtScaleByHeight height name = fmap (handleResult . first show) $ catchGErrorsAsLeft $ PB.pixbufNewFromFileAtScale name (-1) height True where handleResult = (maybe (Left "gdk function returned NULL") Right =<<) loadIcon :: Int32 -> String -> IO (Either String PB.Pixbuf) loadIcon height name = getDataDir >>= pixbufNewFromFileAtScaleByHeight height . ( "icons" name) setMinWidth :: (Gtk.IsWidget w, MonadIO m) => Int -> w -> m w setMinWidth width widget = liftIO $ do Gtk.widgetSetSizeRequest widget (fromIntegral width) (-1) return widget addClassIfMissing :: (IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m () addClassIfMissing klass widget = do context <- Gtk.widgetGetStyleContext widget Gtk.styleContextHasClass context klass >>= (`when` Gtk.styleContextAddClass context klass) . not removeClassIfPresent :: (IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m () removeClassIfPresent klass widget = do context <- Gtk.widgetGetStyleContext widget Gtk.styleContextHasClass context klass >>= (`when` Gtk.styleContextRemoveClass context klass) -- | Wrap a widget with two container boxes. The inner box will have the class -- "inner-pad", and the outer box will have the class "outer-pad". These boxes -- can be used to add padding between the outline of the widget and its -- contents, or for the purpose of displaying a different background behind the -- widget. buildPadBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget buildPadBox contents = liftIO $ do innerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0 outerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0 Gtk.setWidgetValign innerBox Gtk.AlignFill Gtk.setWidgetValign outerBox Gtk.AlignFill Gtk.containerAdd innerBox contents Gtk.containerAdd outerBox innerBox _ <- widgetSetClassGI innerBox "inner-pad" _ <- widgetSetClassGI outerBox "outer-pad" Gtk.widgetShow outerBox Gtk.widgetShow innerBox Gtk.toWidget outerBox buildContentsBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget buildContentsBox widget = liftIO $ do contents <- Gtk.boxNew Gtk.OrientationHorizontal 0 Gtk.containerAdd contents widget _ <- widgetSetClassGI contents "contents" Gtk.widgetShowAll contents Gtk.toWidget contents >>= buildPadBox taffybar-4.1.1/src/System/Taffybar/Widget/Weather.hs0000644000000000000000000002630207346545000020476 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This module defines a simple textual weather widget that polls -- NOAA for weather data. To find your weather station, you can use -- either of the following: -- -- -- -- -- For example, Madison, WI is KMSN. -- -- NOAA provides several pieces of information in each request; you can control -- which pieces end up in your weather widget by providing a _template_ that is -- filled in with the current information. The template is just a 'String' with -- variables between dollar signs. The variables will be substituted with real -- data by the widget. Example: -- -- > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" } -- > weatherWidget = weatherNew wcfg 10 -- -- This example makes a new weather widget that checks the weather at KMSN -- (Madison, WI) every 10 minutes, and displays the results in Celcius. -- -- Available variables: -- -- [@stationPlace@] The name of the weather station -- -- [@stationState@] The state that the weather station is in -- -- [@year@] The year the report was generated -- -- [@month@] The month the report was generated -- -- [@day@] The day the report was generated -- -- [@hour@] The hour the report was generated -- -- [@wind@] The direction and strength of the wind -- -- [@visibility@] Description of current visibility conditions -- -- [@skyCondition@] ? -- -- [@tempC@] The temperature in Celsius -- -- [@tempF@] The temperature in Farenheit -- -- [@dewPoint@] The current dew point -- -- [@humidity@] The current relative humidity -- -- [@pressure@] The current pressure -- -- -- As an example, a template like -- -- > "$tempF$ °F" -- -- would yield a widget displaying the temperature in Farenheit with a small -- label after it. -- -- Implementation Note: the weather data parsing code is taken from xmobar. This -- version of the code makes direct HTTP requests instead of invoking a separate -- cURL process. module System.Taffybar.Widget.Weather ( WeatherConfig(..) , WeatherInfo(..) , WeatherFormatter(WeatherFormatter) , weatherNew , weatherCustomNew , defaultWeatherConfig ) where import Control.Monad.IO.Class import qualified Data.ByteString.Lazy as LB import Data.List (stripPrefix) import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as T import GI.GLib(markupEscapeText) import GI.Gtk import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status import System.Log.Logger import Text.Parsec import Text.Printf import Text.StringTemplate import System.Taffybar.Widget.Generic.PollingLabel data WeatherInfo = WI { stationPlace :: String , stationState :: String , year :: String , month :: String , day :: String , hour :: String , wind :: String , visibility :: String , skyCondition :: String , tempC :: Int , tempF :: Int , dewPoint :: String , humidity :: Int , pressure :: Int } deriving (Show) -- Parsers stolen from xmobar type Parser = Parsec String () pTime :: Parser (String, String, String, String) pTime = do y <- getNumbersAsString _ <- char '.' m <- getNumbersAsString _ <- char '.' d <- getNumbersAsString _ <- char ' ' (h:hh:mi:mimi) <- getNumbersAsString _ <- char ' ' return (y, m, d , [h]++[hh]++":"++[mi]++mimi) pTemp :: Parser (Int, Int) pTemp = do let num = digit <|> char '-' <|> char '.' f <- manyTill num $ char ' ' _ <- manyTill anyChar $ char '(' c <- manyTill num $ char ' ' _ <- skipRestOfLine return (floor (read c :: Double), floor (read f :: Double)) pRh :: Parser Int pRh = do s <- manyTill digit $ char '%' <|> char '.' return $ read s pPressure :: Parser Int pPressure = do _ <- manyTill anyChar $ char '(' s <- manyTill digit $ char ' ' _ <- skipRestOfLine return $ read s parseData :: Parser WeatherInfo parseData = do st <- getAllBut ',' _ <- space ss <- getAllBut '(' _ <- skipRestOfLine >> getAllBut '/' (y,m,d,h) <- pTime w <- getAfterString "Wind: " v <- getAfterString "Visibility: " sk <- getAfterString "Sky conditions: " _ <- skipTillString "Temperature: " (tC,tF) <- pTemp dp <- getAfterString "Dew Point: " _ <- skipTillString "Relative Humidity: " rh <- pRh _ <- skipTillString "Pressure (altimeter): " p <- pPressure _ <- manyTill skipRestOfLine eof return $ WI st ss y m d h w v sk tC tF dp rh p getAllBut :: Char -> Parser String getAllBut c = manyTill (noneOf [c]) (char c) getAfterString :: String -> Parser String getAfterString s = pAfter <|> return ("<" ++ s ++ " not found!>") where pAfter = do _ <- try $ manyTill skipRestOfLine $ string s manyTill anyChar newline skipTillString :: String -> Parser String skipTillString s = manyTill skipRestOfLine $ string s getNumbersAsString :: Parser String getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n skipRestOfLine :: Parser Char skipRestOfLine = do _ <- many $ noneOf "\n\r" newline -- | Simple: download the document at a URL. downloadURL :: Manager -> Request -> IO (Either String String) downloadURL mgr request = do response <- httpLbs request mgr case responseStatus response of s | s >= status200 && s < status300 -> return $ Right (T.unpack . T.decodeUtf8 . LB.toStrict $ responseBody response) otherStatus -> return . Left $ "HTTP 2XX status was expected but received " ++ show otherStatus getWeather :: Manager -> String -> IO (Either String WeatherInfo) getWeather mgr url = do request <- parseRequest url dat <- downloadURL mgr request case dat of Right dat' -> case parse parseData url dat' of Right d -> return (Right d) Left err -> return (Left (show err)) Left err -> return (Left (show err)) defaultFormatter :: StringTemplate String -> WeatherInfo -> String defaultFormatter tpl wi = render tpl' where tpl' = setManyAttrib [ ("stationPlace", stationPlace wi) , ("stationState", stationState wi) , ("year", year wi) , ("month", month wi) , ("day", day wi) , ("hour", hour wi) , ("wind", wind wi) , ("visibility", visibility wi) , ("skyCondition", skyCondition wi) , ("tempC", show (tempC wi)) , ("tempF", show (tempF wi)) , ("dewPoint", dewPoint wi) , ("humidity", show (humidity wi)) , ("pressure", show (pressure wi)) ] tpl getCurrentWeather :: IO (Either String WeatherInfo) -> StringTemplate String -> StringTemplate String -> WeatherFormatter -> IO (T.Text, Maybe T.Text) getCurrentWeather getter labelTpl tooltipTpl formatter = do dat <- getter case dat of Right wi -> case formatter of DefaultWeatherFormatter -> do let rawLabel = T.pack $ defaultFormatter labelTpl wi let rawTooltip = T.pack $ defaultFormatter tooltipTpl wi lbl <- markupEscapeText rawLabel (-1) tooltip <- markupEscapeText rawTooltip (-1) return (lbl, Just tooltip) WeatherFormatter f -> do let rawLabel = T.pack $ f wi lbl <- markupEscapeText rawLabel (-1) return (lbl, Just lbl) Left err -> do logM "System.Taffybar.Widget.Weather" ERROR $ "Error in weather: " <> show err return ("N/A", Nothing) -- | The NOAA URL to get data from baseUrl :: String baseUrl = "https://tgftp.nws.noaa.gov/data/observations/metar/decoded" -- | A wrapper to allow users to specify a custom weather formatter. -- The default interpolates variables into a string as described -- above. Custom formatters can do basically anything. data WeatherFormatter = WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo' | DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter -- | The configuration for the weather widget. You can provide a custom -- format string through 'weatherTemplate' as described above, or you can -- provide a custom function to turn a 'WeatherInfo' into a String via the -- 'weatherFormatter' field. data WeatherConfig = WeatherConfig { weatherStation :: String -- ^ The weather station to poll. No default , weatherTemplate :: String -- ^ Template string, as described above. Default: $tempF$ °F , weatherTemplateTooltip :: String -- ^ Template string, as described above. Default: $tempF$ °F , weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above) , weatherProxy :: Maybe String -- ^ The proxy server, e.g. "http://proxy:port". Default: Nothing } -- | A sensible default configuration for the weather widget that just -- renders the temperature. defaultWeatherConfig :: String -> WeatherConfig defaultWeatherConfig station = WeatherConfig { weatherStation = station , weatherTemplate = "$tempF$ °F" , weatherTemplateTooltip = unlines [ "Station: $stationPlace$" , "Time: $day$.$month$.$year$ $hour$" , "Temperature: $tempF$ °F" , "Pressure: $pressure$ hPa" , "Wind: $wind$" , "Visibility: $visibility$" , "Sky Condition: $skyCondition$" , "Dew Point: $dewPoint$" , "Humidity: $humidity$" ] , weatherFormatter = DefaultWeatherFormatter , weatherProxy = Nothing } -- | Create a periodically-updating weather widget that polls NOAA. weatherNew :: MonadIO m => WeatherConfig -- ^ Configuration to render -> Double -- ^ Polling period in _minutes_ -> m GI.Gtk.Widget weatherNew cfg delayMinutes = liftIO $ do -- TODO: add explicit proxy host/port to WeatherConfig and -- get rid of this ugly stringly-typed setting let usedProxy = case weatherProxy cfg of Nothing -> noProxy Just str -> let strToBs = T.encodeUtf8 . T.pack noHttp = fromMaybe str $ stripPrefix "http://" str (phost, pport) = case span (':'/=) noHttp of (h, "") -> (strToBs h, 80) -- HTTP seems to assume 80 to be the default (h, ':':p) -> (strToBs h, read p) _ -> error "unreachable: broken span" in useProxy $ Proxy phost pport mgr <- newManager $ managerSetProxy usedProxy tlsManagerSettings let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg) let getter = getWeather mgr url weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg) (weatherFormatter cfg) delayMinutes -- | Create a periodically-updating weather widget using custom weather getter weatherCustomNew :: MonadIO m => IO (Either String WeatherInfo) -- ^ Weather querying action -> String -- ^ Weather template -> String -- ^ Weather template -> WeatherFormatter -- ^ Weather formatter -> Double -- ^ Polling period in _minutes_ -> m GI.Gtk.Widget weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = liftIO $ do let labelTpl' = newSTMP labelTpl tooltipTpl' = newSTMP tooltipTpl l <- pollingLabelNewWithTooltip (delayMinutes * 60) (getCurrentWeather getter labelTpl' tooltipTpl' formatter) GI.Gtk.widgetShowAll l return l taffybar-4.1.1/src/System/Taffybar/Widget/Windows.hs0000644000000000000000000001250407346545000020530 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Windows -- Copyright : (c) Ivan Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan Malison -- Stability : unstable -- Portability : unportable -- -- Menu widget that shows the title of the currently focused window and that, -- when clicked, displays a menu from which the user may select a window to -- which to switch the focus. ----------------------------------------------------------------------------- module System.Taffybar.Widget.Windows where 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 import GI.GLib (markupEscapeText) import qualified GI.Gtk as Gtk import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo 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 -- ^ A monadic function that will be used to make a label for the window in -- 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 defaultGetMenuLabel window = do windowString <- runX11Def "(nameless window)" (getWindowTitle window) return $ T.pack windowString defaultGetActiveLabel :: TaffyIO T.Text defaultGetActiveLabel = do label <- fromMaybe "" <$> (runX11Def Nothing getActiveWindow >>= traverse defaultGetMenuLabel) markupEscapeText label (-1) truncatedGetActiveLabel :: Int -> TaffyIO T.Text truncatedGetActiveLabel maxLength = truncateText maxLength <$> defaultGetActiveLabel truncatedGetMenuLabel :: Int -> X11Window -> TaffyIO T.Text truncatedGetMenuLabel maxLength = fmap (truncateText maxLength) . defaultGetMenuLabel defaultWindowsConfig :: WindowsConfig defaultWindowsConfig = WindowsConfig { getMenuLabel = truncatedGetMenuLabel 35 , getActiveLabel = truncatedGetActiveLabel 35 , getActiveWindowIconPixbuf = Just defaultGetWindowIconPixbuf } instance Default WindowsConfig where def = defaultWindowsConfig -- | Create a new Windows widget that will use the given Pager as -- its source of events. windowsNew :: WindowsConfig -> TaffyIO Gtk.Widget windowsNew config = do hbox <- lift $ Gtk.boxNew Gtk.OrientationHorizontal 0 refreshIcon <- case getActiveWindowIconPixbuf config of Just getIcon -> do (rf, icon) <- buildWindowsIcon getIcon Gtk.boxPackStart hbox icon True True 0 pure rf Nothing -> pure (pure ()) (setLabelTitle, label) <- buildWindowsLabel Gtk.boxPackStart hbox label True True 0 let refreshLabel = getActiveLabel config >>= lift . setLabelTitle subscription <- subscribeToPropertyEvents [ewmhActiveWindow, ewmhWMName, ewmhWMClass] (const $ refreshLabel >> lift refreshIcon) void $ mapReaderT (Gtk.onWidgetUnrealize hbox) (unsubscribe subscription) Gtk.widgetShowAll hbox boxWidget <- Gtk.toWidget hbox runTaffy <- asks (flip runReaderT) menu <- dynamicMenuNew 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 () fillMenu config menu = ask >>= \context -> runX11Def () $ do windowIds <- getWindows forM_ windowIds $ \windowId -> lift $ do labelText <- runReaderT (getMenuLabel config windowId) context let focusCallback = runReaderT (runX11 $ focusWindow windowId) context >> return True item <- Gtk.menuItemNewWithLabel labelText _ <- Gtk.onWidgetButtonPressEvent item $ const focusCallback Gtk.menuShellAppend menu item Gtk.widgetShow item taffybar-4.1.1/src/System/Taffybar/Widget/Workspaces.hs0000644000000000000000000007771307346545000021234 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings, StrictData #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Workspaces -- Copyright : (c) Ivan A. Malison -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable ----------------------------------------------------------------------------- module System.Taffybar.Widget.Workspaces where import Control.Arrow ((&&&)) import Control.Concurrent import qualified Control.Concurrent.MVar as MV import Control.Exception.Enclosed (catchAny) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.RateLimit import Data.Default (Default(..)) import qualified Data.Foldable as F import Data.GI.Base.ManagedPtr (unsafeCastTo) import Data.Int import Data.List (elemIndex, intersect, sortBy, (\\)) import qualified Data.Map as M import Data.Maybe import qualified Data.MultiMap as MM import qualified Data.Set as Set import qualified Data.Text as T import Data.Time.Units import Data.Tuple.Select import Data.Tuple.Sequence import qualified GI.Gdk.Enums as Gdk import qualified GI.Gdk.Structs.EventScroll as Gdk import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk import StatusNotifier.Tray (scalePixbufToSize) import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util import System.Taffybar.Widget.Generic.AutoSizeImage (autoSizeImage) import System.Taffybar.Widget.Util import System.Taffybar.WindowIcon import Text.Printf data WorkspaceState = Active | Visible | Hidden | Empty | Urgent deriving (Show, Eq) getCSSClass :: (Show s) => s -> T.Text getCSSClass = T.toLower . T.pack . show cssWorkspaceStates :: [T.Text] cssWorkspaceStates = map getCSSClass [Active, Visible, Hidden, Empty, Urgent] data WindowData = WindowData { windowId :: X11Window , windowTitle :: String , windowClass :: String , windowUrgent :: Bool , windowActive :: Bool , windowMinimized :: Bool } deriving (Show, Eq) data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window] data Workspace = Workspace { workspaceIdx :: WorkspaceId , workspaceName :: String , workspaceState :: WorkspaceState , windows :: [WindowData] } deriving (Show, Eq) data WorkspacesContext = WorkspacesContext { controllersVar :: MV.MVar (M.Map WorkspaceId WWC) , workspacesVar :: MV.MVar (M.Map WorkspaceId Workspace) , workspacesWidget :: Gtk.Box , workspacesConfig :: WorkspacesConfig , taffyContext :: Context } type WorkspacesIO a = ReaderT WorkspacesContext IO a liftContext :: TaffyIO a -> WorkspacesIO a liftContext action = asks taffyContext >>= lift . runReaderT action liftX11Def :: a -> X11Property a -> WorkspacesIO a liftX11Def dflt prop = liftContext $ runX11Def dflt prop setWorkspaceWidgetStatusClass :: (MonadIO m, Gtk.IsWidget a) => Workspace -> a -> m () setWorkspaceWidgetStatusClass workspace widget = updateWidgetClasses widget [getCSSClass $ workspaceState workspace] cssWorkspaceStates updateWidgetClasses :: (Foldable t1, Foldable t, Gtk.IsWidget a, MonadIO m) => a -> t1 T.Text -> t T.Text -> m () updateWidgetClasses widget toAdd toRemove = do context <- Gtk.widgetGetStyleContext widget let hasClass = Gtk.styleContextHasClass context addIfMissing klass = hasClass klass >>= (`when` Gtk.styleContextAddClass context klass) . not removeIfPresent klass = unless (klass `elem` toAdd) $ hasClass klass >>= (`when` Gtk.styleContextRemoveClass context klass) mapM_ removeIfPresent toRemove mapM_ addIfMissing toAdd class WorkspaceWidgetController wc where getWidget :: wc -> WorkspacesIO Gtk.Widget updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc updateWidgetX11 :: wc -> WidgetUpdate -> WorkspacesIO wc updateWidgetX11 cont _ = return cont data WWC = forall a. WorkspaceWidgetController a => WWC a instance WorkspaceWidgetController WWC where getWidget (WWC wc) = getWidget wc updateWidget (WWC wc) update = WWC <$> updateWidget wc update updateWidgetX11 (WWC wc) update = WWC <$> updateWidgetX11 wc update type ControllerConstructor = Workspace -> WorkspacesIO WWC type ParentControllerConstructor = ControllerConstructor -> ControllerConstructor type WindowIconPixbufGetter = Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf) data WorkspacesConfig = WorkspacesConfig { widgetBuilder :: ControllerConstructor , widgetGap :: Int , maxIcons :: Maybe Int , minIcons :: Int , getWindowIconPixbuf :: WindowIconPixbufGetter , labelSetter :: Workspace -> WorkspacesIO String , showWorkspaceFn :: Workspace -> Bool , borderWidth :: Int , updateEvents :: [String] , updateRateLimitMicroseconds :: Integer , iconSort :: [WindowData] -> WorkspacesIO [WindowData] , urgentWorkspaceState :: Bool } defaultWorkspacesConfig :: WorkspacesConfig defaultWorkspacesConfig = WorkspacesConfig { widgetBuilder = buildButtonController defaultBuildContentsController , widgetGap = 0 , maxIcons = Nothing , minIcons = 0 , getWindowIconPixbuf = defaultGetWindowIconPixbuf , labelSetter = return . workspaceName , showWorkspaceFn = const True , borderWidth = 2 , iconSort = sortWindowsByPosition , updateEvents = allEWMHProperties \\ [ewmhWMIcon] , updateRateLimitMicroseconds = 100000 , urgentWorkspaceState = False } instance Default WorkspacesConfig where def = defaultWorkspacesConfig hideEmpty :: Workspace -> Bool hideEmpty Workspace { workspaceState = Empty } = False hideEmpty _ = True wLog :: MonadIO m => Priority -> String -> m () wLog l s = liftIO $ logM "System.Taffybar.Widget.Workspaces" l s updateVar :: MV.MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a updateVar var modify = do ctx <- ask lift $ MV.modifyMVar var $ fmap (\a -> (a, a)) . flip runReaderT ctx . modify updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceId Workspace) updateWorkspacesVar = do workspacesRef <- asks workspacesVar updateVar workspacesRef buildWorkspaceData getWorkspaceToWindows :: [X11Window] -> X11Property (MM.MultiMap WorkspaceId X11Window) getWorkspaceToWindows = foldM (\theMap window -> MM.insert <$> getWorkspace window <*> pure window <*> pure theMap) MM.empty getWindowData :: Maybe X11Window -> [X11Window] -> X11Window -> X11Property WindowData getWindowData activeWindow urgentWindows window = do wTitle <- getWindowTitle window wClass <- getWindowClass window wMinimized <- getWindowMinimized window return WindowData { windowId = window , windowTitle = wTitle , windowClass = wClass , windowUrgent = window `elem` urgentWindows , windowActive = Just window == activeWindow , windowMinimized = wMinimized } buildWorkspaceData :: M.Map WorkspaceId Workspace -> WorkspacesIO (M.Map WorkspaceId Workspace) buildWorkspaceData _ = ask >>= \context -> liftX11Def M.empty $ do names <- getWorkspaceNames wins <- getWindows workspaceToWindows <- getWorkspaceToWindows wins urgentWindows <- filterM isWindowUrgent wins activeWindow <- getActiveWindow active:visible <- getVisibleWorkspaces let getWorkspaceState idx ws | idx == active = Active | idx `elem` visible = Visible | urgentWorkspaceState (workspacesConfig context) && not (null (ws `intersect` urgentWindows)) = Urgent | null ws = Empty | otherwise = Hidden foldM (\theMap (idx, name) -> do let ws = MM.lookup idx workspaceToWindows windowInfos <- mapM (getWindowData activeWindow urgentWindows) ws return $ M.insert idx Workspace { workspaceIdx = idx , workspaceName = name , workspaceState = getWorkspaceState idx ws , windows = windowInfos } theMap) M.empty names addWidgetsToTopLevel :: WorkspacesIO () addWidgetsToTopLevel = do WorkspacesContext { controllersVar = controllersRef , workspacesWidget = cont } <- ask controllersMap <- lift $ MV.readMVar controllersRef -- Elems returns elements in ascending order of their keys so this will always -- add the widgets in the correct order mapM_ addWidget $ M.elems controllersMap lift $ Gtk.widgetShowAll cont addWidget :: WWC -> WorkspacesIO () addWidget controller = do cont <- asks workspacesWidget workspaceWidget <- getWidget controller lift $ do -- XXX: This hbox exists to (hopefully) prevent the issue where workspace -- widgets appear out of order, in the switcher, by acting as an empty -- place holder when the actual widget is hidden. hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0 void $ Gtk.widgetGetParent workspaceWidget >>= traverse (unsafeCastTo Gtk.Box) >>= traverse (`Gtk.containerRemove` workspaceWidget) Gtk.containerAdd hbox workspaceWidget Gtk.containerAdd cont hbox workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget workspacesNew cfg = ask >>= \tContext -> lift $ do cont <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral (widgetGap cfg) controllersRef <- MV.newMVar M.empty workspacesRef <- MV.newMVar M.empty let context = WorkspacesContext { controllersVar = controllersRef , workspacesVar = workspacesRef , workspacesWidget = cont , workspacesConfig = cfg , taffyContext = tContext } -- This will actually create all the widgets runReaderT updateAllWorkspaceWidgets context updateHandler <- onWorkspaceUpdate context iconHandler <- onIconsChanged context let doUpdate = lift . updateHandler handleConfigureEvents e@(ConfigureEvent {}) = doUpdate e handleConfigureEvents _ = return () (workspaceSubscription, iconSubscription, geometrySubscription) <- flip runReaderT tContext $ sequenceT ( subscribeToPropertyEvents (updateEvents cfg) doUpdate , subscribeToPropertyEvents [ewmhWMIcon] (lift . onIconChanged iconHandler) , subscribeToAll handleConfigureEvents ) let doUnsubscribe = flip runReaderT tContext $ mapM_ unsubscribe [ iconSubscription , workspaceSubscription , geometrySubscription ] _ <- Gtk.onWidgetUnrealize cont doUnsubscribe _ <- widgetSetClassGI cont "workspaces" Gtk.toWidget cont updateAllWorkspaceWidgets :: WorkspacesIO () updateAllWorkspaceWidgets = do wLog DEBUG "Updating workspace widgets" workspacesMap <- updateWorkspacesVar wLog DEBUG $ printf "Workspaces: %s" $ show workspacesMap wLog DEBUG "Adding and removing widgets" updateWorkspaceControllers let updateController' idx controller = maybe (return controller) (updateWidget controller . WorkspaceUpdate) $ M.lookup idx workspacesMap logUpdateController i = wLog DEBUG $ printf "Updating %s workspace widget" $ show i updateController i cont = logUpdateController i >> updateController' i cont wLog DEBUG "Done updating individual widget" doWidgetUpdate updateController wLog DEBUG "Showing and hiding controllers" setControllerWidgetVisibility setControllerWidgetVisibility :: WorkspacesIO () setControllerWidgetVisibility = do ctx@WorkspacesContext { workspacesVar = workspacesRef , controllersVar = controllersRef , workspacesConfig = cfg } <- ask lift $ do workspacesMap <- MV.readMVar workspacesRef controllersMap <- MV.readMVar controllersRef forM_ (M.elems workspacesMap) $ \ws -> let action = if showWorkspaceFn cfg ws then Gtk.widgetShow else Gtk.widgetHide in traverse (flip runReaderT ctx . getWidget) (M.lookup (workspaceIdx ws) controllersMap) >>= maybe (return ()) action doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO () doWidgetUpdate updateController = do c@WorkspacesContext { controllersVar = controllersRef } <- ask lift $ MV.modifyMVar_ controllersRef $ \controllers -> do wLog DEBUG "Updating controllers ref" controllersList <- mapM (\(idx, controller) -> do newController <- runReaderT (updateController idx controller) c return (idx, newController)) $ M.toList controllers return $ M.fromList controllersList updateWorkspaceControllers :: WorkspacesIO () updateWorkspaceControllers = do WorkspacesContext { controllersVar = controllersRef , workspacesVar = workspacesRef , workspacesWidget = cont , workspacesConfig = cfg } <- ask workspacesMap <- lift $ MV.readMVar workspacesRef controllersMap <- lift $ MV.readMVar controllersRef let newWorkspacesSet = M.keysSet workspacesMap existingWorkspacesSet = M.keysSet controllersMap when (existingWorkspacesSet /= newWorkspacesSet) $ do let addWorkspaces = Set.difference newWorkspacesSet existingWorkspacesSet removeWorkspaces = Set.difference existingWorkspacesSet newWorkspacesSet builder = widgetBuilder cfg _ <- updateVar controllersRef $ \controllers -> do 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) (buildController idx) foldM buildAndAddController oldRemoved $ Set.toList addWorkspaces -- Clear the container and repopulate it lift $ Gtk.containerForeach cont (Gtk.containerRemove cont) addWidgetsToTopLevel rateLimitFn :: forall req resp. WorkspacesContext -> (req -> IO resp) -> ResultsCombiner req resp -> IO (req -> IO resp) rateLimitFn context = let limit = (updateRateLimitMicroseconds $ workspacesConfig context) rate = fromMicroseconds limit :: Microsecond in generateRateLimitedFunction $ PerInvocation rate onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ()) onWorkspaceUpdate context = do rateLimited <- rateLimitFn context doUpdate combineRequests let withLog event = do case event of PropertyEvent _ _ _ _ _ atom _ _ -> wLog DEBUG $ printf "Event %s" $ show atom _anythingElse -> return () void $ forkIO $ rateLimited event return withLog where combineRequests _ b = Just (b, const ((), ())) doUpdate _ = postGUIASync $ runReaderT updateAllWorkspaceWidgets context onIconChanged :: (Set.Set X11Window -> IO ()) -> Event -> IO () onIconChanged handler event = case event of PropertyEvent { ev_window = wid } -> do wLog DEBUG $ printf "Icon changed event %s" $ show wid handler $ Set.singleton wid _ -> return () onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ()) onIconsChanged context = rateLimitFn context onIconsChanged' combineRequests where combineRequests windows1 windows2 = Just (Set.union windows1 windows2, const ((), ())) onIconsChanged' wids = do wLog DEBUG $ printf "Icon update execute %s" $ show wids postGUIASync $ flip runReaderT context $ doWidgetUpdate (\idx c -> wLog DEBUG (printf "Updating %s icons." $ show idx) >> updateWidget c (IconUpdate $ Set.toList wids)) initializeWWC :: WorkspaceWidgetController a => a -> Workspace -> ReaderT WorkspacesContext IO WWC initializeWWC controller ws = WWC <$> updateWidget controller (WorkspaceUpdate ws) -- | A WrappingController can be used to wrap some child widget with another -- abitrary widget. data WrappingController = WrappingController { wrappedWidget :: Gtk.Widget , wrappedController :: WWC } instance WorkspaceWidgetController WrappingController where getWidget = lift . Gtk.toWidget . wrappedWidget updateWidget wc update = do updated <- updateWidget (wrappedController wc) update return wc { wrappedController = updated } data WorkspaceContentsController = WorkspaceContentsController { containerWidget :: Gtk.Widget , contentsControllers :: [WWC] } buildContentsController :: [ControllerConstructor] -> ControllerConstructor buildContentsController constructors ws = do controllers <- mapM ($ ws) constructors ctx <- ask tempController <- lift $ do cons <- Gtk.boxNew Gtk.OrientationHorizontal 0 mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd cons) controllers outerBox <- Gtk.toWidget cons >>= buildPadBox _ <- widgetSetClassGI cons "contents" widget <- Gtk.toWidget outerBox return WorkspaceContentsController { containerWidget = widget , contentsControllers = controllers } initializeWWC tempController ws defaultBuildContentsController :: ControllerConstructor defaultBuildContentsController = buildContentsController [buildLabelController, buildIconController] bottomLeftAlignedBoxWrapper :: T.Text -> ControllerConstructor -> ControllerConstructor bottomLeftAlignedBoxWrapper boxClass constructor ws = do controller <- constructor ws widget <- getWidget controller ebox <- Gtk.eventBoxNew _ <- widgetSetClassGI ebox boxClass Gtk.widgetSetHalign ebox Gtk.AlignStart Gtk.widgetSetValign ebox Gtk.AlignEnd Gtk.containerAdd ebox widget wrapped <- Gtk.toWidget ebox let wrappingController = WrappingController { wrappedWidget = wrapped , wrappedController = controller } initializeWWC wrappingController ws buildLabelOverlayController :: ControllerConstructor buildLabelOverlayController = buildOverlayContentsController [buildIconController] [bottomLeftAlignedBoxWrapper "overlay-box" buildLabelController] buildOverlayContentsController :: [ControllerConstructor] -> [ControllerConstructor] -> ControllerConstructor buildOverlayContentsController mainConstructors overlayConstructors ws = do controllers <- mapM ($ ws) mainConstructors overlayControllers <- mapM ($ ws) overlayConstructors ctx <- ask tempController <- lift $ do mainContents <- Gtk.boxNew Gtk.OrientationHorizontal 0 mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd mainContents) controllers outerBox <- Gtk.toWidget mainContents >>= buildPadBox _ <- widgetSetClassGI mainContents "contents" overlay <- Gtk.overlayNew Gtk.containerAdd overlay outerBox mapM_ (flip runReaderT ctx . getWidget >=> Gtk.overlayAddOverlay overlay) overlayControllers widget <- Gtk.toWidget overlay return WorkspaceContentsController { containerWidget = widget , contentsControllers = controllers ++ overlayControllers } initializeWWC tempController ws instance WorkspaceWidgetController WorkspaceContentsController where getWidget = return . containerWidget updateWidget cc update = do WorkspacesContext {} <- ask case update of WorkspaceUpdate newWorkspace -> lift $ setWorkspaceWidgetStatusClass newWorkspace $ containerWidget cc _ -> return () newControllers <- mapM (`updateWidget` update) $ contentsControllers cc return cc {contentsControllers = newControllers} updateWidgetX11 cc update = do newControllers <- mapM (`updateWidgetX11` update) $ contentsControllers cc return cc {contentsControllers = newControllers} newtype LabelController = LabelController { label :: Gtk.Label } buildLabelController :: ControllerConstructor buildLabelController ws = do tempController <- lift $ do lbl <- Gtk.labelNew Nothing _ <- widgetSetClassGI lbl "workspace-label" return LabelController { label = lbl } initializeWWC tempController ws instance WorkspaceWidgetController LabelController where getWidget = lift . Gtk.toWidget . label updateWidget lc (WorkspaceUpdate newWorkspace) = do WorkspacesContext { workspacesConfig = cfg } <- ask labelText <- labelSetter cfg newWorkspace lift $ do Gtk.labelSetMarkup (label lc) $ T.pack labelText setWorkspaceWidgetStatusClass newWorkspace $ label lc return lc updateWidget lc _ = return lc data IconWidget = IconWidget { iconContainer :: Gtk.EventBox , iconImage :: Gtk.Image , iconWindow :: MV.MVar (Maybe WindowData) , iconForceUpdate :: IO () } getPixbufForIconWidget :: Bool -> MV.MVar (Maybe WindowData) -> Int32 -> WorkspacesIO (Maybe Gdk.Pixbuf) getPixbufForIconWidget transparentOnNone dataVar size = do ctx <- ask let tContext = taffyContext ctx getPBFromData = getWindowIconPixbuf $ workspacesConfig ctx getPB' = runMaybeT $ MaybeT (lift $ MV.readMVar dataVar) >>= MaybeT . getPBFromData size getPB = if transparentOnNone then maybeTCombine getPB' (Just <$> pixBufFromColor size 0) else getPB' lift $ runReaderT getPB tContext buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget buildIconWidget transparentOnNone ws = do ctx <- ask lift $ do windowVar <- MV.newMVar Nothing img <- Gtk.imageNew refreshImage <- autoSizeImage img (flip runReaderT ctx . getPixbufForIconWidget transparentOnNone windowVar) Gtk.OrientationHorizontal ebox <- Gtk.eventBoxNew _ <- widgetSetClassGI img "window-icon" _ <- widgetSetClassGI ebox "window-icon-container" Gtk.containerAdd ebox img _ <- Gtk.onWidgetButtonPressEvent ebox $ const $ liftIO $ do info <- MV.readMVar windowVar case info of Just updatedInfo -> flip runReaderT ctx $ liftX11Def () $ focusWindow $ windowId updatedInfo _ -> liftIO $ void $ switch ctx (workspaceIdx ws) return True return IconWidget { iconContainer = ebox , iconImage = img , iconWindow = windowVar , iconForceUpdate = refreshImage } data IconController = IconController { iconsContainer :: Gtk.Box , iconImages :: [IconWidget] , iconWorkspace :: Workspace } buildIconController :: ControllerConstructor buildIconController ws = do tempController <- lift $ do hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0 return IconController {iconsContainer = hbox, iconImages = [], iconWorkspace = ws} initializeWWC tempController ws instance WorkspaceWidgetController IconController where getWidget = lift . Gtk.toWidget . iconsContainer updateWidget ic (WorkspaceUpdate newWorkspace) = do newImages <- updateImages ic newWorkspace return ic { iconImages = newImages, iconWorkspace = newWorkspace } updateWidget ic (IconUpdate updatedIcons) = updateWindowIconsById ic updatedIcons >> return ic updateWindowIconsById :: IconController -> [X11Window] -> WorkspacesIO () updateWindowIconsById ic windowIds = mapM_ maybeUpdateWindowIcon $ iconImages ic where maybeUpdateWindowIcon widget = do info <- lift $ MV.readMVar $ iconWindow widget when (maybe False (flip elem windowIds . windowId) info) $ updateIconWidget ic widget info scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter scaledWindowIconPixbufGetter getter size = getter size >=> lift . traverse (scalePixbufToSize size Gtk.OrientationHorizontal) constantScaleWindowIconPixbufGetter :: Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter constantScaleWindowIconPixbufGetter constantSize getter = const $ scaledWindowIconPixbufGetter getter constantSize handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter handleIconGetterException getter size windowData = catchAny (getter size windowData) $ \e -> do wLog WARNING $ printf "Failed to get window icon for %s: %s" (show windowData) (show e) return Nothing getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter getWindowIconPixbufFromEWMH = handleIconGetterException $ \size windowData -> runX11Def Nothing (getIconPixBufFromEWMH size $ windowId windowData) getWindowIconPixbufFromClass :: WindowIconPixbufGetter getWindowIconPixbufFromClass = handleIconGetterException $ \size windowData -> lift $ getWindowIconFromClasses size (windowClass windowData) getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter getWindowIconPixbufFromDesktopEntry = handleIconGetterException $ \size windowData -> getWindowIconFromDesktopEntryByClasses size (windowClass windowData) getWindowIconPixbufFromChrome :: WindowIconPixbufGetter getWindowIconPixbufFromChrome _ windowData = getPixBufFromChromeData $ windowId windowData defaultGetWindowIconPixbuf :: WindowIconPixbufGetter defaultGetWindowIconPixbuf = scaledWindowIconPixbufGetter unscaledDefaultGetWindowIconPixbuf unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter unscaledDefaultGetWindowIconPixbuf = getWindowIconPixbufFromDesktopEntry <|||> getWindowIconPixbufFromClass <|||> getWindowIconPixbufFromEWMH addCustomIconsToDefaultWithFallbackByPath :: (WindowData -> Maybe FilePath) -> FilePath -> WindowIconPixbufGetter addCustomIconsToDefaultWithFallbackByPath getCustomIconPath fallbackPath = addCustomIconsAndFallback getCustomIconPath (const $ lift $ getPixbufFromFilePath fallbackPath) unscaledDefaultGetWindowIconPixbuf addCustomIconsAndFallback :: (WindowData -> Maybe FilePath) -> (Int32 -> TaffyIO (Maybe Gdk.Pixbuf)) -> WindowIconPixbufGetter -> WindowIconPixbufGetter addCustomIconsAndFallback getCustomIconPath fallback defaultGetter = scaledWindowIconPixbufGetter $ getCustomIcon <|||> defaultGetter <|||> (\s _ -> fallback s) where getCustomIcon :: Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf) getCustomIcon _ wdata = lift $ maybe (return Nothing) getPixbufFromFilePath $ getCustomIconPath wdata -- | Sort windows by top-left corner position. sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData] sortWindowsByPosition wins = do let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w) getGeometries = mapM (forkM return (((sel2 &&& sel3) <$>) . getGeometryWorkspaces) . windowId) wins windowGeometries <- liftX11Def [] getGeometries let getLeftPos wd = fromMaybe (999999999, 99999999) $ lookup (windowId wd) windowGeometries compareWindowData a b = compare (windowMinimized a, getLeftPos a) (windowMinimized b, getLeftPos b) return $ sortBy compareWindowData wins -- | Sort windows in reverse _NET_CLIENT_LIST_STACKING order. -- Starting in xmonad-contrib 0.17.0, this is effectively focus history, active first. -- Previous versions erroneously stored focus-sort-order in _NET_CLIENT_LIST. sortWindowsByStackIndex :: [WindowData] -> WorkspacesIO [WindowData] sortWindowsByStackIndex wins = do stackingWindows <- liftX11Def [] getWindowsStacking let getStackIdx wd = fromMaybe (-1) $ elemIndex (windowId wd) stackingWindows compareWindowData a b = compare (getStackIdx b) (getStackIdx a) return $ sortBy compareWindowData wins updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget] updateImages ic ws = do WorkspacesContext {workspacesConfig = cfg} <- ask sortedWindows <- iconSort cfg $ windows ws wLog DEBUG $ printf "Updating images for %s" (show ws) let updateIconWidget' getImageAction wdata = do iconWidget <- getImageAction _ <- updateIconWidget ic iconWidget wdata return iconWidget existingImages = map return $ iconImages ic buildAndAddIconWidget transparentOnNone = do iw <- buildIconWidget transparentOnNone ws lift $ Gtk.containerAdd (iconsContainer ic) $ iconContainer iw return iw infiniteImages = existingImages ++ replicate (minIcons cfg - length existingImages) (buildAndAddIconWidget True) ++ repeat (buildAndAddIconWidget False) windowCount = length $ windows ws maxNeeded = maybe windowCount (min windowCount) $ maxIcons cfg newImagesNeeded = length existingImages < max (minIcons cfg) maxNeeded -- XXX: Only one of the two things being zipped can be an infinite list, -- which is why this newImagesNeeded contortion is needed. imgSrcs = if newImagesNeeded then infiniteImages else existingImages getImgs = maybe imgSrcs (`take` imgSrcs) $ maxIcons cfg justWindows = map Just sortedWindows windowDatas = if newImagesNeeded then justWindows ++ replicate (minIcons cfg - length justWindows) Nothing else justWindows ++ repeat Nothing newImgs <- zipWithM updateIconWidget' getImgs windowDatas when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic return newImgs getWindowStatusString :: WindowData -> T.Text getWindowStatusString windowData = T.toLower $ T.pack $ case windowData of WindowData { windowMinimized = True } -> "minimized" WindowData { windowActive = True } -> show Active WindowData { windowUrgent = True } -> show Urgent _ -> "normal" possibleStatusStrings :: [T.Text] possibleStatusStrings = map (T.toLower . T.pack) [show Active, show Urgent, "minimized", "normal", "inactive"] updateIconWidget :: IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO () updateIconWidget _ IconWidget { iconContainer = iconButton , iconWindow = windowRef , iconForceUpdate = updateIcon } windowData = do let statusString = maybe "inactive" getWindowStatusString windowData :: T.Text title = T.pack . windowTitle <$> windowData setIconWidgetProperties = updateWidgetClasses iconButton [statusString] possibleStatusStrings void $ updateVar windowRef $ const $ return windowData Gtk.widgetSetTooltipText iconButton title lift $ updateIcon >> setIconWidgetProperties data WorkspaceButtonController = WorkspaceButtonController { button :: Gtk.EventBox , buttonWorkspace :: Workspace , contentsController :: WWC } buildButtonController :: ParentControllerConstructor buildButtonController contentsBuilder workspace = do cc <- contentsBuilder workspace workspacesRef <- asks workspacesVar ctx <- ask widget <- getWidget cc lift $ do ebox <- Gtk.eventBoxNew Gtk.containerAdd ebox widget Gtk.eventBoxSetVisibleWindow ebox False _ <- Gtk.onWidgetScrollEvent ebox $ \scrollEvent -> do dir <- Gdk.getEventScrollDirection scrollEvent workspaces <- liftIO $ MV.readMVar workspacesRef let switchOne a = liftIO $ flip runReaderT ctx $ liftX11Def () (switchOneWorkspace a (length (M.toList workspaces) - 1)) >> return True case dir of Gdk.ScrollDirectionUp -> switchOne True Gdk.ScrollDirectionLeft -> switchOne True Gdk.ScrollDirectionDown -> switchOne False Gdk.ScrollDirectionRight -> switchOne False _ -> return False _ <- Gtk.onWidgetButtonPressEvent ebox $ const $ switch ctx $ workspaceIdx workspace return $ WWC WorkspaceButtonController { button = ebox, buttonWorkspace = workspace, contentsController = cc } switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool switch ctx idx = do liftIO $ flip runReaderT ctx $ liftX11Def () $ switchToWorkspace idx return True instance WorkspaceWidgetController WorkspaceButtonController where getWidget wbc = lift $ Gtk.toWidget $ button wbc updateWidget wbc update = do newContents <- updateWidget (contentsController wbc) update return wbc { contentsController = newContents } taffybar-4.1.1/src/System/Taffybar/Widget/WttrIn.hs0000644000000000000000000000602307346545000020324 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This is a simple weather widget that polls wttr.in to retrieve the weather, -- instead of relying on noaa data. -- -- Useful if NOAA data doesn't cover your needs, or if you just like wttr.in -- better. -- -- For more information on how to use wttr.in, see . module System.Taffybar.Widget.WttrIn (textWttrNew) where import Control.Exception as E (handle) import Control.Monad.IO.Class (MonadIO) import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict) import Data.Maybe (isJust) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import GI.Gtk (Widget) import Network.HTTP.Client ( HttpException, Request (requestHeaders), Response (responseBody, responseStatus), defaultManagerSettings, httpLbs, newManager, parseRequest, ) import Network.HTTP.Types.Status (statusIsSuccessful) import System.Log.Logger (Priority (ERROR), logM) import System.Taffybar.Widget.Generic.PollingLabel (pollingLabelWithVariableDelayAndRefresh) import Text.Regex (matchRegex, mkRegex) -- | Creates a GTK Label widget that polls the requested wttr.in url for weather -- information. -- -- Not compatible with image endpoints and binary data, such as the %.png% -- endpoints. -- -- > -- Yields a label with the text "London: ⛅️ +72°F". Updates every 60 -- > -- seconds. -- > textWttrNew "http://wttr.in/London?format=3" 60 textWttrNew :: MonadIO m => -- | URL. All non-alphanumeric characters must be properly %-encoded. String -> -- | Update Interval (in seconds) Double -> m Widget textWttrNew url interval = pollingLabelWithVariableDelayAndRefresh action True where action = do rsp <- callWttr url return (rsp, Nothing, interval) -- | IO Action that calls wttr.in as per the user's request. callWttr :: String -> IO T.Text callWttr url = let unknownLocation rsp = -- checks for a common wttr.in bug case T.stripPrefix "Unknown location; please try" rsp of Nothing -> False Just strippedRsp -> T.length strippedRsp < T.length rsp isImage = isJust . matchRegex (mkRegex ".png") getResponseData r = ( statusIsSuccessful $ responseStatus r, toStrict $ responseBody r ) in do manager <- newManager defaultManagerSettings request <- parseRequest url (isOk, response) <- handle logException ( getResponseData <$> httpLbs (request {requestHeaders = [("User-Agent", "curl")]}) manager ) let body = decodeUtf8 response return $ if not isOk || isImage url || unknownLocation body then "✨" else body -- Logs an Http Exception and returns wttr.in's weather unknown label. logException :: HttpException -> IO (Bool, ByteString) logException e = do let errmsg = show e logM "System.Taffybar.Widget.WttrIn" ERROR ("Warning: Couldn't call wttr.in. \n" ++ errmsg) return (False, "✨") taffybar-4.1.1/src/System/Taffybar/Widget/XDGMenu/0000755000000000000000000000000007346545000020007 5ustar0000000000000000taffybar-4.1.1/src/System/Taffybar/Widget/XDGMenu/Menu.hs0000644000000000000000000001104407346545000021247 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.XDGMenu.Menu -- Copyright : 2017 Ulf Jasper -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ulf Jasper -- Stability : unstable -- Portability : unportable -- -- Implementation of version 1.1 of the freedesktop "Desktop Menu -- Specification", see -- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html -- -- See also 'MenuWidget'. ----------------------------------------------------------------------------- module System.Taffybar.Widget.XDGMenu.Menu ( Menu(..) , MenuEntry(..) , buildMenu , getApplicationEntries ) where import Data.Char (toLower) import Data.List import Data.Maybe import qualified Data.Text as T import System.Environment.XDG.DesktopEntry import System.Taffybar.Information.XDG.Protocol -- | Displayable menu data Menu = Menu { fmName :: String , fmComment :: String , fmIcon :: Maybe String , fmSubmenus :: [Menu] , fmEntries :: [MenuEntry] , fmOnlyUnallocated :: Bool } deriving (Eq, Show) -- | Displayable menu entry data MenuEntry = MenuEntry { feName :: T.Text , feComment :: T.Text , feCommand :: String , feIcon :: Maybe T.Text } deriving (Eq, Show) -- | Fetch menus and desktop entries and assemble the menu. buildMenu :: Maybe String -> IO Menu buildMenu mMenuPrefix = do mMenuDes <- readXDGMenu mMenuPrefix case mMenuDes of Nothing -> return $ Menu "???" "Parsing failed" Nothing [] [] False Just (menu, des) -> do dt <- getXDGDesktop dirDirs <- getDirectoryDirs langs <- getPreferredLanguages (fm, ae) <- xdgToMenu dt langs dirDirs des menu let fm' = fixOnlyUnallocated ae fm return fm' -- | Convert xdg menu to displayable menu xdgToMenu :: String -> [String] -> [FilePath] -> [DesktopEntry] -> XDGMenu -> IO (Menu, [MenuEntry]) xdgToMenu desktop langs dirDirs des xm = do dirEntry <- getDirectoryEntry dirDirs (xmDirectory xm) mas <- mapM (xdgToMenu desktop langs dirDirs des) (xmSubmenus xm) let (menus, subaes) = unzip mas menus' = sortBy (\fm1 fm2 -> compare (map toLower $ fmName fm1) (map toLower $ fmName fm2)) menus entries = map (xdgToMenuEntry langs) $ -- hide NoDisplay filter (not . deNoDisplay) $ -- onlyshowin filter (matchesOnlyShowIn desktop) $ -- excludes filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $ -- includes filter (`matchesCondition` fromMaybe None (xmInclude xm)) des onlyUnallocated = xmOnlyUnallocated xm aes = if onlyUnallocated then [] else entries ++ concat subaes let fm = Menu {fmName = maybe (xmName xm) (deName langs) dirEntry, fmComment = maybe "???" (fromMaybe "???" . deComment langs) dirEntry, fmIcon = deIcon =<< dirEntry, fmSubmenus = menus', fmEntries = entries, fmOnlyUnallocated = onlyUnallocated} return (fm, aes) -- | Check the "only show in" logic matchesOnlyShowIn :: String -> DesktopEntry -> Bool matchesOnlyShowIn desktop de = matchesShowIn && notMatchesNotShowIn where matchesShowIn = case deOnlyShowIn de of [] -> True desktops -> desktop `elem` desktops notMatchesNotShowIn = case deNotShowIn de of [] -> True desktops -> desktop `notElem` desktops -- | convert xdg desktop entry to displayble menu entry xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry xdgToMenuEntry langs de = MenuEntry {feName = name, feComment = comment, feCommand = cmd, feIcon = mIcon} where mc = case deCommand de of Nothing -> Nothing Just c -> Just $ "(" ++ c ++ ")" comment = T.pack $ fromMaybe "??" $ case deComment langs de of Nothing -> mc Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc cmd = fromMaybe "FIXME" $ deCommand de name = T.pack $ deName langs de mIcon = T.pack <$> deIcon de -- | postprocess unallocated entries fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu fixOnlyUnallocated fes fm = fm { fmEntries = entries , fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm) } where entries = if fmOnlyUnallocated fm then filter (not . (`elem` fes)) (fmEntries fm) else fmEntries fm taffybar-4.1.1/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs0000644000000000000000000000713507346545000022421 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.XDGMenu.MenuWidget -- Copyright : 2017 Ulf Jasper -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ulf Jasper -- Stability : unstable -- Portability : unportable -- -- MenuWidget provides a hierachical GTK menu containing all -- applicable desktop entries found on the system. The menu is built -- according to the version 1.1 of the XDG "Desktop Menu -- Specification", see -- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html ----------------------------------------------------------------------------- module System.Taffybar.Widget.XDGMenu.MenuWidget ( -- * Usage -- $usage menuWidgetNew ) where import Control.Monad import Control.Monad.IO.Class import qualified Data.Text as T import GI.Gtk hiding (Menu, imageMenuItemNew) import System.Log.Logger import System.Process import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Util import System.Taffybar.Widget.XDGMenu.Menu -- $usage -- -- In order to use this widget add the following line to your -- @taffybar.hs@ file: -- -- > import System.Taffybar.Widget.XDGMenu.MenuWidget -- > main = do -- > let menu = menuWidgetNew $ Just "PREFIX-" -- -- The menu will look for a file named "PREFIX-applications.menu" in the -- (subdirectory "menus" of the) directories specified by the environment -- variables XDG_CONFIG_HOME and XDG_CONFIG_DIRS. (If XDG_CONFIG_HOME is not set -- or empty then $HOME/.config is used, if XDG_CONFIG_DIRS is not set or empty -- then "/etc/xdg" is used). If no prefix is given (i.e. if you pass Nothing) -- then the value of the environment variable XDG_MENU_PREFIX is used, if it is -- set. If taffybar is running inside a desktop environment like Mate, Gnome, -- XFCE etc. the environment variables XDG_CONFIG_DIRS and XDG_MENU_PREFIX -- should be set and you may create the menu like this: -- -- > let menu = menuWidgetNew Nothing -- -- Now you can use @menu@ as any other Taffybar widget. logHere :: Priority -> String -> IO () logHere = logM "System.Taffybar.Widget.XDGMenu.MenuWidget" -- | Add a desktop entry to a gtk menu by appending a gtk menu item. addItem :: (IsMenuShell msc) => msc -- ^ GTK menu -> MenuEntry -- ^ Desktop entry -> IO () addItem ms de = do item <- imageMenuItemNew (feName de) (getImageForMaybeIconName (feIcon de)) setWidgetTooltipText item (feComment de) menuShellAppend ms item _ <- onMenuItemActivate item $ do let cmd = feCommand de logHere DEBUG $ "Launching '" ++ cmd ++ "'" _ <- spawnCommand cmd return () return () -- | Add an xdg menu to a gtk menu by appending gtk menu items and submenus. addMenu :: (IsMenuShell msc) => msc -- ^ A GTK menu -> Menu -- ^ A menu object -> IO () addMenu ms fm = do let subMenus = fmSubmenus fm items = fmEntries fm when (not (null items) || not (null subMenus)) $ do item <- imageMenuItemNew (T.pack $ fmName fm) (getImageForMaybeIconName (T.pack <$> fmIcon fm)) menuShellAppend ms item subMenu <- menuNew menuItemSetSubmenu item (Just subMenu) mapM_ (addMenu subMenu) subMenus mapM_ (addItem subMenu) items -- | Create a new XDG Menu Widget. menuWidgetNew :: MonadIO m => Maybe String -- ^ menu name, must end with a dash, e.g. "mate-" or "gnome-" -> m GI.Gtk.Widget menuWidgetNew mMenuPrefix = liftIO $ do mb <- menuBarNew m <- buildMenu mMenuPrefix addMenu mb m widgetShowAll mb toWidget mb taffybar-4.1.1/src/System/Taffybar/WindowIcon.hs0000644000000000000000000001261707346545000017740 0ustar0000000000000000module System.Taffybar.WindowIcon where import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Data.Bits import Data.Int import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.MultiMap as MM import Data.Ord import qualified Data.Text as T import Data.Word import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import qualified GI.GdkPixbuf.Enums as Gdk import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Hooks import System.Taffybar.Information.Chrome import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Information.X11DesktopInfo import System.Environment.XDG.DesktopEntry import System.Taffybar.Util import System.Taffybar.Widget.Util import Text.Printf type ColorRGBA = Word32 -- | Convert a C array of integer pixels in the ARGB format to the ABGR format. -- Returns an unmanged Ptr that points to a block of memory that must be freed -- manually. pixelsARGBToBytesABGR :: (Storable a, Bits a, Num a, Integral a) => Ptr a -> Int -> IO (Ptr Word8) pixelsARGBToBytesABGR ptr size = do target <- mallocArray (size * 4) let writeIndex i = do bits <- peekElemOff ptr i let b = toByte bits g = toByte $ bits `shift` (-8) r = toByte $ bits `shift` (-16) a = toByte $ bits `shift` (-24) baseTarget = 4 * i doPoke offset = pokeElemOff target (baseTarget + offset) toByte = fromIntegral . (.&. 0xFF) doPoke 0 r doPoke 1 g doPoke 2 b doPoke 3 a writeIndexAndNext i | i >= size = return () | otherwise = writeIndex i >> writeIndexAndNext (i + 1) writeIndexAndNext 0 return target selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon selectEWMHIcon imgSize icons = listToMaybe prefIcon where sortedIcons = sortBy (comparing ewmhHeight) icons smallestLargerIcon = take 1 $ dropWhile ((<= fromIntegral imgSize) . ewmhHeight) sortedIcons largestIcon = take 1 $ reverse sortedIcons prefIcon = smallestLargerIcon ++ largestIcon getPixbufFromEWMHIcons :: Int32 -> [EWMHIcon] -> IO (Maybe Gdk.Pixbuf) getPixbufFromEWMHIcons size = traverse pixBufFromEWMHIcon . selectEWMHIcon size -- | Create a pixbuf from the pixel data in an EWMHIcon. pixBufFromEWMHIcon :: EWMHIcon -> IO Gdk.Pixbuf pixBufFromEWMHIcon EWMHIcon {ewmhWidth = w, ewmhHeight = h, ewmhPixelsARGB = px} = do let width = fromIntegral w height = fromIntegral h rowStride = width * 4 wPtr <- pixelsARGBToBytesABGR px (w * h) Gdk.pixbufNewFromData wPtr Gdk.ColorspaceRgb True 8 width height rowStride (Just free) getIconPixBufFromEWMH :: Int32 -> X11Window -> X11Property (Maybe Gdk.Pixbuf) getIconPixBufFromEWMH size x11WindowId = runMaybeT $ do ewmhData <- MaybeT $ getWindowIconsData x11WindowId MaybeT $ lift $ withEWMHIcons ewmhData (getPixbufFromEWMHIcons size) -- | Create a pixbuf with the indicated RGBA color. pixBufFromColor :: MonadIO m => Int32 -> Word32 -> m Gdk.Pixbuf pixBufFromColor imgSize c = do pixbuf <- fromJust <$> Gdk.pixbufNew Gdk.ColorspaceRgb True 8 imgSize imgSize Gdk.pixbufFill pixbuf c return pixbuf getDirectoryEntryByClass :: String -> TaffyIO (Maybe DesktopEntry) getDirectoryEntryByClass klass = do entries <- MM.lookup klass <$> getDirectoryEntriesByClassName when (length entries > 1) $ liftIO $ logM "System.Taffybar.WindowIcon" DEBUG $ printf "Class \"%s\" has multiple desktop entries: %s" klass (intercalate ", " $ map deFilename entries) return $ listToMaybe entries getWindowIconForAllClasses :: Monad m => (p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a) getWindowIconForAllClasses doOnClass size klass = foldl combine (return Nothing) $ parseWindowClasses klass where combine soFar theClass = maybeTCombine soFar (doOnClass size theClass) getWindowIconFromDesktopEntryByClasses :: Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf) getWindowIconFromDesktopEntryByClasses = getWindowIconForAllClasses getWindowIconFromDesktopEntryByClass where getWindowIconFromDesktopEntryByClass size klass = runMaybeT $ do entry <- MaybeT $ getDirectoryEntryByClass klass lift $ logPrintF "System.Taffybar.WindowIcon" DEBUG "Using desktop entry for icon %s" (deFilename entry, klass) MaybeT $ lift $ getImageForDesktopEntry size entry getWindowIconFromClasses :: Int32 -> String -> IO (Maybe Gdk.Pixbuf) getWindowIconFromClasses = getWindowIconForAllClasses getWindowIconFromClass where getWindowIconFromClass size klass = loadPixbufByName size (T.pack klass) getPixBufFromChromeData :: X11Window -> TaffyIO (Maybe Gdk.Pixbuf) getPixBufFromChromeData window = do imageData <- getChromeTabImageDataTable >>= lift . readMVar X11WindowToChromeTabId x11LookupMapVar <- getX11WindowToChromeTabId x11LookupMap <- lift $ readMVar x11LookupMapVar return $ tabImageData <$> (M.lookup window x11LookupMap >>= flip M.lookup imageData) taffybar-4.1.1/taffybar.cabal0000644000000000000000000002125407346545000014272 0ustar0000000000000000cabal-version: 3.4 name: taffybar version: 4.1.1 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD-3-Clause license-file: LICENSE author: Ivan Malison maintainer: IvanMalison@gmail.com category: System build-type: Simple tested-with: GHC == 9.8.4, GHC == 9.10.3 homepage: http://github.com/taffybar/taffybar data-files: taffybar.css icons/*.svg extra-source-files: dbus-xml/org.freedesktop.UPower.Device.xml dbus-xml/org.freedesktop.UPower.xml dbus-xml/org.mpris.MediaPlayer2.Player.xml dbus-xml/org.mpris.MediaPlayer2.xml test/data/*.golden extra-doc-files: README.md CHANGELOG.md doc/*.md flag Deprecated-Pager-Hints description: Enables the deprecated System.Taffybar.Support.PagerHints module, which has been moved to xmonad-contrib. common haskell default-extensions: DeriveGeneric GeneralizedNewtypeDeriving LambdaCase NumericUnderscores StandaloneDeriving TupleSections default-language: Haskell2010 build-depends: base >= 4.15.0.0 && < 5 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 , bytestring , conduit , containers , data-default , dbus >= 1.2.11 && < 2.0.0 , dbus-hslogger >= 0.1.0.1 && < 0.2.0.0 , directory , dyre >= 0.9.0 && < 0.10 , either >= 4.0.0.0 , enclosed-exceptions >= 1.0.0.1 , filepath , fsnotify >= 0.4 && < 0.5 , gi-cairo-connector , gi-cairo-render , gi-gdk3 >=3.0.30 && <3.1 , gi-gdkpixbuf >=2.0.6 && <2.1 , gi-gdkx113 >=3.0.17 && < 4 , gi-glib , gi-gtk3 >= 3.0.44 && < 4 , gi-gtk-hs >= 0.3.17 && < 0.4 , gi-pango , gtk-sni-tray >= 0.1.8.0 , gtk-strut >= 0.1.2.1 , haskell-gi-base >= 0.24 , hslogger , http-conduit , http-client >= 0.5 , http-client-tls , http-types , multimap >= 1.2.1 , parsec >= 3.1 , process >= 1.0.1.1 , rate-limit >= 1.1.1 , regex-compat , safe >= 0.3 && < 1 , scotty >= 0.20 && < 0.23 , split >= 0.1.4.2 , status-notifier-item >= 0.3.1.0 , stm , template-haskell , text , time >= 1.9 && < 2.0 , time-locale-compat >= 0.1 && < 0.2 , time-units >= 1.0.0 , transformers >= 0.3.0.0 , tuple >= 0.3.0.2 , unix , utf8-string , xdg-desktop-entry , xdg-basedir >= 0.2 && < 0.3 , xml , xml-helpers hs-source-dirs: src pkgconfig-depends: gtk+-3.0 exposed-modules: System.Taffybar , System.Taffybar.Auth , System.Taffybar.Context , System.Taffybar.DBus , System.Taffybar.DBus.Toggle , System.Taffybar.Example , System.Taffybar.Hooks , System.Taffybar.Information.Battery , System.Taffybar.Information.CPU , System.Taffybar.Information.CPU2 , System.Taffybar.Information.Chrome , System.Taffybar.Information.Crypto , System.Taffybar.Information.DiskIO , System.Taffybar.Information.EWMHDesktopInfo , System.Taffybar.Information.MPRIS2 , System.Taffybar.Information.Memory , System.Taffybar.Information.Network , System.Taffybar.Information.SafeX11 , System.Taffybar.Information.StreamInfo , System.Taffybar.Information.X11DesktopInfo , System.Taffybar.Information.XDG.Protocol , System.Taffybar.LogFormatter , System.Taffybar.SimpleConfig , System.Taffybar.Util , System.Taffybar.Widget , System.Taffybar.Widget.Battery , System.Taffybar.Widget.CPUMonitor , System.Taffybar.Widget.CommandRunner , System.Taffybar.Widget.Crypto , System.Taffybar.Widget.DiskIOMonitor , System.Taffybar.Widget.FSMonitor , System.Taffybar.Widget.FreedesktopNotifications , System.Taffybar.Widget.Generic.AutoSizeImage , System.Taffybar.Widget.Generic.ChannelGraph , System.Taffybar.Widget.Generic.ChannelWidget , System.Taffybar.Widget.Generic.DynamicMenu , System.Taffybar.Widget.Generic.Graph , System.Taffybar.Widget.Generic.Icon , System.Taffybar.Widget.Generic.PollingBar , System.Taffybar.Widget.Generic.PollingGraph , System.Taffybar.Widget.Generic.PollingLabel , System.Taffybar.Widget.Generic.VerticalBar , System.Taffybar.Widget.Layout , System.Taffybar.Widget.MPRIS2 , System.Taffybar.Widget.NetworkGraph , System.Taffybar.Widget.SNITray , System.Taffybar.Widget.SimpleClock , System.Taffybar.Widget.SimpleCommandButton , System.Taffybar.Widget.Text.CPUMonitor , System.Taffybar.Widget.Text.MemoryMonitor , System.Taffybar.Widget.Text.NetworkMonitor , System.Taffybar.Widget.Util , System.Taffybar.Widget.Weather , System.Taffybar.Widget.Windows , System.Taffybar.Widget.Workspaces , System.Taffybar.Widget.WttrIn , System.Taffybar.Widget.XDGMenu.Menu , System.Taffybar.Widget.XDGMenu.MenuWidget , System.Taffybar.WindowIcon if flag(Deprecated-Pager-Hints) build-depends: xmonad exposed-modules: System.Taffybar.Support.PagerHints other-modules: Paths_taffybar , System.Taffybar.DBus.Client.MPRIS2 , System.Taffybar.DBus.Client.Params , System.Taffybar.DBus.Client.UPower , System.Taffybar.DBus.Client.UPowerDevice , System.Taffybar.DBus.Client.Util autogen-modules: Paths_taffybar cc-options: -fPIC ghc-options: -funbox-strict-fields -fno-warn-orphans executable taffybar import: haskell, exe build-depends: data-default , directory , hslogger , optparse-applicative , taffybar other-modules: Paths_taffybar autogen-modules: Paths_taffybar hs-source-dirs: app main-is: Main.hs pkgconfig-depends: gtk+-3.0 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/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-gtk3 , hspec , hspec-core , hspec-golden , taffybar , taffybar:testlib , transformers , QuickCheck build-tool-depends: hspec-discover:hspec-discover == 2.* source-repository head type: git location: http://github.com/taffybar/taffybar.git taffybar-4.1.1/taffybar.css0000644000000000000000000000476207346545000014025 0ustar0000000000000000@define-color transparent rgba(0, 0, 0, 0.0); @define-color white #FFFFFF; @define-color black #000000; @define-color taffy-blue #0c7cd5; @define-color active-window-color @white; @define-color urgent-window-color @taffy-blue; @define-color font-color @white; @define-color menu-background-color @white; @define-color menu-font-color @black; /* Top level styling */ .taffy-window * { /* This removes any existing styling from UI elements. Taffybar will not cohere with your gtk theme. */ all: unset; font-family: "Noto Sans", sans-serif; font-size: 10pt; color: @font-color; } .taffy-box { border-radius: 10px; background-color: rgba(0, 0, 0, 0.3); } .inner-pad { padding-bottom: 5px; padding-top: 5px; padding-left: 2px; padding-right: 2px; } .contents { padding-bottom: 4px; padding-top: 4px; padding-right: 2px; padding-left: 2px; transition: background-color .5s; border-radius: 5px; } /* Workspaces styling */ .workspace-label { padding-right: 3px; padding-left: 2px; font-size: 12pt; } .active .contents { background-color: rgba(0, 0, 0, 0.5); } .visible .contents { background-color: rgba(0, 0, 0, 0.2); } .window-icon-container { transition: opacity .5s, box-shadow .5s; opacity: 1; } /* This gives space for the box-shadow (they look like underlines) that follow. This will actually affect all widgets, (not just the workspace icons), but that is what we want since we want the icons to look the same. */ .auto-size-image, .sni-tray { padding-top: 3px; padding-bottom: 3px; } .window-icon-container.active { box-shadow: inset 0 -3px @white; } .window-icon-container.urgent { box-shadow: inset 0 -3px @urgent-window-color; } .window-icon-container.inactive .window-icon { padding: 0px; } .window-icon-container.minimized .window-icon { opacity: .3; } .window-icon { opacity: 1; transition: opacity .5s; } /* Button styling */ button { background-color: @transparent; border-width: 0px; border-radius: 0px; } button:checked, button:hover .Contents:hover { box-shadow: inset 0 -3px @taffy-blue; } /* Menu styling */ /* The ".taffy-window" prefixed selectors are needed because if they aren't present, the top level .Taffybar selector takes precedence */ .taffy-window menuitem *, menuitem * { color: @menu-font-color; } .taffy-window menuitem, menuitem { background-color: @menu-background-color; } .taffy-window menuitem:hover, menuitem:hover { background-color: @taffy-blue; } .taffy-window menuitem:hover > label, menuitem:hover > label { color: @white; } taffybar-4.1.1/test/data/0000755000000000000000000000000007346545000013374 5ustar0000000000000000taffybar-4.1.1/test/data/System.Taffybar.Auth-passGet-get-a-password-with-info.golden0000644000000000000000000000006307346545000026647 0ustar0000000000000000Right ("secret",[("Username","fred"),("silly","")])taffybar-4.1.1/test/data/System.Taffybar.Auth-passGet-get-a-password.golden0000644000000000000000000000002207346545000024740 0ustar0000000000000000Right ("xyzzy",[])taffybar-4.1.1/test/data/System.Taffybar.Auth-passGet-missing-entry.golden0000644000000000000000000000007507346545000024723 0ustar0000000000000000Left "Exit code 1: Error: is not in the password store.\n\n "taffybar-4.1.1/test/lib/System/Taffybar/Test/0000755000000000000000000000000007346545000017172 5ustar0000000000000000taffybar-4.1.1/test/lib/System/Taffybar/Test/DBusSpec.hs0000644000000000000000000002765507346545000021215 0ustar0000000000000000module System.Taffybar.Test.DBusSpec ( spec -- * Start private D-Busses for testing , withTestDBus , withTestDBusInDir , Bus(..) , withDBusDaemon_ , withConnectDBusDaemon , withConnectDBusDaemon' -- ** Using the private D-Bus , setDBusEnv , withBusEnv -- ** @python-dbusmock@ Services , withPythonDBusMock , withTaffyMocks -- * Utils , withMatch , withClient ) where import Control.Monad (forM_, void, when) import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Data.ByteString.Char8 qualified as B8 import Data.Function ((&)) import Data.List (sort) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Int (Int64) import DBus import DBus.Client import Test.Hspec import System.FilePath ((), (<.>), takeFileName) import System.IO (hGetLine, hClose) import System.Process.Typed import System.Taffybar.Test.UtilSpec (withSetEnv, logSetup, specLog, withService, getSpecLogPriority, setServiceDefaults, laxTimeout') import UnliftIO.Directory (makeAbsolute, createDirectoryIfMissing, createFileLink) import UnliftIO.Temporary (withSystemTempDirectory) import UnliftIO.Exception (bracket, throwString, finally, throwIO) import UnliftIO.MVar qualified as MV -- | Uses 'withDBusDaemon_' to provide both a private session bus and -- a private system bus while the given action is running. -- -- The @DBUS_SESSION_BUS_ADDRESS@ and @DBUS_SYSTEM_BUS_ADDRESS@ -- environment variables will be set to point to socket files within -- the given directory. -- -- Files in the directory will be left behind after this function -- returns. -- -- __Note__: Environment variables are global to the process, so be -- careful using this with 'parallel' unit tests. withTestDBusInDir :: FilePath -- ^ Directory for config files and sockets. -> IO a -> IO a withTestDBusInDir socketDir = withDBusDaemon_ System socketDir . withDBusDaemon_ Session socketDir -- | Same as 'withTestDBusInDir', except that it creates and removes the -- temporary directory for you. withTestDBus :: IO a -> IO a withTestDBus = withSystemTempDirectory "dbus-spec" . flip withTestDBusInDir data Bus = Session | System deriving (Show, Read, Eq, Enum) busName :: Bus -> String busName Session = "session" busName System = "system" busArg :: Bus -> String busArg = ("--" ++) . busName envName :: Bus -> String envName Session = "DBUS_SESSION_BUS_ADDRESS" envName System = "DBUS_SYSTEM_BUS_ADDRESS" busEnv :: Bus -> Address -> (String, String) busEnv bus addr = (envName bus, formatAddress addr) -- | Adjust a 'ProcessConfig' so that the child process will use the -- given D-Bus address. setDBusEnv :: Bus -> Address -> ProcessConfig i o e -> ProcessConfig i o e setDBusEnv bus addr = setEnv [busEnv bus addr] withDBusDaemon :: Bus -> FilePath -> (Address -> IO a) -> IO a withDBusDaemon bus socketDir action = do cfg <- makeDBusDaemon <$> setupBusDir bus socketDir <*> getSpecLogPriority specLog $ "withDBusDaemon " ++ show bus ++ " running: " ++ show cfg withService cfg $ \p -> consumeAddress (getStdout p) >>= action where consumeAddress h = (just . parseAddress =<< hGetLine h) `finally` hClose h just = maybe (throwString "Could not parse address from dbus-daemon") pure makeDBusDaemon configFile logLevel = proc "dbus-daemon" ["--print-address", "--config-file", configFile] & setServiceDefaults logLevel & setStdout createPipe -- | Start a D-Bus daemon of the given 'Bus' type, and set the -- corresponding environment variable while running the given action. -- -- __Note__: Environment variables are global to the process, so be -- careful using this with 'parallel' unit tests. A safer option could -- be 'withConnectDBusDaemon'' and 'setBusEnv'. withDBusDaemon_ :: Bus -> FilePath -> IO a -> IO a withDBusDaemon_ bus socketDir action = withDBusDaemon bus socketDir $ \addr -> withBusEnv bus addr action -- | Same as 'withDBusDaemon', but it also provides a 'Client' -- connection. withConnectDBusDaemon' :: Bus -> FilePath -> (Address -> Client -> IO a) -> IO a withConnectDBusDaemon' bus socketDir action = withDBusDaemon bus socketDir $ \addr -> withClient addr $ \c -> action addr c withConnectDBusDaemon :: Bus -> FilePath -> (Client -> IO a) -> IO a withConnectDBusDaemon bus socketDir = withConnectDBusDaemon' bus socketDir. const setupBusDir :: Bus -> FilePath -> IO FilePath setupBusDir bus socketDir = do let busDir = socketDir busName bus serviceDir = busDir "service.d" configFile = busDir "config.xml" createDirectoryIfMissing True serviceDir forM_ [] $ \service -> createFileLink service (serviceDir takeFileName service) -- createFileLink "/nix/store/ygd600kkc1h3p5dgw9vjm5xnfci43v0k-upower-1.90.4/share/dbus-1/system-services/org.freedesktop.UPower.service" (serviceDir "org.freedesktop.UPower.service") addr <- mkAddress (socketDir busName bus <.> "socket") writeFile configFile $ unlines [ "" , "" , " " ++ busName bus ++ "" , " " , " " ++ addr ++ "" , " " ++ serviceDir ++ "" , " " , " " , " " , " " , " " , "" ] pure configFile mkAddress :: FilePath -> IO String mkAddress = fmap ("unix:path=" ++) . makeAbsolute -- | Set the @DBUS_SESSION_BUS_ADDRESS@ or @DBUS_SYSTEM_BUS_ADDRESS@ -- environment variable according to the given bus and address. -- -- __Note 1__: Environment variables are global to the process, so -- be careful using this with 'parallel' unit tests. -- -- __Note 2__. Using a @DBUS_SYSTEM_BUS_ADDRESS@ environment variable to set a -- custom system bus address is supported by libdbus (therefore -- python-dbus) and haskell-dbus, but not necessarily other libraries -- or programs. Notably, systemd hardcodes the system bus address. withBusEnv :: Bus -> Address -> IO a -> IO a withBusEnv bus addr = withSetEnv [busEnv bus addr] withClient :: Address -> (Client -> IO a) -> IO a withClient addr = bracket (connect addr) disconnect withMatch :: MonadUnliftIO m => Client -> MatchRule -> (Signal -> m ()) -> m a -> m a withMatch client rule cb action = withRunInIO $ \run -> bracket (addMatch client rule (run . cb)) (removeMatch client) (const $ run action) makeBusNameWaiter :: Client -> (BusName -> Bool) -> IO (IO ()) makeBusNameWaiter client p = do v <- MV.newEmptyMVar h <- MV.newEmptyMVar let cb sig = onNameOwnerChanged sig $ do hh <- MV.takeMVar h removeMatch client hh MV.putMVar v () MV.putMVar h =<< addMatch client rule cb pure (MV.takeMVar v) where rule = matchAny { matchMember = Just "NameOwnerChanged" , matchInterface = Just "org.freedesktop.DBus" , matchSender = Just "org.freedesktop.DBus" } isMatch = maybe False p . fromVariant isOwned = not . null . fromMaybe ("" :: String) . fromVariant onNameOwnerChanged sig next = case signalBody sig of [name, _, owner] -> when (isMatch name && isOwned owner) next _ -> pure () -- | Starts up [@python-dbusmock@](https://martinpitt.github.io/python-dbusmock/). -- The given action will be run once the mock is ready. withPythonDBusMock :: Bus -- ^ @python-dbusmock@ wants to know which bus. -> (Address, Client) -- ^ Connection to the 'Bus' -> BusName -- ^ Name of mock service. -> ObjectPath -- ^ Path of mock service. -> InterfaceName -- ^ Interface of mock service. -> IO a -> IO a withPythonDBusMock bus (addr, client) name path interface action = do waiter <- makeBusNameWaiter client (== name) logLevel <- getSpecLogPriority withService (cfg & setServiceDefaults logLevel) $ const $ waiter *> action where cfg = proc "python3" args & setDBusEnv bus addr args = ["-m", "dbusmock", busArg bus , formatBusName name , formatObjectPath path , formatInterfaceName interface] mockAddTemplate :: Client -> BusName -> ObjectPath -> String -> [(String, Variant)] -> IO () mockAddTemplate client dest path templ params = do void $ call_ client (addTemplate templ params) { methodCallDestination = Just dest } where addTemplate t p = (methodCall path "org.freedesktop.DBus.Mock" "AddTemplate") { methodCallBody = [toVariant t, toVariant (Map.fromList p)] } ------------------------------------------------------------------------ upName :: BusName upName = "org.freedesktop.UPower" upPath, upDisplayDevicePath :: ObjectPath upPath = "/org/freedesktop/UPower" upDisplayDevicePath = objectPath_ (formatObjectPath upPath ++ "/devices/DisplayDevice") upIface, upDeviceIface :: InterfaceName upIface = "org.freedesktop.UPower" upDeviceIface = interfaceName_ (formatInterfaceName upIface ++ ".Device") mockIconName :: String mockIconName = "face-cool-symbolic" mockUPower :: Client -> IO () mockUPower client = do -- oh dbus, so ugly. mockAddTemplate client upName upPath "upower" [("OnBattery", toVariant True)] void $ call_ client (methodCall upPath "org.freedesktop.DBus.Mock" "AddAC") { methodCallBody = map toVariant ["mock_AC" :: String, "Mock AC"], methodCallDestination = Just upName } void $ call_ client (methodCall upPath "org.freedesktop.DBus.Mock" "AddChargingBattery") { methodCallBody = map toVariant ["mock_BAT" :: String, "Mock Battery"] ++ [toVariant (30.0 :: Double), toVariant (1200 :: Int64)] , methodCallDestination = Just upName } void $ setPropertyValue client (methodCall upDisplayDevicePath upDeviceIface "IconName") { methodCallDestination = Just upName } mockIconName withTaffyMocks :: IO a -> IO a withTaffyMocks action = do maddr <- getSystemAddress addr <- maybe (throwIO (clientError "getSystemAddress")) pure maddr withClient addr $ \client -> do withPythonDBusMock System (addr, client) upName upPath upIface $ do mockUPower client action ------------------------------------------------------------------------ spec :: Spec spec = logSetup $ around_ (laxTimeout' 1_000_000) $ around (withSystemTempDirectory "dbus-spec") $ do describe "withDBusDaemon org.freedesktop.DBus.Peer.Ping" $ do forM_ [System, Session] $ \bus -> aroundWith (flip (withConnectDBusDaemon' bus) . curry) $ do it ("can ping private test " ++ show bus ++ " bus") $ \(_, client) -> do (fmap methodReturnBody <$> call client ping) `shouldReturn` Right [] it ("gdbus can ping private test " ++ show bus ++ " bus") $ \(addr, _) -> readProcessStdout_ (gdbusPing bus & setDBusEnv bus addr) `shouldReturn` "()\n" forM_ [System] $ \bus -> aroundWith (flip (withConnectDBusDaemon' bus) . curry) $ describe ("python-dbusmock " ++ show bus ++ " services") $ do it "simple" $ \(addr, client) -> example $ withPythonDBusMock bus (addr, client) "com.example.Foo" "/" "com.example.Foo.Manager" $ pure () it "UPower" $ \(addr, client) -> example $ do withPythonDBusMock bus (addr, client) upName upPath upIface $ do mockUPower client models <- upowerDumpModels addr sort models `shouldBe` ["Mock AC", "Mock Battery"] upowerDumpModels :: Address -> IO [String] upowerDumpModels addr = parse <$> readProcessStdout_ cfg where cfg = proc "upower" ["--dump"] & setDBusEnv System addr parse = map (B8.unpack . B8.dropSpace . B8.drop 1 . snd) . filter ((== "model") . fst) . map (B8.break (== ':') . B8.dropSpace) . B8.lines . B8.toStrict gdbusPing :: Bus -> ProcessConfig () () () gdbusPing bus = proc "gdbus" ["call", "--" ++ busName bus, "--dest", "org.freedesktop.DBus", "--object-path", "/org/freedesktop/DBus", "--method", "org.freedesktop.DBus.Peer.Ping"] ping :: MethodCall ping = (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus.Peer" "Ping") { methodCallDestination = Just "org.freedesktop.DBus" } taffybar-4.1.1/test/lib/System/Taffybar/Test/UtilSpec.hs0000644000000000000000000003113007346545000021254 0ustar0000000000000000{-# 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 = flip setServiceDefaults (proc prog args) <$> 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" taffybar-4.1.1/test/lib/System/Taffybar/Test/XvfbSpec.hs0000644000000000000000000005356607346545000021265 0ustar0000000000000000{-# 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 taffybar-4.1.1/test/lib/0000755000000000000000000000000007346545000013231 5ustar0000000000000000taffybar-4.1.1/test/lib/TestLibSpec.hs0000644000000000000000000000011407346545000015742 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=TestLibSpec #-} taffybar-4.1.1/test/unit/System/Taffybar/0000755000000000000000000000000007346545000016464 5ustar0000000000000000taffybar-4.1.1/test/unit/System/Taffybar/AuthSpec.hs0000644000000000000000000000445007346545000020537 0ustar0000000000000000module 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" ] taffybar-4.1.1/test/unit/System/Taffybar/ContextSpec.hs0000644000000000000000000001254407346545000021265 0ustar0000000000000000{-# 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 taffybar-4.1.1/test/unit/System/Taffybar/Information/0000755000000000000000000000000007346545000020751 5ustar0000000000000000taffybar-4.1.1/test/unit/System/Taffybar/Information/X11DesktopInfoSpec.hs0000644000000000000000000000163207346545000024641 0ustar0000000000000000{-# 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 taffybar-4.1.1/test/unit/System/Taffybar/SimpleConfigSpec.hs0000644000000000000000000000256607346545000022223 0ustar0000000000000000{-# 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 taffybar-4.1.1/test/unit/0000755000000000000000000000000007346545000013442 5ustar0000000000000000taffybar-4.1.1/test/unit/UnitSpec.hs0000644000000000000000000000011107346545000015521 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=UnitSpec #-} taffybar-4.1.1/test/unit/unit-tests.hs0000644000000000000000000000035507346545000016120 0ustar0000000000000000module 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