ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'fix_rio_run'

This commit is contained in:
Nathan Dwarshuis 2023-01-04 13:55:31 -05:00
parent af5877a402 24f0f034f0
commit 3cc7e02416
35 changed files with 3881 additions and 3051 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

357
.stylish-haskell.yaml
View File

@ -1,357 +0,0 @@
# stylish-haskell configuration file
# ==================================
# The stylish-haskell tool is mainly configured by specifying steps. These steps
# are a list, so they have an order, and one specific step may appear more than
# once (if needed). Each file is processed by these steps in the given order.
steps:
# Convert some ASCII sequences to their Unicode equivalents. This is disabled
# by default.
# - unicode_syntax:
# # In order to make this work, we also need to insert the UnicodeSyntax
# # language pragma. If this flag is set to true, we insert it when it's
# # not already present. You may want to disable it if you configure
# # language extensions using some other method than pragmas. Default:
# # true.
# add_language_pragma: true
# Format module header
#
# Currently, this option is not configurable and will format all exports and
# module declarations to minimize diffs
#
# - module_header:
# # How many spaces use for indentation in the module header.
# indent: 4
#
# # Should export lists be sorted? Sorting is only performed within the
# # export section, as delineated by Haddock comments.
# sort: true
#
# # See `separate_lists` for the `imports` step.
# separate_lists: true
# Format record definitions. This is disabled by default.
#
# You can control the layout of record fields. The only rules that can't be configured
# are these:
#
# - "|" is always aligned with "="
# - "," in fields is always aligned with "{"
# - "}" is likewise always aligned with "{"
#
# - records:
# # How to format equals sign between type constructor and data constructor.
# # Possible values:
# # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor.
# # - "indent N" -- insert a new line and N spaces from the beginning of the next line.
# equals: "indent 2"
#
# # How to format first field of each record constructor.
# # Possible values:
# # - "same_line" -- "{" and first field goes on the same line as the data constructor.
# # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
# first_field: "indent 2"
#
# # How many spaces to insert between the column with "," and the beginning of the comment in the next line.
# field_comment: 2
#
# # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
# deriving: 2
#
# # How many spaces to insert before "via" clause counted from indentation of deriving clause
# # Possible values:
# # - "same_line" -- "via" part goes on the same line as "deriving" keyword.
# # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword.
# via: "indent 2"
#
# # Sort typeclass names in the "deriving" list alphabetically.
# sort_deriving: true
#
# # Wheter or not to break enums onto several lines
# #
# # Default: false
# break_enums: false
#
# # Whether or not to break single constructor data types before `=` sign
# #
# # Default: true
# break_single_constructors: true
#
# # Whether or not to curry constraints on function.
# #
# # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@
# #
# # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@
# #
# # Default: false
# curried_context: false
# Align the right hand side of some elements. This is quite conservative
# and only applies to statements where each element occupies a single
# line.
# Possible values:
# - always - Always align statements.
# - adjacent - Align statements that are on adjacent lines in groups.
# - never - Never align statements.
# All default to always.
- simple_align:
cases: always
top_level_patterns: always
records: always
multi_way_if: always
# Import cleanup
- imports:
# There are different ways we can align names and lists.
#
# - global: Align the import names and import list throughout the entire
# file.
#
# - file: Like global, but don't add padding when there are no qualified
# imports in the file.
#
# - group: Only align the imports per group (a group is formed by adjacent
# import lines).
#
# - none: Do not perform any alignment.
#
# Default: global.
align: global
# The following options affect only import list alignment.
#
# List align has following options:
#
# - after_alias: Import list is aligned with end of import including
# 'as' and 'hiding' keywords.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# > init, last, length)
#
# - with_alias: Import list is aligned with start of alias or hiding.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# > init, last, length)
#
# - with_module_name: Import list is aligned `list_padding` spaces after
# the module name.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# init, last, length)
#
# This is mainly intended for use with `pad_module_names: false`.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# init, last, length, scanl, scanr, take, drop,
# sort, nub)
#
# - new_line: Import list starts always on new line.
#
# > import qualified Data.List as List
# > (concat, foldl, foldr, head, init, last, length)
#
# - repeat: Repeat the module name to align the import list.
#
# > import qualified Data.List as List (concat, foldl, foldr, head)
# > import qualified Data.List as List (init, last, length)
#
# Default: after_alias
list_align: after_alias
# Right-pad the module names to align imports in a group:
#
# - true: a little more readable
#
# > import qualified Data.List as List (concat, foldl, foldr,
# > init, last, length)
# > import qualified Data.List.Extra as List (concat, foldl, foldr,
# > init, last, length)
#
# - false: diff-safe
#
# > import qualified Data.List as List (concat, foldl, foldr, init,
# > last, length)
# > import qualified Data.List.Extra as List (concat, foldl, foldr,
# > init, last, length)
#
# Default: true
pad_module_names: true
# Long list align style takes effect when import is too long. This is
# determined by 'columns' setting.
#
# - inline: This option will put as much specs on same line as possible.
#
# - new_line: Import list will start on new line.
#
# - new_line_multiline: Import list will start on new line when it's
# short enough to fit to single line. Otherwise it'll be multiline.
#
# - multiline: One line per import list entry.
# Type with constructor list acts like single import.
#
# > import qualified Data.Map as M
# > ( empty
# > , singleton
# > , ...
# > , delete
# > )
#
# Default: inline
long_list_align: multiline
# Align empty list (importing instances)
#
# Empty list align has following options
#
# - inherit: inherit list_align setting
#
# - right_after: () is right after the module name:
#
# > import Vector.Instances ()
#
# Default: inherit
empty_list_align: inherit
# List padding determines indentation of import list on lines after import.
# This option affects 'long_list_align'.
#
# - <integer>: constant value
#
# - module_name: align under start of module name.
# Useful for 'file' and 'group' align settings.
#
# Default: 4
list_padding: 4
# Separate lists option affects formatting of import list for type
# or class. The only difference is single space between type and list
# of constructors, selectors and class functions.
#
# - true: There is single space between Foldable type and list of it's
# functions.
#
# > import Data.Foldable (Foldable (fold, foldl, foldMap))
#
# - false: There is no space between Foldable type and list of it's
# functions.
#
# > import Data.Foldable (Foldable(fold, foldl, foldMap))
#
# Default: true
separate_lists: true
# Space surround option affects formatting of import lists on a single
# line. The only difference is single space after the initial
# parenthesis and a single space before the terminal parenthesis.
#
# - true: There is single space associated with the enclosing
# parenthesis.
#
# > import Data.Foo ( foo )
#
# - false: There is no space associated with the enclosing parenthesis
#
# > import Data.Foo (foo)
#
# Default: false
space_surround: false
# Enabling this argument will use the new GHC lib parse to format imports.
#
# This currently assumes a few things, it will assume that you want post
# qualified imports. It is also not as feature complete as the old
# imports formatting.
#
# It does not remove redundant lines or merge lines. As such, the full
# feature scope is still pending.
#
# It _is_ however, a fine alternative if you are using features that are
# not parseable by haskell src extensions and you're comfortable with the
# presets.
#
# Default: false
ghc_lib_parser: false
# Language pragmas
- language_pragmas:
# We can generate different styles of language pragma lists.
#
# - vertical: Vertical-spaced language pragmas, one per line.
#
# - compact: A more compact style.
#
# - compact_line: Similar to compact, but wrap each line with
# `{-#LANGUAGE #-}'.
#
# Default: vertical.
style: vertical
# Align affects alignment of closing pragma brackets.
#
# - true: Brackets are aligned in same column.
#
# - false: Brackets are not aligned together. There is only one space
# between actual import and closing bracket.
#
# Default: true
align: true
# stylish-haskell can detect redundancy of some language pragmas. If this
# is set to true, it will remove those redundant pragmas. Default: true.
remove_redundant: true
# Language prefix to be used for pragma declaration, this allows you to
# use other options non case-sensitive like "language" or "Language".
# If a non correct String is provided, it will default to: LANGUAGE.
language_prefix: LANGUAGE
# Replace tabs by spaces. This is disabled by default.
# - tabs:
# # Number of spaces to use for each tab. Default: 8, as specified by the
# # Haskell report.
# spaces: 8
# Remove trailing whitespace
- trailing_whitespace: {}
# Squash multiple spaces between the left and right hand sides of some
# elements into single spaces. Basically, this undoes the effect of
# simple_align but is a bit less conservative.
# - squash: {}
# A common setting is the number of columns (parts of) code will be wrapped
# to. Different steps take this into account.
#
# Set this to null to disable all line wrapping.
#
# Default: 80.
columns: 80
# By default, line endings are converted according to the OS. You can override
# preferred format here.
#
# - native: Native newline format. CRLF on Windows, LF on other OSes.
#
# - lf: Convert to LF ("\n").
#
# - crlf: Convert to CRLF ("\r\n").
#
# Default: native.
newline: native
# Sometimes, language extensions are specified in a cabal file or from the
# command line instead of using language pragmas in the file. stylish-haskell
# needs to be aware of these, so it can parse the file correctly.
#
# No language extensions are enabled by default.
# language_extensions:
# - TemplateHaskell
# - QuasiQuotes
# Attempt to find the cabal file in ancestors of the current directory, and
# parse options (currently only language extensions) from that.
#
# Default: true
cabal: true

25
bin/vbox-start.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | Start a VirtualBox instance with a sentinel wrapper process.
--
-- The only reason why this is needed is because I want to manage virtualboxes
@ -15,21 +14,17 @@
-- until its PID exits. By monitoring this wrapper, the dynamic workspace only
-- has one process to track and will maintain the workspace throughout the
-- lifetime of the VM.
module Main (main) where
import qualified Data.ByteString.Lazy.UTF8 as BU
import RIO
import RIO.Process
import qualified RIO.Text as T
import System.Process (Pid)
import Text.XML.Light
import System.Environment
import UnliftIO.Environment
import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.Process (waitUntilExit)
import XMonad.Internal.IO
main :: IO ()
main = do
@ -46,20 +41,21 @@ runAndWait [n] = do
runID i = do
vmLaunch i
p <- vmPID i
liftIO $ waitUntilExit p
liftIO $ mapM_ waitUntilExit p
err = logError "Could not get machine ID"
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
runAndWait _ = logInfo "Usage: vbox-start VBOXNAME"
vmLaunch :: T.Text -> RIO SimpleApp ()
vmLaunch i = do
rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess
case rc of
ExitSuccess -> return ()
_ -> logError $ "Failed to start VM: "
_ ->
logError $
"Failed to start VM: "
<> displayBytesUtf8 (encodeUtf8 i)
vmPID :: T.Text -> RIO SimpleApp (Maybe Int)
vmPID :: T.Text -> RIO SimpleApp (Maybe Pid)
vmPID vid = do
(rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout
return $ case rc of
@ -73,7 +69,8 @@ vmMachineID iPath = do
Right contents -> return $ findMachineID contents
Left e -> logError (displayShow e) >> return Nothing
where
findMachineID c = T.stripSuffix "}"
findMachineID c =
T.stripSuffix "}"
=<< T.stripPrefix "{"
=<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
=<< (\e -> findChild (qual e "Machine") e)

433
bin/xmobar.hs
View File

@ -1,8 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
--------------------------------------------------------------------------------
-- | Xmobar binary
--
-- Features:
@ -12,29 +9,16 @@ module Main (main) where
-- * 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
module Main (main) where
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
import Data.Maybe
import Data.Internal.XIO
import Options.Applicative
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.Environment
import System.IO
import System.IO.Error
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 hiding (config)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Command.Power
@ -42,37 +26,64 @@ import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import XMonad.Internal.Process hiding (CmdSpec)
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
main = parse >>= xio
parse :: [String] -> IO ()
parse [] = run
parse ["--deps"] = withCache printDeps
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
parse _ = usage
parse :: IO XOpts
parse = execParser opts
where
parseOpts = parseDeps <|> parseTest <|> pure XRun
opts =
info (parseOpts <**> helper) $
fullDesc <> header "xmobar: the best taskbar ever"
run :: IO ()
data XOpts = XDeps | XTest | XRun
parseDeps :: Parser XOpts
parseDeps =
flag'
XDeps
(long "deps" <> short 'd' <> help "print dependencies")
parseTest :: Parser XOpts
parseTest =
flag'
XTest
(long "test" <> short 't' <> help "test dependencies without running")
xio :: XOpts -> IO ()
xio o = case o of
XDeps -> hRunXIO False stderr printDeps
XTest -> hRunXIO False stderr $ withDBus_ evalConfig
XRun -> runXIO "xmobar.log" run
run :: XIO ()
run = do
db <- connectDBus
c <- withCache $ evalConfig db
disconnectDBus db
-- 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
xmobar c
-- IDK why this is needed, I thought this was default
liftIO $ hSetBuffering stdout LineBuffering
-- this isn't totally necessary except for the fact that killing xmobar
-- will make it print something about catching SIGTERM, and without
-- linebuffering it usually only prints the first few characters (even then
-- it only prints 10-20% of the time)
liftIO $ hSetBuffering stderr LineBuffering
withDBus_ $ \db -> do
c <- evalConfig db
liftIO $ xmobar c
evalConfig :: DBusState -> FIO Config
evalConfig :: DBusState -> XIO Config
evalConfig db = do
cs <- getAllCommands <$> rightPlugins db
bf <- getTextFont
@ -80,21 +91,17 @@ evalConfig db = do
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"
]
printDeps :: XIO ()
printDeps = withDBus_ $ \db ->
mapM_ logInfo $
fmap showFulfillment $
sort $
nub $
concatMap dumpFeature $
allFeatures db
--------------------------------------------------------------------------------
-- | toplevel configuration
-- toplevel configuration
-- | The text font family
textFont :: Always XT.FontBuilder
@ -110,7 +117,10 @@ 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"
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)
@ -136,7 +146,8 @@ iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing }
-- 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
config bf ifs ios br confDir =
defaultConfig
{ font = T.unpack bf
, additionalFonts = fmap T.unpack ifs
, textOffset = textFontOffset
@ -146,32 +157,31 @@ config bf ifs ios br confDir = defaultConfig
, 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"
, -- store the icons with the xmonad/xmobar stack project
iconRoot = confDir ++ "/icons"
, commands = csRunnable <$> concatRegions br
}
--------------------------------------------------------------------------------
-- | plugin features
-- 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
getAllCommands right =
BarRegions
{ brLeft =
[ CmdSpec
{ csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader
}
@ -180,8 +190,10 @@ getAllCommands right = BarRegions
, brRight = catMaybes right
}
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins db = mapM evalFeature $ allFeatures db
rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
rightPlugins db =
mapM evalFeature $
allFeatures db
++ [always' "date indicator" dateCmd]
where
always' n = Right . Always n . Always_ . FallbackAlone
@ -204,7 +216,10 @@ type BarFeature = Sometimes CmdSpec
-- TODO what if I don't have a wireless card?
getWireless :: BarFeature
getWireless = Sometimes "wireless status indicator" xpfWireless
getWireless =
Sometimes
"wireless status indicator"
xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getEthernet :: Maybe SysClient -> BarFeature
@ -217,32 +232,49 @@ getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
where
root useIcon = IORoot_ (batteryCmd useIcon)
tree = Only_ $ IOTest_ "Test if battery is present" []
$ fmap (Msg LevelError) <$> hasBattery
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
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"
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
getBl =
xmobarDBus
"Intel backlight indicator"
xpfIntelBacklight
intelBacklightSignalDep
blCmd
getCk :: Maybe SesClient -> BarFeature
getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
clevoKeyboardSignalDep ckCmd
getCk =
xmobarDBus
"Clevo keyboard indicator"
xpfClevoBacklight
clevoKeyboardSignalDep
ckCmd
getSs :: Maybe SesClient -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
@ -253,29 +285,58 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
--------------------------------------------------------------------------------
-- | bar feature constructors
-- bar feature constructors
xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c
-> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
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_
:: 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
:: 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_
:: 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
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"
]
@ -284,125 +345,170 @@ iconSometimes' c d n q r t = Sometimes n q
text = r fontifyAlt t
--------------------------------------------------------------------------------
-- | command specifications
-- command specifications
data BarRegions = BarRegions
{ brLeft :: [CmdSpec]
, brCenter :: [CmdSpec]
, brRight :: [CmdSpec]
} deriving Show
}
deriving (Show)
data CmdSpec = CmdSpec
{ csAlias :: T.Text
, csRunnable :: Runnable
} deriving Show
}
deriving (Show)
concatRegions :: BarRegions -> [CmdSpec]
concatRegions (BarRegions l c r) = l ++ c ++ r
wirelessCmd :: T.Text -> CmdSpec
wirelessCmd iface = 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>"
args =
fmap
T.unpack
[ "-t"
, "<qualityipat><essid>"
, "--"
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
, "--quality-icon-pattern"
, "<icon=wifi_%%.xpm/>"
]
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
ethernetCmd fontify iface = CmdSpec
ethernetCmd fontify iface =
CmdSpec
{ csAlias = iface
, csRunnable = Run
$ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
, csRunnable =
Run $
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
}
batteryCmd :: Fontifier -> CmdSpec
batteryCmd fontify = 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
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"
, "-o"
, fontify' "\xf0e7" "BAT"
, "-O"
, fontify' "\xf1e6" "AC"
, "-i"
, fontify' "\xf1e6" "AC"
]
vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify = CmdSpec
vpnCmd fontify =
CmdSpec
{ csAlias = vpnAlias
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
}
btCmd :: Fontifier -> CmdSpec
btCmd fontify = CmdSpec
btCmd fontify =
CmdSpec
{ csAlias = btAlias
, csRunnable = Run
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
, csRunnable =
Run $
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
}
where
fontify' i = fontify IconLarge i . T.append "BT"
alsaCmd :: Fontifier -> CmdSpec
alsaCmd fontify = CmdSpec
alsaCmd fontify =
CmdSpec
{ csAlias = "alsa:default:Master"
, csRunnable = Run
$ Alsa "default" "Master"
$ fmap T.unpack
[ "-t", "<status><volume>%"
, 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
, "-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
blCmd fontify =
CmdSpec
{ csAlias = blAlias
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
}
ckCmd :: Fontifier -> CmdSpec
ckCmd fontify = CmdSpec
ckCmd fontify =
CmdSpec
{ csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
}
ssCmd :: Fontifier -> CmdSpec
ssCmd fontify = CmdSpec
ssCmd fontify =
CmdSpec
{ csAlias = ssAlias
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
}
lockCmd :: Fontifier -> CmdSpec
lockCmd fontify = 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", " "
, csRunnable =
Run $
Locks $
fmap
T.unpack
[ "-N"
, numIcon
, "-n"
, disabledColor numIcon
, "-C"
, capIcon
, "-c"
, disabledColor capIcon
, "-s"
, ""
, "-S"
, ""
, "-d"
, " "
]
}
where
@ -412,51 +518,61 @@ lockCmd fontify = CmdSpec
disabledColor = xmobarFGColor XT.backdropFgColor
dateCmd :: CmdSpec
dateCmd = CmdSpec
dateCmd =
CmdSpec
{ csAlias = "date"
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
}
--------------------------------------------------------------------------------
-- | low-level testing functions
-- low-level testing functions
vpnPresent :: IO (Maybe Msg)
vpnPresent =
go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` T.lines out then Nothing
else Just $ Msg LevelError "vpn not found"
go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError
$ T.concat ["vpn search exited with code "
vpnPresent :: XIO (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
, ": "
, err]
go (Left e) = Just $ Msg LevelError $ T.pack $ show e
, T.decodeUtf8With T.lenientDecode $
BL.toStrict err
]
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
--------------------------------------------------------------------------------
-- | text font
-- 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 :: XIO T.Text
getTextFont = do
fb <- evalAlways textFont
return $ fb textFontData
--------------------------------------------------------------------------------
-- | icon fonts
-- icon fonts
getIconFonts :: FIO ([T.Text], [Int])
getIconFonts :: XIO ([T.Text], [Int])
getIconFonts = do
fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb
where
apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
apply fb =
unzip $
(\i -> (iconString fb i, iconOffset i + textFontOffset))
<$> iconFonts
data BarFont = IconSmall
data BarFont
= IconSmall
| IconMedium
| IconLarge
| IconXLarge
@ -484,7 +600,7 @@ fontifyIcon :: Fontifier
fontifyIcon f i _ = fontifyText f i
--------------------------------------------------------------------------------
-- | various formatting things
-- various formatting things
colors :: Colors
colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
@ -507,5 +623,6 @@ fmtSpecs = T.intercalate sep . fmap go
go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep]
fmtRegions :: BarRegions -> T.Text
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat $
fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
T.concat
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]

699
bin/xmonad.hs
View File

@ -1,36 +1,32 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
--------------------------------------------------------------------------------
-- | XMonad binary
-- XMonad binary
module Main (main) where
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
import Data.Maybe
import Data.Internal.XIO
import Data.Monoid
import Data.Text.IO (hPutStrLn)
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras
import RIO (async)
import Options.Applicative hiding (action)
import RIO
import RIO.Directory
import RIO.List
import RIO.Process
import qualified RIO.Text as T
import System.Directory
import System.Environment
import System.IO hiding
( hPutStrLn
)
import System.IO.Error
import System.Posix.Signals
import System.Process
( getPid
, getProcessExitCode
)
import XMonad
import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS
@ -53,8 +49,7 @@ import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Removable
import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Internal.Shell hiding (proc)
import qualified XMonad.Internal.Theme as XT
import XMonad.Layout.MultiToggle
import XMonad.Layout.NoBorders
@ -71,23 +66,95 @@ import XMonad.Util.NamedActions
import XMonad.Util.WorkspaceCompare
main :: IO ()
main = getArgs >>= parse
main = parse >>= xio
parse :: [String] -> IO ()
parse [] = run
parse ["--deps"] = withCache printDeps
parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
parse _ = usage
parse :: IO XOpts
parse = execParser opts
where
parseOpts = parseDeps <|> parseTest <|> pure XRun
opts =
info (parseOpts <**> helper) $
fullDesc <> header "xmonad: the best window manager ever"
data XOpts = XDeps | XTest | XRun
run :: IO ()
parseDeps :: Parser XOpts
parseDeps =
flag'
XDeps
(long "deps" <> short 'd' <> help "print dependencies")
parseTest :: Parser XOpts
parseTest =
flag'
XTest
(long "test" <> short 't' <> help "test dependencies without running")
xio :: XOpts -> IO ()
xio o = case o of
XDeps -> hRunXIO False stderr printDeps
XTest -> undefined
XRun -> runXIO "xmonad.log" run
run :: XIO ()
run = do
db <- connectDBusX
conf <- withCache $ evalConf db
ds <- getCreateDirectories
-- IDK why this is necessary; nothing prior to this will print if missing
hFlush stdout
launch conf ds
-- These first two commands are only significant when xmonad is restarted.
-- The 'launch' function below this will turn off buffering (so flushes are
-- required to see stdout) and will also install xmonad's silly signal
-- handlers (which set the handlers for sigCHLD and sigPIPE to SIG_IGN).
-- Ignoring sigCHLD is particularly bad since most of my setup entails
-- spawning processes and waiting for their exit code, which totally breaks
-- when sigCHLD is ignored (since children are killed immediately without
-- the parent invoking 'wait'). Since the 'launch' function is called last
-- here, everything before should be fine except for the case where xmonad
-- is restarted, which uses 'exec' and thus should cause the buffering and
-- signal handlers to carry over to the top.
uninstallSignalHandlers
hSetBuffering stdout LineBuffering
withDBusX_ $ \db -> do
let fs = features $ dbSysClient db
withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
withXmobar $ \xmobarP -> do
withChildDaemons fs $ \ds -> do
let toClean = Cleanup ds (Just xmobarP) unexporters
void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
void $ async $ void $ executeSometimes $ fsPowerMon fs
dws <- startDynWorkspaces fs
runIO <- askRunInIO
let cleanup = runCleanup runIO toClean db
kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs
tt <- evalAlways $ fsTabbedTheme fs
let conf =
ewmh $
addKeymap dws (liftIO . runIO . sk) kbs $
docks $
def
{ terminal = myTerm
, modMask = myModMask
, layoutHook = myLayouts tt
, manageHook = myManageHook dws
, handleEventHook = myEventHook runIO ha
, startupHook = myStartupHook
, workspaces = myWorkspaces
, logHook = myLoghook xmobarP
, clickJustFocuses = False
, focusFollowsMouse = False
, normalBorderColor = T.unpack XT.bordersColor
, focusedBorderColor = T.unpack XT.selectedBordersColor
}
io $ runXMonad conf
where
startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
void $ async $ runWorkspaceMon dws
return dws
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
runXMonad conf = do
dirs <- getCreateDirectories
launch conf dirs
getCreateDirectories :: IO Directories
getCreateDirectories = do
@ -97,21 +164,21 @@ getCreateDirectories = do
where
createIfMissing ds f = do
let d = f ds
r <- tryIOError $ createDirectoryIfMissing True d
r <- tryIO $ createDirectoryIfMissing True d
case r of
(Left e) -> print e
_ -> return ()
data FeatureSet = FeatureSet
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
, fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
, fsPowerMon :: SometimesIO
, fsRemovableMon :: Maybe SysClient -> SometimesIO
, fsDaemons :: [Sometimes (IO ProcessHandle)]
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
, fsACPIHandler :: Always (String -> X ())
, fsTabbedTheme :: Always Theme
, fsDynWorkspaces :: [Sometimes DynWorkspace]
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ())
}
tabbedFeature :: Always Theme
@ -122,7 +189,8 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
features :: Maybe SysClient -> FeatureSet
features cl = FeatureSet
features cl =
FeatureSet
{ fsKeys = externalBindings
, fsDBusExporters = dbusExporters
, fsPowerMon = runPowermon
@ -134,104 +202,141 @@ features cl = FeatureSet
, fsDaemons = [runNetAppDaemon cl, runAutolock]
}
evalConf db@DBusState { dbSysClient = cl } = do
-- start DBus interfaces first since many features after this test these
-- interfaces as dependencies
let fs = features cl
startDBusInterfaces fs
(xmobarHandle, ts) <- startChildDaemons fs
startRemovableMon fs
startPowerMon fs
dws <- startDynWorkspaces fs
tt <- evalAlways $ fsTabbedTheme fs
-- fb <- evalAlways $ fsFontBuilder features
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs
return $ ewmh
$ addKeymap dws sk kbs
$ docks
$ def { terminal = myTerm
, modMask = myModMask
, layoutHook = myLayouts tt
, manageHook = myManageHook dws
, handleEventHook = myEventHook ha
, startupHook = myStartupHook
, workspaces = myWorkspaces
, logHook = myLoghook xmobarHandle
, clickJustFocuses = False
, focusFollowsMouse = False
, normalBorderColor = T.unpack XT.bordersColor
, focusedBorderColor = T.unpack XT.selectedBordersColor
}
withXmobar :: (Process Handle () () -> XIO a) -> XIO a
withXmobar = bracket startXmobar stopXmobar
startXmobar :: XIO (Process Handle () ())
startXmobar = do
logInfo "starting xmobar child process"
p <- proc "xmobar" [] start
io $ hSetBuffering (getStdin p) LineBuffering
return p
where
forkIO_ = void . async
startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
$ fsDBusExporters fs
startChildDaemons fs = do
(h, p) <- io $ spawnPipe "xmobar"
ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
return (h, ThreadState (p:ps) [h])
startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
$ dbSysClient db
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
io $ forkIO_ $ runWorkspaceMon dws
return dws
start =
startProcess
. setStdin createPipe
. setCreateGroup True
printDeps :: FIO ()
printDeps = do
db <- io connectDBus
(i, f, d) <- allFeatures db
io $ mapM_ (putStrLn . T.unpack)
$ fmap showFulfillment
$ sort
$ nub
$ concat
$ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
io $ disconnectDBus db
stopXmobar
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Process Handle () ()
-> m ()
stopXmobar p = do
logInfo "stopping xmobar child process"
io $ killNoWait p
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
allFeatures db = do
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
$ externalBindings ts db
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
withChildDaemons
:: FeatureSet
-> ([(Utf8Builder, Process () () ())] -> XIO a)
-> XIO a
withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
where
start s@(Sometimes sname _ _) = do
let sname_ = Utf8Builder $ encodeUtf8Builder sname
res <- executeSometimes s
case res of
Just p -> do
logInfo $ "starting child process: " <> sname_
return $ Just (sname_, p)
-- don't log anything here since presumably the feature itself will log
-- an error if it fails during execution
_ -> return Nothing
stopChildDaemons
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [(Utf8Builder, Process () () ())]
-> m ()
stopChildDaemons = mapM_ stop
where
stop (n, p) = do
logInfo $ "stopping child process: " <> n
liftIO $ killNoWait p
printDeps :: XIO ()
printDeps = withDBus_ $ \db -> do
runIO <- askRunInIO
let mockCleanup = runCleanup runIO mockClean db
let bfs =
concatMap (fmap kbMaybeAction . kgBindings) $
externalBindings runIO mockCleanup db
let dbus =
fmap (\f -> f $ dbSesClient db) dbusExporters
:: [Sometimes (XIO (), XIO ())]
let others = [runRemovableMon $ dbSysClient db, runPowermon]
return (dbus ++ others, Left runScreenLock:bfs, allDWs')
-- TODO might be better to use glog for this?
mapM_ logInfo $
fmap showFulfillment $
sort $
nub $
concat $
fmap dumpSometimes dbus
++ fmap dumpSometimes others
++ fmap dumpSometimes allDWs'
++ fmap dumpFeature bfs
where
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
usage :: IO ()
usage = putStrLn $ intercalate "\n"
[ "xmonad: run greatest window manager"
, "xmonad --deps: print dependencies"
]
mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
--------------------------------------------------------------------------------
-- | Concurrency configuration
-- Concurrency configuration
data ThreadState = ThreadState
{ tsChildPIDs :: [ProcessHandle]
, tsChildHandles :: [Handle]
data Cleanup = Cleanup
{ clChildren :: [(Utf8Builder, Process () () ())]
, clXmobar :: Maybe (Process Handle () ())
, clDBusUnexporters :: [XIO ()]
}
-- TODO shouldn't this be run by a signal handler?
runCleanup :: ThreadState -> DBusState -> X ()
runCleanup ts db = io $ do
mapM_ killHandle $ tsChildPIDs ts
runCleanup
:: (XIO () -> IO ())
-> Cleanup
-> DBusState
-> X ()
runCleanup runIO ts db = liftIO $ runIO $ do
mapM_ stopXmobar $ clXmobar ts
stopChildDaemons $ clChildren ts
sequence_ $ clDBusUnexporters ts
disconnectDBusX db
-- | Kill a process (group) after xmonad has already started
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
-- sets the handler for sigCHLD to Ignore which breaks 'waitForProcess' (which
-- in turn will break 'stopProcess') and b) because I want to kill off entire
-- process groups since they may spawn child processes themselves. NOTE:
-- for reasons unknown I cannot just turn off/on the signal handlers here.
killNoWait :: Process a () () -> IO ()
killNoWait p = do
-- this strategy is outlined/sanctioned in RIO.Process under
-- 'unsafeProcessHandle':
--
-- get the handle (unsafely, since it breaks the semantics of RIO)
let ph = unsafeProcessHandle p
-- check if the process has already exited (if so, do nothing since trying
-- to kill it will open wormholes
ec <- getProcessExitCode ph
unless (isJust ec) $ do
-- send SIGTERM to the entire group (NOTE: 'System.Process.terminateProcess'
-- does not actually do this despite what the docs say)
i <- getPid ph
forM_ i $ signalProcessGroup sigTERM
-- actually call 'stopProcess' which will clean up associated data and
-- then try to wait for the exit, which will fail because we are assuming
-- this function is called when the handler for SIGCHLD is Ignore. Ignore
-- the failure and move on with life.
handleIO (\_ -> return ()) $ stopProcess p
--------------------------------------------------------------------------------
-- | Startuphook configuration
-- Startuphook configuration
-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
myStartupHook :: X ()
myStartupHook = setDefaultCursor xC_left_ptr
myStartupHook =
setDefaultCursor xC_left_ptr
<+> startupHook def
--------------------------------------------------------------------------------
-- | Workspace configuration
-- Workspace configuration
myWorkspaces :: [WorkspaceId]
myWorkspaces = map show [1 .. 10 :: Int]
@ -252,7 +357,8 @@ gimpDynamicWorkspace :: Sometimes DynWorkspace
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
where
tree = Only_ $ sysExe [Package Official "gimp"] exe
dw = DynWorkspace
dw =
DynWorkspace
{ dwName = "Gimp"
, dwTag = gimpTag
, dwClass = c
@ -266,21 +372,32 @@ gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
, dwCmd = Just $ spawnCmd exe []
}
exe = "gimp-2.10"
matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
<&&> className =? c
matchGimpRole role =
isPrefixOf role
<$> stringProperty "WM_WINDOW_ROLE"
<&&> className
=? c
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
-- TODO don't hardcode the VM name/title/shortcut
vmDynamicWorkspace :: Sometimes DynWorkspace
vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
vmDynamicWorkspace =
Sometimes
"virtualbox workspace"
xpfVirtualBox
[Subfeature root "windows 8 VM"]
where
root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
$ IOTest_ name [] $ vmExists vm
root =
IORoot_ dw $
toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") $
IOTest_ name [] $
io $
vmExists vm
name = T.unwords ["test if", vm, "exists"]
c = "VirtualBoxVM"
vm = "win8raw"
dw = DynWorkspace
dw =
DynWorkspace
{ dwName = "Windows VirtualBox"
, dwTag = vmTag
, dwClass = c
@ -290,11 +407,15 @@ vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
}
xsaneDynamicWorkspace :: Sometimes DynWorkspace
xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
xsaneDynamicWorkspace =
Sometimes
"scanner workspace"
xpfXSANE
[Subfeature (IORoot_ dw tree) "xsane"]
where
tree = Only_ $ sysExe [Package Official "xsane"] "xsane"
dw = DynWorkspace
dw =
DynWorkspace
{ dwName = "XSane"
, dwTag = xsaneTag
, dwClass = c
@ -305,11 +426,15 @@ xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
c = "Xsane"
f5vpnDynamicWorkspace :: Sometimes DynWorkspace
f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN
f5vpnDynamicWorkspace =
Sometimes
"F5 VPN workspace"
xpfF5VPN
[Subfeature (IORoot_ dw tree) "f5vpn"]
where
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
dw = DynWorkspace
dw =
DynWorkspace
{ dwName = "F5Vpn"
, dwTag = f5Tag
, dwClass = c
@ -320,42 +445,48 @@ f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN
c = "F5 VPN"
allDWs' :: [Sometimes DynWorkspace]
allDWs' = [xsaneDynamicWorkspace
allDWs' =
[ xsaneDynamicWorkspace
, vmDynamicWorkspace
, gimpDynamicWorkspace
, f5vpnDynamicWorkspace
]
--------------------------------------------------------------------------------
-- | Layout configuration
-- Layout configuration
-- NOTE this will have all available layouts, even those that may be for
-- features that failed. Trying to dynamically take out a layout seems to
-- make a new type :/
myLayouts tt = onWorkspace vmTag vmLayout
$ onWorkspace gimpTag gimpLayout
$ mkToggle (single HIDE)
$ tall ||| fulltab ||| full
myLayouts tt =
onWorkspace vmTag vmLayout $
onWorkspace gimpTag gimpLayout $
mkToggle (single HIDE) $
tall ||| fulltab ||| full
where
addTopBar = noFrillsDeco shrinkText tt
tall = renamed [Replace "Tall"]
$ avoidStruts
$ addTopBar
$ noBorders
$ Tall 1 0.03 0.5
fulltab = renamed [Replace "Tabbed"]
$ avoidStruts
$ noBorders
$ tabbedAlways shrinkText tt
full = renamed [Replace "Full"]
$ noBorders Full
tall =
renamed [Replace "Tall"] $
avoidStruts $
addTopBar $
noBorders $
Tall 1 0.03 0.5
fulltab =
renamed [Replace "Tabbed"] $
avoidStruts $
noBorders $
tabbedAlways shrinkText tt
full =
renamed [Replace "Full"] $
noBorders Full
vmLayout = noBorders Full
-- TODO use a tabbed layout for multiple master windows
gimpLayout = renamed [Replace "Gimp Layout"]
$ avoidStruts
$ noBorders
$ addTopBar
$ Tall 1 0.025 0.8
gimpLayout =
renamed [Replace "Gimp Layout"] $
avoidStruts $
noBorders $
addTopBar $
Tall 1 0.025 0.8
-- | Make a new empty layout and add a message to show/hide it. This is useful
-- for quickly showing conky.
@ -377,10 +508,9 @@ runHide :: X ()
runHide = sendMessage $ Toggle HIDE
--------------------------------------------------------------------------------
-- | Loghook configuration
--
-- Loghook configuration
myLoghook :: Handle -> X ()
myLoghook :: Process Handle () () -> X ()
myLoghook h = do
logXinerama h
logViewports
@ -396,7 +526,7 @@ myLoghook h = do
-- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why
-- bother...(if that were necessary it would go in the startup hook)
newtype DesktopViewports = DesktopViewports [Int]
deriving Eq
deriving (Eq)
instance ExtensionClass DesktopViewports where
initialValue = DesktopViewports []
@ -409,8 +539,9 @@ logViewports = withWindowSet $ \s -> do
whenChanged (DesktopViewports desktopViewports) $
setDesktopViewports desktopViewports
where
wsToViewports s w = let cur = W.current s in
if W.tag w == currentTag cur then currentPos cur else [0, 0]
wsToViewports s w =
let cur = W.current s
in if W.tag w == currentTag cur then currentPos cur else [0, 0]
currentTag = W.tag . W.workspace
currentPos = rectXY . screenRect . W.screenDetail
rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y]
@ -436,20 +567,22 @@ whenChanged v action = do
-- currently visible and the order reflects the physical location of each
-- screen. The "<>" is the workspace that currently has focus. N is the number
-- of windows on the current workspace.
logXinerama :: Handle -> X ()
logXinerama h = withWindowSet $ \ws -> io
$ hPutStrLn h
$ T.unwords
$ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
logXinerama :: Process Handle () () -> X ()
logXinerama p = withWindowSet $ \ws ->
io $
hPutStrLn (getStdin p) $
T.unwords $
filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
where
onScreen ws = xmobarColor_ hilightFgColor hilightBgColor
$ (T.pack . pad . T.unpack)
$ T.unwords
$ map (fmtTags ws . W.tag . W.workspace)
$ sortBy compareXCoord
$ W.current ws : W.visible ws
offScreen = xmobarColor_ XT.backdropFgColor ""
onScreen ws =
xmobarColor_ hilightFgColor hilightBgColor $
(T.pack . pad . T.unpack) $
T.unwords $
map (fmtTags ws . W.tag . W.workspace) $
sortBy compareXCoord $
W.current ws : W.visible ws
offScreen =
xmobarColor_ XT.backdropFgColor ""
. T.unwords
. fmap (T.pack . W.tag)
. filter (isJust . W.stack)
@ -457,7 +590,8 @@ logXinerama h = withWindowSet $ \ws -> io
. W.hidden
sep = xmobarColor_ XT.backdropFgColor "" ":"
layout = T.pack . description . W.layout . W.workspace . W.current
nWindows = (\x -> T.concat ["(", x, ")"])
nWindows =
(\x -> T.concat ["(", x, ")"])
. T.pack
. show
. length
@ -467,76 +601,97 @@ logXinerama h = withWindowSet $ \ws -> io
. W.current
hilightBgColor = "#A6D3FF"
hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
fmtTags ws t = let t_ = T.pack t in
if t == W.currentTag ws
fmtTags ws t =
let t_ = T.pack t
in if t == W.currentTag ws
then xmobarColor_ XT.fgColor hilightBgColor t_
else t_
xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c)
compareXCoord
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
-> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering
-> W.Screen i2 l2 a2 ScreenId ScreenDetail
-> Ordering
compareXCoord s0 s1 = compare (go s0) (go s1)
where
go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle
--------------------------------------------------------------------------------
-- | Managehook configuration
-- Managehook configuration
myManageHook :: [DynWorkspace] -> ManageHook
myManageHook dws = manageApps dws <+> manageHook def
manageApps :: [DynWorkspace] -> ManageHook
manageApps dws = composeOne $ concatMap dwHook dws ++
[ isDialog -?> doCenterFloat
-- the seafile applet
, className =? "Seafile Client" -?> doFloat
-- gnucash
, (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
-- plots and graphics
, className =? "R_x11" -?> doFloat
manageApps dws =
composeOne $
concatMap dwHook dws
++ [ isDialog -?> doCenterFloat
, -- the seafile applet
className =? "Seafile Client" -?> doFloat
, -- gnucash
(className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
, -- plots and graphics
className =? "R_x11" -?> doFloat
, className =? "Matplotlib" -?> doFloat
, className =? "mpv" -?> doFloat
-- the floating windows created by the brave browser
, stringProperty "WM_NAME" =? "Brave" -?> doFloat
-- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up"
, -- the floating windows created by the brave browser
stringProperty "WM_NAME" =? "Brave" -?> doFloat
, -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up"
-- <&&> className =? "Brave-browser") -?> doFloat
-- the dialog windows created by the zotero addon in Google Docs
, (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
(className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
]
--------------------------------------------------------------------------------
-- | Eventhook configuration
-- Eventhook configuration
myEventHook :: (String -> X ()) -> Event -> X All
myEventHook handler = xMsgEventHook handler <+> handleEventHook def
myEventHook
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (m () -> IO ())
-> (String -> X ())
-> Event
-> X All
myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def
-- | React to ClientMessage events from concurrent threads
xMsgEventHook :: (String -> X ()) -> Event -> X All
xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
xMsgEventHook
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (m () -> IO ())
-> (String -> X ())
-> Event
-> X All
xMsgEventHook runIO handler ClientMessageEvent {ev_message_type = t, ev_data = d}
| t == bITMAP = do
let (xtype, tag) = splitXMsg d
case xtype of
Workspace -> removeDynamicWorkspace tag
ACPI -> handler tag
Unknown -> io $ putStrLn "WARNING: unknown concurrent message"
Unknown -> liftIO $ runIO $ logWarn "unknown concurrent message"
return (All True)
xMsgEventHook _ _ = return (All True)
xMsgEventHook _ _ _ = return (All True)
--------------------------------------------------------------------------------
-- | Keymap configuration
-- Keymap configuration
myModMask :: KeyMask
myModMask = mod4Mask
addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ())
-> [KeyGroup (X ())] -> XConfig l -> XConfig l
addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys)
addKeymap
:: [DynWorkspace]
-> ([((KeyMask, KeySym), NamedAction)] -> X ())
-> [KeyGroup (X ())]
-> XConfig l
-> XConfig l
addKeymap dws showKeys external =
addDescrKeys'
((myModMask, xK_F1), showKeys)
(\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external)
internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())]
internalBindings dws c =
[ KeyGroup "Window Layouts"
[ KeyGroup
"Window Layouts"
[ KeyBinding "M-j" "focus down" $ windows W.focusDown
, KeyBinding "M-k" "focus up" $ windows W.focusUp
, KeyBinding "M-m" "focus master" $ windows W.focusMaster
@ -553,32 +708,36 @@ internalBindings dws c =
, KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1)
, KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1
]
, KeyGroup "Workspaces"
, KeyGroup
"Workspaces"
-- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get
-- valid keysyms)
([ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces
, (mods, msg, f) <-
( [ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces, (mods, msg, f) <-
[ ("M-", "switch to workspace ", windows . W.view)
, ("M-S-", "move client to workspace ", windows . W.shift)
, ("M-C-", "follow client to workspace ", \n' -> do
,
( "M-C-"
, "follow client to workspace "
, \n' -> do
windows $ W.shift n'
windows $ W.view n')
windows $ W.view n'
)
]
] ++
[ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS)
]
++ [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS)
, KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS)
])
, KeyGroup "Dynamic Workspaces"
]
)
, KeyGroup
"Dynamic Workspaces"
[ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
| DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- dws,
let cmd = case a of
| DynWorkspace {dwTag = t, dwKey = k, dwCmd = a, dwName = n} <- dws
, let cmd = case a of
Just a' -> spawnOrSwitch t a'
Nothing -> windows $ W.view t
]
, KeyGroup "Screens"
, KeyGroup
"Screens"
[ KeyBinding "M-l" "move up screen" nextScr
, KeyBinding "M-h" "move down screen" prevScr
, KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift
@ -597,8 +756,9 @@ internalBindings dws c =
mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} =
(subtitle h:) $ mkNamedKeymap c
$ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
(subtitle h :) $
mkNamedKeymap c $
(\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
<$> b
data KeyBinding a = KeyBinding
@ -612,13 +772,13 @@ data KeyGroup a = KeyGroup
, kgBindings :: [KeyBinding a]
}
evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
evalExternal = mapM go
where
go k@KeyGroup {kgBindings = bs} =
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
(\f -> k {kbMaybeAction = f}) <$> evalFeature a
@ -626,59 +786,62 @@ filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go
where
go k@KeyGroup {kgBindings = bs} =
k { kgBindings = [ kb { kbMaybeAction = x }
k
{ kgBindings =
[ kb {kbMaybeAction = x}
| kb@KeyBinding {kbMaybeAction = Just x} <- bs
]
}
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
externalBindings ts db =
[ KeyGroup "Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
, KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
, KeyBinding "M-w" "launch window selector" $ Left runWinMenu
, KeyBinding "M-u" "launch device selector" $ Left runDevMenu
, KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses
, KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
, KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
, KeyBinding "M-C-e" "launch editor" $ Left runEditor
, KeyBinding "M-C-w" "launch browser" $ Left runBrowser
, KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
, KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
, KeyBinding "M-C-q" "launch calc" $ Left runCalc
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
externalBindings runIO cleanup db =
[ KeyGroup
"Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" $ Left $ toX runAppMenu
, KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu
, KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys
, KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu
, KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu
, KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses
, KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu
, KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu
, KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor
, KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser
, KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux
, KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm
, KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc
, KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager
]
, KeyGroup "Actions"
, KeyGroup
"Actions"
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
, KeyBinding "M-r" "run program" $ Left runCmdMenu
, KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
, KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses
, KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses
, KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
, KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses
, KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses
, KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses
, KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
]
, KeyGroup "Multimedia"
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
, KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
, KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
, KeyGroup
"Multimedia"
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left $ toX runTogglePlay
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left $ toX runPrevTrack
, KeyBinding "<XF86AudioNext>" "next track" $ Left $ toX runNextTrack
, KeyBinding "<XF86AudioStop>" "stop" $ Left $ toX runStopPlay
, KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left $ toX runVolumeDown
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left $ toX runVolumeUp
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left $ toX runVolumeMute
]
, KeyGroup "Dunst"
[ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
, KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
, KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
, KeyGroup
"Dunst"
[ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses
, KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses
, KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ runNotificationCloseAll ses
]
, KeyGroup "System"
, KeyGroup
"System"
[ KeyBinding "M-." "backlight up" $ ib bctlInc
, KeyBinding "M-," "backlight down" $ ib bctlDec
, KeyBinding "M-M1-," "backlight min" $ ib bctlMin
@ -690,25 +853,27 @@ externalBindings ts db =
, KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
-- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" restartf
, -- M-<F1> reserved for showing the keymap
KeyBinding "M-<F2>" "restart xmonad" restartf
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle ses
, KeyBinding "M-<F8>" "select autorandr profile" $ Left $ toX runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" $ Left $ toX runToggleEthernet
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ toX $ callToggle ses
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
]
]
where
ses = dbSesClient db
sys = dbSysClient db
brightessControls ctl getter = (ioSometimes . getter . ctl) ses
brightessControls ctl getter = (toX . getter . ctl) ses
ib = Left . brightessControls intelBacklightControls
ck = Left . brightessControls clevoKeyboardControls
ftrAlways n = Right . Always n . Always_ . FallbackAlone
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
restartf = ftrAlways "restart function" (cleanup >> runRestart)
recompilef = ftrAlways "recompile function" runRecompile
toX_ = liftIO . runIO
toX = fmap toX_
type MaybeX = Maybe (X ())

14
fourmolu.yaml Normal file
View File

@ -0,0 +1,14 @@
indentation: 2
function-arrows: leading
comma-style: leading
import-export-style: leading
indent-wheres: true
record-brace-space: true
newlines-between-decls: 1
haddock-style: single-line
haddock-style-module:
let-style: inline
in-style: right-align
respectful: false
fixities: []
unicode: never

405
lib/Data/Internal/DBus.hs
View File

@ -1,10 +1,18 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Common internal DBus functions
-- Common internal DBus functions
module Data.Internal.DBus
( SafeClient (..)
, SysClient (..)
, SesClient (..)
, DBusEnv (..)
, DIO
, HasClient (..)
, withDIO
, addMatchCallback
, matchProperty
, matchPropertyFull
@ -25,43 +33,53 @@ module Data.Internal.DBus
, addInterfaceRemovedListener
, fromSingletonVariant
, bodyToMaybe
) where
import Control.Exception
import Control.Monad
import Data.Bifunctor
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified RIO.Text as T
, exportPair
, displayBusName
, displayObjectPath
, displayMemberName
, displayInterfaceName
, displayWrapQuote
)
where
import DBus
import DBus.Client
import qualified Data.ByteString.Char8 as BC
import RIO
import RIO.List
import qualified RIO.Map as M
import qualified RIO.Text as T
--------------------------------------------------------------------------------
-- | Type-safe client
-- Type-safe client
class SafeClient c where
toClient :: c -> Client
getDBusClient :: IO (Maybe c)
getDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m (Maybe c)
disconnectDBusClient :: c -> IO ()
disconnectDBusClient = disconnect . toClient
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
disconnectDBusClient = liftIO . disconnect . toClient
withDBusClient :: (c -> IO a) -> IO (Maybe a)
withDBusClient f = do
client <- getDBusClient
forM client $ \c -> do
r <- f c
disconnect (toClient c)
return r
withDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m a)
-> m (Maybe a)
withDBusClient f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
withDBusClient_ :: (c -> IO ()) -> IO ()
withDBusClient_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m ())
-> m ()
withDBusClient_ = void . withDBusClient
fromDBusClient :: (c -> a) -> IO (Maybe a)
fromDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> a)
-> m (Maybe a)
fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client
@ -78,46 +96,101 @@ instance SafeClient SesClient where
getDBusClient = fmap SesClient <$> getDBusClient' False
getDBusClient' :: Bool -> IO (Maybe Client)
getDBusClient'
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Bool
-> m (Maybe Client)
getDBusClient' sys = do
res <- try $ if sys then connectSystem else connectSession
res <- try $ liftIO $ if sys then connectSystem else connectSession
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Left e -> do
logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
return Nothing
Right c -> return $ Just c
data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}
type DIO env c = RIO (DBusEnv env c)
instance HasClient (DBusEnv SimpleApp) where
clientL = lens dClient (\x y -> x {dClient = y})
instance SafeClient c => HasLogFunc (DBusEnv SimpleApp c) where
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
withDIO
:: (MonadUnliftIO m, MonadReader env m, SafeClient c)
=> c
-> DIO env c a
-> m a
withDIO cl x = do
env <- ask
runRIO (DBusEnv cl env) x
class HasClient env where
clientL :: SafeClient c => Lens' (env c) c
--------------------------------------------------------------------------------
-- | Methods
-- Methods
type MethodBody = Either T.Text [Variant]
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl)
callMethod'
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> MethodCall
-> m MethodBody
callMethod' mc = do
cl <- toClient <$> view clientL
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> IO MethodBody
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
callMethod
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> m MethodBody
callMethod bus path iface = callMethod' . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCallBus b p i m = (methodCall p i m)
{ methodCallDestination = Just b }
methodCallBus b p i m =
(methodCall p i m)
{ methodCallDestination = Just b
}
--------------------------------------------------------------------------------
-- | Bus names
-- Bus names
dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
callGetNameOwner
:: ( SafeClient c
, MonadUnliftIO m
, MonadReader (env c) m
, HasClient env
, HasLogFunc (env c)
)
=> BusName
-> m (Maybe BusName)
callGetNameOwner name = do
res <- callMethod' mc
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
return Nothing
Right body -> return $ fromSingletonVariant body
where
mc = (methodCallBus dbusName dbusPath dbusInterface mem)
{ methodCallBody = [toVariant name] }
mc =
(methodCallBus dbusName dbusPath dbusInterface mem)
{ methodCallBody = [toVariant name]
}
mem = memberName_ "GetNameOwner"
--------------------------------------------------------------------------------
-- | Variant parsing
-- Variant parsing
-- TODO log failures here?
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe
@ -125,30 +198,72 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
bodyToMaybe = either (const Nothing) fromSingletonVariant
--------------------------------------------------------------------------------
-- | Signals
-- Signals
type SignalCallback = [Variant] -> IO ()
type SignalCallback m = [Variant] -> m ()
addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
-> IO SignalHandler
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
addMatchCallback
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> MatchRule
-> SignalCallback m
-> m SignalHandler
addMatchCallback rule cb = do
cl <- toClient <$> view clientL
withRunInIO $ \run -> do
addMatch cl rule $ run . cb . signalBody
matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
-> Maybe MemberName -> MatchRule
matchSignal b p i m = matchAny
matchSignal
:: Maybe BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> MatchRule
matchSignal b p i m =
matchAny
{ matchPath = p
, matchSender = b
, matchInterface = i
, matchMember = m
}
matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
-> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
matchSignalFull
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> m (Maybe MatchRule)
matchSignalFull b p i m = do
res <- callGetNameOwner b
case res of
Just o -> return $ Just $ matchSignal (Just o) p i m
Nothing -> do
logError msg
return Nothing
where
bus_ = displayWrapQuote $ displayBusName b
iface_ = displayWrapQuote . displayInterfaceName <$> i
path_ = displayWrapQuote . displayObjectPath <$> p
mem_ = displayWrapQuote . displayMemberName <$> m
match =
intersperse ", " $
mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $
zip ["interface", "path", "member"] [iface_, path_, mem_]
stem = "could not get match rule for bus " <> bus_
msg = if null match then stem else stem <> " where " <> mconcat match
--------------------------------------------------------------------------------
-- | Properties
-- Properties
propertyInterface :: InterfaceName
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
@ -156,35 +271,64 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"
callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
-> MemberName -> c -> IO [Variant]
callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
$ getProperty (toClient cl) $ methodCallBus bus path iface property
callPropertyGet
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
)
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> m [Variant]
callPropertyGet bus path iface property = do
cl <- toClient <$> view clientL
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
case res of
Left err -> do
logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
return []
Right v -> return [v]
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
-> IO (Maybe MatchRule)
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> Maybe ObjectPath
-> m (Maybe MatchRule)
matchPropertyFull b p =
matchSignalFull b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
withSignalMatch f (Match x) = f (Just x)
withSignalMatch f Failure = f Nothing
withSignalMatch _ NoMatch = return ()
matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant]
matchPropertyChanged
:: IsVariant a
=> InterfaceName
-> T.Text
-> [Variant]
-> SignalMatch a
matchPropertyChanged iface property [i, body, _] =
let i' = (fromVariant i :: Maybe T.Text)
b = toMap body in
case (i', b) of
(Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then
maybe NoMatch Match $ fromVariant =<< M.lookup property b'
b = toMap body
in case (i', b) of
(Just i'', Just b') ->
if i'' == T.pack (formatInterfaceName iface)
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
else NoMatch
_ -> Failure
where
@ -192,7 +336,7 @@ matchPropertyChanged iface property [i, body, _] =
matchPropertyChanged _ _ _ = Failure
--------------------------------------------------------------------------------
-- | Object Manager
-- Object Manager
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
@ -208,24 +352,117 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
-> IO ObjectTree
callGetManagedObjects cl bus path =
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
<$> callMethod cl bus path omInterface getManagedObjects
callGetManagedObjects
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> m ObjectTree
callGetManagedObjects bus path = do
res <- callMethod bus path omInterface getManagedObjects
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
return M.empty
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
-> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl
addInterfaceChangedListener
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> MemberName
-> ObjectPath
-> SignalCallback m
-> m (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc = do
res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
case res of
Nothing -> do
logError $
"could not add listener for property"
<> prop_
<> " at path "
<> path_
<> " on bus "
<> bus_
return Nothing
Just rule -> Just <$> addMatchCallback rule sc
where
bus_ = "'" <> displayBusName bus <> "'"
path_ = "'" <> displayObjectPath path <> "'"
prop_ = "'" <> displayMemberName prop <> "'"
addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
-> SignalCallback -> c -> IO (Maybe SignalHandler)
addInterfaceAddedListener
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> SignalCallback m
-> m (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
-> SignalCallback -> c -> IO (Maybe SignalHandler)
addInterfaceRemovedListener
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
-> ObjectPath
-> SignalCallback m
-> m (Maybe SignalHandler)
addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved
--------------------------------------------------------------------------------
-- Interface export/unexport
exportPair
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> ObjectPath
-> (Client -> m Interface)
-> c
-> (m (), m ())
exportPair path toIface cl = (up, down)
where
cl_ = toClient cl
up = do
logInfo $ "adding interface: " <> path_
i <- toIface cl_
liftIO $ export cl_ path i
down = do
logInfo $ "removing interface: " <> path_
liftIO $ unexport cl_ path
path_ = displayObjectPath path
--------------------------------------------------------------------------------
-- logging helpers
displayBusName :: BusName -> Utf8Builder
displayBusName = displayBytesUtf8 . BC.pack . formatBusName
displayObjectPath :: ObjectPath -> Utf8Builder
displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath
displayMemberName :: MemberName -> Utf8Builder
displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName
displayInterfaceName :: InterfaceName -> Utf8Builder
displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName
displayWrapQuote :: Utf8Builder -> Utf8Builder
displayWrapQuote x = "'" <> x <> "'"

596
lib/Data/Internal/Dependency.hs → lib/Data/Internal/XIO.hs
View File

File diff suppressed because it is too large Load Diff

176
lib/XMonad/Internal/Command/DMenu.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Dmenu (Rofi) Commands
-- Dmenu (Rofi) Commands
module XMonad.Internal.Command.DMenu
( runCmdMenu
@ -15,35 +15,31 @@ module XMonad.Internal.Command.DMenu
, runBTMenu
, runShowKeys
, runAutorandrMenu
) where
import Control.Monad.Reader
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import qualified Data.ByteString.Char8 as BC
import Data.Internal.DBus
import Data.Internal.XIO
import Graphics.X11.Types
import qualified RIO.Text as T
import System.Directory
import RIO
import qualified RIO.ByteString as B
import RIO.Directory
( XdgDirectory (..)
, getXdgDirectory
)
import System.IO
import qualified RIO.Text as T
-- import System.IO
import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import XMonad.Internal.Notify
import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Util.NamedActions
--------------------------------------------------------------------------------
-- | DMenu executables
-- DMenu executables
myDmenuCmd :: FilePath
myDmenuCmd = "rofi"
@ -70,7 +66,7 @@ myClipboardManager :: FilePath
myClipboardManager = "greenclip"
--------------------------------------------------------------------------------
-- | Packages
-- Packages
dmenuPkgs :: [Fulfillment]
dmenuPkgs = [Package Official "rofi"]
@ -79,9 +75,9 @@ clipboardPkgs :: [Fulfillment]
clipboardPkgs = [Package AUR "rofi-greenclip"]
--------------------------------------------------------------------------------
-- | Other internal functions
-- Other internal functions
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
spawnDmenuCmd n =
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
@ -101,111 +97,153 @@ dmenuDep :: IODependency_
dmenuDep = sysExe dmenuPkgs myDmenuCmd
--------------------------------------------------------------------------------
-- | Exported Commands
-- Exported Commands
-- TODO test that veracrypt and friends are installed
runDevMenu :: SometimesX
runDevMenu :: MonadUnliftIO m => Sometimes (m ())
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
where
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
x = do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
spawnCmd myDmenuDevices
$ ["-c", T.pack c]
++ "--" : themeArgs "#999933"
spawnCmd myDmenuDevices $
["-c", T.pack c]
++ "--"
: themeArgs "#999933"
++ myDmenuMatchingArgs
-- TODO test that bluetooth interface exists
runBTMenu :: SometimesX
runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
runBTMenu :: MonadUnliftIO m => Sometimes (m ())
runBTMenu =
Sometimes
"bluetooth selector"
xpfBluetooth
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
where
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
runVPNMenu :: SometimesX
runVPNMenu = Sometimes "VPN selector" xpfVPN
runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
runVPNMenu =
Sometimes
"VPN selector"
xpfVPN
[Subfeature (IORoot_ cmd tree) "rofi VPN"]
where
cmd = spawnCmd myDmenuVPN
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN)
$ socketExists "expressVPN" []
$ return "/var/lib/expressvpn/expressvpnd.socket"
cmd =
spawnCmd myDmenuVPN $
["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
tree =
dmenuTree $
toAnd_ (localExe [] myDmenuVPN) $
socketExists "expressVPN" [] $
return "/var/lib/expressvpn/expressvpnd.socket"
runCmdMenu :: SometimesX
runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
runAppMenu :: SometimesX
runAppMenu :: MonadUnliftIO m => Sometimes (m ())
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runWinMenu :: SometimesX
runWinMenu :: MonadUnliftIO m => Sometimes (m ())
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: Maybe SysClient -> SometimesX
runNetMenu cl = Sometimes "network control menu" enabled
runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
runNetMenu cl =
Sometimes
"network control menu"
enabled
[Subfeature root "network control menu"]
where
enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
root = DBusRoot_ cmd tree cl
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus)
$ toAnd_ (DBusIO dmenuDep) $ DBusIO
$ sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
tree =
And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
toAnd_ (DBusIO dmenuDep) $
DBusIO $
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
runAutorandrMenu :: SometimesX
runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
where
cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
--------------------------------------------------------------------------------
-- | Password manager
-- Password manager
runBwMenu :: Maybe SesClient -> SometimesX
runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
where
cmd _ = spawnCmd myDmenuPasswords
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden")
$ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
cmd _ =
spawnCmd myDmenuPasswords $
["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
tree =
And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
--------------------------------------------------------------------------------
-- | Clipboard
-- Clipboard
runClipMenu :: SometimesX
runClipMenu :: MonadUnliftIO m => Sometimes (m ())
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
where
act = spawnCmd myDmenuCmd args
tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
tree =
listToAnds
dmenuDep
[ sysExe clipboardPkgs myClipboardManager
, process [] $ T.pack myClipboardManager
]
args = [ "-modi", "\"clipboard:greenclip print\""
, "-show", "clipboard"
, "-run-command", "'{cmd}'"
] ++ themeArgs "#00c44e"
args =
[ "-modi"
, "\"clipboard:greenclip print\""
, "-show"
, "clipboard"
, "-run-command"
, "'{cmd}'"
]
++ themeArgs "#00c44e"
--------------------------------------------------------------------------------
-- | Shortcut menu
-- Shortcut menu
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
$ FallbackAlone fallback
runShowKeys
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Always ([((KeyMask, KeySym), NamedAction)] -> m ())
runShowKeys =
Always "keyboard menu" $
Option showKeysDMenu $
Always_ $
FallbackAlone fallback
where
-- TODO this should technically depend on dunst
fallback = const $ spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" }
fallback =
const $
spawnNotify $
defNoteError {body = Just $ Text "could not display keymap"}
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
showKeysDMenu = Subfeature
showKeysDMenu
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
showKeysDMenu =
Subfeature
{ sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ dmenuDep
}
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
showKeys kbs = io $ do
(h, _, _, _) <- createProcess' $ (shell' $ T.unpack cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
showKeys
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [((KeyMask, KeySym), NamedAction)]
-> m ()
showKeys kbs = do
h <- spawnPipe cmd
B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
hClose h
where
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
cmd =
fmtCmd myDmenuCmd $
["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff"
++ myDmenuMatchingArgs

244
lib/XMonad/Internal/Command/Desktop.hs
View File

@ -1,12 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | General commands
-- General commands
module XMonad.Internal.Command.Desktop
( myTerm
, playSound
-- commands
, runTerm
, runTMux
@ -33,40 +32,32 @@ module XMonad.Internal.Command.Desktop
, runNotificationCloseAll
, runNotificationHistory
, runNotificationContext
-- daemons
, runNetAppDaemon
-- packages
, networkManagerPkgs
) where
import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import RIO.Directory
import RIO.FilePath
import qualified RIO.Process as P
import qualified RIO.Text as T
import System.Directory
import System.Environment
import System.Posix.User
import XMonad (asks)
import UnliftIO.Environment
import XMonad.Actions.Volume
import XMonad.Core hiding (spawn)
import XMonad.Internal.DBus.Common
import XMonad.Internal.Notify
import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Internal.Shell as S
import XMonad.Operations
--------------------------------------------------------------------------------
-- | My Executables
-- My Executables
myTerm :: FilePath
myTerm = "urxvt"
@ -99,10 +90,11 @@ myNotificationCtrl :: FilePath
myNotificationCtrl = "dunstctl"
--------------------------------------------------------------------------------
-- | Packages
-- Packages
myTermPkgs :: [Fulfillment]
myTermPkgs = [ Package Official "rxvt-unicode"
myTermPkgs =
[ Package Official "rxvt-unicode"
, Package Official "urxvt-perls"
]
@ -119,78 +111,101 @@ networkManagerPkgs :: [Fulfillment]
networkManagerPkgs = [Package Official "networkmanager"]
--------------------------------------------------------------------------------
-- | Misc constants
-- Misc constants
volumeChangeSound :: FilePath
volumeChangeSound = "smb_fireball.wav"
--------------------------------------------------------------------------------
-- | Some nice apps
-- Some nice apps
runTerm :: SometimesX
runTerm :: MonadUnliftIO m => Sometimes (m ())
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
runTMux :: SometimesX
runTMux :: MonadUnliftIO m => Sometimes (m ())
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
where
deps = listToAnds (socketExists "tmux" [] socketName)
$ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
act = spawn
$ T.unpack
$ fmtCmd "tmux" ["has-session"]
deps =
listToAnds (socketExists "tmux" [] socketName) $
fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
act =
S.spawn $
fmtCmd "tmux" ["has-session"]
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
#!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
c = "exec tmux attach-session -d"
msg = "could not connect to tmux session"
socketName = do
u <- getEffectiveUserID
u <- liftIO getEffectiveUserID
t <- getTemporaryDirectory
return $ t </> "tmux-" ++ show u </> "default"
runCalc :: SometimesX
runCalc :: MonadUnliftIO m => Sometimes (m ())
runCalc = sometimesIO_ "calculator" "bc" deps act
where
deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
False myBrowser
runBrowser :: MonadUnliftIO m => Sometimes (m ())
runBrowser =
sometimesExe
"web browser"
"brave"
[Package AUR "brave-bin"]
False
myBrowser
runEditor :: SometimesX
runEditor :: MonadUnliftIO m => Sometimes (m ())
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
where
cmd = spawnCmd myEditor
cmd =
spawnCmd
myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
-- NOTE 1: we could test if the emacs socket exists, but it won't come up
-- before xmonad starts, so just check to see if the process has started
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
runFileManager :: SometimesX
runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"]
True "pcmanfm"
runFileManager :: MonadUnliftIO m => Sometimes (m ())
runFileManager =
sometimesExe
"file browser"
"pcmanfm"
[Package Official "pcmanfm"]
True
"pcmanfm"
--------------------------------------------------------------------------------
-- | Multimedia Commands
-- Multimedia Commands
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
runMultimediaIfInstalled n cmd = sometimesExeArgs (T.append n " multimedia control")
"playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd]
runMultimediaIfInstalled
:: MonadUnliftIO m
=> T.Text
-> T.Text
-> Sometimes (m ())
runMultimediaIfInstalled n cmd =
sometimesExeArgs
(T.append n " multimedia control")
"playerctl"
[Package Official "playerctl"]
True
myMultimediaCtl
[cmd]
runTogglePlay :: SometimesX
runTogglePlay :: MonadUnliftIO m => Sometimes (m ())
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
runPrevTrack :: SometimesX
runPrevTrack :: MonadUnliftIO m => Sometimes (m ())
runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
runNextTrack :: SometimesX
runNextTrack :: MonadUnliftIO m => Sometimes (m ())
runNextTrack = runMultimediaIfInstalled "next track" "next"
runStopPlay :: SometimesX
runStopPlay :: MonadUnliftIO m => Sometimes (m ())
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
--------------------------------------------------------------------------------
-- | Volume Commands
-- Volume Commands
soundDir :: FilePath
soundDir = "sound"
@ -202,111 +217,140 @@ playSound file = do
-- paplay seems to have less latency than aplay
spawnCmd "paplay" [T.pack p]
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
featureSound
:: MonadUnliftIO m
=> T.Text
-> FilePath
-> m ()
-> m ()
-> Sometimes (m ())
featureSound n file pre post =
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree
$ pre >> playSound file >> post
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
pre >> playSound file >> post
where
-- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
-- to play sound (duh) but libpulse is the package with the paplay binary
tree = Only_ $ sysExe [Package Official "pulseaudio"] "paplay"
runVolumeDown :: SometimesX
runVolumeDown :: MonadUnliftIO m => Sometimes (m ())
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
runVolumeUp :: SometimesX
runVolumeUp :: MonadUnliftIO m => Sometimes (m ())
runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
runVolumeMute :: SometimesX
runVolumeMute :: MonadUnliftIO m => Sometimes (m ())
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
--------------------------------------------------------------------------------
-- | Notification control
-- Notification control
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
runNotificationCmd
:: MonadUnliftIO m
=> T.Text
-> T.Text
-> Maybe SesClient
-> Sometimes (m ())
runNotificationCmd n arg cl =
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
where
cmd _ = spawnCmd myNotificationCtrl [arg]
tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
$ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
$ Method_ $ memberName_ "NotificationAction"
tree =
toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $
Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $
Method_ $
memberName_ "NotificationAction"
runNotificationClose :: Maybe SesClient -> SometimesX
runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationClose = runNotificationCmd "close notification" "close"
runNotificationCloseAll :: Maybe SesClient -> SometimesX
runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationCloseAll =
runNotificationCmd "close all notifications" "close-all"
runNotificationHistory :: Maybe SesClient -> SometimesX
runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationHistory =
runNotificationCmd "see notification history" "history-pop"
runNotificationContext :: Maybe SesClient -> SometimesX
runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runNotificationContext =
runNotificationCmd "open notification context" "context"
--------------------------------------------------------------------------------
-- | System commands
-- System commands
-- this is required for some vpn's to work properly with network-manager
runNetAppDaemon :: Maybe SysClient -> Sometimes (IO ProcessHandle)
runNetAppDaemon cl = Sometimes "network applet" xpfVPN
runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
runNetAppDaemon cl =
Sometimes
"network applet"
xpfVPN
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
where
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
cmd _ = snd <$> spawnPipe "nm-applet"
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
runToggleBluetooth :: Maybe SysClient -> SometimesX
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
runToggleBluetooth cl =
Sometimes
"bluetooth toggle"
xpfBluetooth
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
where
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
cmd _ = spawn
$ T.unpack
$ T.unwords [T.pack myBluetooth, "show | grep -q \"Powered: no\""]
cmd _ =
S.spawn $
fmtCmd myBluetooth ["show"]
#!| "grep -q \"Powered: no\""
#!&& "a=on"
#!|| "a=off"
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
runToggleEthernet :: SometimesX
runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
runToggleEthernet :: MonadUnliftIO m => Sometimes (m ())
runToggleEthernet =
Sometimes
"ethernet toggle"
xpfEthernet
[Subfeature root "nmcli"]
where
root = IORoot (spawn . T.unpack . cmd) $ And1 (Only readEthernet) $ Only_
$ sysExe networkManagerPkgs "nmcli"
root =
IORoot cmd $
And1 (Only readEthernet) $
Only_ $
sysExe networkManagerPkgs "nmcli"
-- TODO make this less noisy
cmd iface =
T.unwords ["nmcli -g GENERAL.STATE device show", iface, "| grep -q disconnected"]
S.spawn $
fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
#!| "grep -q disconnected"
#!&& "a=connect"
#!|| "a=disconnect"
#!>> fmtCmd "nmcli" ["device", "$a", iface]
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
--------------------------------------------------------------------------------
-- | Configuration commands
-- Configuration commands
runRestart :: X ()
runRestart = restart "xmonad" True
-- TODO use rio in here so I don't have to fill my xinit log with stack poop
-- TODO only recompile the VM binary if we have virtualbox enabled
runRecompile :: X ()
runRecompile = do
-- assume that the conf directory contains a valid stack project
confDir <- asks (cfgDir . directories)
spawnAt confDir
$ T.unpack
$ fmtCmd "stack" ["install"]
spawn $
fmtCmd "cd" [T.pack confDir]
#!&& fmtCmd "stack" ["install"]
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
#!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}
--------------------------------------------------------------------------------
-- | Screen capture commands
-- Screen capture commands
getCaptureDir :: IO FilePath
getCaptureDir :: MonadIO m => m FilePath
getCaptureDir = do
e <- lookupEnv "XDG_DATA_HOME"
parent <- case e of
@ -320,28 +364,38 @@ getCaptureDir = do
where
fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
runFlameshot
:: MonadUnliftIO m
=> T.Text
-> T.Text
-> Maybe SesClient
-> Sometimes (m ())
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
where
cmd _ = spawnCmd myCapture [mode]
tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture)
$ Bus [] $ busName_ "org.flameshot.Flameshot"
tree =
toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $
Bus [] $
busName_ "org.flameshot.Flameshot"
-- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix
runAreaCapture :: Maybe SesClient -> SometimesX
runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runAreaCapture = runFlameshot "screen area capture" "gui"
-- myWindowCap = "screencap -w" --external script
runDesktopCapture :: Maybe SesClient -> SometimesX
runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runDesktopCapture = runFlameshot "fullscreen capture" "full"
runScreenCapture :: Maybe SesClient -> SometimesX
runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
(Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
dir <- io getCaptureDir
runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())
runCaptureBrowser = sometimesIO_
"screen capture browser"
"feh"
(Only_ $ sysExe [Package Official "feh"] myImageBrowser)
$ do
dir <- getCaptureDir
spawnCmd myImageBrowser [T.pack dir]

127
lib/XMonad/Internal/Command/Power.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Commands for controlling power
-- Commands for controlling power
module XMonad.Internal.Command.Power
-- commands
@ -14,10 +14,8 @@ module XMonad.Internal.Command.Power
, runSuspend
, runSuspendPrompt
, runQuitPrompt
-- daemons
, runAutolock
-- functions
, hasBattery
, suspendPrompt
@ -25,35 +23,25 @@ module XMonad.Internal.Command.Power
, powerPrompt
, defFontPkgs
, promptFontDep
) where
import Control.Arrow (first)
import Data.Internal.Dependency
import Data.Either
import qualified Data.Map as M
)
where
import Data.Internal.XIO
import Graphics.X11.Types
import RIO
import RIO.Directory
import RIO.FilePath
import qualified RIO.Map as M
import qualified RIO.Process as P
import qualified RIO.Text as T
import System.Directory
import System.Exit
import System.IO.Error
import System.Process (ProcessHandle)
import XMonad.Core
import XMonad.Internal.Process (spawnPipeArgs)
import XMonad.Core hiding (spawn)
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as XT
import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt
--------------------------------------------------------------------------------
-- | Executables
-- Executables
myScreenlock :: FilePath
myScreenlock = "screenlock"
@ -64,42 +52,49 @@ myPrimeOffload :: FilePath
myPrimeOffload = "prime-offload"
--------------------------------------------------------------------------------
-- | Packages
-- Packages
optimusPackages :: [Fulfillment]
optimusPackages = [Package AUR "optimus-manager"]
--------------------------------------------------------------------------------
-- | Core commands
-- Core commands
runScreenLock :: SometimesX
runScreenLock = sometimesExe "screen locker" "i3lock script"
[Package AUR "i3lock-color"] False myScreenlock
runScreenLock =
sometimesExe
"screen locker"
"i3lock script"
[Package AUR "i3lock-color"]
False
myScreenlock
runPowerOff :: X ()
runPowerOff :: MonadUnliftIO m => m ()
runPowerOff = spawn "systemctl poweroff"
runSuspend :: X ()
runSuspend :: MonadUnliftIO m => m ()
runSuspend = spawn "systemctl suspend"
runHibernate :: X ()
runHibernate :: MonadUnliftIO m => m ()
runHibernate = spawn "systemctl hibernate"
runReboot :: X ()
runReboot :: MonadUnliftIO m => m ()
runReboot = spawn "systemctl reboot"
--------------------------------------------------------------------------------
-- | Autolock
-- Autolock
runAutolock :: Sometimes (IO ProcessHandle)
runAutolock :: Sometimes (XIO (P.Process () () ()))
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where
tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
$ Only_ $ IOSometimes_ runScreenLock
cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"]
tree =
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
Only_ $
IOSometimes_ runScreenLock
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
--------------------------------------------------------------------------------
-- | Confirmation prompts
-- Confirmation prompts
promptFontDep :: IOTree XT.FontBuilder
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
@ -111,7 +106,7 @@ confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
suspendPrompt :: XT.FontBuilder -> X ()
suspendPrompt = confirmPrompt' "suspend?" runSuspend
suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
quitPrompt :: XT.FontBuilder -> X ()
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
@ -127,21 +122,24 @@ runQuitPrompt :: SometimesX
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
--------------------------------------------------------------------------------
-- | Nvidia Optimus
-- Nvidia Optimus
-- TODO for some reason the screen never wakes up after suspend when
-- the nvidia card is up, so block suspend if nvidia card is running
-- and warn user
isUsingNvidia :: IO Bool
isUsingNvidia :: MonadUnliftIO m => m Bool
isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
hasBattery :: IO (Maybe T.Text)
hasBattery :: MonadUnliftIO m => m (Maybe T.Text)
hasBattery = do
ps <- fromRight [] <$> tryIOError (listDirectory syspath)
ts <- mapM readType ps
return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
ps <- fromRight [] <$> tryIO (listDirectory syspath)
ts <- catMaybes <$> mapM readType ps
return $
if any (T.isPrefixOf "Battery") ts
then Nothing
else Just "battery not found"
where
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
readType p = either (const Nothing) Just <$> tryIO (readFileUtf8 $ syspath </> p </> "type")
syspath = "/sys/class/power_supply"
runOptimusPrompt' :: XT.FontBuilder -> X ()
@ -151,27 +149,32 @@ runOptimusPrompt' fb = do
where
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
prompt mode = T.concat ["gpu switch to ", mode, "?"]
cmd mode = spawn $
T.unpack
$ T.pack myPrimeOffload
cmd mode =
spawn $
T.pack myPrimeOffload
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad"
runOptimusPrompt :: SometimesX
runOptimusPrompt = Sometimes "graphics switcher"
(\x -> xpfOptimus x && xpfBattery x) [s]
runOptimusPrompt =
Sometimes
"graphics switcher"
(\x -> xpfOptimus x && xpfBattery x)
[s]
where
s = Subfeature {sfData = r, sfName = "optimus manager"}
r = IORoot runOptimusPrompt' t
t = And1 promptFontDep
$ listToAnds (socketExists "optimus-manager" [] socketName)
$ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
t =
And1 promptFontDep $
listToAnds (socketExists "optimus-manager" [] socketName) $
sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
socketName = (</> "optimus-manager") <$> getTemporaryDirectory
--------------------------------------------------------------------------------
-- | Universal power prompt
-- Universal power prompt
data PowerMaybeAction = Poweroff
data PowerMaybeAction
= Poweroff
| Shutdown
| Hibernate
| Reboot
@ -207,9 +210,11 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
where
comp = mkComplFunFromList theme []
theme = (XT.promptTheme fb) {promptKeymap = keymap}
keymap = M.fromList
$ ((controlMask, xK_g), quit) :
map (first $ (,) 0)
keymap =
M.fromList $
((controlMask, xK_g), quit)
: map
(first $ (,) 0)
[ (xK_p, sendMaybeAction Poweroff)
, (xK_s, sendMaybeAction Shutdown)
, (xK_h, sendMaybeAction Hibernate)
@ -219,7 +224,7 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
]
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeMaybeAction a = case toEnum $ read a of
Poweroff -> runPowerOff
Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate
Reboot -> runReboot
Poweroff -> liftIO runPowerOff
Shutdown -> lock >> liftIO runSuspend
Hibernate -> lock >> liftIO runHibernate
Reboot -> liftIO runReboot

62
lib/XMonad/Internal/Concurrent/ACPIEvent.hs
View File

@ -2,26 +2,19 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Concurrent module to handle events from acpid
-- Concurrent module to handle events from acpid
module XMonad.Internal.Concurrent.ACPIEvent
( runPowermon
, runHandleACPI
) where
import Control.Exception
import Control.Monad
import Data.ByteString hiding (readFile)
import Data.ByteString.Char8 as C hiding (readFile)
import Data.Connection
import Data.Internal.Dependency
import Text.Read (readMaybe)
import System.IO.Streams as S (read)
import System.IO.Streams.UnixSocket
)
where
import Data.Internal.XIO
import Network.Socket
import Network.Socket.ByteString
import RIO
import qualified RIO.ByteString as B
import XMonad.Core
import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage
@ -29,12 +22,13 @@ import XMonad.Internal.Shell
import XMonad.Internal.Theme (FontBuilder)
--------------------------------------------------------------------------------
-- | Data structure to hold the ACPI events I care about
-- Data structure to hold the ACPI events I care about
--
-- Enumerate so these can be converted to strings and back when sent in a
-- ClientMessage event to X
data ACPIEvent = Power
data ACPIEvent
= Power
| Sleep
| LidClose
deriving (Eq)
@ -50,7 +44,7 @@ instance Enum ACPIEvent where
fromEnum LidClose = 2
--------------------------------------------------------------------------------
-- | Internal functions
-- Internal functions
-- | Convert a string to an ACPI event (this string is assumed to come from
-- the acpid socket)
@ -64,7 +58,9 @@ parseLine line =
(_ : "LID" : "close" : _) -> Just LidClose
_ -> Nothing
where
splitLine = C.words . C.reverse . C.dropWhile (== '\n') . C.reverse
splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
newline = 10
space = 32
-- | Send an ACPIEvent to the X server as a ClientMessage
sendACPIEvent :: ACPIEvent -> IO ()
@ -72,20 +68,18 @@ sendACPIEvent = sendXMsg ACPI . show . fromEnum
isDischarging :: IO (Maybe Bool)
isDischarging = do
status <- try $ readFile "/sys/class/power_supply/BAT0/status"
:: IO (Either IOException String)
status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
case status of
Left _ -> return Nothing
Right s -> return $ Just (s == "Discharging")
listenACPI :: IO ()
listenACPI = do
Connection { source = s } <- connect acpiPath
forever $ readStream s
where
readStream s = do
out <- S.read s
mapM_ sendACPIEvent $ parseLine =<< out
sock <- socket AF_UNIX Stream defaultProtocol
connect sock $ SockAddrUnix acpiPath
forever $ do
out <- recv sock 1024
mapM_ sendACPIEvent $ parseLine out
acpiPath :: FilePath
acpiPath = "/var/run/acpid.socket"
@ -104,22 +98,24 @@ handleACPI fb lock tag = do
LidClose -> do
status <- io isDischarging
-- only run suspend if battery exists and is discharging
forM_ status $ flip when runSuspend
forM_ status $ flip when $ liftIO runSuspend
lock
--------------------------------------------------------------------------------
-- | Exported API
-- Exported API
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them
runPowermon :: SometimesIO
runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI
runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep $ io listenACPI
runHandleACPI :: Always (String -> X ())
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
where
sf = Subfeature withLock "acpid prompt"
withLock = IORoot (uncurry handleACPI)
$ And12 (,) promptFontDep $ Only
$ IOSometimes runScreenLock id
withLock =
IORoot (uncurry handleACPI) $
And12 (,) promptFontDep $
Only $
IOSometimes runScreenLock id
fallback = Always_ $ FallbackAlone $ const skip

23
lib/XMonad/Internal/Concurrent/ClientMessage.hs
View File

@ -1,5 +1,5 @@
--------------------------------------------------------------------------------
-- | Core ClientMessage module to 'achieve' concurrency in XMonad
-- Core ClientMessage module to 'achieve' concurrency in XMonad
--
-- Since XMonad is single threaded, the only way to have multiple threads that
-- listen/react to non-X events is to spawn other threads the run outside of
@ -19,23 +19,25 @@ module XMonad.Internal.Concurrent.ClientMessage
( XMsgType (..)
, sendXMsg
, splitXMsg
) where
)
where
import Data.Char
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import XMonad.Internal.IO
--------------------------------------------------------------------------------
-- | Data structure for the ClientMessage
-- Data structure for the ClientMessage
--
-- These are the "types" of client messages to send; add more here as needed
-- TODO is there a way to do this in the libraries that import this one?
data XMsgType = ACPI
data XMsgType
= ACPI
| Workspace
| Unknown
deriving (Eq, Show)
@ -50,7 +52,7 @@ instance Enum XMsgType where
fromEnum Unknown = 2
--------------------------------------------------------------------------------
-- | Exported API
-- Exported API
-- | Given a string from the data field in a ClientMessage event, return the
-- type and payload
@ -58,13 +60,12 @@ splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
splitXMsg [] = (Unknown, "")
splitXMsg (x : xs) = (xtype, tag)
where
xtype = toEnum $ fromInteger $ toInteger x
tag = map (chr . fromInteger . toInteger) $ takeWhile (/= 0) xs
xtype = toEnum $ fromIntegral x
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
-- | Emit a ClientMessage event to the X server with the given type and payloud
sendXMsg :: XMsgType -> String -> IO ()
sendXMsg xtype tag = do
dpy <- openDisplay ""
sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
root <- rootWindow dpy $ defaultScreen dpy
allocaXEvent $ \e -> do
setEventType e clientMessage
@ -84,8 +85,6 @@ sendXMsg xtype tag = do
-- for more details.
setClientMessageEvent' e root bITMAP 8 (x : t)
sendEvent dpy root False substructureNotifyMask e
flush dpy
closeDisplay dpy
where
x = fromIntegral $ fromEnum xtype
t = fmap (fromIntegral . fromEnum) tag

169
lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Automatically Manage Dynamic Workspaces
-- Automatically Manage Dynamic Workspaces
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
-- in the contrib library. The general behavior this allows:
-- 1) launch app
@ -33,25 +33,26 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
, runWorkspaceMon
, spawnOrSwitch
, doSink
) where
import Data.List (deleteBy, find)
import qualified Data.Map as M
import Data.Maybe
import Control.Concurrent
import Control.Monad
import Control.Monad.Reader
)
where
import qualified Data.ByteString.Char8 as BC
import Data.Internal.XIO
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Misc
import Graphics.X11.Xlib.Types
import RIO hiding
( Display
, display
)
import RIO.List (deleteBy, find)
import qualified RIO.Map as M
import qualified RIO.Set as S
import System.Process
import XMonad.Actions.DynamicWorkspaces
import XMonad.Core
( ManageHook
@ -62,14 +63,14 @@ import XMonad.Core
)
import XMonad.Hooks.ManageHelpers (MaybeManageHook)
import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Process
import XMonad.Internal.IO
import XMonad.ManageHook
import XMonad.Operations
import qualified XMonad.StackSet as W
--------------------------------------------------------------------------------
-- | Dynamic Workspace datatype
-- This hold all the data needed to tie an app to a particular dynamic workspace
-- Dynamic Workspace datatype
-- This holds all the data needed to tie an app to a particular dynamic workspace
data DynWorkspace = DynWorkspace
{ dwName :: String
@ -82,7 +83,7 @@ data DynWorkspace = DynWorkspace
}
--------------------------------------------------------------------------------
-- | Manager thread
-- Manager thread
-- The main thread that watches for new windows. When a match is found, this
-- thread spawns a new thread the waits for the PID of the window to exit. When
-- the PID exits, it sends a ClientMessage event to X
@ -91,79 +92,93 @@ data DynWorkspace = DynWorkspace
-- the same as that in XMonad itself (eg with Query types)
-- type MatchTags = M.Map String String
type WatchedPIDs = MVar [Pid]
data WConf = WConf
{ display :: Display
, dynWorkspaces :: [DynWorkspace]
data WEnv = WEnv
{ wDisplay :: !Display
, wDynWorkspaces :: ![DynWorkspace]
, wCurPIDs :: !(MVar (S.Set Pid))
, wXEnv :: !XEnv
}
newtype W a = W (ReaderT WConf IO a)
deriving (Functor, Monad, MonadIO, MonadReader WConf)
instance HasLogFunc WEnv where
logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
instance Applicative W where
pure = return
(<*>) = ap
type WIO a = RIO WEnv a
runW :: WConf -> W a -> IO a
runW c (W a) = runReaderT a c
runWorkspaceMon :: [DynWorkspace] -> IO ()
runWorkspaceMon dws = do
dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy
curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad
runWorkspaceMon :: [DynWorkspace] -> XIO ()
runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
root <- liftIO $ rootWindow dpy $ defaultScreen dpy
-- listen only for substructure change events (which includes MapNotify)
allocaSetWindowAttributes $ \a -> do
liftIO $ allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a
let c = WConf { display = dpy, dynWorkspaces = dws }
_ <- allocaXEvent $ \e ->
runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
return ()
withRunInIO $ \runIO -> do
void $ allocaXEvent $ runIO . withEvents dpy
where
wrapEnv dpy ps x =
WEnv
{ wDisplay = dpy
, wDynWorkspaces = dws
, wCurPIDs = ps
, wXEnv = x
}
withEvents dpy e = do
ps <- newMVar S.empty
mapRIO (wrapEnv dpy ps) $ do
forever $
handleEvent =<< io (nextEvent dpy e >> getEvent e)
handle :: WatchedPIDs -> Event -> W ()
handleEvent :: Event -> WIO ()
-- | assume this fires at least once when a new window is created (also could
-- use CreateNotify but that is really noisy)
handle curPIDs MapNotifyEvent { ev_window = w } = do
dpy <- asks display
handleEvent MapNotifyEvent {ev_window = w} = do
dpy <- asks wDisplay
hint <- io $ getClassHint dpy w
dws <- asks dynWorkspaces
let m = M.fromList $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
let tag = M.lookup (resClass hint) m
io $ forM_ tag $ \t -> do
a <- internAtom dpy "_NET_WM_PID" False
pid <- getWindowProperty32 dpy a w
dws <- asks wDynWorkspaces
let tag =
M.lookup (resClass hint) $
M.fromList $
fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws
forM_ tag $ \t -> do
a <- io $ internAtom dpy "_NET_WM_PID" False
pid <- io $ getWindowProperty32 dpy a w
case pid of
-- ASSUMPTION windows will only have one PID at one time
Just [p] -> let p' = fromIntegral p
in void $ forkIO $ withUniquePid curPIDs p' $ waitAndKill t p'
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
_ -> return ()
handleEvent _ = return ()
handle _ _ = return ()
waitAndKill :: String -> Pid -> IO ()
waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
withUniquePid curPIDs pid f = do
pids <- readMVar curPIDs
unless (pid `elem` pids) $ do
modifyMVar_ curPIDs (return . (pid:))
f
modifyMVar_ curPIDs (return . filter (/=pid))
withUniquePid :: Pid -> String -> WIO ()
withUniquePid pid tag = do
ps <- asks wCurPIDs
pids <- readMVar ps
unless (pid `elem` pids)
$ bracket_
(modifyMVar_ ps (return . S.insert pid))
(modifyMVar_ ps (return . S.delete pid))
$ do
logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
waitUntilExit pid
logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
liftIO $ sendXMsg Workspace tag
where
pid_ = "'" <> displayShow pid <> "'"
tag_ = "'" <> displayBytesUtf8 (BC.pack tag) <> "'"
--------------------------------------------------------------------------------
-- | Launching apps
-- Launching apps
-- When launching apps on dymamic workspaces, first check if they are running
-- and launch if not, then switch to their workspace
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust . W.stack)
wsOccupied tag ws =
elem tag $
map W.tag $
filter (isJust . W.stack)
-- list of all workspaces with windows on them
-- TODO is there not a better way to do this?
$ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
$
W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
spawnOrSwitch :: WorkspaceId -> X () -> X ()
spawnOrSwitch tag cmd = do
@ -171,7 +186,7 @@ spawnOrSwitch tag cmd = do
if occupied then windows $ W.view tag else cmd
--------------------------------------------------------------------------------
-- | Managehook
-- Managehook
-- Move windows to new workspace if they are part of a dynamic workspace
-- shamelessly ripped off from appendWorkspace (this analogue doesn't exist)
@ -196,25 +211,27 @@ doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
Nothing -> s
--------------------------------------------------------------------------------
-- | Eventhook
-- Eventhook
-- When an app is closed, this will respond the event that is sent in the main
-- XMonad thread
removeDynamicWorkspace :: WorkspaceId -> X ()
removeDynamicWorkspace target = windows removeIfEmpty
where
-- remove workspace if it is empty and if there are hidden workspaces
removeIfEmpty s@W.StackSet {W.visible = vis, W.hidden = hall@(h : hs)}
-- if hidden, delete from hidden
| Just x <- find isEmptyTarget hall
= s { W.hidden = deleteBy (eq W.tag) x hall }
| Just x <- find isEmptyTarget hall =
s {W.hidden = deleteBy (eq W.tag) x hall}
-- if visible, delete from visible and move first hidden to its place
| Just x <- find (isEmptyTarget . W.workspace) vis
= s { W.visible = x { W.workspace = h } : deleteBy (eq W.screen) x vis
, W.hidden = hs }
| Just x <- find (isEmptyTarget . W.workspace) vis =
s
{ W.visible = x {W.workspace = h} : deleteBy (eq W.screen) x vis
, W.hidden = hs
}
-- if current, move the first hidden workspace to the current
| isEmptyTarget $ W.workspace $ W.current s
= s { W.current = (W.current s) { W.workspace = h }, W.hidden = hs }
| isEmptyTarget $ W.workspace $ W.current s =
s {W.current = (W.current s) {W.workspace = h}, W.hidden = hs}
-- otherwise do nothing
| otherwise = s
removeIfEmpty s = s

27
lib/XMonad/Internal/Concurrent/VirtualBox.hs
View File

@ -2,26 +2,21 @@
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | VirtualBox-specific functions
-- VirtualBox-specific functions
module XMonad.Internal.Concurrent.VirtualBox
( vmExists
, vmInstanceConfig
, qual
) where
import Control.Exception
import Data.Internal.Dependency
import Text.XML.Light
)
where
import Data.Internal.XIO
import RIO hiding (try)
import RIO.Directory
import RIO.FilePath
import qualified RIO.Text as T
import System.Directory
import Text.XML.Light
import XMonad.Internal.Shell
vmExists :: T.Text -> IO (Maybe Msg)
@ -41,13 +36,15 @@ vmInstanceConfig vmName = do
vmDirectory :: IO (Either String String)
vmDirectory = do
p <- vmConfig
(s :: Either IOException String) <- try $ readFile p
s <- tryIO $ readFile p
return $ case s of
(Left _) -> Left "could not read VirtualBox config file"
(Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
$ findDir =<< parseXMLDoc x
(Right x) ->
maybe (Left "Could not parse VirtualBox config file") Right $
findDir =<< parseXMLDoc x
where
findDir e = findAttr (unqual "defaultMachineFolder")
findDir e =
findAttr (unqual "defaultMachineFolder")
=<< findChild (qual e "SystemProperties")
=<< findChild (qual e "Global") e

82
lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | DBus module for Clevo Keyboard control
-- DBus module for Clevo Keyboard control
module XMonad.Internal.DBus.Brightness.ClevoKeyboard
( callGetBrightnessCK
@ -10,24 +11,20 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
, clevoKeyboardControls
, clevoKeyboardSignalDep
, blPath
) where
import Control.Monad (when)
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.IO
--------------------------------------------------------------------------------
-- | Low level sysfs functions
--
-- Low level sysfs functions
type Brightness = Float
type RawBrightness = Int32
@ -50,41 +47,41 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
stateFile :: FilePath
stateFile = backlightDir </> "state"
stateChange :: Bool -> IO ()
stateChange :: MonadUnliftIO m => Bool -> m ()
stateChange = writeBool stateFile
stateOn :: IO ()
stateOn :: MonadUnliftIO m => m ()
stateOn = stateChange True
stateOff :: IO ()
stateOff :: MonadUnliftIO m => m ()
stateOff = stateChange False
brightnessFile :: FilePath
brightnessFile = backlightDir </> "brightness"
getBrightness :: RawBounds -> IO Brightness
getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
getBrightness bounds = readPercent bounds brightnessFile
minBrightness :: RawBounds -> IO Brightness
minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
minBrightness bounds = do
b <- writePercentMin bounds brightnessFile
stateOff
return b
maxBrightness :: RawBounds -> IO Brightness
maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
incBrightness :: RawBounds -> IO Brightness
incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
decBrightness :: RawBounds -> IO Brightness
decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
decBrightness bounds = do
b <- decPercent steps brightnessFile bounds
when (b == 0) stateOff
return b
--------------------------------------------------------------------------------
-- | DBus interface
-- DBus interface
blPath :: ObjectPath
blPath = objectPath_ "/clevo_keyboard"
@ -92,8 +89,9 @@ blPath = objectPath_ "/clevo_keyboard"
interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness"
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
clevoKeyboardConfig = BrightnessConfig
clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
clevoKeyboardConfig =
BrightnessConfig
{ bcMin = minBrightness
, bcMax = maxBrightness
, bcInc = incBrightness
@ -107,7 +105,7 @@ clevoKeyboardConfig = BrightnessConfig
}
--------------------------------------------------------------------------------
-- | Exported haskell API
-- Exported haskell API
stateFileDep :: IODependency_
stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
@ -116,17 +114,39 @@ brightnessFileDep :: IODependency_
brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
clevoKeyboardSignalDep :: DBusDependency_ SesClient
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
clevoKeyboardSignalDep =
-- TODO do I need to get rid of the IO here?
signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
exportClevoKeyboard :: Maybe SesClient -> SometimesIO
exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
[stateFileDep, brightnessFileDep] clevoKeyboardConfig
exportClevoKeyboard
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe SesClient
-> Sometimes (m (), m ())
exportClevoKeyboard =
brightnessExporter
xpfClevoBacklight
[]
[stateFileDep, brightnessFileDep]
clevoKeyboardConfig
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
clevoKeyboardControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
-> BrightnessControls m
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
callGetBrightnessCK
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
=> m (Maybe Brightness)
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
matchSignalCK
:: ( SafeClient c
, HasLogFunc (env c)
, HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
)
=> (Maybe Brightness -> m ())
-> m ()
matchSignalCK = matchSignal clevoKeyboardConfig

163
lib/XMonad/Internal/DBus/Brightness/Common.hs
View File

@ -1,7 +1,9 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
--------------------------------------------------------------------------------
-- | DBus module for DBus brightness controls
-- DBus module for DBus brightness controls
module XMonad.Internal.DBus.Brightness.Common
( BrightnessConfig (..)
@ -11,53 +13,52 @@ module XMonad.Internal.DBus.Brightness.Common
, callGetBrightness
, matchSignal
, signalDep
) where
import Control.Monad (void)
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
import XMonad.Core (io)
import XMonad.Internal.DBus.Common
--------------------------------------------------------------------------------
-- | External API
-- External API
--
-- Define four methods to increase, decrease, maximize, or minimize the
-- brightness. These methods will all return the current brightness as a 32-bit
-- integer and emit a signal with the same brightness value. Additionally, there
-- is one method to get the current brightness.
data BrightnessConfig a b = BrightnessConfig
{ bcMin :: (a, a) -> IO b
, bcMax :: (a, a) -> IO b
, bcDec :: (a, a) -> IO b
, bcInc :: (a, a) -> IO b
, bcGet :: (a, a) -> IO b
data BrightnessConfig m a b = BrightnessConfig
{ bcMin :: (a, a) -> m b
, bcMax :: (a, a) -> m b
, bcDec :: (a, a) -> m b
, bcInc :: (a, a) -> m b
, bcGet :: (a, a) -> m b
, bcMinRaw :: a
, bcGetMax :: IO a
, bcGetMax :: m a
, bcPath :: ObjectPath
, bcInterface :: InterfaceName
, bcName :: T.Text
}
data BrightnessControls = BrightnessControls
{ bctlMax :: SometimesIO
, bctlMin :: SometimesIO
, bctlInc :: SometimesIO
, bctlDec :: SometimesIO
data BrightnessControls m = BrightnessControls
{ bctlMax :: Sometimes (m ())
, bctlMin :: Sometimes (m ())
, bctlInc :: Sometimes (m ())
, bctlDec :: Sometimes (m ())
}
brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
-> BrightnessControls
brightnessControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> XPQuery
-> BrightnessConfig m a b
-> Maybe SesClient
-> BrightnessControls m
brightnessControls q bc cl =
BrightnessControls
{ bctlMax = cb "max brightness" memMax
@ -68,91 +69,131 @@ brightnessControls q bc cl =
where
cb = callBacklight q cl bc
callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c
-> IO (Maybe n)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
callGetBrightness
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> m (Maybe n)
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet
<$> callMethod xmonadBusName p i memGet
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadBusName p i $ Signal_ memCur
matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b
-> (Maybe n-> IO ()) -> c -> IO ()
matchSignal
:: ( HasClient env
, HasLogFunc (env c)
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> (Maybe n -> m ())
-> m ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
void $ addMatchCallback brMatcher (cb . bodyGetBrightness)
where
-- TODO add busname to this
brMatcher = matchAny
brMatcher =
matchAny
{ matchPath = Just p
, matchInterface = Just i
, matchMember = Just memCur
}
--------------------------------------------------------------------------------
-- | Internal DBus Crap
-- Internal DBus Crap
brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
-> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
brightnessExporter
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> XPQuery
-> [Fulfillment]
-> [IODependency_]
-> BrightnessConfig m a b
-> Maybe SesClient
-> Sometimes (m (), m ())
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
where
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> IO ()
exportBrightnessControls' bc cl = do
let ses = toClient cl
maxval <- bcGetMax bc -- assume the max value will never change
let bounds = (bcMinRaw bc, maxval)
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
let funget = bcGet bc
export ses (bcPath bc) defaultInterface
exportBrightnessControlsInner
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> BrightnessConfig m a b
-> SesClient
-> (m (), m ())
exportBrightnessControlsInner bc = cmd
where
cmd = exportPair (bcPath bc) $ \cl_ -> do
-- assume the max value will never change
bounds <- (bcMinRaw bc,) <$> bcGetMax bc
runIO <- askRunInIO
let autoMethod' m f = autoMethod m $ runIO $ do
val <- f bc bounds
emitBrightness bc cl_ val
funget <- toIO $ bcGet bc bounds
return $
defaultInterface
{ interfaceName = bcInterface bc
, interfaceMethods =
[ autoMethod' memMax bcMax
, autoMethod' memMin bcMin
, autoMethod' memInc bcInc
, autoMethod' memDec bcDec
, autoMethod memGet (round <$> funget bounds :: IO Int32)
, autoMethod memGet (round <$> funget :: IO Int32)
]
, interfaceSignals = [sig]
}
where
sig = I.Signal
sig =
I.Signal
{ I.signalName = memCur
, I.signalArgs =
[
I.SignalArg
[ I.SignalArg
{ I.signalArgName = "brightness"
, I.signalArgType = TypeInt32
}
]
}
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
emitBrightness
:: (MonadUnliftIO m, RealFrac b)
=> BrightnessConfig m a b
-> Client
-> b
-> m ()
emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
emit client $ sig { signalBody = [toVariant (round cur :: Int32)] }
liftIO $ emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
where
sig = signal p i memCur
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text
-> MemberName -> SometimesIO
callBacklight q cl BrightnessConfig { bcPath = p
, bcInterface = i
, bcName = n } controlName m =
callBacklight
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
=> XPQuery
-> Maybe SesClient
-> BrightnessConfig m a b
-> T.Text
-> MemberName
-> Sometimes (m ())
callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
where
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
cmd c = io $ void $ callMethod c xmonadBusName p i m
cmd c = void $ withDIO c $ callMethod xmonadBusName p i m
bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
bodyGetBrightness _ = Nothing
--------------------------------------------------------------------------------
-- | DBus Members
-- DBus Members
memCur :: MemberName
memCur = memberName_ "CurrentBrightness"

78
lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | DBus module for Intel Backlight control
-- DBus module for Intel Backlight control
module XMonad.Internal.DBus.Brightness.IntelBacklight
( callGetBrightnessIB
@ -10,22 +11,20 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
, intelBacklightControls
, intelBacklightSignalDep
, blPath
) where
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.IO
--------------------------------------------------------------------------------
-- | Low level sysfs functions
--
-- Low level sysfs functions
type Brightness = Float
type RawBrightness = Int32
@ -47,26 +46,26 @@ maxFile = backlightDir </> "max_brightness"
curFile :: FilePath
curFile = backlightDir </> "brightness"
getMaxRawBrightness :: IO RawBrightness
getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
getMaxRawBrightness = readInt maxFile
getBrightness :: RawBounds -> IO Brightness
getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
getBrightness bounds = readPercent bounds curFile
minBrightness :: RawBounds -> IO Brightness
minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
minBrightness bounds = writePercentMin bounds curFile
maxBrightness :: RawBounds -> IO Brightness
maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
maxBrightness bounds = writePercentMax bounds curFile
incBrightness :: RawBounds -> IO Brightness
incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
incBrightness = incPercent steps curFile
decBrightness :: RawBounds -> IO Brightness
decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
decBrightness = decPercent steps curFile
--------------------------------------------------------------------------------
-- | DBus interface
-- DBus interface
blPath :: ObjectPath
blPath = objectPath_ "/intelbacklight"
@ -74,8 +73,11 @@ blPath = objectPath_ "/intelbacklight"
interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness"
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
intelBacklightConfig = BrightnessConfig
intelBacklightConfig
:: MonadUnliftIO m
=> BrightnessConfig m RawBrightness Brightness
intelBacklightConfig =
BrightnessConfig
{ bcMin = minBrightness
, bcMax = maxBrightness
, bcInc = incBrightness
@ -89,7 +91,7 @@ intelBacklightConfig = BrightnessConfig
}
--------------------------------------------------------------------------------
-- | Exported haskell API
-- Exported haskell API
curFileDep :: IODependency_
curFileDep = pathRW curFile []
@ -98,17 +100,39 @@ maxFileDep :: IODependency_
maxFileDep = pathR maxFile []
intelBacklightSignalDep :: DBusDependency_ SesClient
intelBacklightSignalDep = signalDep intelBacklightConfig
intelBacklightSignalDep =
-- TODO do I need to get rid of the IO here?
signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
exportIntelBacklight :: Maybe SesClient -> SometimesIO
exportIntelBacklight = brightnessExporter xpfIntelBacklight []
[curFileDep, maxFileDep] intelBacklightConfig
exportIntelBacklight
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe SesClient
-> Sometimes (m (), m ())
exportIntelBacklight =
brightnessExporter
xpfIntelBacklight
[]
[curFileDep, maxFileDep]
intelBacklightConfig
intelBacklightControls :: Maybe SesClient -> BrightnessControls
intelBacklightControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
-> BrightnessControls m
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
callGetBrightnessIB
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
=> m (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig
matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
matchSignalIB
:: ( SafeClient c
, HasLogFunc (env c)
, HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
)
=> (Maybe Brightness -> m ())
-> m ()
matchSignalIB = matchSignal intelBacklightConfig

6
lib/XMonad/Internal/DBus/Common.hs
View File

@ -1,5 +1,5 @@
--------------------------------------------------------------------------------
-- | High-level interface for managing XMonad's DBus
-- High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Common
( xmonadBusName
@ -7,7 +7,8 @@ module XMonad.Internal.DBus.Common
, notifyBus
, notifyPath
, networkManagerBus
) where
)
where
import DBus
@ -25,4 +26,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
networkManagerBus :: BusName
networkManagerBus = busName_ "org.freedesktop.NetworkManager"

114
lib/XMonad/Internal/DBus/Control.hs
View File

@ -1,11 +1,17 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | High-level interface for managing XMonad's DBus
-- High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Control
( Client
, DBusState (..)
, withDBusInterfaces
, withDBusX
, withDBusX_
, withDBus
, withDBus_
, connectDBus
, connectDBusX
, disconnectDBus
@ -15,16 +21,15 @@ module XMonad.Internal.DBus.Control
, withDBusClient_
, disconnect
, dbusExporters
) where
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
@ -36,48 +41,109 @@ data DBusState = DBusState
, dbSysClient :: Maybe SysClient
}
withDBusX_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m ()
withDBusX_ = void . withDBusX
withDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m (Maybe a)
withDBusX f = withDBus $ \db -> do
forM (dbSesClient db) $ \ses -> do
bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
withDBus_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m ()
withDBus_ = void . withDBus
withDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m a
withDBus = bracket connectDBus disconnectDBus
-- | Connect to the DBus
connectDBus :: IO DBusState
connectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState
connectDBus = do
ses <- getDBusClient
sys <- getDBusClient
return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus
disconnectDBus :: DBusState -> IO ()
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
disconnectDBus db = disc dbSesClient >> disc dbSysClient
where
disc f = maybe (return ()) disconnectDBusClient $ f db
-- | Connect to the DBus and request the XMonad name
connectDBusX :: IO DBusState
connectDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState
connectDBusX = do
db <- connectDBus
forM_ (dbSesClient db) requestXMonadName
return db
-- | Disconnect from DBus and release the XMonad name
disconnectDBusX :: DBusState -> IO ()
disconnectDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> DBusState
-> m ()
disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName
disconnectDBus db
withDBusInterfaces
:: DBusState
-> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
-> ([XIO ()] -> XIO a)
-> XIO a
withDBusInterfaces db interfaces = bracket up sequence
where
up = do
pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
mapM_ fst pairs
return $ snd <$> pairs
-- | All exporter features to be assigned to the DBus
dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [Maybe SesClient -> Sometimes (m (), m ())]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName :: SesClient -> IO ()
releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
releaseXMonadName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SesClient
-> m ()
releaseXMonadName ses = do
-- TODO this might error?
liftIO $ void $ releaseName (toClient ses) xmonadBusName
logInfo "released xmonad name"
requestXMonadName :: SesClient -> IO ()
requestXMonadName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SesClient
-> m ()
requestXMonadName ses = do
res <- requestName (toClient ses) xmonadBusName []
-- TODO if the client is not released on shutdown the owner will be different
let msg | res == NamePrimaryOwner = Nothing
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
res <- liftIO $ requestName (toClient ses) xmonadBusName []
let msg
| res == NamePrimaryOwner = "registering name"
| res == NameAlreadyOwner = "this process already owns name"
| res == NameInQueue
|| res == NameExists = Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg putStrLn
|| res == NameExists =
"another process owns name"
| otherwise = "unknown error when requesting name"
logInfo $ msg <> ": " <> xn
where
xn = "'" ++ formatBusName xmonadBusName ++ "'"
xn =
Utf8Builder $
encodeUtf8Builder $
T.pack $
formatBusName xmonadBusName

52
lib/XMonad/Internal/DBus/Removable.hs
View File

@ -1,22 +1,20 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Module for monitoring removable drive events
-- Module for monitoring removable drive events
--
-- Currently, its only purpose is to play Super Mario sounds when a drive is
-- inserted or removed. Why? Because I can.
module XMonad.Internal.DBus.Removable (runRemovableMon) where
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Map.Strict (Map, member)
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Map as M
import XMonad.Core (io)
import XMonad.Internal.Command.Desktop
@ -51,7 +49,8 @@ driveRemovedSound :: FilePath
driveRemovedSound = "smb_pipe.wav"
ruleUdisks :: MatchRule
ruleUdisks = matchAny
ruleUdisks =
matchAny
{ matchPath = Just path
, matchInterface = Just interface
}
@ -60,31 +59,52 @@ driveFlag :: String
driveFlag = "org.freedesktop.UDisks2.Drive"
addedHasDrive :: [Variant] -> Bool
addedHasDrive [_, a] = maybe False (member driveFlag)
addedHasDrive [_, a] =
maybe
False
(M.member driveFlag)
(fromVariant a :: Maybe (Map String (Map String Variant)))
addedHasDrive _ = False
removedHasDrive :: [Variant] -> Bool
removedHasDrive [_, a] = maybe False (driveFlag `elem`)
removedHasDrive [_, a] =
maybe
False
(driveFlag `elem`)
(fromVariant a :: Maybe [String])
removedHasDrive _ = False
playSoundMaybe :: FilePath -> Bool -> IO ()
playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
playSoundMaybe p b = when b $ io $ playSound p
-- NOTE: the udisks2 service should be already running for this module to work.
-- If it not already, we won't see any signals from the dbus until it is
-- started (it will work after it is started however). It seems safe to simply
-- enable the udisks2 service at boot; however this is not default behavior.
listenDevices :: SysClient -> IO ()
listenDevices
:: ( HasClient (DBusEnv env)
, HasLogFunc (DBusEnv env SysClient)
, MonadReader env m
, MonadUnliftIO m
)
=> SysClient
-> m ()
listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive
addMatch' memRemoved driveRemovedSound removedHasDrive
where
addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m }
$ playSoundMaybe p . f . signalBody
addMatch' m p f = do
let rule = ruleUdisks {matchMember = Just m}
void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
runRemovableMon :: Maybe SysClient -> SometimesIO
runRemovableMon
:: ( HasClient (DBusEnv env)
, HasLogFunc (DBusEnv env SysClient)
, MonadReader env m
, MonadUnliftIO m
)
=> Maybe SysClient
-> Sometimes (m ())
runRemovableMon cl =
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
where

116
lib/XMonad/Internal/DBus/Screensaver.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | DBus module for X11 screensave/DPMS control
-- DBus module for X11 screensave/DPMS control
module XMonad.Internal.DBus.Screensaver
( exportScreensaver
@ -9,46 +10,40 @@ module XMonad.Internal.DBus.Screensaver
, callQuery
, matchSignal
, ssSignalDep
) where
import Control.Monad (void)
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
import Data.Internal.XIO
import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display
import RIO
import XMonad.Internal.DBus.Common
import XMonad.Internal.Process
import XMonad.Internal.IO
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
-- | Low-level functions
-- Low-level functions
type SSState = Bool -- true is enabled
ssExecutable :: String
ssExecutable :: FilePath
ssExecutable = "xset"
toggle :: IO SSState
toggle :: MonadUnliftIO m => m SSState
toggle = do
st <- query
-- TODO figure out how not to do this with shell commands
void $ createProcess' $ proc ssExecutable $ "s" : args st
-- TODO this assumes the command succeeds
return $ not st
where
args s = if s then ["off", "-dpms"] else ["on", "+dpms"]
let args = if st then ["off", "-dpms"] else ["on", "+dpms"]
-- this needs to be done with shell commands, because as far as I know there
-- are no Haskell bindings for DPMSDisable/Enable (from libxext)
rc <- runProcess (proc ssExecutable $ "s" : args)
return $ if rc == ExitSuccess then not st else st
query :: IO SSState
query :: MonadUnliftIO m => m SSState
query = do
dpy <- openDisplay ""
xssi <- xScreenSaverQueryInfo dpy
closeDisplay dpy
xssi <- withOpenDisplay (liftIO . xScreenSaverQueryInfo)
return $ case xssi of
Just XScreenSaverInfo {xssi_state = ScreenSaverDisabled} -> False
Just XScreenSaverInfo {xssi_state = _} -> True
@ -56,7 +51,7 @@ query = do
Nothing -> False
--------------------------------------------------------------------------------
-- | DBus Interface
-- DBus Interface
--
-- Define a methods to toggle the screensaver. This methods will emit signal
-- with the new state when called. Define another method to get the current
@ -81,40 +76,47 @@ sigCurrentState :: Signal
sigCurrentState = signal ssPath interface memState
ruleCurrentState :: MatchRule
ruleCurrentState = matchAny
ruleCurrentState =
matchAny
{ matchPath = Just ssPath
, matchInterface = Just interface
, matchMember = Just memState
}
emitState :: Client -> SSState -> IO ()
emitState client sss = emit client $ sigCurrentState { signalBody = [toVariant sss] }
emitState :: MonadUnliftIO m => Client -> SSState -> m ()
emitState client sss =
liftIO $ emit client $ sigCurrentState {signalBody = [toVariant sss]}
bodyGetCurrentState :: [Variant] -> Maybe SSState
bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
bodyGetCurrentState _ = Nothing
--------------------------------------------------------------------------------
-- | Exported haskell API
-- Exported haskell API
exportScreensaver :: Maybe SesClient -> SometimesIO
exportScreensaver
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe SesClient
-> Sometimes (m (), m ())
exportScreensaver ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
where
cmd cl = let cl' = toClient cl in
export cl' ssPath defaultInterface
cmd = exportPair ssPath $ \cl_ -> do
liftIO $ withRunInIO $ \run ->
return $
defaultInterface
{ interfaceName = interface
, interfaceMethods =
[ autoMethod memToggle $ emitState cl' =<< toggle
, autoMethod memQuery query
[ autoMethod memToggle $ run $ emitState cl_ =<< toggle
, autoMethod memQuery (run query)
]
, interfaceSignals = [sig]
}
sig = I.Signal
sig =
I.Signal
{ I.signalName = memState
, I.signalArgs =
[
I.SignalArg
[ I.SignalArg
{ I.signalArgName = "enabled"
, I.signalArgType = TypeBoolean
}
@ -123,18 +125,40 @@ exportScreensaver ses =
bus = Bus [] xmonadBusName
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
callToggle :: Maybe SesClient -> SometimesIO
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
xmonadBusName ssPath interface memToggle
callToggle
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
-> Sometimes (m ())
callToggle =
sometimesEndpoint
"screensaver toggle"
"dbus switch"
[]
xmonadBusName
ssPath
interface
memToggle
callQuery :: SesClient -> IO (Maybe SSState)
callQuery ses = do
reply <- callMethod ses xmonadBusName ssPath interface memQuery
callQuery
:: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
=> m (Maybe SSState)
callQuery = do
reply <- callMethod xmonadBusName ssPath interface memQuery
return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
matchSignal cb ses = void $ addMatchCallback ruleCurrentState
(cb . bodyGetCurrentState) ses
matchSignal
:: ( HasLogFunc (env SesClient)
, HasClient env
, MonadReader (env SesClient) m
, MonadUnliftIO m
)
=> (Maybe SSState -> m ())
-> m ()
matchSignal cb =
void $
addMatchCallback
ruleCurrentState
(cb . bodyGetCurrentState)
ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState

115
lib/XMonad/Internal/IO.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
-- | Random IO-ish functions used throughtout xmonad
-- Random IO-ish functions used throughtout xmonad
--
-- Most (probably all) of these functions are intended to work with sysfs where
-- some safe assumptions can be made about file contents.
@ -21,84 +21,122 @@ module XMonad.Internal.IO
-- , isWritable
, PermResult (..)
, getPermissionsSafe
) where
, waitUntilExit
, withOpenDisplay
)
where
import Data.Char
import Data.Text (pack, unpack)
import Data.Text.IO as T (readFile, writeFile)
import System.Directory
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Types
import RIO hiding (Display)
import RIO.Directory
import RIO.FilePath
import qualified RIO.Text as T
import System.IO.Error
import System.Process
--------------------------------------------------------------------------------
-- | read
-- read
readInt :: (Read a, Integral a) => FilePath -> IO a
readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
readBool :: FilePath -> IO Bool
readBool :: MonadIO m => FilePath -> m Bool
readBool = fmap (== (1 :: Int)) . readInt
--------------------------------------------------------------------------------
-- | write
-- write
writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
writeInt f = T.writeFile f . pack . show
writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
writeInt f = writeFileUtf8 f . T.pack . show
writeBool :: FilePath -> Bool -> IO ()
writeBool :: MonadIO m => FilePath -> Bool -> m ()
writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
--------------------------------------------------------------------------------
-- | percent-based read/write
-- percent-based read/write
--
-- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
-- value. Assume that the file being read has a min of 0 and an unchanging max
-- given by a runtime argument, which is scaled linearly to the range 0-100
-- (percent).
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
rawToPercent (lower, upper) raw =
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
readPercent :: MonadIO m => (Integral a, RealFrac b) => (a, a) -> FilePath -> m b
readPercent bounds path = do
i <- readInt path
return $ rawToPercent bounds (i :: Integer)
percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
percentToRaw (lower, upper) perc = round $
percentToRaw (lower, upper) perc =
round $
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
writePercent
:: (MonadIO m, Integral a, RealFrac b)
=> (a, a)
-> FilePath
-> b
-> m b
writePercent bounds path perc = do
let t | perc > 100 = 100
let t
| perc > 100 = 100
| perc < 0 = 0
| otherwise = perc
writeInt path (percentToRaw bounds t :: Int)
return t
writePercentMin :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
writePercentMin
:: (MonadIO m, Integral a, RealFrac b)
=> (a, a)
-> FilePath
-> m b
writePercentMin bounds path = writePercent bounds path 0
writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
writePercentMax
:: (MonadIO m, Integral a, RealFrac b)
=> (a, a)
-> FilePath
-> m b
writePercentMax bounds path = writePercent bounds path 100
shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath
-> (a, a) -> IO b
shiftPercent f steps path bounds = writePercent bounds path . f stepsize
shiftPercent
:: (MonadIO m, Integral a, RealFrac b)
=> (b -> b -> b)
-> Int
-> FilePath
-> (a, a)
-> m b
shiftPercent f steps path bounds =
writePercent bounds path . f stepsize
=<< readPercent bounds path
where
stepsize = 100 / fromIntegral steps
incPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
incPercent
:: (MonadIO m, Integral a, RealFrac b)
=> Int
-> FilePath
-> (a, a)
-> m b
incPercent = shiftPercent (+)
decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
decPercent
:: (MonadIO m, Integral a, RealFrac b)
=> Int
-> FilePath
-> (a, a)
-> m b
decPercent = shiftPercent subtract -- silly (-) operator thingy error
--------------------------------------------------------------------------------
-- | permission query
-- permission query
data PermResult a = PermResult a | NotFoundError | PermError
deriving (Show, Eq)
@ -108,9 +146,9 @@ data PermResult a = PermResult a | NotFoundError | PermError
-- fmap _ NotFoundError = NotFoundError
-- fmap _ PermError = PermError
getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
getPermissionsSafe :: MonadUnliftIO m => FilePath -> m (PermResult Permissions)
getPermissionsSafe f = do
r <- tryIOError $ getPermissions f
r <- tryIO $ getPermissions f
return $ case r of
Right z -> PermResult z
Left (isPermissionError -> True) -> PermError
@ -124,3 +162,20 @@ getPermissionsSafe f = do
-- isWritable :: FilePath -> IO (PermResult Bool)
-- isWritable = fmap (fmap writable) . getPermissionsSafe
-- | Block until a PID has exited.
-- Use this to control flow based on a process that was not explicitly started
-- by the Haskell runtime itself, and thus has no data structures to query.
waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
waitUntilExit pid = do
res <- doesDirectoryExist $ "/proc" </> show pid
when res $ do
threadDelay 100000
waitUntilExit pid
withOpenDisplay :: MonadUnliftIO m => (Display -> m a) -> m a
withOpenDisplay = bracket (liftIO $ openDisplay "") cleanup
where
cleanup dpy = liftIO $ do
flush dpy
closeDisplay dpy

31
lib/XMonad/Internal/Notify.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Functions for formatting and sending notifications
-- Functions for formatting and sending notifications
--
-- NOTE I use the DBus.Notify lib even though I don't actually use the DBus for
-- notifications (just formation them into 'notify-send' commands and spawn a
@ -16,33 +16,34 @@ module XMonad.Internal.Notify
, defNoteError
, fmtNotifyCmd
, spawnNotify
) where
import Control.Monad.IO.Class
import Data.Maybe
)
where
import DBus.Notify
import RIO
import qualified RIO.Text as T
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
-- | Some nice default notes
-- Some nice default notes
defNote :: Note
defNote = blankNote {summary = "\"xmonad\""}
defNoteInfo :: Note
defNoteInfo = defNote
{ appImage = Just $ Icon "dialog-information-symbolic" }
defNoteInfo =
defNote
{ appImage = Just $ Icon "dialog-information-symbolic"
}
defNoteError :: Note
defNoteError = defNote
{ appImage = Just $ Icon "dialog-error-symbolic" }
defNoteError =
defNote
{ appImage = Just $ Icon "dialog-error-symbolic"
}
--------------------------------------------------------------------------------
-- | Format a 'notify-send' command to be send to the shell
-- Format a 'notify-send' command to be send to the shell
parseBody :: Body -> Maybe T.Text
parseBody (Text s) = Just $ T.pack s
@ -60,6 +61,6 @@ fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
-- TODO add the rest of the options as needed
getSummary = (: []) . doubleQuote . T.pack . summary
getIcon n' =
maybe [] (\i -> ["-i", T.pack $ case i of { Icon s -> s; File s -> s }])
$ appImage n'
maybe [] (\i -> ["-i", T.pack $ case i of Icon s -> s; File s -> s]) $
appImage n'
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'

96
lib/XMonad/Internal/Process.hs
View File

@ -1,96 +0,0 @@
--------------------------------------------------------------------------------
-- | Functions for managing processes
module XMonad.Internal.Process
( waitUntilExit
, killHandle
, spawnPipe'
, spawnPipe
, spawnPipeArgs
, createProcess'
, readCreateProcessWithExitCode'
, proc'
, shell'
, spawn
, spawnAt
, module System.Process
) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import qualified RIO.Text as T
import System.Directory
import System.Exit
import System.IO
import System.Posix.Signals
import System.Process
import XMonad.Core hiding (spawn)
-- | Block until a PID has exited (in any form)
-- ASSUMPTION on linux PIDs will always increase until they overflow, in which
-- case they will start to recycle. Barring any fork bombs, this code should
-- work because we can reasonably expect that no processes will spawn with the
-- same PID within the delay limit
-- TODO this will not work if the process is a zombie (maybe I care...)
waitUntilExit :: Show t => t -> IO ()
waitUntilExit pid = do
res <- doesDirectoryExist $ "/proc/" ++ show pid
when res $ threadDelay 100000 >> waitUntilExit pid
killHandle :: ProcessHandle -> IO ()
killHandle ph = do
ec <- getProcessExitCode ph
unless (isJust ec) $ do
pid <- getPid ph
forM_ pid $ signalProcess sigTERM
-- this may fail if the process exits instantly and the handle
-- is destroyed by the time we get to this line (I think?)
void (try $ waitForProcess ph :: IO (Either IOException ExitCode))
withDefaultSignalHandlers :: IO a -> IO a
withDefaultSignalHandlers =
bracket_ uninstallSignalHandlers installSignalHandlers
addGroupSession :: CreateProcess -> CreateProcess
addGroupSession cp = cp { create_group = True, new_session = True }
createProcess' :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess' = withDefaultSignalHandlers . createProcess
readCreateProcessWithExitCode' :: CreateProcess -> String
-> IO (ExitCode, T.Text, T.Text)
readCreateProcessWithExitCode' c i = withDefaultSignalHandlers $ do
(r, e, p) <- readCreateProcessWithExitCode c i
return (r, T.pack e, T.pack p)
shell' :: String -> CreateProcess
shell' = addGroupSession . shell
proc' :: FilePath -> [String] -> CreateProcess
proc' cmd args = addGroupSession $ proc cmd args
spawn :: MonadIO m => String -> m ()
spawn = io . void . createProcess' . shell'
spawnAt :: MonadIO m => FilePath -> String -> m ()
spawnAt fp cmd = io $ void $ createProcess' $ (shell' cmd) { cwd = Just fp }
spawnPipe' :: CreateProcess -> IO (Handle, ProcessHandle)
spawnPipe' cp = do
-- ASSUME creating a pipe will always succeed in making a Just Handle
(Just h, _, _, p) <- createProcess' $ cp { std_in = CreatePipe }
hSetBuffering h LineBuffering
return (h, p)
spawnPipe :: String -> IO (Handle, ProcessHandle)
spawnPipe = spawnPipe' . shell
spawnPipeArgs :: FilePath -> [String] -> IO (Handle, ProcessHandle)
spawnPipeArgs cmd = spawnPipe' . proc cmd

119
lib/XMonad/Internal/Shell.hs
View File

@ -1,64 +1,159 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Functions for formatting and spawning shell commands
-- Functions for formatting and spawning shell commands
module XMonad.Internal.Shell
( fmtCmd
, spawnCmd
, spawn
, spawnPipe
, doubleQuote
, singleQuote
, skip
, runProcess
, proc
, shell
, (#!&&)
, (#!||)
, (#!|)
, (#!>>)
) where
import Control.Monad.IO.Class
)
where
import RIO
import qualified RIO.Text as T
import qualified System.Process.Typed as P
import qualified XMonad.Core as X
import qualified XMonad.Util.Run as XR
import XMonad.Internal.Process
-- | Fork a new process and wait for its exit code.
--
-- This function will work despite xmonad ignoring SIGCHLD.
--
-- A few facts about xmonad (and window managers in general):
-- 1) It is single-threaded (since X is single threaded)
-- 2) Because of (1), it ignores SIGCHLD, which means any subprocess started
-- by xmonad will instantly be reaped after spawning. This guarantees the
-- main thread running the WM will never be blocked.
--
-- In general, this means I can't wait for exit codes (since wait() doesn't
-- work) See https://github.com/xmonad/xmonad/issues/113.
--
-- If I want an exit code, The best solution (I can come up with), is to use
-- bracket to uninstall handlers, run process (with wait), and then reinstall
-- handlers. I can use this with a much higher-level interface which will make
-- things easier. This obviously means that if the process is running in the
-- main thread, it needs to be almost instantaneous. Note if using a high-level
-- API for this, the process needs to spawn, finish, and be reaped by the
-- xmonad process all while the signal handlers are 'disabled' (which limits
-- the functions I can use to those that call waitForProcess).
--
-- XMonad and contrib use their own method of spawning subprocesses using the
-- extremely low-level 'System.Process.Posix' API. See the code for
-- 'XMonad.Core.spawn' or 'XMonad.Util.Run.safeSpawn'. Specifically, the
-- sequence is (in terms of the low level Linux API):
-- 1) call fork()
-- 2) uninstall signal handlers (to allow wait() to work in subprocesses)
-- 3) call setsid() (so killing the child will kill its children, if any)
-- 4) start new thing with exec()
--
-- In contrast with high-level APIs like 'System.Process', this will leave no
-- trailing data structures to clean up, at the cost of being gross to look at
-- and possibly more error-prone.
runProcess :: MonadUnliftIO m => P.ProcessConfig a b c -> m ExitCode
runProcess = withDefaultSignalHandlers . P.runProcess
--------------------------------------------------------------------------------
-- | Opening subshell
-- | Run an action without xmonad's signal handlers.
withDefaultSignalHandlers :: MonadUnliftIO m => m a -> m a
withDefaultSignalHandlers =
bracket_ X.uninstallSignalHandlers X.installSignalHandlers
-- | Set a child process to create a new group and session
addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z
addGroupSession = P.setCreateGroup True . P.setNewSession True
-- | Create a 'ProcessConfig' for a shell command
shell :: T.Text -> P.ProcessConfig () () ()
shell = addGroupSession . P.shell . T.unpack
-- | Create a 'ProcessConfig' for a command with arguments
proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)
-- | Run 'XMonad.Core.spawn' with 'Text' input.
spawn :: MonadIO m => T.Text -> m ()
spawn = X.spawn . T.unpack
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
spawnPipe
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> T.Text
-> m Handle
spawnPipe = liftIO . XR.spawnPipe . T.unpack
-- spawnPipeRW
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-- => T.Text
-- -> m Handle
-- spawnPipeRW x = do
-- (r, h) <- liftIO mkPipe
-- child r
-- liftIO $ closeFd r
-- return h
-- where
-- mkPipe = do
-- (r, w) <- createPipe
-- setFdOption w CloseOnExec True
-- h <- fdToHandle w
-- -- ASSUME we are using utf8 everywhere
-- hSetEncoding h utf8
-- hSetBuffering h LineBuffering
-- return (r, h)
-- child r = void $ withRunInIO $ \runIO -> do
-- X.xfork $ runIO $ do
-- void $ liftIO $ dupTo r stdInput
-- liftIO $ executeFile "/bin/sh" False ["-c", T.unpack x] Nothing
-- | Run 'XMonad.Core.spawn' with a command and arguments
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args
--------------------------------------------------------------------------------
-- | Formatting commands
spawnCmd cmd = spawn . fmtCmd cmd
-- | Format a command and list of arguments as 'Text'
fmtCmd :: FilePath -> [T.Text] -> T.Text
fmtCmd cmd args = T.unwords $ T.pack cmd : args
op :: T.Text -> T.Text -> T.Text -> T.Text
op a x b = T.unwords [a, x, b]
-- | Format two shell expressions separated by "&&"
(#!&&) :: T.Text -> T.Text -> T.Text
cmdA #!&& cmdB = op cmdA "&&" cmdB
infixr 0 #!&&
-- | Format two shell expressions separated by "|"
(#!|) :: T.Text -> T.Text -> T.Text
cmdA #!| cmdB = op cmdA "|" cmdB
infixr 0 #!|
-- | Format two shell expressions separated by "||"
(#!||) :: T.Text -> T.Text -> T.Text
cmdA #!|| cmdB = op cmdA "||" cmdB
infixr 0 #!||
-- | Format two shell expressions separated by ";"
(#!>>) :: T.Text -> T.Text -> T.Text
cmdA #!>> cmdB = op cmdA ";" cmdB
infixr 0 #!>>
-- | Wrap input in double quotes
doubleQuote :: T.Text -> T.Text
doubleQuote s = T.concat ["\"", s, "\""]
-- | Wrap input in single quotes
singleQuote :: T.Text -> T.Text
singleQuote s = T.concat ["'", s, "'"]

54
lib/XMonad/Internal/Theme.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Theme for XMonad and Xmobar
-- Theme for XMonad and Xmobar
module XMonad.Internal.Theme
( baseColor
@ -28,18 +28,17 @@ module XMonad.Internal.Theme
, defFontData
, tabbedTheme
, promptTheme
) where
)
where
import Data.Colour
import Data.Colour.SRGB
import qualified RIO.Text as T
import qualified XMonad.Layout.Decoration as D
import qualified XMonad.Prompt as P
--------------------------------------------------------------------------------
-- | Colors - vocabulary roughly based on GTK themes
-- Colors - vocabulary roughly based on GTK themes
baseColor :: T.Text
baseColor = "#f7f7f7"
@ -78,7 +77,7 @@ backdropFgColor :: T.Text
backdropFgColor = blend' 0.75 fgColor bgColor
--------------------------------------------------------------------------------
-- | Color functions
-- Color functions
blend' :: Float -> T.Text -> T.Text -> T.Text
blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)
@ -93,14 +92,16 @@ sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
sRGB24showT = T.pack . sRGB24show
--------------------------------------------------------------------------------
-- | Fonts
-- Fonts
data Slant = Roman
data Slant
= Roman
| Italic
| Oblique
deriving (Eq, Show)
data Weight = Light
data Weight
= Light
| Medium
| Demibold
| Bold
@ -119,15 +120,21 @@ type FontBuilder = FontData -> T.Text
buildFont :: Maybe T.Text -> FontData -> T.Text
buildFont Nothing _ = "fixed"
buildFont (Just fam) FontData { weight = w
buildFont
(Just fam)
FontData
{ weight = w
, slant = l
, size = s
, pixelsize = p
, antialias = a
}
= T.intercalate ":" $ ["xft", fam] ++ elems
} =
T.intercalate ":" $ ["xft", fam] ++ elems
where
elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w)
elems =
[ T.concat [k, "=", v]
| (k, Just v) <-
[ ("weight", showLower w)
, ("slant", showLower l)
, ("size", showLower s)
, ("pixelsize", showLower p)
@ -141,10 +148,11 @@ fallbackFont :: FontBuilder
fallbackFont = buildFont Nothing
--------------------------------------------------------------------------------
-- | Default font and data
-- Default font and data
defFontData :: FontData
defFontData = FontData
defFontData =
FontData
{ size = Just 10
, antialias = Just True
, weight = Nothing
@ -162,36 +170,34 @@ defFontFamily = "DejaVu Sans"
-- defFontTree = fontTree "DejaVu Sans"
--------------------------------------------------------------------------------
-- | Complete themes
-- Complete themes
tabbedTheme :: FontBuilder -> D.Theme
tabbedTheme fb = D.def
tabbedTheme fb =
D.def
{ D.fontName = T.unpack $ fb $ defFontData {weight = Just Bold}
, D.activeTextColor = T.unpack fgColor
, D.activeColor = T.unpack bgColor
, D.activeBorderColor = T.unpack bgColor
, D.inactiveTextColor = T.unpack backdropTextColor
, D.inactiveColor = T.unpack backdropFgColor
, D.inactiveBorderColor = T.unpack backdropFgColor
, D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
, D.urgentColor = T.unpack errorColor
, D.urgentBorderColor = T.unpack errorColor
-- this is in a newer version
, -- this is in a newer version
-- , D.activeBorderWidth = 0
-- , D.inactiveBorderWidth = 0
-- , D.urgentBorderWidth = 0
, D.decoHeight = 20
D.decoHeight = 20
, D.windowTitleAddons = []
, D.windowTitleIcons = []
}
promptTheme :: FontBuilder -> P.XPConfig
promptTheme fb = P.def
promptTheme fb =
P.def
{ P.font = T.unpack $ fb $ defFontData {size = Just 12}
, P.bgColor = T.unpack bgColor
, P.fgColor = T.unpack fgColor

27
lib/Xmobar/Plugins/BacklightCommon.hs
View File

@ -1,25 +1,28 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Common backlight plugin bits
-- Common backlight plugin bits
--
-- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands
module Xmobar.Plugins.BacklightCommon (startBacklight) where
import Data.Internal.DBus
import RIO
import qualified RIO.Text as T
import Xmobar.Plugins.Common
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
-> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
startBacklight matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb $ \c -> do
matchSignal display c
display =<< callGetBrightness c
startBacklight
:: (MonadUnliftIO m, RealFrac a)
=> Maybe FilePath
-> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
-> DIO SimpleApp SesClient (Maybe a)
-> T.Text
-> Callback
-> m ()
startBacklight name matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb name $ \c -> withDIO c $ do
matchSignal dpy
dpy =<< callGetBrightness
where
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
display = displayMaybe cb formatBrightness
dpy = displayMaybe cb formatBrightness

335
lib/Xmobar/Plugins/Bluetooth.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Bluetooth plugin
-- Bluetooth plugin
--
-- Use the bluez interface on DBus to check status
--
@ -36,23 +36,18 @@ module Xmobar.Plugins.Bluetooth
( Bluetooth (..)
, btAlias
, btDep
) where
import Control.Concurrent.MVar
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
)
where
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import RIO.FilePath
import RIO.List
import qualified RIO.Map as M
import qualified RIO.Text as T
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
@ -61,36 +56,44 @@ btAlias :: T.Text
btAlias = "bluetooth"
btDep :: DBusDependency_ SysClient
btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
$ Method_ getManagedObjects
btDep =
Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
Method_ getManagedObjects
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
instance Exec Bluetooth where
alias (Bluetooth _ _) = T.unpack btAlias
start (Bluetooth icons colors) cb =
withDBusClientConnection cb $ startAdapter icons colors cb
withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb
startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
startAdapter
:: Icons
-> Colors
-> Callback
-> SysClient
-> RIO SimpleApp ()
startAdapter is cs cb cl = do
ot <- getBtObjectTree cl
state <- newMVar emptyState
let display = displayIcon cb (iconFormatter is cs) state
forM_ (findAdapter ot) $ \adapter -> do
let dpy = displayIcon cb (iconFormatter is cs)
mapRIO (BTEnv cl state dpy) $ do
ot <- getBtObjectTree
case findAdapter ot of
Nothing -> logError "could not find bluetooth adapter"
Just adapter -> do
-- set up adapter
initAdapter state adapter cl
-- TODO this step could fail; at least warn the user...
void $ addAdaptorListener state display adapter cl
initAdapter adapter
void $ addAdaptorListener adapter
-- set up devices on the adapter (and listeners for adding/removing devices)
let devices = findDevices adapter ot
addDeviceAddedListener state display adapter cl
addDeviceRemovedListener state display adapter cl
forM_ devices $ \d -> addAndInitDevice state display d cl
addDeviceAddedListener adapter
addDeviceRemovedListener adapter
forM_ devices $ \d -> addAndInitDevice d
-- after setting things up, show the icon based on the initialized state
display
dpy
--------------------------------------------------------------------------------
-- | Icon Display
-- Icon Display
--
-- Color corresponds to the adaptor powered state, and the icon corresponds to
-- if it is paired or not. If the adaptor state is undefined, display "N/A"
@ -99,9 +102,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
type Icons = (T.Text, T.Text)
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
displayIcon :: Callback -> IconFormatter -> BTIO ()
displayIcon callback formatter =
callback . T.unpack . uncurry formatter <=< readState
liftIO . callback . T.unpack . uncurry formatter =<< readState
-- TODO maybe I want this to fail when any of the device statuses are Nothing
iconFormatter :: Icons -> Colors -> IconFormatter
@ -111,13 +114,28 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
icon = if connected then iconConn else iconDisc
--------------------------------------------------------------------------------
-- | Connection State
-- Connection State
--
-- The signal handlers all run on separate threads, yet the icon depends on
-- the state reflected by all these signals. The best (only?) way to do this is
-- is to track the shared state of the bluetooth adaptor and its devices using
-- an MVar.
data BTEnv c = BTEnv
{ btClient :: !c
, btState :: !(MVar BtState)
, btDisplay :: !(BTIO ())
, btEnv :: !SimpleApp
}
instance HasClient BTEnv where
clientL = lens btClient (\x y -> x {btClient = y})
instance HasLogFunc (BTEnv a) where
logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
type BTIO = RIO (BTEnv SysClient)
data BTDevice = BTDevice
{ btDevConnected :: Maybe Bool
, btDevSigHandler :: SignalHandler
@ -130,22 +148,29 @@ data BtState = BtState
, btPowered :: Maybe Bool
}
type MutableBtState = MVar BtState
emptyState :: BtState
emptyState = BtState
emptyState =
BtState
{ btDevices = M.empty
, btPowered = Nothing
}
readState :: MutableBtState -> IO (Maybe Bool, Bool)
readState state = do
p <- readPowered state
c <- readDevices state
readState :: BTIO (Maybe Bool, Bool)
readState = do
p <- readPowered
c <- readDevices
return (p, anyDevicesConnected c)
modifyState :: (BtState -> BTIO (BtState, a)) -> BTIO a
modifyState f = do
m <- asks btState
modifyMVar m f
beforeDisplay :: BTIO () -> BTIO ()
beforeDisplay f = f >> join (asks btDisplay)
--------------------------------------------------------------------------------
-- | Object manager
-- Object manager
findAdapter :: ObjectTree -> Maybe ObjectPath
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
@ -154,73 +179,136 @@ findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
adaptorHasDevice adaptor device = case splitPath device of
[org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
adaptorHasDevice adaptor device = case splitPathNoRoot device of
[org, bluez, hciX, _] -> splitPathNoRoot adaptor == [org, bluez, hciX]
_ -> False
splitPath :: ObjectPath -> [T.Text]
splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
splitPathNoRoot :: ObjectPath -> [FilePath]
splitPathNoRoot = dropWhile (== "/") . splitDirectories . formatObjectPath
getBtObjectTree :: SysClient -> IO ObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
getBtObjectTree
:: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getBtObjectTree = callGetManagedObjects btBus btOMPath
btOMPath :: ObjectPath
btOMPath = objectPath_ "/"
addBtOMListener :: SignalCallback -> SysClient -> IO ()
addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
addBtOMListener
:: ( HasClient env
, SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> SignalCallback m
-> m ()
addBtOMListener sc = void $ addInterfaceAddedListener btBus btOMPath sc
addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceAddedListener state display adapter client =
addBtOMListener addDevice client
addDeviceAddedListener :: ObjectPath -> BTIO ()
addDeviceAddedListener adapter = addBtOMListener addDevice
where
addDevice = pathCallback adapter display $ \d ->
addAndInitDevice state display d client
addDevice = pathCallback adapter $ \d ->
addAndInitDevice d
addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addDeviceRemovedListener state display adapter sys =
addBtOMListener remDevice sys
addDeviceRemovedListener :: ObjectPath -> BTIO ()
addDeviceRemovedListener adapter =
addBtOMListener remDevice
where
remDevice = pathCallback adapter display $ \d -> do
old <- removeDevice state d
forM_ old $ removeMatch (toClient sys) . btDevSigHandler
remDevice = pathCallback adapter $ \d -> do
old <- removeDevice d
cl <- asks btClient
forM_ old $ liftIO . removeMatch (toClient cl) . btDevSigHandler
pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
when (adaptorHasDevice adapter d) $ f d >> display
pathCallback _ _ _ _ = return ()
pathCallback :: ObjectPath -> (ObjectPath -> BTIO ()) -> SignalCallback BTIO
pathCallback adapter f [device, _] = forM_ (fromVariant device) $ \d -> do
when (adaptorHasDevice adapter d) $ beforeDisplay $ f d
pathCallback _ _ _ = return ()
--------------------------------------------------------------------------------
-- | Adapter
-- Adapter
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
initAdapter state adapter client = do
reply <- callGetPowered adapter client
putPowered state $ fromSingletonVariant reply
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-> IO (Maybe SignalHandler)
addAdaptorListener state display adaptor sys = do
rule <- matchBTProperty sys adaptor
forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
initAdapter :: ObjectPath -> BTIO ()
initAdapter adapter = do
reply <- callGetPowered adapter
logInfo $ "initializing adapter at path " <> adapter_
-- TODO this could fail if the variant is something weird; the only
-- indication I will get is "NA"
putPowered $ fromSingletonVariant reply
where
procMatch = withSignalMatch $ \b -> putPowered state b >> display
adapter_ = displayWrapQuote $ displayObjectPath adapter
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
$ memberName_ $ T.unpack adaptorPowered
matchBTProperty
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
-> m (Maybe MatchRule)
matchBTProperty p = matchPropertyFull btBus (Just p)
matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
withBTPropertyRule
:: ( SafeClient c
, MonadReader (env c) m
, HasLogFunc (env c)
, HasClient env
, MonadUnliftIO m
, IsVariant a
)
=> ObjectPath
-> (Maybe a -> m ())
-> InterfaceName
-> T.Text
-> m (Maybe SignalHandler)
withBTPropertyRule path update iface prop = do
res <- matchBTProperty path
case res of
Just rule -> Just <$> addMatchCallback rule (signalToUpdate . matchConnected)
Nothing -> do
logError $
"could not add listener for prop "
<> prop_
<> " on path "
<> path_
return Nothing
where
path_ = displayObjectPath path
prop_ = Utf8Builder $ encodeUtf8Builder prop
signalToUpdate = withSignalMatch update
matchConnected = matchPropertyChanged iface prop
putPowered :: MutableBtState -> Maybe Bool -> IO ()
putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
addAdaptorListener :: ObjectPath -> BTIO (Maybe SignalHandler)
addAdaptorListener adaptor =
withBTPropertyRule adaptor procMatch adapterInterface adaptorPowered
where
procMatch = beforeDisplay . putPowered
readPowered :: MutableBtState -> IO (Maybe Bool)
readPowered = fmap btPowered . readMVar
callGetPowered
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, SafeClient c
, MonadUnliftIO m
)
=> ObjectPath
-> m [Variant]
callGetPowered adapter =
callPropertyGet btBus adapter adapterInterface $
memberName_ $
T.unpack adaptorPowered
putPowered :: Maybe Bool -> BTIO ()
putPowered ds = modifyState $ \s -> return (s {btPowered = ds}, ())
readPowered :: BTIO (Maybe Bool)
readPowered = fmap btPowered $ readMVar =<< asks btState
adapterInterface :: InterfaceName
adapterInterface = interfaceName_ "org.bluez.Adapter1"
@ -229,57 +317,68 @@ adaptorPowered :: T.Text
adaptorPowered = "Powered"
--------------------------------------------------------------------------------
-- | Devices
-- Devices
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addAndInitDevice state display device client = do
sh <- addDeviceListener state display device client
-- TODO add some intelligent error messages here
forM_ sh $ \s -> initDevice state s device client
addAndInitDevice :: ObjectPath -> BTIO ()
addAndInitDevice device = do
res <- addDeviceListener device
case res of
Just handler -> do
logInfo $ "initializing device at path " <> device_
initDevice handler device
Nothing -> logError $ "could not initialize device at path " <> device_
where
device_ = displayWrapQuote $ displayObjectPath device
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
initDevice state sh device sys = do
reply <- callGetConnected device sys
void $ insertDevice state device $
BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
initDevice :: SignalHandler -> ObjectPath -> BTIO ()
initDevice sh device = do
reply <- callGetConnected device
void $
insertDevice device $
BTDevice
{ btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh
}
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
-> IO (Maybe SignalHandler)
addDeviceListener state display device sys = do
rule <- matchBTProperty sys device
forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
addDeviceListener :: ObjectPath -> BTIO (Maybe SignalHandler)
addDeviceListener device =
withBTPropertyRule device procMatch devInterface devConnected
where
procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
procMatch = beforeDisplay . void . updateDevice device
matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected
callGetConnected
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
-> m [Variant]
callGetConnected p =
callPropertyGet btBus p devInterface $
memberName_ (T.unpack devConnected)
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
callGetConnected p = callPropertyGet btBus p devInterface
$ memberName_ (T.unpack devConnected)
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
insertDevice m device dev = modifyMVar m $ \s -> do
insertDevice :: ObjectPath -> BTDevice -> BTIO Bool
insertDevice device dev = modifyState $ \s -> do
let new = M.insert device dev $ btDevices s
return (s {btDevices = new}, anyDevicesConnected new)
updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
updateDevice m device status = modifyMVar m $ \s -> do
updateDevice :: ObjectPath -> Maybe Bool -> BTIO Bool
updateDevice device status = modifyState $ \s -> do
let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
return (s {btDevices = new}, anyDevicesConnected new)
anyDevicesConnected :: ConnectedDevices -> Bool
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
removeDevice m device = modifyMVar m $ \s -> do
removeDevice :: ObjectPath -> BTIO (Maybe BTDevice)
removeDevice device = modifyState $ \s -> do
let devs = btDevices s
return (s {btDevices = M.delete device devs}, M.lookup device devs)
readDevices :: MutableBtState -> IO ConnectedDevices
readDevices = fmap btDevices . readMVar
readDevices :: BTIO ConnectedDevices
readDevices = fmap btDevices $ readMVar =<< asks btState
devInterface :: InterfaceName
devInterface = interfaceName_ "org.bluez.Device1"

14
lib/Xmobar/Plugins/ClevoKeyboard.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Clevo Keyboard plugin
-- Clevo Keyboard plugin
--
-- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands
@ -9,15 +9,13 @@
module Xmobar.Plugins.ClevoKeyboard
( ClevoKeyboard (..)
, ckAlias
) where
)
where
import qualified RIO.Text as T
import Xmobar
import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import Xmobar
import Xmobar.Plugins.BacklightCommon
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
@ -27,4 +25,4 @@ ckAlias = "clevokeyboard"
instance Exec ClevoKeyboard where
alias (ClevoKeyboard _) = T.unpack ckAlias
start (ClevoKeyboard icon) =
startBacklight matchSignalCK callGetBrightnessCK icon
startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon

59
lib/Xmobar/Plugins/Common.hs
View File

@ -15,15 +15,12 @@ module Xmobar.Plugins.Common
)
where
import Control.Monad
import Data.Internal.DBus
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor)
-- use string here since all the callbacks in xmobar use strings :(
@ -35,17 +32,29 @@ data Colors = Colors
}
deriving (Eq, Show, Read)
startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
-> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
-> c -> IO ()
startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client
startListener
:: ( HasLogFunc (env c)
, HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, IsVariant a
)
=> MatchRule
-> m [Variant]
-> ([Variant] -> SignalMatch a)
-> (a -> m T.Text)
-> Callback
-> m ()
startListener rule getProp fromSignal toColor cb = do
reply <- getProp
displayMaybe cb toColor $ fromSingletonVariant reply
void $ addMatchCallback rule (procMatch . fromSignal) client
void $ addMatchCallback rule (procMatch . fromSignal)
where
procMatch = procSignalMatch cb toColor
procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
procSignalMatch
:: MonadUnliftIO m => Callback -> (a -> m T.Text) -> SignalMatch a -> m ()
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
colorText :: Colors -> Bool -> T.Text -> T.Text
@ -58,11 +67,23 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
na :: T.Text
na = "N/A"
displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
displayMaybe :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> Maybe a -> m ()
displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
displayMaybe' cb = maybe (cb $ T.unpack na)
displayMaybe' :: MonadUnliftIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
withDBusClientConnection
:: (MonadUnliftIO m, SafeClient c)
=> Callback
-> Maybe FilePath
-> (c -> RIO SimpleApp ())
-> m ()
withDBusClientConnection cb logfile f =
maybe (run stderr) (`withLogFile` run) logfile
where
run h = do
logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
withLogFunc logOpts $ \lf -> do
env <- mkSimpleApp lf Nothing
runRIO env $ displayMaybe' cb f =<< getDBusClient

67
lib/Xmobar/Plugins/Device.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | Device plugin
-- Device plugin
--
-- Display different text depending on whether or not the interface has
-- connectivity
@ -9,18 +10,14 @@
module Xmobar.Plugins.Device
( Device (..)
, devDep
) where
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Word
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
@ -44,33 +41,49 @@ devSignal :: T.Text
devSignal = "Ip4Connectivity"
devDep :: DBusDependency_ SysClient
devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
$ Method_ getByIP
devDep =
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
Method_ getByIP
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
getDevice
:: (SafeClient c, HasClient env, MonadReader (env c) m, MonadUnliftIO m)
=> T.Text
-> m (Maybe ObjectPath)
getDevice iface = bodyToMaybe <$> callMethod' mc
where
mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
mc =
(methodCallBus networkManagerBus nmPath nmInterface getByIP)
{ methodCallBody = [toVariant iface]
}
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
$ memberName_ $ T.unpack devSignal
getDeviceConnected
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> ObjectPath
-> m [Variant]
getDeviceConnected path =
callPropertyGet networkManagerBus path nmDeviceInterface $
memberName_ $
T.unpack devSignal
matchStatus :: [Variant] -> SignalMatch Word32
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
instance Exec Device where
alias (Device (iface, _, _)) = T.unpack iface
start (Device (iface, text, colors)) cb = do
withDBusClientConnection cb $ \sys -> do
path <- getDevice sys iface
displayMaybe' cb (listener sys) path
start (Device (iface, text, colors)) cb =
withDBusClientConnection cb logName $ \(sys :: SysClient) -> withDIO sys $ do
path <- getDevice iface
displayMaybe' cb listener path
where
listener sys path = do
rule <- matchPropertyFull sys networkManagerBus (Just path)
-- TODO warn the user here rather than silently drop the listener
forM_ rule $ \r ->
startListener r (getDeviceConnected path) matchStatus chooseColor' cb sys
logName = Just $ T.unpack $ T.concat ["device@", iface, ".log"]
listener path = do
res <- matchPropertyFull networkManagerBus (Just path)
case res of
Just rule -> startListener rule (getDeviceConnected path) matchStatus chooseColor' cb
Nothing -> logError "could not start listener"
chooseColor' = return . (\s -> colorText colors s text) . (> 1)

14
lib/Xmobar/Plugins/IntelBacklight.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Intel backlight plugin
-- Intel backlight plugin
--
-- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands
@ -9,15 +9,13 @@
module Xmobar.Plugins.IntelBacklight
( IntelBacklight (..)
, blAlias
) where
)
where
import qualified RIO.Text as T
import Xmobar
import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.IntelBacklight
import Xmobar
import Xmobar.Plugins.BacklightCommon
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
@ -27,4 +25,4 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where
alias (IntelBacklight _) = T.unpack blAlias
start (IntelBacklight icon) =
startBacklight matchSignalIB callGetBrightnessIB icon
startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon

21
lib/Xmobar/Plugins/Screensaver.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Screensaver plugin
-- Screensaver plugin
--
-- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands
@ -9,13 +9,13 @@
module Xmobar.Plugins.Screensaver
( Screensaver (..)
, ssAlias
) where
)
where
import Data.Internal.DBus
import qualified RIO.Text as T
import Xmobar
import XMonad.Internal.DBus.Screensaver
import Xmobar
import Xmobar.Plugins.Common
newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
@ -25,10 +25,9 @@ ssAlias = "screensaver"
instance Exec Screensaver where
alias (Screensaver _) = T.unpack ssAlias
start (Screensaver (text, colors)) cb = do
withDBusClientConnection cb $ \sys -> do
matchSignal display sys
display =<< callQuery sys
start (Screensaver (text, colors)) cb =
withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
matchSignal dpy
dpy =<< callQuery
where
display = displayMaybe cb $ return . (\s -> colorText colors s text)
dpy = displayMaybe cb $ return . (\s -> colorText colors s text)

161
lib/Xmobar/Plugins/VPN.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | VPN plugin
-- VPN plugin
--
-- Use the networkmanager to detect when a VPN interface is added or removed.
-- Specifically, monitor the object tree to detect paths with the interface
@ -11,21 +12,16 @@ module Xmobar.Plugins.VPN
( VPN (..)
, vpnAlias
, vpnDep
) where
import Control.Concurrent.MVar
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Map as M
import qualified RIO.Set as S
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
@ -36,80 +32,128 @@ newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
instance Exec VPN where
alias (VPN _) = T.unpack vpnAlias
start (VPN (text, colors)) cb =
withDBusClientConnection cb $ \c -> do
state <- initState c
let display = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state display
vpnAddedListener (signalCallback' addedCallback) c
vpnRemovedListener (signalCallback' removedCallback) c
display
withDBusClientConnection cb (Just "vpn.log") $ \c -> do
let dpy = displayMaybe cb iconFormatter . Just =<< readState
s <- newEmptyMVar
mapRIO (VEnv c s dpy) $ do
initState
vpnAddedListener addedCallback
vpnRemovedListener removedCallback
dpy
where
iconFormatter b = return $ colorText colors b text
--------------------------------------------------------------------------------
-- | VPN State
-- VPN State
--
-- Maintain a set of paths which are the currently active VPNs. Most of the time
-- this will be a null or singleton set, but this setup could handle the edge
-- case of multiple VPNs being active at once without puking.
data VEnv c = VEnv
{ vClient :: !c
, vState :: !(MVar VPNState)
, vDisplay :: !(VIO ())
, vEnv :: !SimpleApp
}
instance SafeClient c => HasLogFunc (VEnv c) where
logFuncL = lens vEnv (\x y -> x {vEnv = y}) . logFuncL
instance HasClient VEnv where
clientL = lens vClient (\x y -> x {vClient = y})
type VIO = RIO (VEnv SysClient)
type VPNState = S.Set ObjectPath
type MutableVPNState = MVar VPNState
initState :: VIO ()
initState = do
ot <- getVPNObjectTree
s <- asks vState
putMVar s $ findTunnels ot
initState :: SysClient -> IO MutableVPNState
initState client = do
ot <- getVPNObjectTree client
newMVar $ findTunnels ot
readState :: VIO Bool
readState = fmap (not . null) . readMVar =<< asks vState
readState :: MutableVPNState -> IO Bool
readState = fmap (not . null) . readMVar
updateState :: (ObjectPath -> VPNState -> VPNState) -> ObjectPath -> VIO ()
updateState f op = do
s <- asks vState
modifyMVar_ s $ return . f op
updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-> ObjectPath -> IO ()
updateState f state op = modifyMVar_ state $ return . f op
beforeDisplay :: VIO () -> VIO ()
beforeDisplay f = f >> join (asks vDisplay)
--------------------------------------------------------------------------------
-- | Tunnel Device Detection
--
-- Tunnel Device Detection
getVPNObjectTree :: SysClient -> IO ObjectTree
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
getVPNObjectTree
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> m ObjectTree
getVPNObjectTree = callGetManagedObjects vpnBus vpnPath
findTunnels :: ObjectTree -> VPNState
findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
vpnAddedListener :: SignalCallback -> SysClient -> IO ()
vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
vpnAddedListener
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> SignalCallback m
-> m ()
vpnAddedListener cb = void $ addInterfaceAddedListener vpnBus vpnPath cb
vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
vpnRemovedListener
:: ( SafeClient c
, HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
)
=> SignalCallback m
-> m ()
vpnRemovedListener cb = void $ addInterfaceRemovedListener vpnBus vpnPath cb
addedCallback :: MutableVPNState -> IO () -> SignalCallback
addedCallback state display [device, added] = update >> display
addedCallback :: SignalCallback VIO
addedCallback [device, added] =
beforeDisplay $
updateDevice S.insert device $
M.keys $
fromMaybe M.empty added'
where
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
is = M.keys $ fromMaybe M.empty added'
update = updateDevice S.insert state device is
addedCallback _ _ _ = return ()
addedCallback _ = return ()
removedCallback :: MutableVPNState -> IO () -> SignalCallback
removedCallback state display [device, interfaces] = update >> display
where
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
update = updateDevice S.delete state device is
removedCallback _ _ _ = return ()
removedCallback :: SignalCallback VIO
removedCallback [device, interfaces] =
beforeDisplay $
updateDevice S.delete device $
fromMaybe [] $
fromVariant interfaces
removedCallback _ = return ()
updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-> Variant -> [T.Text] -> IO ()
updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
forM_ d $ updateState f state
updateDevice
:: (ObjectPath -> VPNState -> VPNState)
-> Variant
-> [T.Text]
-> VIO ()
updateDevice f device interfaces =
when (vpnDeviceTun `elem` interfaces) $
forM_ d $
updateState f
where
d = fromVariant device :: Maybe ObjectPath
--------------------------------------------------------------------------------
-- | DBus Interface
--
-- DBus Interface
vpnBus :: BusName
vpnBus = busName_ "org.freedesktop.NetworkManager"
@ -124,5 +168,6 @@ vpnAlias :: T.Text
vpnAlias = "vpn"
vpnDep :: DBusDependency_ SysClient
vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
$ Method_ getManagedObjects
vpnDep =
Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
Method_ getManagedObjects

15
package.yaml
View File

@ -7,7 +7,7 @@ copyright: "2022 Nathan Dwarshuis"
extra-source-files:
- README.md
- .stylish-haskell.yaml
- fourmolu.yaml
- make_pkgs
- icons/*
- scripts/*
@ -19,28 +19,23 @@ dependencies:
- base
- bytestring >= 0.10.8.2
- colour >= 2.3.5
- containers >= 0.6.0.1
- dbus >= 1.2.7
- fdo-notify
- io-streams >= 1.5.1.0
- mtl >= 2.2.2
- unix >= 2.7.2.2
- tcp-streams >= 1.0.1.1
- text >= 1.2.3.1
- directory >= 1.3.3.0
- process >= 1.6.5.0
- split >= 0.2.3.4
- xmobar
- xmonad-extras >= 0.15.2
- xmonad >= 0.13
- xmonad-contrib >= 0.13
- aeson >= 2.0.3.0
- yaml >=0.11.8.0
- unordered-containers >= 0.2.16.0
- hashable >= 1.3.5.0
- xml >= 1.3.14
- lifted-base >= 0.2.3.12
- utf8-string >= 1.0.2
- typed-process >= 0.2.8.0
- network >= 3.1.2.7
- unliftio >= 0.2.21.0
- optparse-applicative >= 0.16.1.0
library:
source-dirs: lib/