xmonad-config/bin/xmobar.hs

{-# LANGUAGE OverloadedStrings #-}

-- | 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
module Main (main) where

import Data.Internal.DBus
import Data.Internal.Dependency
import RIO hiding (hFlush)
import qualified RIO.ByteString.Lazy as BL
import RIO.List
import RIO.Process
import qualified RIO.Text as T
import System.IO
import UnliftIO.Environment
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 qualified XMonad.Internal.Theme as XT
import Xmobar hiding
  ( iconOffset
  , run
  )
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Common
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN

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
          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 :: FIO (Maybe Msg)
vpnPresent = do
  res <- proc "nmcli" args readProcess
  return $ case res of
    (ExitSuccess, out, _)
      | "vpn" `elem` BL.split 10 out -> Nothing
      | otherwise -> Just $ Msg LevelError "vpn not found"
    (ExitFailure c, _, err) ->
      Just $
        Msg LevelError $
          T.concat
            [ "vpn search exited with code "
            , T.pack $ show c
            , ": "
            , T.decodeUtf8With T.lenientDecode $
                BL.toStrict err
            ]
  where
    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]

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