xmonad-config/bin/xmobar.hs

434 lines
12 KiB
Haskell
Raw Normal View History

2020-04-01 20:17:47 -04:00
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
2020-04-01 20:17:47 -04:00
import Data.List
import Data.Maybe
2020-04-01 20:17:47 -04:00
import DBus.Client
import DBus.Internal
import System.Directory
import System.Exit
2021-06-23 23:08:50 -04:00
import System.IO
import System.IO.Error
2022-07-02 18:22:26 -04:00
-- import System.Process
-- ( readProcessWithExitCode
-- )
2020-03-25 18:55:52 -04:00
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
2020-05-28 23:17:17 -04:00
import Xmobar.Plugins.Device
2020-03-25 18:55:52 -04:00
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
2020-03-15 15:10:25 -04:00
2022-07-02 18:22:26 -04:00
import System.Posix.Signals
2022-03-05 18:18:16 -05:00
import XMonad.Core
( cfgDir
, getDirectories
)
2021-11-27 17:33:02 -05:00
import XMonad.Hooks.DynamicLog (wrap)
import XMonad.Internal.Command.Power (hasBattery)
2021-11-21 17:54:00 -05:00
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
2021-11-08 00:27:39 -05:00
import XMonad.Internal.Dependency
2022-07-02 18:22:26 -04:00
import XMonad.Internal.Process
( proc'
, readCreateProcessWithExitCode'
)
2021-11-23 18:28:38 -05:00
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T
2021-06-19 00:54:01 -04:00
import Xmobar
2021-11-27 17:33:02 -05:00
import Xmobar.Plugins.Common
2020-03-15 13:12:01 -04:00
2021-06-23 23:08:50 -04:00
main :: IO ()
main = do
sysClient <- getDBusClient True
sesClient <- getDBusClient False
2022-07-02 17:09:21 -04:00
ff <- evalFonts
cs <- getAllCommands =<< rightPlugins sysClient sesClient
2022-03-05 18:18:16 -05:00
d <- cfgDir <$> getDirectories
2022-07-02 18:22:26 -04:00
-- 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]
2022-07-02 17:09:21 -04:00
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
2021-06-23 23:08:50 -04:00
, bgColor = T.bgColor
, fgColor = T.fgColor
, position = BottomSize C 100 24
, border = NoBorder
, borderColor = T.bordersColor
2021-06-23 23:08:50 -04:00
, sepChar = pSep
, alignSep = [lSep, rSep]
, template = fmtRegions br
2021-06-23 23:08:50 -04:00
, 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
2021-11-27 17:33:02 -05:00
$ 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"
2021-11-27 17:33:02 -05:00
, "-o" , fontify "\xf0e7"
, "-O" , fontify "\xf1e6"
, "-i" , fontify "\xf1e6"
] 50
}
2021-06-30 23:04:00 -04:00
where
2021-11-27 17:33:02 -05:00
fontify = fontifyText IconSmall
vpnCmd :: CmdSpec
vpnCmd = CmdSpec
{ csAlias = vpnAlias
2021-11-27 17:33:02 -05:00
, csRunnable = Run $ VPN (fontifyText IconMedium "\xf023", colors)
}
2021-06-23 23:08:50 -04:00
btCmd :: CmdSpec
btCmd = CmdSpec
{ csAlias = btAlias
, csRunnable = Run
2021-11-27 17:33:02 -05:00
$ Bluetooth (fontify "\xf5b0", fontify "\xf5ae") colors
2021-06-23 23:08:50 -04:00
}
2021-11-27 17:33:02 -05:00
where
fontify = fontifyText IconLarge
2021-06-23 23:08:50 -04:00
alsaCmd :: CmdSpec
alsaCmd = CmdSpec
{ csAlias = "alsa:default:Master"
, csRunnable = Run
$ Alsa "default" "Master"
[ "-t", "<status><volume>%"
, "--"
2021-11-27 17:33:02 -05:00
, "-O", fontifyText IconSmall "\xf028"
, "-o", fontifyText IconSmall "\xf026 "
2021-06-23 23:08:50 -04:00
, "-c", T.fgColor
, "-C", T.fgColor
]
}
2021-06-23 23:08:50 -04:00
blCmd :: CmdSpec
blCmd = CmdSpec
2021-11-21 00:42:40 -05:00
{ csAlias = blAlias
2021-11-27 17:33:02 -05:00
, csRunnable = Run $ IntelBacklight $ fontifyText IconSmall "\xf185"
2021-06-23 23:08:50 -04:00
}
ckCmd :: CmdSpec
ckCmd = CmdSpec
{ csAlias = ckAlias
2021-11-27 17:33:02 -05:00
, csRunnable = Run $ ClevoKeyboard $ fontifyText IconSmall "\xf40b"
}
2021-06-23 23:08:50 -04:00
ssCmd :: CmdSpec
ssCmd = CmdSpec
{ csAlias = ssAlias
, csRunnable = Run
2021-11-27 17:33:02 -05:00
$ Screensaver (fontifyText IconSmall "\xf254", colors)
2021-06-23 23:08:50 -04:00
}
2021-06-23 23:08:50 -04:00
lockCmd :: CmdSpec
lockCmd = CmdSpec
{ csAlias = "locks"
, csRunnable = Run
$ Locks
2021-11-27 17:33:02 -05:00
[ "-N", numIcon
, "-n", disabledColor numIcon
, "-C", capIcon
, "-c", disabledColor capIcon
2021-06-23 23:08:50 -04:00
, "-s", ""
, "-S", ""
2021-06-30 22:47:49 -04:00
, "-d", " "
2021-06-23 23:08:50 -04:00
]
}
2021-11-27 17:33:02 -05:00
where
numIcon = fontify "\xf8a5"
capIcon = fontify "\xf657"
fontify = fontifyText IconXLarge
disabledColor = xmobarFGColor T.backdropFgColor
2021-06-23 23:08:50 -04:00
dateCmd :: CmdSpec
dateCmd = CmdSpec
{ csAlias = "date"
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
}
2021-06-23 23:08:50 -04:00
--------------------------------------------------------------------------------
-- | command runtime checks and setup
2021-11-23 18:28:38 -05:00
--
2021-06-23 23:08:50 -04:00
-- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here
2021-11-23 18:28:38 -05:00
--
2021-06-23 23:08:50 -04:00
-- 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"
2021-11-23 18:28:38 -05:00
type BarFeature = Sometimes CmdSpec
2021-11-27 17:33:02 -05:00
2021-06-23 23:08:50 -04:00
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)
2021-06-23 23:08:50 -04:00
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
2021-11-19 00:35:54 -05:00
vpnPresent :: IO (Maybe String)
2022-07-02 18:22:26 -04:00
vpnPresent =
go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
2022-07-02 17:09:21 -04:00
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
2022-06-28 23:27:55 -04:00
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
2022-06-28 23:27:55 -04:00
, always' "lock indicator" lockCmd
, always' "date indicator" dateCmd
]
2022-06-28 23:27:55 -04:00
where
always' n = Right . Always n . Always_ . FallbackAlone
getWireless :: BarFeature
2022-06-28 23:27:55 -04:00
getWireless = sometimes1 "wireless status indicator" "sysfs path"
$ IORoot wirelessCmd
$ Only $ readInterface "get wifi interface" isWireless
2021-11-22 23:02:23 -05:00
getEthernet :: Maybe Client -> BarFeature
2022-06-28 23:27:55 -04:00
getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
$ DBusRoot (const . ethernetCmd) tree client
2021-11-22 23:02:23 -05:00
where
2022-06-26 20:48:26 -04:00
tree = And1 (Only readEth) (Only_ devDep)
readEth = readInterface "read ethernet interface" isEthernet
2021-06-23 23:08:50 -04:00
2021-11-11 23:25:11 -05:00
getBattery :: BarFeature
2022-07-02 17:09:21 -04:00
getBattery = sometimesIO_ "battery level indicator" "sysfs path"
(Only_ $ sysTest "Test if battery is present" hasBattery)
batteryCmd
2021-06-23 23:08:50 -04:00
getVPN :: Maybe Client -> BarFeature
getVPN client = sometimesDBus client "VPN status indicator"
2022-06-28 23:27:55 -04:00
"xmobar dbus interface" (toAnd vpnDep test) (const vpnCmd)
2021-11-21 23:55:19 -05:00
where
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
2021-11-11 23:25:11 -05:00
getBt :: Maybe Client -> BarFeature
2022-06-28 23:27:55 -04:00
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
2021-06-23 23:08:50 -04:00
2021-11-11 23:25:11 -05:00
getAlsa :: BarFeature
2022-07-02 17:09:21 -04:00
getAlsa = sometimesIO_ "volume level indicator" "alsactl"
2022-06-28 23:27:55 -04:00
(Only_ $ sysExe "alsactl") alsaCmd
2021-06-23 23:08:50 -04:00
getBl :: Maybe Client -> BarFeature
2022-06-28 23:27:55 -04:00
getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
2021-06-23 23:08:50 -04:00
getCk :: Maybe Client -> BarFeature
2022-06-28 23:27:55 -04:00
getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
2021-11-21 17:54:00 -05:00
getSs :: Maybe Client -> BarFeature
2022-06-28 23:27:55 -04:00
getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
2021-06-23 23:08:50 -04:00
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
getAllCommands right = do
2021-06-23 23:08:50 -04:00
let left =
[ CmdSpec
{ csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader
}
]
return $ BarRegions
{ brLeft = left
, brCenter = []
, brRight = catMaybes right
}
2021-06-23 23:08:50 -04:00
--------------------------------------------------------------------------------
2021-11-27 17:33:02 -05:00
-- | fonts
2021-06-23 23:08:50 -04:00
2022-07-02 17:09:21 -04:00
data BarFont = Text
2021-11-27 17:33:02 -05:00
| IconSmall
| IconMedium
| IconLarge
| IconXLarge
deriving (Eq, Enum, Bounded, Show)
2021-06-23 23:08:50 -04:00
2022-07-02 17:09:21 -04:00
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
2021-06-23 23:08:50 -04:00
2022-07-02 17:09:21 -04:00
fontOffset :: (BarFont -> BarMetaFont) -> BarFont -> Int
fontOffset f = bfOffset . f
2021-06-23 23:08:50 -04:00
2022-07-02 17:09:21 -04:00
firstFont :: BarFont
firstFont = minBound
2021-06-23 23:08:50 -04:00
2022-07-02 17:09:21 -04:00
restFonts :: [BarFont]
restFonts = enumFrom $ succ minBound
2022-07-02 17:09:21 -04:00
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"
2020-03-16 13:50:08 -04:00
2022-07-02 17:09:21 -04:00
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
2021-11-27 17:33:02 -05:00
fontifyText fnt txt = concat ["<fn=", show $ fromEnum fnt, ">", txt, "</fn>"]
2021-11-27 17:33:02 -05:00
--------------------------------------------------------------------------------
-- | 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 = '{'
2020-03-22 17:17:57 -04:00
2021-11-27 17:33:02 -05:00
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