xmonad-config/bin/xmobar.hs

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           Data.Either
import           Data.List
import           Data.Maybe

import           DBus.Client
import           DBus.Internal

import           System.Directory
import           System.Exit
import           System.IO
import           System.IO.Error
-- import           System.Process
--     ( readProcessWithExitCode
--     )

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           System.Posix.Signals
import           XMonad.Core
    ( cfgDir
    , getDirectories
    )
import           XMonad.Hooks.DynamicLog                        (wrap)
import           XMonad.Internal.Command.Power                  (hasBattery)
import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
import           XMonad.Internal.DBus.Brightness.IntelBacklight
import           XMonad.Internal.DBus.Screensaver               (ssSignalDep)
import           XMonad.Internal.Dependency
import           XMonad.Internal.Process
    ( proc'
    , readCreateProcessWithExitCode'
    )
import           XMonad.Internal.Shell
import qualified XMonad.Internal.Theme                          as T
import           Xmobar
import           Xmobar.Plugins.Common

main :: IO ()
main = do
  sysClient <- getDBusClient True
  sesClient <- getDBusClient False
  ff <- evalFonts
  cs <- getAllCommands =<< rightPlugins sysClient sesClient
  d <- cfgDir <$> getDirectories
  -- this is needed to prevent waitForProcess error when forking in plugins (eg
  -- alsacmd)
  _ <- installHandler sigCHLD Default Nothing
  -- this is needed to see any printed messages
  hFlush stdout
  mapM_ (maybe skip disconnect) [sysClient, sesClient]
  xmobar $ config ff cs d

config :: (BarFont -> BarMetaFont) -> BarRegions -> String -> Config
config ff br confDir = defaultConfig
  { font = fontString ff firstFont
  , additionalFonts = fontString ff <$> restFonts
  , textOffset = fontOffset ff firstFont
  , textOffsets = fontOffset ff <$> restFonts
  , bgColor = T.bgColor
  , fgColor = T.fgColor
  , position = BottomSize C 100 24
  , border = NoBorder
  , borderColor = T.bordersColor

  , sepChar = pSep
  , alignSep = [lSep, rSep]
  , template = 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
  }

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

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

data CmdSpec = CmdSpec
  { csAlias    :: String
  , csRunnable :: Runnable
  } deriving Show

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

wirelessCmd :: String -> CmdSpec
wirelessCmd iface = CmdSpec
  { csAlias = iface ++ "wi"
  , csRunnable = Run
    $ Wireless iface
    [ "-t", "<qualityipat><essid>"
    , "--"
    , "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
    ] 5
  }

ethernetCmd :: String -> CmdSpec
ethernetCmd iface = CmdSpec
  { csAlias = iface
  , csRunnable = Run
    $ Device (iface, fontifyText IconMedium "\xf0e8", colors)
  }

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

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

btCmd :: CmdSpec
btCmd = CmdSpec
  { csAlias = btAlias
  , csRunnable = Run
    $ Bluetooth (fontify "\xf5b0", fontify "\xf5ae") colors
  }
  where
    fontify = fontifyText IconLarge

alsaCmd :: CmdSpec
alsaCmd = CmdSpec
  { csAlias = "alsa:default:Master"
  , csRunnable = Run
    $ Alsa "default" "Master"
    [ "-t", "<status><volume>%"
    , "--"
    , "-O", fontifyText IconSmall "\xf028"
    , "-o", fontifyText IconSmall "\xf026 "
    , "-c", T.fgColor
    , "-C", T.fgColor
    ]
  }

blCmd :: CmdSpec
blCmd = CmdSpec
  { csAlias = blAlias
  , csRunnable = Run $ IntelBacklight $ fontifyText IconSmall "\xf185"
  }

ckCmd :: CmdSpec
ckCmd = CmdSpec
  { csAlias = ckAlias
  , csRunnable = Run $ ClevoKeyboard $ fontifyText IconSmall "\xf40b"
  }

ssCmd :: CmdSpec
ssCmd = CmdSpec
  { csAlias = ssAlias
  , csRunnable = Run
    $ Screensaver (fontifyText IconSmall "\xf254", colors)
  }

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

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

--------------------------------------------------------------------------------
-- | command runtime checks and setup
--
-- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here
--
-- in the case of network interfaces, assume that the system uses systemd in
-- which case ethernet interfaces always start with "en" and wireless
-- interfaces always start with "wl"

type BarFeature = Sometimes CmdSpec

isWireless :: String -> Bool
isWireless ('w':'l':_) = True
isWireless _           = False

isEthernet :: String -> Bool
isEthernet ('e':'n':_) = True
isEthernet _           = False

listInterfaces :: IO [String]
listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)

sysfsNet :: FilePath
sysfsNet = "/sys/class/net"

readInterface :: String -> (String -> Bool) -> IODependency String
readInterface n f = IORead n go
  where
    go = do
      ns <- filter f <$> listInterfaces
      case ns of
        [] -> return $ Left ["no interfaces found"]
        (x:xs) -> do
          return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs

vpnPresent :: IO (Maybe String)
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 "vpn not found"
    go (Right (ExitFailure c, _, err)) = Just $ "vpn search exited with code "
                                         ++ show c ++ ": " ++ err
    go (Left e)                        = Just $ show e

xmobarDBus :: String -> DBusDependency_ -> CmdSpec -> Maybe Client -> BarFeature
xmobarDBus n dep cmd cl = sometimesDBus cl n "xmobar dbus interface"
  (Only_ dep) $ const cmd

rightPlugins :: Maybe Client -> Maybe Client -> IO [Maybe CmdSpec]
rightPlugins sysClient sesClient = mapM evalFeature
  [ Left getWireless
  , Left $ getEthernet sysClient
  , Left $ getVPN sysClient
  , Left $ getBt sysClient
  , Left getAlsa
  , Left getBattery
  , Left $ getBl sesClient
  , Left $ getCk sesClient
  , Left $ getSs sesClient
  , always' "lock indicator" lockCmd
  , always' "date indicator" dateCmd
  ]
  where
    always' n = Right . Always n . Always_ . FallbackAlone

getWireless :: BarFeature
getWireless = sometimes1 "wireless status indicator" "sysfs path"
  $ IORoot wirelessCmd
  $ Only $ readInterface "get wifi interface" isWireless

getEthernet :: Maybe Client -> BarFeature
getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
  $ DBusRoot (const . ethernetCmd) tree client
  where
    tree = And1 (Only readEth) (Only_ devDep)
    readEth = readInterface "read ethernet interface" isEthernet

getBattery :: BarFeature
getBattery = sometimesIO_ "battery level indicator" "sysfs path"
  (Only_ $ sysTest "Test if battery is present" hasBattery)
  batteryCmd

getVPN :: Maybe Client -> BarFeature
getVPN client = sometimesDBus client "VPN status indicator"
  "xmobar dbus interface" (toAnd vpnDep test) (const vpnCmd)
  where
    test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent

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

getAlsa :: BarFeature
getAlsa = sometimesIO_ "volume level indicator" "alsactl"
  (Only_ $ sysExe "alsactl") alsaCmd

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

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

getSs :: Maybe Client -> BarFeature
getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd

getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
getAllCommands right = do
  let left =
        [ CmdSpec
          { csAlias = "UnsafeStdinReader"
          , csRunnable = Run UnsafeStdinReader
          }
        ]
  return $ BarRegions
    { brLeft = left
    , brCenter = []
    , brRight = catMaybes right
    }

--------------------------------------------------------------------------------
-- | fonts

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

data BarMetaFont = BarMetaFont
  { bfOffset   :: Int
  , bfBuilder  :: T.FontBuilder
  , bfFontData :: T.FontData
  }

fontString :: (BarFont -> BarMetaFont) -> BarFont -> String
fontString f bf = b d
  where
    b = bfBuilder $ f bf
    d = bfFontData $ f bf

fontOffset :: (BarFont -> BarMetaFont) -> BarFont -> Int
fontOffset f = bfOffset . f

firstFont :: BarFont
firstFont = minBound

restFonts :: [BarFont]
restFonts = enumFrom $ succ minBound

barFont :: Always T.FontBuilder
barFont = T.fontFeature "XMobar Text Font" "DejaVu Sans Mono"

nerdFont :: Always T.FontBuilder
nerdFont = T.fontFeature "XMobar Icon Font" "Symbols Nerd Font"

evalFonts :: IO (BarFont -> BarMetaFont)
evalFonts = do
  bf <- evalAlways barFont
  nf <- evalAlways nerdFont
  return $ fontData bf nf

fontData :: T.FontBuilder -> T.FontBuilder -> BarFont -> BarMetaFont
fontData barBuilder nerdBuilder bf = case bf of
  Text       -> BarMetaFont 16 barBuilder
                $ T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
  IconSmall  -> nerd 16 13
  IconMedium -> nerd 17 15
  IconLarge  -> nerd 17 18
  IconXLarge -> nerd 18 20
  where
    nerd o s = BarMetaFont o nerdBuilder
      $ T.defFontData { T.pixelsize = Just s, T.size = Nothing }

fontifyText :: BarFont -> String -> String
fontifyText fnt txt = concat ["<fn=", show $ fromEnum fnt, ">", txt, "</fn>"]

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

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

sep :: String
sep = xmobarFGColor T.backdropFgColor " : "

lSep :: Char
lSep = '}'

rSep :: Char
rSep = '{'

pSep :: String
pSep = "%"

fmtSpecs :: [CmdSpec] -> String
fmtSpecs = intercalate sep . fmap go
  where
    go CmdSpec { csAlias = a } = wrap pSep pSep a

fmtRegions :: BarRegions -> String
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } =
  fmtSpecs l ++ [lSep] ++ fmtSpecs c ++ [rSep] ++ fmtSpecs r