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           Control.Monad                       (filterM)

import           Data.Either
import           Data.List
import           Data.Maybe

import           DBus

import           System.Directory
import           System.Exit
import           System.FilePath.Posix
import           System.IO.Error
import           System.Process                      (readProcessWithExitCode)

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

import           XMonad                              (getXMonadDir)
import           XMonad.Hooks.DynamicLog             (wrap, xmobarColor)
import           XMonad.Internal.DBus.Common         (xmonadBus)
import           XMonad.Internal.DBus.Control        (pathExists)
import           XMonad.Internal.DBus.IntelBacklight (blPath)
import           XMonad.Internal.DBus.Screensaver    (ssPath)
import qualified XMonad.Internal.Theme               as T
import           Xmobar

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

lSep :: Char
lSep = '}'

rSep :: Char
rSep = '{'

pSep :: String
pSep = "%"

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

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

data DBusDepends = DBusDepends
  { ddBus  :: BusName
  , ddPath :: ObjectPath
  , ddSys  :: Bool
  } deriving Show

sysDepends :: BusName -> ObjectPath -> DBusDepends
sysDepends b p = DBusDepends b p True

sesDepends :: BusName -> ObjectPath -> DBusDepends
sesDepends b p = DBusDepends b p False

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

mapRegionsM :: Monad m => ([CmdSpec] -> m [CmdSpec]) -> BarRegions -> m BarRegions
mapRegionsM f (BarRegions l c r) = do
  l' <- f l
  c' <- f c
  r' <- f r
  return $ BarRegions l' c' r'

filterSpecs :: [CmdSpec] -> IO [CmdSpec]
filterSpecs = filterM (maybe (return True) exists . csDepends)
  where
    exists DBusDepends { ddBus = b, ddPath = p, ddSys = s } = pathExists s b p

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

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

getWireless :: IO (Maybe CmdSpec)
getWireless = do
  r <- tryIOError (listDirectory sysfsNet)
  ns <- filterM hasWireless $ fromRight [] r
  return $ case ns of
    [n] -> Just $ wirelessCmd n
    _   -> Nothing
  where
    hasWireless p = doesPathExist $ sysfsNet </> p </> "wireless"

vpnCmd :: CmdSpec
vpnCmd = CmdSpec
  { csAlias = vpnAlias
  , csDepends = Just $ sysDepends vpnBus vpnPath
  , csRunnable = Run
    $ VPN ("<fn=2>\xf023</fn>", T.fgColor, T.backdropFgColor) 5
  }

getVPN :: IO (Maybe CmdSpec)
getVPN = do
  -- TODO ensure nmcli exists (or guard against an exception if it doesn't)
  (ec, out, _) <- readProcessWithExitCode "nmcli" args ""
  return $ case ec of
    ExitSuccess -> if "vpn" `elem` lines out then Just vpnCmd else Nothing
    _           -> Nothing
  where
    args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]

myCommands :: IO BarRegions
myCommands = do
  wirelessSpec <- getWireless
  vpnSpec <- getVPN
  let left =
        [ CmdSpec
          { csAlias = "UnsafeStdinReader"
          , csDepends = Nothing
          , csRunnable = Run UnsafeStdinReader
          }
        ]
  let right =
        [ wirelessSpec

        , Just $ CmdSpec
          { csAlias = "enp7s0f1"
          , csDepends = Just $ sysDepends devBus devPath
          , csRunnable = Run
            $ Device ("enp7s0f1", "<fn=2>\xf0e8</fn>", T.fgColor, T.backdropFgColor) 5
          }

        , vpnSpec

        , Just $ CmdSpec
          { csAlias = btAlias
          , csDepends = Just $ sysDepends btBus btPath
          , csRunnable = Run
            $ Bluetooth ("<fn=2>\xf293</fn>", T.fgColor, T.backdropFgColor) 5
          }

        , Just $ CmdSpec
          { csAlias = "alsa:default:Master"
          , csDepends = Nothing
          , csRunnable = Run
            $ Alsa "default" "Master"
            [ "-t", "<status><volume>%"
            , "--"
            , "-O", "<fn=1>\xf028</fn>"
            , "-o", "<fn=1>\xf026 </fn>"
            , "-c", T.fgColor
            , "-C", T.fgColor
            ]
          }

        , Just $ CmdSpec
          { csAlias = "battery"
          , csDepends = Nothing
          , csRunnable = Run
            $ Battery
            [ "--template", "<acstatus><left>"
            , "--Low", "10"
            , "--High", "80"
            , "--low", "red"
            , "--normal", T.fgColor
            , "--high", T.fgColor
            , "--"
            , "-P"
            , "-o" , "<fn=1>\xf0e7</fn>"
            , "-O" , "<fn=1>\xf1e6</fn>"
            , "-i" , "<fn=1>\xf1e6</fn>"
            ] 50
          }

        , Just $ CmdSpec
          { csAlias = "intelbacklight"
          , csDepends = Just $ sesDepends xmonadBus blPath
          , csRunnable = Run $ IntelBacklight "<fn=1>\xf185</fn>"
          }

        , Just $ CmdSpec
          { csAlias = ssAlias
          , csDepends = Just $ sesDepends xmonadBus ssPath
          , csRunnable = Run
            $ Screensaver ("<fn=1>\xf254</fn>", T.fgColor, T.backdropFgColor)
          }

        , Just $ CmdSpec
          { csAlias = "locks"
          , csDepends = Nothing
          , csRunnable = Run
            $ Locks
            [ "-N", "<fn=3>\x1f13d</fn>"
            , "-n", xmobarColor T.backdropFgColor "" "<fn=3>\x1f13d</fn>"
            , "-C", "<fn=3>\x1f132</fn>"
            , "-c", xmobarColor T.backdropFgColor "" "<fn=3>\x1f132</fn>"
            , "-s", ""
            , "-S", ""
            , "-d", "<fn=3> </fn>"
            ]
          }

        , Just $ CmdSpec
          { csAlias = "date"
          , csDepends = Nothing
          , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
          }
        ]
  return $ BarRegions
    { brLeft = left
    , brCenter = []
    , brRight = catMaybes right
    }

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

barFont :: String
barFont = T.fmtFontXFT T.font
  { T.family = "DejaVu Sans Mono"
  , T.size = Just 11
  , T.weight = Just T.Bold
  }

iconFont :: String
iconFont = T.fmtFontXFT T.font
  { T.family = "FontAwesome"
  , T.size = Nothing
  , T.pixelsize = Just 13
  }

iconFontLarge :: String
iconFontLarge = T.fmtFontXFT T.font
  { T.family = "FontAwesome"
  , T.size = Nothing
  , T.pixelsize = Just 15
  }

blockFont :: String
blockFont = T.fmtFontXFT T.font
  { T.family = "Symbola"
  , T.size = Just 13
  , T.weight = Just T.Bold
  }

config :: BarRegions -> String -> Config
config br confDir = defaultConfig
  { font = barFont
  , additionalFonts = [ iconFont, iconFontLarge, blockFont ]
  , textOffset = 16
  , textOffsets = [ 16, 17, 17 ]
  , 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
  }

main :: IO ()
main = do
  br <- mapRegionsM filterSpecs =<< myCommands
  dir <- getXMonadDir
  xmobar $ config br dir