xmonad-config/bin/xmobar.hs

{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

--------------------------------------------------------------------------------
-- | Xmobar binary
--
-- Features:
-- * Uses the 'UnsafeStdinReader' to receive the current workspace/layout config
--   from xmonad
-- * FontAwesome and Symbol fonts for icons
-- * Some custom plugins (imported below)
-- * Theme integration with xmonad (shared module imported below)
-- * A custom Locks plugin from my own forked repo

import           Control.Monad

import           Data.Internal.DBus
import           Data.Internal.Dependency
import           Data.List
import           Data.Maybe

import           RIO                                            hiding (hFlush)
import qualified RIO.Text                                       as T

import           System.Environment
import           System.IO
import           System.IO.Error

import           Xmobar.Plugins.Bluetooth
import           Xmobar.Plugins.ClevoKeyboard
import           Xmobar.Plugins.Device
import           Xmobar.Plugins.IntelBacklight
import           Xmobar.Plugins.Screensaver
import           Xmobar.Plugins.VPN

import           XMonad.Core                                    hiding (config)
import           XMonad.Internal.Command.Desktop
import           XMonad.Internal.Command.Power
import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
import           XMonad.Internal.DBus.Brightness.IntelBacklight
import           XMonad.Internal.DBus.Control
import           XMonad.Internal.DBus.Screensaver               (ssSignalDep)
import           XMonad.Internal.Process                        hiding (CmdSpec)
import qualified XMonad.Internal.Theme                          as XT
import           Xmobar                                         hiding
    ( iconOffset
    , run
    )
import           Xmobar.Plugins.Common


main :: IO ()
main = getArgs >>= parse

parse :: [String] -> IO ()
parse []         = run
parse ["--deps"] = withCache printDeps
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
parse _          = usage

run :: IO ()
run = do
  db <- connectDBus
  c <- withCache $ evalConfig db
  disconnectDBus db
  -- this is needed to see any printed messages
  hFlush stdout
  xmobar c

evalConfig :: DBusState -> FIO Config
evalConfig db = do
  cs <- getAllCommands <$> rightPlugins db
  bf <- getTextFont
  (ifs, ios) <- getIconFonts
  d <- io $ cfgDir <$> getDirectories
  return $ config bf ifs ios cs d

printDeps :: FIO ()
printDeps = do
  db <- io connectDBus
  let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
  io $ mapM_ (putStrLn . T.unpack) ps
  io $ disconnectDBus db

usage :: IO ()
usage = putStrLn $ intercalate "\n"
  [ "xmobar: run greatest taskbar"
  , "xmobar --deps: print dependencies"
  ]

--------------------------------------------------------------------------------
-- | toplevel configuration

-- | The text font family
textFont :: Always XT.FontBuilder
textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono" defFontPkgs

-- | Offset of the text in the bar
textFontOffset :: Int
textFontOffset = 16

-- | Attributes for the bar font (size, weight, etc)
textFontData :: XT.FontData
textFontData = XT.defFontData { XT.weight = Just XT.Bold, XT.size = Just 11 }

-- | The icon font family
iconFont :: Sometimes XT.FontBuilder
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
  [Package Official "ttf-nerd-fonts-symbols-2048-em"]

-- | Offsets for the icons in the bar (relative to the text offset)
iconOffset :: BarFont -> Int
iconOffset IconSmall  = 0
iconOffset IconMedium = 1
iconOffset IconLarge  = 1
iconOffset IconXLarge = 2

-- | Sizes (in pixels) for the icon fonts
iconSize :: BarFont -> Int
iconSize IconSmall  = 13
iconSize IconMedium = 15
iconSize IconLarge  = 18
iconSize IconXLarge = 20

-- | Attributes for icon fonts
iconFontData :: Int -> XT.FontData
iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing }

-- | Global configuration
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
-- only one) text font, and all other fonts are icon fonts. If this assumption
-- changes the code will need to change significantly
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
config bf ifs ios br confDir = defaultConfig
  { font = T.unpack bf
  , additionalFonts = fmap T.unpack ifs
  , textOffset = textFontOffset
  , textOffsets = ios
  , bgColor = T.unpack XT.bgColor
  , fgColor = T.unpack XT.fgColor
  , position = BottomSize C 100 24
  , border = NoBorder
  , borderColor = T.unpack XT.bordersColor

  , sepChar = T.unpack pSep
  , alignSep = [lSep, rSep]
  , template = T.unpack $ fmtRegions br

  , lowerOnStart = False
  , hideOnStart = False
  , allDesktops = True
  , overrideRedirect = True
  , pickBroadest = False
  , persistent = True
  -- store the icons with the xmonad/xmobar stack project
  , iconRoot = confDir ++ "/icons"

  , commands = csRunnable <$> concatRegions br
  }

--------------------------------------------------------------------------------
-- | plugin features
--
-- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here

getAllCommands :: [Maybe CmdSpec] -> BarRegions
getAllCommands right = BarRegions
  { brLeft = [ CmdSpec
               { csAlias = "UnsafeStdinReader"
               , csRunnable = Run UnsafeStdinReader
               }
             ]
  , brCenter = []
  , brRight = catMaybes right
  }

rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins db = mapM evalFeature $ allFeatures db
  ++ [always' "date indicator" dateCmd]
  where
    always' n = Right . Always n . Always_ . FallbackAlone

allFeatures :: DBusState -> [Feature CmdSpec]
allFeatures DBusState { dbSesClient = ses, dbSysClient = sys } =
  [ Left getWireless
  , Left $ getEthernet sys
  , Left $ getVPN sys
  , Left $ getBt sys
  , Left getAlsa
  , Left getBattery
  , Left $ getBl ses
  , Left $ getCk ses
  , Left $ getSs ses
  , Right getLock
  ]

type BarFeature = Sometimes CmdSpec

-- TODO what if I don't have a wireless card?
getWireless :: BarFeature
getWireless = Sometimes "wireless status indicator" xpfWireless
  [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]

getEthernet :: Maybe SysClient -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
  where
    root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
    tree = And1 (Only readEthernet) (Only_ devDep)

getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
  where
    root useIcon = IORoot_ (batteryCmd useIcon)
    tree = Only_ $ IOTest_ "Test if battery is present" []
      $ io $ fmap (Msg LevelError) <$> hasBattery

getVPN :: Maybe SysClient -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
  where
    root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
    test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
      networkManagerPkgs $ io vpnPresent

getBt :: Maybe SysClient -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd

getAlsa :: BarFeature
getAlsa = iconIO_ "volume level indicator" (const True) root
  $ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl"
  where
    root useIcon = IORoot_ (alsaCmd useIcon)

getBl :: Maybe SesClient -> BarFeature
getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
  intelBacklightSignalDep blCmd

getCk :: Maybe SesClient -> BarFeature
getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
  clevoKeyboardSignalDep ckCmd

getSs :: Maybe SesClient -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd

getLock :: Always CmdSpec
getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
  where
    root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency

--------------------------------------------------------------------------------
-- | bar feature constructors

xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c
  -> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
  where
    root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl

iconIO_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
  -> IOTree_ -> BarFeature
iconIO_ = iconSometimes' And_ Only_

iconDBus :: SafeClient c => T.Text -> XPQuery
  -> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
iconDBus = iconSometimes' And1 $ Only_ . DBusIO

iconDBus_ :: SafeClient c => T.Text -> XPQuery
  -> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO

iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> T.Text -> XPQuery
  -> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
iconSometimes' c d n q r t = Sometimes n q
  [ Subfeature icon "icon indicator"
  , Subfeature text "text indicator"
  ]
  where
    icon = r fontifyIcon $ c t $ d iconDependency
    text = r fontifyAlt t

--------------------------------------------------------------------------------
-- | command specifications

data BarRegions = BarRegions
  { brLeft   :: [CmdSpec]
  , brCenter :: [CmdSpec]
  , brRight  :: [CmdSpec]
  } deriving Show

data CmdSpec = CmdSpec
  { csAlias    :: T.Text
  , csRunnable :: Runnable
  } deriving Show

concatRegions :: BarRegions -> [CmdSpec]
concatRegions (BarRegions l c r) = l ++ c ++ r

wirelessCmd :: T.Text -> CmdSpec
wirelessCmd iface = CmdSpec
  { csAlias = T.append iface "wi"
  , csRunnable = Run $ Wireless (T.unpack iface) args 5
  }
  where
    args = fmap T.unpack
      [ "-t", "<qualityipat><essid>"
      , "--"
      , "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
      ]

ethernetCmd :: Fontifier -> T.Text -> CmdSpec
ethernetCmd fontify iface = CmdSpec
  { csAlias = iface
  , csRunnable = Run
    $ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
  }

batteryCmd :: Fontifier -> CmdSpec
batteryCmd fontify = CmdSpec
  { csAlias = "battery"
  , csRunnable = Run $ Battery args 50
  }
  where
    fontify' = fontify IconSmall
    args = fmap T.unpack
      [ "--template", "<acstatus><left>"
      , "--Low", "10"
      , "--High", "80"
      , "--low", "red"
      , "--normal", XT.fgColor
      , "--high", XT.fgColor
      , "--"
      , "-P"
      , "-o" , fontify' "\xf0e7" "BAT"
      , "-O" , fontify' "\xf1e6" "AC"
      , "-i" , fontify' "\xf1e6" "AC"
      ]

vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify = CmdSpec
  { csAlias = vpnAlias
  , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
  }

btCmd :: Fontifier -> CmdSpec
btCmd fontify = CmdSpec
  { csAlias = btAlias
  , csRunnable = Run
    $ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
  }
  where
    fontify' i = fontify IconLarge i . T.append "BT"

alsaCmd :: Fontifier -> CmdSpec
alsaCmd fontify = CmdSpec
  { csAlias = "alsa:default:Master"
  , csRunnable = Run
    $ Alsa "default" "Master"
    $ fmap T.unpack
    [ "-t", "<status><volume>%"
    , "--"
    , "-O", fontify' "\xf028" "+"
    , "-o", T.append (fontify' "\xf026" "-") " "
    , "-c", XT.fgColor
    , "-C", XT.fgColor
    ]
  }
  where
    fontify' i = fontify IconSmall i . T.append "VOL"

blCmd :: Fontifier -> CmdSpec
blCmd fontify = CmdSpec
  { csAlias = blAlias
  , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
  }

ckCmd :: Fontifier -> CmdSpec
ckCmd fontify = CmdSpec
  { csAlias = ckAlias
  , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
  }

ssCmd :: Fontifier -> CmdSpec
ssCmd fontify = CmdSpec
  { csAlias = ssAlias
  , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
  }

lockCmd :: Fontifier -> CmdSpec
lockCmd fontify = CmdSpec
  { csAlias = "locks"
  , csRunnable = Run
    $ Locks
    $ fmap T.unpack
    [ "-N", numIcon
    , "-n", disabledColor numIcon
    , "-C", capIcon
    , "-c", disabledColor capIcon
    , "-s", ""
    , "-S", ""
    , "-d", " "
    ]
  }
  where
    numIcon = fontify' "\xf8a5" "N"
    capIcon = fontify' "\xf657" "C"
    fontify' = fontify IconXLarge
    disabledColor = xmobarFGColor XT.backdropFgColor

dateCmd :: CmdSpec
dateCmd = CmdSpec
  { csAlias = "date"
  , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
  }

--------------------------------------------------------------------------------
-- | low-level testing functions

vpnPresent :: IO (Maybe Msg)
vpnPresent =
  go <$> tryIOError (readCreateProcessWithExitCode (proc "nmcli" args) "")
  where
    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
    go (Right (ExitSuccess, out, _))   = if "vpn" `elem` lines out then Nothing
                                         else Just $ Msg LevelError "vpn not found"
    go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError
                                         $ T.concat ["vpn search exited with code "
                                                    , T.pack $ show c
                                                    , ": "
                                                    , T.pack err]
    go (Left e)                        = Just $ Msg LevelError $ T.pack $ show e

--------------------------------------------------------------------------------
-- | text font
--
-- ASSUME there is only one text font for this entire configuration. This
-- will correspond to the first font/offset parameters in the config record.

getTextFont :: FIO T.Text
getTextFont = do
  fb <- evalAlways textFont
  return $ fb textFontData

--------------------------------------------------------------------------------
-- | icon fonts

getIconFonts :: FIO ([T.Text], [Int])
getIconFonts = do
  fb <- evalSometimes iconFont
  return $ maybe ([], []) apply fb
  where
    apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
      <$> iconFonts

data BarFont = IconSmall
  | IconMedium
  | IconLarge
  | IconXLarge
  deriving (Eq, Enum, Bounded, Show)

iconFonts :: [BarFont]
iconFonts = enumFrom minBound

iconString :: XT.FontBuilder -> BarFont -> T.Text
iconString fb i = fb $ iconFontData $ iconSize i

iconDependency :: IODependency_
iconDependency = IOSometimes_ iconFont

fontifyText :: BarFont -> T.Text -> T.Text
fontifyText fnt txt =
  T.concat ["<fn=", T.pack $ show $ 1 + fromEnum fnt, ">", txt, "</fn>"]

type Fontifier = BarFont -> T.Text -> T.Text -> T.Text

fontifyAlt :: Fontifier
fontifyAlt _ _ alt = alt

fontifyIcon :: Fontifier
fontifyIcon f i _ = fontifyText f i

--------------------------------------------------------------------------------
-- | various formatting things

colors :: Colors
colors = Colors { colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor }

sep :: T.Text
sep = xmobarFGColor XT.backdropFgColor " : "

lSep :: Char
lSep = '}'

rSep :: Char
rSep = '{'

pSep :: T.Text
pSep = "%"

fmtSpecs :: [CmdSpec] -> T.Text
fmtSpecs = T.intercalate sep . fmap go
  where
    go CmdSpec { csAlias = a } = T.concat [pSep, a, pSep]

fmtRegions :: BarRegions -> T.Text
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat $
  [fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]