Taffybar.hs

{-# 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.SimpleConfig
    -- > import System.Taffybar.Widget
    -- >
    -- > main = do
    -- >   let cpuCfg = def
    -- >                  { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)]
    -- >                  , graphLabel = Just "cpu"
    -- >                  }
    -- >       clock = textClockNewWith def
    -- >       cpu = cpuMonitorNew cpuCfg 0.5 "cpu"
    -- >       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
    -- <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>.

    -- * 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 Config.Dyre as Dyre
import qualified Config.Dyre.Params as Dyre
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.MVar as MV
import Control.Exception (finally)
import Control.Exception.Enclosed (catchAny)
import Control.Monad
import Data.Char (toLower)
import Data.Function (on)
import qualified Data.GI.Gtk.Threading as GIThreading
import Data.List (groupBy, isPrefixOf, sort)
import Data.Maybe (isJust)
import qualified Data.Text as T
import Data.Word (Word32)
import qualified GI.GLib as G
import qualified GI.Gdk as Gdk
import qualified GI.Gtk as Gtk
import Graphics.X11.Xlib.Misc (initThreads)
import Paths_taffybar (getDataDir)
import System.Directory
import System.Environment (lookupEnv)
import System.Environment.XDG.BaseDir (getUserConfigFile)
import System.Exit (exitFailure)
import System.FSNotify (Event (..), EventIsDirectory (..), startManager, stopManager, watchDir)
import System.FilePath (normalise, splitSearchPath, takeDirectory, takeFileName, (</>))
import qualified System.IO as IO
import System.Log.Logger
import System.Posix.Files (getFileStatus, isSocket)
import System.Taffybar.Context
import System.Taffybar.Context.Backend (prepareBackendEnvironment)
import System.Taffybar.Hooks
import System.Taffybar.Util (maybeHandleSigHUP, onSigINT, rebracket_)

-- | 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} = do
  disableVendor <- envFlag "TAFFYBAR_DISABLE_VENDOR_CSS"
  disableUser <- envFlag "TAFFYBAR_DISABLE_USER_CSS"
  explicitUserCss <- lookupEnv "TAFFYBAR_CSS_PATHS"
  resolvedUserCss <-
    if disableUser
      then pure []
      else case explicitUserCss of
        Just rawPaths -> pure $ filter (not . null) (splitSearchPath rawPaths)
        Nothing -> sequence defaultUserCSS
  vendorCss <-
    if disableVendor
      then pure []
      else (: []) <$> defaultCSS
  pure (vendorCss <> resolvedUserCss)
  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.
    defaultUserCSS
      | null cssPaths = [getTaffyFile "taffybar.css"]
      | otherwise = map return cssPaths
    envFlag name = do
      value <- lookupEnv name
      pure $
        case fmap (map toLower) value of
          Just "1" -> True
          Just "true" -> True
          Just "yes" -> True
          Just "on" -> True
          _ -> False

-- | 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)
-- Use a higher priority than GTK's user stylesheet (800) so taffybar's CSS can
-- override theme/user rules for things like menu backgrounds.
startCSS = startCSS' 900

-- | 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"

  -- Fix up stale session-manager environment before GTK/GDK choose a display,
  -- then use GDK's actual opened display as the source of truth.
  waitForBackendEnvironment
  void initThreads

  _ <- Gtk.init Nothing
  GIThreading.setCurrentThreadAsGUIThread
  backendType <- detectBackend

  cssPathsToLoad <- getCSSPaths config
  context <- buildContextWithBackend backendType config

  withCSSReloadable cssPathsToLoad $
    Gtk.main
      `finally` logTaffy DEBUG "Finished main loop"
      `onSigINT` do
        logTaffy INFO "Interrupted"
        exitTaffybar context

  logTaffy DEBUG "Exited normally"

waitForBackendEnvironment :: IO ()
waitForBackendEnvironment = do
  prepareBackendEnvironment
  shouldWait <- shouldWaitForWaylandDisplay
  when shouldWait $ do
    logTaffy NOTICE "Waiting for Wayland display before starting GTK"
    go (120 :: Int)
  where
    retryDelayMicros = 500000

    go 0 = do
      prepareBackendEnvironment
      stillWaiting <- shouldWaitForWaylandDisplay
      when stillWaiting $
        logTaffy WARNING "Starting GTK even though no Wayland display socket is available"
    go n = do
      threadDelay retryDelayMicros
      prepareBackendEnvironment
      shouldWait <- shouldWaitForWaylandDisplay
      when shouldWait $ go (n - 1)

shouldWaitForWaylandDisplay :: IO Bool
shouldWaitForWaylandDisplay = do
  mRuntime <- lookupEnv "XDG_RUNTIME_DIR"
  mDisplay <- lookupEnv "DISPLAY"
  mSessionType <- lookupEnv "XDG_SESSION_TYPE"
  mWaylandDisplay <- lookupEnv "WAYLAND_DISPLAY"
  let explicitX11Session =
        mSessionType == Just "x11" && maybe False (not . null) mDisplay
      expectsWayland =
        not explicitX11Session
          && (mSessionType == Just "wayland" || isJust mWaylandDisplay)
  if not expectsWayland
    then pure False
    else do
      waylandOk <- maybe (pure False) isWaylandDisplaySocket $ do
        runtime <- mRuntime
        waylandDisplay <- mWaylandDisplay
        pure (runtime </> waylandDisplay)
      pure $ not waylandOk

isWaylandDisplaySocket :: FilePath -> IO Bool
isWaylandDisplaySocket path =
  catchAny
    (isSocket <$> getFileStatus path)
    (const $ pure False)

logTaffy :: Priority -> String -> IO ()
logTaffy = logM "System.Taffybar"