xmonad-config/bin/xmobar.hs

406 lines
10 KiB
Haskell

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 (unless)
import Data.Either
import Data.List
import Data.Maybe
import DBus
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 XMonad (getXMonadDir)
import XMonad.Hooks.DynamicLog
( wrap
, xmobarColor
)
import XMonad.Internal.Command.Power (hasBattery)
import XMonad.Internal.DBus.Brightness.IntelBacklight
( curFileDep
, maxFileDep
)
-- import XMonad.Internal.DBus.Common (xmonadBus)
-- import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.DBus.Screensaver (ssDep)
import XMonad.Internal.Dependency
-- import XMonad.Internal.Shell (fmtCmd)
import qualified XMonad.Internal.Theme as T
import Xmobar
main :: IO ()
main = do
rs <- sequence rightPlugins
warnMissing rs
cs <- getAllCommands rs
d <- getXMonadDir
-- this is needed to see any printed messages
hFlush stdout
xmobar $ config cs d
config :: BarRegions -> String -> Config
config br confDir = defaultConfig
{ font = barFont
, additionalFonts = [iconFont, iconFontLarge, iconFontXLarge]
, textOffset = 16
, textOffsets = [16, 17, 18]
, 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, "<fn=2>\xf0e8</fn>", T.fgColor, T.backdropFgColor) 5
}
batteryCmd :: CmdSpec
batteryCmd = CmdSpec
{ csAlias = "battery"
, csRunnable = Run
$ Battery
[ "--template", "<acstatus><left>"
, "--Low", "10"
, "--High", "80"
, "--low", "red"
, "--normal", T.fgColor
, "--high", T.fgColor
, "--"
, "-a", notify
, "-P"
, "-o" , "<fn=1>\xf0e7</fn>"
, "-O" , "<fn=1>\xf1e6</fn>"
, "-i" , "<fn=1>\xf1e6</fn>"
] 50
}
where
notify = fmtCmd "notify-send"
[ "-u"
, "critical"
, "-i"
, "'dialog-information-symbolic'"
, "'low battery'"
]
vpnCmd :: CmdSpec
vpnCmd = CmdSpec
{ csAlias = vpnAlias
, csRunnable = Run
$ VPN ("<fn=2>\xf023</fn>", T.fgColor, T.backdropFgColor) 5
}
btCmd :: CmdSpec
btCmd = CmdSpec
{ csAlias = btAlias
, csRunnable = Run
$ Bluetooth ("<fn=2>\xf293</fn>", T.fgColor, T.backdropFgColor) 5
}
alsaCmd :: CmdSpec
alsaCmd = CmdSpec
{ csAlias = "alsa:default:Master"
, csRunnable = Run
$ Alsa "default" "Master"
[ "-t", "<status><volume>%"
, "--"
, "-O", "<fn=1>\xf028</fn>"
, "-o", "<fn=1>\xf026 </fn>"
, "-c", T.fgColor
, "-C", T.fgColor
]
}
blCmd :: CmdSpec
blCmd = CmdSpec
{ csAlias = "intelbacklight"
, csRunnable = Run $ IntelBacklight "<fn=1>\xf185</fn>"
}
ckCmd :: CmdSpec
ckCmd = CmdSpec
{ csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard ("<fn=1>\xf40b</fn>", T.fgColor, T.backdropFgColor) 5
}
ssCmd :: CmdSpec
ssCmd = CmdSpec
{ csAlias = ssAlias
, csRunnable = Run
$ Screensaver ("<fn=1>\xf254</fn>", T.fgColor, T.backdropFgColor)
}
lockCmd :: CmdSpec
lockCmd = CmdSpec
{ csAlias = "locks"
, csRunnable = Run
$ Locks
[ "-N", "<fn=3>\xf8a5</fn>"
, "-n", xmobarColor T.backdropFgColor "" "<fn=3>\xf8a5</fn>"
, "-C", "<fn=3>\xf657</fn>"
, "-c", xmobarColor T.backdropFgColor "" "<fn=3>\xf657</fn>"
, "-s", ""
, "-S", ""
, "-d", " "
]
}
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
-- noSetup :: Monad m => a -> m (Maybe a)
-- noSetup = return . Just
-- toJust :: a -> Bool -> Maybe a
-- toJust x b = if b then Just x else Nothing
dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
dbusDep usesys bus obj iface mem =
Dependency { depRequired = True, depData = d }
where
d = DBusEndpoint
{ ddDbusBus = bus
, ddDbusSystem = usesys
, ddDbusObject = obj
, ddDbusInterface = iface
, ddDbusMember = mem
}
-- 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"
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 -> Bool) -> IO (Maybe String)
readInterface f = do
ns <- filter f <$> listInterfaces
case ns of
(x:xs) -> do
unless (null xs) $
putStrLn $ "WARNING: extra interfaces found, using " ++ x
return $ Just x
_ -> return Nothing
vpnPresent :: IO (Maybe Bool)
vpnPresent = do
res <- tryIOError $ readProcessWithExitCode "nmcli" args ""
-- TODO provide some error messages
return $ case res of
(Right (ExitSuccess, out, _)) -> Just $ "vpn" `elem` lines out
_ -> Nothing
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
rightPlugins :: [IO (MaybeExe CmdSpec)]
rightPlugins =
[ getWireless
, getEthernet
, getVPN
, getBt
, getAlsa
, getBattery
, getBl
, nocheck ckCmd
, getSs
, nocheck lockCmd
, nocheck dateCmd
]
where
nocheck = return . flip Installed []
getWireless :: IO (MaybeExe CmdSpec)
getWireless = do
i <- readInterface isWireless
return $ maybe Ignore (flip Installed [] . wirelessCmd) i
getEthernet :: IO (MaybeExe CmdSpec)
getEthernet = do
i <- readInterface isEthernet
maybe (return Ignore) (runIfInstalled [dep] . ethernetCmd) i
where
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
getBattery :: IO (MaybeExe CmdSpec)
getBattery = go <$> hasBattery
where
-- TODO refactor this pattern
go True = Installed batteryCmd []
go False = Ignore
getVPN :: IO (MaybeExe CmdSpec)
getVPN = do
v <- vpnPresent
case v of
(Just True) -> runIfInstalled [dep] vpnCmd
_ -> return Ignore
where
dep = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
getBt :: IO (MaybeExe CmdSpec)
getBt = runIfInstalled [dep] btCmd
where
dep = dbusDep True btBus btPath btInterface $ Property_ btPowered
getAlsa :: IO (MaybeExe CmdSpec)
getAlsa = runIfInstalled [exe "alsactl"] alsaCmd
getBl :: IO (MaybeExe CmdSpec)
getBl = runIfInstalled [curFileDep, maxFileDep] blCmd
getSs :: IO (MaybeExe CmdSpec)
getSs = runIfInstalled [ssDep] ssCmd
getAllCommands :: [MaybeExe CmdSpec] -> IO BarRegions
getAllCommands right = do
let left =
[ CmdSpec
{ csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader
}
]
return $ BarRegions
{ brLeft = left
, brCenter = []
, brRight = mapMaybe eval right
}
where
eval (Installed x _) = Just x
eval _ = Nothing
--------------------------------------------------------------------------------
-- | various formatting things
sep :: String
sep = xmobarColor 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
barFont :: String
barFont = T.fmtFontXFT T.font
{ T.family = "DejaVu Sans Mono"
, T.size = Just 11
, T.weight = Just T.Bold
}
nerdFont :: Int -> String
nerdFont size = T.fmtFontXFT T.font
{ T.family = "Symbols Nerd Font"
, T.size = Nothing
, T.pixelsize = Just size
}
iconFont :: String
iconFont = nerdFont 13
iconFontLarge :: String
iconFontLarge = nerdFont 15
iconFontXLarge :: String
iconFontXLarge = nerdFont 20