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

Compare commits

base: ndwarshuis:aa3979b36fa756f08a8e43fbe041dfb118eef361
Branches Tags
ndwarshuis:master
ndwarshuis:fix_dbus
ndwarshuis:fix_rio_run
ndwarshuis:fix_process
ndwarshuis:use_nix
...
compare: ndwarshuis:adf0257533a750b91e6e7076fa6228f030b4a777
Branches Tags
ndwarshuis:master
ndwarshuis:fix_dbus
ndwarshuis:fix_rio_run
ndwarshuis:fix_process
ndwarshuis:use_nix

5 Commits
aa3979b36f ... adf0257533

Author SHA1 Message Date
Nathan Dwarshuis adf0257533 REF reformat everything with fourmolu 2022-12-30 14:58:23 -05:00
Nathan Dwarshuis b2b0f72178 ENH use fourmolu 2022-12-30 12:21:53 -05:00
Nathan Dwarshuis d560db1548 Revert "WIP use unliftio everywhere-ish" 
This reverts commit 769df2fb00.
 2022-12-30 10:56:09 -05:00
Nathan Dwarshuis 769df2fb00 WIP use unliftio everywhere-ish 2022-12-30 10:38:21 -05:00
Nathan Dwarshuis 017d13d80c ENH clean up docs in shell 2022-12-29 15:22:48 -05:00
35 changed files with 2534 additions and 2456 deletions
Show Stats 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

18
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,19 +14,14 @@
-- 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 Text.XML.Light
import System.Environment
import Text.XML.Light
import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.IO
@ -48,7 +42,6 @@ runAndWait [n] = do
p <- vmPID i
liftIO $ mapM_ waitUntilExit p
err = logError "Could not get machine ID"
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
vmLaunch :: T.Text -> RIO SimpleApp ()
@ -56,7 +49,9 @@ 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)
@ -73,8 +68,9 @@ 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" }))
=<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
=<< (\e -> findChild (qual e "Machine") e)
=<< parseXMLDoc c

338
bin/xmobar.hs
View File

@ -1,8 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
--------------------------------------------------------------------------------
-- | Xmobar binary
--
-- Features:
@ -12,29 +9,19 @@ 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
module Main (main) where
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
import Data.Maybe
import RIO hiding (hFlush)
import qualified RIO.ByteString.Lazy as BL
import RIO.Process
import qualified RIO.Text as T
import System.Environment
import System.IO
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
import XMonad.Core hiding (config)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Command.Power
@ -47,8 +34,13 @@ 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
@ -84,13 +76,16 @@ printDeps = do
io $ disconnectDBus db
usage :: IO ()
usage = putStrLn $ intercalate "\n"
usage =
putStrLn $
intercalate
"\n"
[ "xmobar: run greatest taskbar"
, "xmobar --deps: print dependencies"
]
--------------------------------------------------------------------------------
-- | toplevel configuration
-- toplevel configuration
-- | The text font family
textFont :: Always XT.FontBuilder
@ -102,11 +97,14 @@ textFontOffset = 16
-- | Attributes for the bar font (size, weight, etc)
textFontData :: XT.FontData
textFontData = XT.defFontData { XT.weight = Just XT.Bold, XT.size = Just 11 }
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)
@ -125,14 +123,15 @@ iconSize IconXLarge = 20
-- | Attributes for icon fonts
iconFontData :: Int -> XT.FontData
iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing }
iconFontData s = XT.defFontData {XT.pixelsize = Just s, XT.size = Nothing}
-- | Global configuration
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
-- 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
@ -142,32 +141,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
}
@ -177,13 +175,15 @@ getAllCommands right = BarRegions
}
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins db = mapM evalFeature $ allFeatures db
rightPlugins db =
mapM evalFeature $
allFeatures db
++ [always' "date indicator" dateCmd]
where
always' n = Right . Always n . Always_ . FallbackAlone
allFeatures :: DBusState -> [Feature CmdSpec]
allFeatures DBusState { dbSesClient = ses, dbSysClient = sys } =
allFeatures DBusState {dbSesClient = ses, dbSysClient = sys} =
[ Left getWireless
, Left $ getEthernet sys
, Left $ getVPN sys
@ -200,7 +200,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
@ -213,32 +216,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" []
$ io $ 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
@ -249,29 +269,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"
]
@ -280,125 +329,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
@ -408,33 +502,37 @@ 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 :: FIO (Maybe Msg)
vpnPresent = do
res <- proc "nmcli" args readProcess
return $ case res of
(ExitSuccess, out, _) | "vpn" `elem` BL.split 10 out -> Nothing
(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 "
(ExitFailure c, _, err) ->
Just $
Msg LevelError $
T.concat
[ "vpn search exited with code "
, T.pack $ show c
, ": "
, T.decodeUtf8With T.lenientDecode
$ BL.toStrict err
, 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.
@ -445,17 +543,20 @@ getTextFont = do
return $ fb textFontData
--------------------------------------------------------------------------------
-- | icon fonts
-- icon fonts
getIconFonts :: FIO ([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
@ -483,10 +584,10 @@ fontifyIcon :: Fontifier
fontifyIcon f i _ = fontifyText f i
--------------------------------------------------------------------------------
-- | various formatting things
-- various formatting things
colors :: Colors
colors = Colors { colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor }
colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
sep :: T.Text
sep = xmobarFGColor XT.backdropFgColor " : "
@ -503,8 +604,9 @@ pSep = "%"
fmtSpecs :: [CmdSpec] -> T.Text
fmtSpecs = T.intercalate sep . fmap go
where
go CmdSpec { csAlias = a } = T.concat [pSep, a, pSep]
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]

347
bin/xmonad.hs
View File

@ -4,35 +4,30 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | 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.Monoid
import Data.Text.IO (hPutStrLn)
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras
import RIO
import RIO.Directory
import RIO.Process
import qualified RIO.Text as T
import System.Environment
import System.Posix.Signals
import System.Process
( getPid
, getProcessExitCode
)
import XMonad
import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS
@ -110,10 +105,12 @@ run = do
sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs
tt <- evalAlways $ fsTabbedTheme fs
let conf = ewmh
$ addKeymap dws sk kbs
$ docks
$ def { terminal = myTerm
let conf =
ewmh $
addKeymap dws sk kbs $
docks $
def
{ terminal = myTerm
, modMask = myModMask
, layoutHook = myLayouts tt
, manageHook = myManageHook dws
@ -128,8 +125,11 @@ run = do
}
io $ runXMonad conf
where
startRemovableMon db fs = void $ executeSometimes $ fsRemovableMon fs
$ dbSysClient db
startRemovableMon db fs =
void $
executeSometimes $
fsRemovableMon fs $
dbSysClient db
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
@ -142,8 +142,9 @@ runXMonad conf = do
launch conf dirs
startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
startDBusInterfaces db fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
$ fsDBusExporters fs
startDBusInterfaces db fs =
mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
fsDBusExporters fs
getCreateDirectories :: IO Directories
getCreateDirectories = do
@ -178,7 +179,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
@ -196,7 +198,8 @@ startXmobar = do
io $ hSetBuffering (getStdin p) LineBuffering
return p
where
start = startProcess
start =
startProcess
. setStdin createPipe
. setCreateGroup True
@ -228,32 +231,37 @@ 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 $
mapM_ (putStrLn . T.unpack) $
fmap showFulfillment $
sort $
nub $
concat $
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
io $ disconnectDBus db
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
allFeatures db = do
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
$ externalBindings ts db
let bfs =
concatMap (fmap kbMaybeAction . kgBindings) $
externalBindings ts db
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
let others = [runRemovableMon $ dbSysClient db, runPowermon]
return (dbus ++ others, Left runScreenLock:bfs, allDWs')
return (dbus ++ others, Left runScreenLock : bfs, allDWs')
where
ts = ThreadState { tsChildPIDs = [], tsXmobar = Nothing }
ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
usage :: IO ()
usage = putStrLn $ intercalate "\n"
usage =
putStrLn $
intercalate
"\n"
[ "xmonad: run greatest window manager"
, "xmonad --deps: print dependencies"
]
--------------------------------------------------------------------------------
-- | Concurrency configuration
-- Concurrency configuration
data ThreadState = ThreadState
{ tsChildPIDs :: [Process () () ()]
@ -294,18 +302,19 @@ killNoWait p = do
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]
myWorkspaces = map show [1 .. 10 :: Int]
gimpTag :: String
gimpTag = "GIMP"
@ -323,7 +332,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
@ -337,96 +347,121 @@ 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 [] $ io $ 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
, dwHook = [ className =? c -?> appendViewShift vmTag ]
, dwHook = [className =? c -?> appendViewShift vmTag]
, dwKey = 'v'
, dwCmd = Just $ spawnCmd "vbox-start" [vm]
}
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
, dwHook = [ className =? c -?> appendViewShift xsaneTag >> doFloat ]
, dwHook = [className =? c -?> appendViewShift xsaneTag >> doFloat]
, dwKey = 'x'
, dwCmd = Just $ spawnCmd "xsane" []
}
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
, dwHook = [ className =? c -?> appendShift f5Tag ]
, dwHook = [className =? c -?> appendShift f5Tag]
, dwKey = 'i'
, dwCmd = Just skip
}
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.
@ -448,8 +483,7 @@ runHide :: X ()
runHide = sendMessage $ Toggle HIDE
--------------------------------------------------------------------------------
-- | Loghook configuration
--
-- Loghook configuration
myLoghook :: Process Handle () () -> X ()
myLoghook h = do
@ -467,7 +501,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 []
@ -480,8 +514,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]
@ -507,20 +542,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 :: 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]
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)
@ -528,7 +565,8 @@ logXinerama p = 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
@ -538,53 +576,57 @@ logXinerama p = 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
-- | React to ClientMessage events from concurrent threads
xMsgEventHook :: (String -> X ()) -> Event -> X All
xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
xMsgEventHook handler ClientMessageEvent {ev_message_type = t, ev_data = d}
| t == bITMAP = do
let (xtype, tag) = splitXMsg d
case xtype of
@ -595,19 +637,26 @@ xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
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
@ -624,32 +673,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
@ -667,9 +720,10 @@ internalBindings dws c =
nextScr' f = next f >> nextScr
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))
mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} =
(subtitle h :) $
mkNamedKeymap c $
(\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
<$> b
data KeyBinding a = KeyBinding
@ -686,25 +740,28 @@ data KeyGroup a = KeyGroup
evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
evalExternal = mapM go
where
go k@KeyGroup { kgBindings = bs } =
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
go k@KeyGroup {kgBindings = bs} =
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
(\f -> k {kbMaybeAction = f}) <$> evalFeature a
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go
where
go k@KeyGroup { kgBindings = bs } =
k { kgBindings = [ kb { kbMaybeAction = x }
| kb@KeyBinding { kbMaybeAction = Just x } <- bs
go k@KeyGroup {kgBindings = bs} =
k
{ kgBindings =
[ kb {kbMaybeAction = x}
| kb@KeyBinding {kbMaybeAction = Just x} <- bs
]
}
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
externalBindings ts db =
[ KeyGroup "Launchers"
[ 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
@ -720,8 +777,8 @@ externalBindings ts db =
, KeyBinding "M-C-q" "launch calc" $ Left runCalc
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
]
, KeyGroup "Actions"
, KeyGroup
"Actions"
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
, KeyBinding "M-r" "run program" $ Left runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
@ -731,8 +788,8 @@ externalBindings ts db =
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
]
, KeyGroup "Multimedia"
, KeyGroup
"Multimedia"
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
@ -741,15 +798,15 @@ externalBindings ts db =
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
]
, KeyGroup "Dunst"
, 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 "System"
, KeyGroup
"System"
[ KeyBinding "M-." "backlight up" $ ib bctlInc
, KeyBinding "M-," "backlight down" $ ib bctlDec
, KeyBinding "M-M1-," "backlight min" $ ib bctlMin
@ -761,8 +818,8 @@ 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

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

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

@ -1,15 +1,15 @@
--------------------------------------------------------------------------------
-- | Common internal DBus functions
-- Common internal DBus functions
module Data.Internal.DBus
( SafeClient(..)
, SysClient(..)
, SesClient(..)
( SafeClient (..)
, SysClient (..)
, SesClient (..)
, addMatchCallback
, matchProperty
, matchPropertyFull
, matchPropertyChanged
, SignalMatch(..)
, SignalMatch (..)
, SignalCallback
, MethodBody
, withSignalMatch
@ -25,22 +25,20 @@ module Data.Internal.DBus
, addInterfaceRemovedListener
, fromSingletonVariant
, bodyToMaybe
) where
)
where
import Control.Exception
import Control.Monad
import DBus
import DBus.Client
import Data.Bifunctor
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified RIO.Text as T
import DBus
import DBus.Client
--------------------------------------------------------------------------------
-- | Type-safe client
-- Type-safe client
class SafeClient c where
toClient :: c -> Client
@ -86,24 +84,33 @@ getDBusClient' sys = do
Right c -> return $ Just c
--------------------------------------------------------------------------------
-- | Methods
-- Methods
type MethodBody = Either T.Text [Variant]
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
callMethod' cl =
fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl)
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> IO MethodBody
callMethod
:: SafeClient c
=> c
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> IO MethodBody
callMethod client bus path iface = callMethod' client . 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"
@ -111,12 +118,14 @@ dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
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
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe
@ -125,30 +134,45 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
bodyToMaybe = either (const Nothing) fromSingletonVariant
--------------------------------------------------------------------------------
-- | Signals
-- Signals
type SignalCallback = [Variant] -> IO ()
addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
addMatchCallback
:: SafeClient c
=> MatchRule
-> SignalCallback
-> c
-> IO SignalHandler
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ 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
:: 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
--------------------------------------------------------------------------------
-- | Properties
-- Properties
propertyInterface :: InterfaceName
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
@ -156,16 +180,28 @@ 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
:: 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
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
matchPropertyFull
:: SafeClient c
=> c
-> BusName
-> Maybe ObjectPath
-> IO (Maybe MatchRule)
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
@ -177,14 +213,19 @@ 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 +233,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 +249,44 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
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
addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
-> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
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
addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
-> SignalCallback -> c -> IO (Maybe SignalHandler)
addInterfaceAddedListener
:: SafeClient c
=> BusName
-> ObjectPath
-> SignalCallback
-> c
-> IO (Maybe SignalHandler)
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
-> SignalCallback -> c -> IO (Maybe SignalHandler)
addInterfaceRemovedListener
:: SafeClient c
=> BusName
-> ObjectPath
-> SignalCallback
-> c
-> IO (Maybe SignalHandler)
addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved

397
lib/Data/Internal/Dependency.hs
View File

@ -6,56 +6,52 @@
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | Functions for handling dependencies
-- Functions for handling dependencies
module Data.Internal.Dependency
-- feature types
-- feature types
( Feature
, Always(..)
, Always_(..)
, FallbackRoot(..)
, FallbackStack(..)
, Sometimes(..)
, Always (..)
, Always_ (..)
, FallbackRoot (..)
, FallbackStack (..)
, Sometimes (..)
, Sometimes_
, AlwaysX
, AlwaysIO
, SometimesX
, SometimesIO
, PostPass(..)
, Subfeature(..)
, PostPass (..)
, Subfeature (..)
, SubfeatureRoot
, Msg(..)
, Msg (..)
-- configuration
, XParams(..)
, XPFeatures(..)
, XParams (..)
, XPFeatures (..)
, XPQuery
-- dependency tree types
, Root(..)
, Tree(..)
, Tree_(..)
, Root (..)
, Tree (..)
, Tree_ (..)
, IOTree
, IOTree_
, DBusTree
, DBusTree_
, SafeClient(..)
, IODependency(..)
, IODependency_(..)
, SystemDependency(..)
, DBusDependency_(..)
, DBusMember(..)
, UnitType(..)
, SafeClient (..)
, IODependency (..)
, IODependency_ (..)
, SystemDependency (..)
, DBusDependency_ (..)
, DBusMember (..)
, UnitType (..)
, Result
, Fulfillment(..)
, ArchPkg(..)
, Fulfillment (..)
, ArchPkg (..)
-- dumping
, dumpFeature
, dumpAlways
, dumpSometimes
, showFulfillment
-- testing
, FIO
, withCache
@ -72,11 +68,9 @@ module Data.Internal.Dependency
, readEthernet
, readWireless
, socketExists
-- lifting
, ioSometimes
, ioAlways
-- feature construction
, always1
, sometimes1
@ -86,7 +80,6 @@ module Data.Internal.Dependency
, sometimesExe
, sometimesExeArgs
, sometimesEndpoint
-- dependency construction
, sysExe
, localExe
@ -101,15 +94,16 @@ module Data.Internal.Dependency
, voidResult
, voidRead
, process
-- misc
, shellTest
) where
)
where
import Control.Monad.IO.Class
import Control.Monad.Identity
import Control.Monad.Reader
import DBus hiding (typeOf)
import qualified DBus.Introspection as I
import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key
import Data.Bifunctor
@ -118,30 +112,23 @@ import Data.Internal.DBus
import Data.List
import Data.Maybe
import Data.Yaml
import GHC.IO.Exception (ioe_description)
import DBus hiding (typeOf)
import qualified DBus.Introspection as I
import RIO hiding (bracket, fromString)
import RIO.FilePath
import RIO.Process hiding (findExecutable)
import qualified RIO.Text as T
import System.Directory
import System.Environment
import System.IO.Error
import System.Posix.Files
import System.Process.Typed (nullStream)
import XMonad.Core (X, io)
import XMonad.Internal.IO
import XMonad.Internal.Shell hiding (proc, runProcess)
import XMonad.Internal.Theme
--------------------------------------------------------------------------------
-- | Feature Evaluation
-- Feature Evaluation
--
-- Here we attempt to build and return the monadic actions encoded by each
-- feature.
@ -195,15 +182,16 @@ logMsg (FMsg fn n (Msg ll m)) = do
llFun LevelWarn = ("WARN", logWarn)
llFun _ = ("DEBUG", logDebug)
(s, f) = llFun ll
fmt p l = [ bracket p
fmt p l =
[ bracket p
, bracket l
, bracket fn
]
++ maybe [] ((:[]) . bracket) n
++ maybe [] ((: []) . bracket) n
++ [m]
--------------------------------------------------------------------------------
-- | Package status
-- Package status
showFulfillment :: Fulfillment -> T.Text
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
@ -220,7 +208,7 @@ dumpSometimes :: Sometimes a -> [Fulfillment]
dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs
--------------------------------------------------------------------------------
-- | Wrapper types
-- Wrapper types
type AlwaysX = Always (X ())
@ -233,7 +221,7 @@ type SometimesIO = Sometimes (FIO ())
type Feature a = Either (Sometimes a) (Always a)
--------------------------------------------------------------------------------
-- | Feature declaration
-- Feature declaration
-- | Feature that is guaranteed to work
-- This is composed of sub-features that are tested in order, and if all fail
@ -241,17 +229,20 @@ type Feature a = Either (Sometimes a) (Always a)
data Always a = Always T.Text (Always_ a)
-- | Feature that is guaranteed to work (inner data)
data Always_ a = Option (SubfeatureRoot a) (Always_ a)
data Always_ a
= Option (SubfeatureRoot a) (Always_ a)
| Always_ (FallbackRoot a)
-- | Root of a fallback action for an always
-- This may either be a lone action or a function that depends on the results
-- from other Always features.
data FallbackRoot a = FallbackAlone a
data FallbackRoot a
= FallbackAlone a
| forall p. FallbackTree (p -> a) (FallbackStack p)
-- | Always features that are used as a payload for a fallback action
data FallbackStack p = FallbackBottom (Always p)
data FallbackStack p
= FallbackBottom (Always p)
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
-- | Feature that might not be present
@ -276,14 +267,15 @@ type SubfeatureRoot a = Subfeature (Root a)
-- | An action and its dependencies
-- May be a plain old monad or be DBus-dependent, in which case a client is
-- needed
data Root a = forall p. IORoot (p -> a) (IOTree p)
data Root a
= forall p. IORoot (p -> a) (IOTree p)
| IORoot_ a IOTree_
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
-- | The dependency tree with rule to merge results when needed
data Tree d d_ p =
forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
data Tree d d_ p
= forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
| And1 (Tree d d_ p) (Tree_ d_)
| And2 (Tree_ d_) (Tree d d_ p)
| Or (Tree d d_ p) (Tree d d_ p)
@ -294,36 +286,41 @@ data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
-- | Shorthand tree types for lazy typers
type IOTree p = Tree IODependency IODependency_ p
type DBusTree c p = Tree IODependency (DBusDependency_ c) p
type IOTree_ = Tree_ IODependency_
type DBusTree_ c = Tree_ (DBusDependency_ c)
-- | A dependency that only requires IO to evaluate (with payload)
data IODependency p =
-- an IO action that yields a payload
data IODependency p
= -- an IO action that yields a payload
IORead T.Text [Fulfillment] (FIO (Result p))
-- always yields a payload
| IOConst p
-- an always that yields a payload
| forall a. IOAlways (Always a) (a -> p)
-- a sometimes that yields a payload
| forall a. IOSometimes (Sometimes a) (a -> p)
| -- always yields a payload
IOConst p
| -- an always that yields a payload
forall a. IOAlways (Always a) (a -> p)
| -- a sometimes that yields a payload
forall a. IOSometimes (Sometimes a) (a -> p)
-- | A dependency pertaining to the DBus
data DBusDependency_ c = Bus [Fulfillment] BusName
data DBusDependency_ c
= Bus [Fulfillment] BusName
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_
deriving (Generic)
-- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
data IODependency_
= IOSystem_ [Fulfillment] SystemDependency
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a)
-- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious
data SystemDependency =
Executable Bool FilePath
data SystemDependency
= Executable Bool FilePath
| AccessiblePath FilePath Bool Bool
| Systemd UnitType T.Text
| Process T.Text
@ -333,7 +330,8 @@ data SystemDependency =
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
-- | Wrapper type to describe and endpoint
data DBusMember = Method_ MemberName
data DBusMember
= Method_ MemberName
| Signal_ MemberName
| Property_ T.Text
deriving (Eq, Show, Generic)
@ -345,7 +343,7 @@ data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
--------------------------------------------------------------------------------
-- | Tested dependency tree
-- Tested dependency tree
--
-- The main reason I need this is so I have a "result" I can convert to JSON
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
@ -357,7 +355,8 @@ data Msg = Msg LogLevel T.Text
data FMsg = FMsg T.Text (Maybe T.Text) Msg
-- | Tested Always feature
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
data PostAlways a
= Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
| Fallback a [SubfeatureFail]
-- | Tested Sometimes feature
@ -382,7 +381,7 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
data PostFail = PostFail [Msg] | PostMissing Msg
--------------------------------------------------------------------------------
-- | Configuration
-- Configuration
type FIO a = RIO DepStage a
@ -393,10 +392,10 @@ data DepStage = DepStage
}
instance HasLogFunc DepStage where
logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y })
logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y})
instance HasProcessContext DepStage where
processContextL = lens dsProcCxt (\x y -> x { dsProcCxt = y })
processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y})
data XParams = XParams
{ xpLogLevel :: LogLevel
@ -434,34 +433,48 @@ data XPFeatures = XPFeatures
}
instance FromJSON XPFeatures where
parseJSON = withObject "features" $ \o -> XPFeatures
<$> o .:+ "optimus"
<*> o .:+ "virtualbox"
<*> o .:+ "xsane"
<*> o .:+ "ethernet"
<*> o .:+ "wireless"
<*> o .:+ "vpn"
<*> o .:+ "bluetooth"
<*> o .:+ "intel_backlight"
<*> o .:+ "clevo_backlight"
<*> o .:+ "battery"
<*> o .:+ "f5vpn"
parseJSON = withObject "features" $ \o ->
XPFeatures
<$> o
.:+ "optimus"
<*> o
.:+ "virtualbox"
<*> o
.:+ "xsane"
<*> o
.:+ "ethernet"
<*> o
.:+ "wireless"
<*> o
.:+ "vpn"
<*> o
.:+ "bluetooth"
<*> o
.:+ "intel_backlight"
<*> o
.:+ "clevo_backlight"
<*> o
.:+ "battery"
<*> o
.:+ "f5vpn"
defParams :: XParams
defParams = XParams
defParams =
XParams
{ xpLogLevel = LevelError
, xpFeatures = defXPFeatures
}
defXPFeatures :: XPFeatures
defXPFeatures = XPFeatures
defXPFeatures =
XPFeatures
{ xpfOptimus = False
, xpfVirtualBox = False
, xpfXSANE = False
, xpfEthernet = False
, xpfWireless = False
-- TODO this might be broken down into different flags (expressvpn, etc)
, xpfVPN = False
, -- TODO this might be broken down into different flags (expressvpn, etc)
xpfVPN = False
, xpfBluetooth = False
, xpfIntelBacklight = False
, xpfClevoBacklight = False
@ -476,7 +489,8 @@ getParams = do
p <- getParamFile
maybe (return defParams) decodeYaml p
where
decodeYaml p = either (\e -> print e >> return defParams) return
decodeYaml p =
either (\e -> print e >> return defParams) return
=<< decodeFileEither p
getParamFile :: IO (Maybe FilePath)
@ -495,16 +509,18 @@ getParamFile = do
(.:+) :: Object -> String -> Parser Bool
(.:+) o n = o .:? fromString n .!= False
infix .:+
infix 9 .:+
--------------------------------------------------------------------------------
-- | Testing pipeline
-- Testing pipeline
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do
r <- asks (u . xpFeatures . dsParams)
if not r then return $ Left [dis n] else do
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
if not r
then return $ Left [dis n]
else do
PostSometimes {psSuccess = s, psFailed = fs} <- testSometimes xs
let fs' = failedMsgs n fs
return $ case s of
(Just p) -> Right $ second (++ fs') $ passActMsg n p
@ -520,13 +536,13 @@ evalAlwaysMsg (Always n x) = do
(Fallback act fs) -> (act, failedMsgs n fs)
passActMsg :: T.Text -> SubfeaturePass a -> (a, [FMsg])
passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn (Just n)) ws)
passActMsg fn Subfeature {sfData = PostPass a ws, sfName = n} = (a, fmap (FMsg fn (Just n)) ws)
failedMsgs :: T.Text -> [SubfeatureFail] -> [FMsg]
failedMsgs n = concatMap (failedMsg n)
failedMsg :: T.Text -> SubfeatureFail -> [FMsg]
failedMsg fn Subfeature { sfData = d, sfName = n } = case d of
failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
(PostFail es) -> f es
(PostMissing e) -> f [e]
where
@ -538,7 +554,7 @@ testAlways = go []
go failed (Option fd next) = do
r <- testSubfeature fd
case r of
(Left l) -> go (l:failed) next
(Left l) -> go (l : failed) next
(Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
@ -557,17 +573,17 @@ testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing [])
where
go ts [] = return ts
go ts (x:xs) = do
go ts (x : xs) = do
sf <- testSubfeature x
case sf of
(Left l) -> go (ts { psFailed = l:psFailed ts }) xs
(Right pass) -> return $ ts { psSuccess = Just pass }
(Left l) -> go (ts {psFailed = l : psFailed ts}) xs
(Right pass) -> return $ ts {psSuccess = Just pass}
testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
testSubfeature sf@Subfeature{ sfData = t } = do
testSubfeature sf@Subfeature {sfData = t} = do
t' <- testRoot t
-- monomorphism restriction :(
return $ bimap (\n -> sf { sfData = n }) (\n -> sf { sfData = n }) t'
return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
testRoot :: Root a -> FIO (Either PostFail (PostPass a))
testRoot r = do
@ -576,8 +592,11 @@ testRoot r = do
(IORoot_ a t) -> go_ a testIODep_ t
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
_ -> return $ Left $ PostMissing
$ Msg LevelError "client not available"
_ ->
return $
Left $
PostMissing $
Msg LevelError "client not available"
where
-- rank N polymorphism is apparently undecidable...gross
go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
@ -585,13 +604,15 @@ testRoot r = do
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
--------------------------------------------------------------------------------
-- | Payloaded dependency testing
-- Payloaded dependency testing
type Result p = Either [Msg] (PostPass p)
type MResult p = Memoized (Result p)
testTree :: forall d d_ p. (d_ -> FIO MResult_)
testTree
:: forall d d_ p
. (d_ -> FIO MResult_)
-> (forall q. d q -> FIO (MResult q))
-> Tree d d_ p
-> FIO (Either [Msg] (PostPass p))
@ -622,18 +643,22 @@ testIODep d = memoizeMVar $ case d of
-- succeed, which kinda makes this pointless. The only reason I would want
-- this is if I want to have a built-in logic to "choose" a payload to use in
-- building a higher-level feature
IOAlways a f -> Right . uncurry PostPass
IOAlways a f ->
Right
. uncurry PostPass
-- TODO this is wetter than Taco Bell shit
. bimap f (fmap stripMsg) <$> evalAlwaysMsg a
IOSometimes x f -> bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
. bimap f (fmap stripMsg)
<$> evalAlwaysMsg a
IOSometimes x f ->
bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
<$> evalSometimesMsg x
stripMsg :: FMsg -> Msg
stripMsg (FMsg _ _ m) = m
--------------------------------------------------------------------------------
-- | Standalone dependency testing
-- | Standalone dependency testing
type Result_ = Either [Msg] [Msg]
type MResult_ = Memoized Result_
@ -652,14 +677,17 @@ testIODep_ d = memoizeMVar $ testIODepNoCache_ d
testIODepNoCache_ :: IODependency_ -> FIO Result_
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
testIODepNoCache_ (IOSometimes_ x) =
bimap (fmap stripMsg) (fmap stripMsg . snd)
<$> evalSometimesMsg x
--------------------------------------------------------------------------------
-- | System Dependency Testing
-- | System Dependency Testing
testSysDependency :: SystemDependency -> FIO (Maybe Msg)
testSysDependency (Executable sys bin) = io $ maybe (Just msg) (const Nothing)
testSysDependency (Executable sys bin) =
io $
maybe (Just msg) (const Nothing)
<$> findExecutable bin
where
msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
@ -668,8 +696,9 @@ testSysDependency (Systemd t n) = shellTest "systemctl" args msg
where
msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
args = ["--user" | t == UserUnit] ++ ["status", n]
testSysDependency (Process n) = shellTest "pidof" [n]
$ T.unwords ["Process", singleQuote n, "not found"]
testSysDependency (Process n) =
shellTest "pidof" [n] $
T.unwords ["Process", singleQuote n, "not found"]
testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
where
testPerm False _ _ = Nothing
@ -696,7 +725,7 @@ unitType SystemUnit = "system"
unitType UserUnit = "user"
--------------------------------------------------------------------------------
-- | Font testers
-- Font testers
--
-- Make a special case for these since we end up testing the font alot, and it
-- would be nice if I can cache them.
@ -706,7 +735,7 @@ fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont
where
root = IORoot id $ fontTree fam ful
fontSometimes :: T.Text -> T.Text -> [Fulfillment]-> Sometimes FontBuilder
fontSometimes :: T.Text -> T.Text -> [Fulfillment] -> Sometimes FontBuilder
fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root
where
root = IORoot id $ fontTree fam ful
@ -736,7 +765,7 @@ fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
-- testFont = liftIO . testFont'
testFont :: T.Text -> FIO (Result FontBuilder)
testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg
testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
where
msg = T.unwords ["font family", qFam, "not found"]
args = [qFam]
@ -744,7 +773,7 @@ testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg
pass = Right $ PostPass (buildFont $ Just fam) []
--------------------------------------------------------------------------------
-- | Network Testers
-- Network Testers
--
-- ASSUME that the system uses systemd in which case ethernet interfaces always
-- start with "en" and wireless interfaces always start with "wl"
@ -762,7 +791,8 @@ isEthernet :: T.Text -> Bool
isEthernet = T.isPrefixOf "en"
listInterfaces :: IO [T.Text]
listInterfaces = fromRight []
listInterfaces =
fromRight []
<$> tryIOError (fmap T.pack <$> listDirectory sysfsNet)
sysfsNet :: FilePath
@ -777,16 +807,20 @@ readInterface n f = IORead n [] go
ns <- filter f <$> listInterfaces
case ns of
[] -> return $ Left [Msg LevelError "no interfaces found"]
(x:xs) -> do
return $ Right $ PostPass x
$ fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs
(x : xs) -> do
return $
Right $
PostPass x $
fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs
--------------------------------------------------------------------------------
-- | Misc testers
-- Misc testers
socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_
socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
. io . socketExists'
socketExists n ful =
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
. io
. socketExists'
socketExists' :: IO FilePath -> IO (Maybe Msg)
socketExists' getPath = do
@ -799,7 +833,7 @@ socketExists' getPath = do
toErr = Just . Msg LevelError
--------------------------------------------------------------------------------
-- | DBus Dependency Testing
-- DBus Dependency Testing
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -815,10 +849,13 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Left [Msg LevelError e]
Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Right []
else Left [
Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
Right b ->
let ns = bodyGetNames b
in if bus' `elem` ns
then Right []
else
Left
[ Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
]
where
bus' = T.pack $ formatBusName bus
@ -828,19 +865,23 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
bodyGetNames _ = []
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod cl busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Left [Msg LevelError e]
Right body -> procBody body
where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in
case res of
procBody body =
let res =
findMem
=<< I.parseXML objpath
=<< fromVariant
=<< listToMaybe body
in case res of
Just True -> Right []
_ -> Left [Msg LevelError $ fmtMsg' mem]
findMem = fmap (matchMem mem)
findMem =
fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface)
. I.objectInterfaces
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
@ -850,7 +891,8 @@ testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)]
fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)]
fmtMem (Property_ n) = T.unwords ["property", singleQuote n]
fmtMsg' m = T.unwords
fmtMsg' m =
T.unwords
[ "could not find"
, fmtMem m
, "on interface"
@ -858,11 +900,10 @@ testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
, "on bus"
, T.pack $ formatBusName busname
]
testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
--------------------------------------------------------------------------------
-- | IO Lifting functions
-- IO Lifting functions
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs
@ -879,7 +920,7 @@ ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a
ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
ioRoot (IORoot a t) = IORoot (io . a) t
@ -888,15 +929,19 @@ ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
--------------------------------------------------------------------------------
-- | Feature constructors
-- Feature constructors
sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a
sometimes1_ x fn n t = Sometimes fn x
[Subfeature{ sfData = t, sfName = n }]
sometimes1_ x fn n t =
Sometimes
fn
x
[Subfeature {sfData = t, sfName = n}]
always1_ :: T.Text -> T.Text -> Root a -> a -> Always a
always1_ fn n t x = Always fn
$ Option (Subfeature{ sfData = t, sfName = n }) (Always_ $ FallbackAlone x)
always1_ fn n t x =
Always fn $
Option (Subfeature {sfData = t, sfName = n}) (Always_ $ FallbackAlone x)
sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a
sometimes1 = sometimes1_ (const True)
@ -910,22 +955,49 @@ sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
sometimesExe :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool
-> FilePath -> Sometimes (m ())
sometimesExe
:: MonadIO m
=> T.Text
-> T.Text
-> [Fulfillment]
-> Bool
-> FilePath
-> Sometimes (m ())
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
sometimesExeArgs :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool
-> FilePath -> [T.Text] -> Sometimes (m ())
sometimesExeArgs
:: MonadIO m
=> T.Text
-> T.Text
-> [Fulfillment]
-> Bool
-> FilePath
-> [T.Text]
-> Sometimes (m ())
sometimesExeArgs fn n ful sys path args =
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
sometimesDBus :: SafeClient c => Maybe c -> T.Text -> T.Text
-> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a
sometimesDBus
:: SafeClient c
=> Maybe c
-> T.Text
-> T.Text
-> Tree_ (DBusDependency_ c)
-> (c -> a)
-> Sometimes a
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
sometimesEndpoint :: (SafeClient c, MonadIO m) => T.Text -> T.Text
-> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName
-> Maybe c -> Sometimes (m ())
sometimesEndpoint
:: (SafeClient c, MonadIO m)
=> T.Text
-> T.Text
-> [Fulfillment]
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> Maybe c
-> Sometimes (m ())
sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd
where
@ -933,7 +1005,7 @@ sometimesEndpoint fn name ful busname path iface mem cl =
cmd c = io $ void $ callMethod c busname path iface mem
--------------------------------------------------------------------------------
-- | Dependency Tree Constructors
-- Dependency Tree Constructors
listToAnds :: d -> [d] -> Tree_ d
listToAnds i = foldr (And_ . Only_) (Only_ i)
@ -950,7 +1022,7 @@ voidResult (Right (PostPass _ ws)) = Right ws
voidRead :: Result p -> Maybe Msg
voidRead (Left []) = Just $ Msg LevelError "unspecified error"
voidRead (Left (e:_)) = Just e
voidRead (Left (e : _)) = Just e
voidRead (Right _) = Nothing
readResult_ :: Maybe Msg -> Result_
@ -958,7 +1030,7 @@ readResult_ (Just w) = Left [w]
readResult_ _ = Right []
--------------------------------------------------------------------------------
-- | IO Dependency Constructors
-- IO Dependency Constructors
exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_
exe b ful = IOSystem_ ful . Executable b
@ -994,12 +1066,12 @@ process :: [Fulfillment] -> T.Text -> IODependency_
process ful = IOSystem_ ful . Process
--------------------------------------------------------------------------------
-- | Dependency data for JSON
-- Dependency data for JSON
type DependencyData = [Fulfillment]
dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData
dataSubfeatureRoot Subfeature { sfData = r } = dataRoot r
dataSubfeatureRoot Subfeature {sfData = r} = dataRoot r
dataRoot :: Root a -> DependencyData
dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t
@ -1007,8 +1079,12 @@ dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
dataTree :: forall d d_ p. (forall q. d q -> DependencyData)
-> (d_ -> DependencyData) -> Tree d d_ p -> DependencyData
dataTree
:: forall d d_ p
. (forall q. d q -> DependencyData)
-> (d_ -> DependencyData)
-> Tree d d_ p
-> DependencyData
dataTree f f_ = go
where
go :: forall q. Tree d d_ q -> DependencyData
@ -1045,8 +1121,7 @@ dataDBusDependency d = case d of
(DBusIO x) -> dataIODependency_ x
--------------------------------------------------------------------------------
-- | JSON formatting
-- formatting
bracket :: T.Text -> T.Text
bracket s = T.concat ["[", s, "]"]

124
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,23 +15,19 @@ module XMonad.Internal.Command.DMenu
, runBTMenu
, runShowKeys
, runAutorandrMenu
) where
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import Graphics.X11.Types
import qualified RIO.Text as T
import System.Directory
( XdgDirectory (..)
, getXdgDirectory
)
import System.IO
import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
@ -40,7 +36,7 @@ import XMonad.Internal.Shell
import XMonad.Util.NamedActions
--------------------------------------------------------------------------------
-- | DMenu executables
-- DMenu executables
myDmenuCmd :: FilePath
myDmenuCmd = "rofi"
@ -67,7 +63,7 @@ myClipboardManager :: FilePath
myClipboardManager = "greenclip"
--------------------------------------------------------------------------------
-- | Packages
-- Packages
dmenuPkgs :: [Fulfillment]
dmenuPkgs = [Package Official "rofi"]
@ -76,7 +72,7 @@ clipboardPkgs :: [Fulfillment]
clipboardPkgs = [Package AUR "rofi-greenclip"]
--------------------------------------------------------------------------------
-- | Other internal functions
-- Other internal functions
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
spawnDmenuCmd n =
@ -98,7 +94,7 @@ dmenuDep :: IODependency_
dmenuDep = sysExe dmenuPkgs myDmenuCmd
--------------------------------------------------------------------------------
-- | Exported Commands
-- Exported Commands
-- TODO test that veracrypt and friends are installed
runDevMenu :: SometimesX
@ -107,28 +103,38 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
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 =
Sometimes
"bluetooth selector"
xpfBluetooth
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
where
cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb"
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
runVPNMenu :: SometimesX
runVPNMenu = Sometimes "VPN selector" xpfVPN
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 = spawnDmenuCmd "command menu" ["-show", "run"]
@ -140,15 +146,20 @@ runWinMenu :: SometimesX
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: Maybe SysClient -> SometimesX
runNetMenu cl = Sometimes "network control menu" enabled
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 = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
@ -157,44 +168,60 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
--------------------------------------------------------------------------------
-- | Password manager
-- Password manager
runBwMenu :: Maybe SesClient -> SometimesX
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 = 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 =
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 =
Subfeature
{ sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ dmenuDep
}
@ -205,5 +232,8 @@ showKeys kbs = do
io $ hPutStr h $ unlines $ showKm kbs
io $ hClose h
where
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
cmd =
fmtCmd myDmenuCmd $
["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff"
++ myDmenuMatchingArgs

152
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,28 +32,23 @@ module XMonad.Internal.Command.Desktop
, runNotificationCloseAll
, runNotificationHistory
, runNotificationContext
-- daemons
, runNetAppDaemon
-- packages
, networkManagerPkgs
) where
import Data.Internal.DBus
import Data.Internal.Dependency
)
where
import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
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.Actions.Volume
import XMonad.Core hiding (spawn)
import XMonad.Internal.DBus.Common
@ -63,7 +57,7 @@ import XMonad.Internal.Shell as S
import XMonad.Operations
--------------------------------------------------------------------------------
-- | My Executables
-- My Executables
myTerm :: FilePath
myTerm = "urxvt"
@ -96,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"
]
@ -116,13 +111,13 @@ 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 = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
@ -130,12 +125,14 @@ runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
runTMux :: SometimesX
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
where
deps = listToAnds (socketExists "tmux" [] socketName)
$ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
act = S.spawn
$ 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 }
#!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
c = "exec tmux attach-session -d"
msg = "could not connect to tmux session"
socketName = do
@ -150,28 +147,46 @@ runCalc = sometimesIO_ "calculator" "bc" deps act
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
False myBrowser
runBrowser =
sometimesExe
"web browser"
"brave"
[Package AUR "brave-bin"]
False
myBrowser
runEditor :: SometimesX
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 =
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 n cmd =
sometimesExeArgs
(T.append n " multimedia control")
"playerctl"
[Package Official "playerctl"]
True
myMultimediaCtl
[cmd]
runTogglePlay :: SometimesX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
@ -186,7 +201,7 @@ runStopPlay :: SometimesX
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
--------------------------------------------------------------------------------
-- | Volume Commands
-- Volume Commands
soundDir :: FilePath
soundDir = "sound"
@ -200,8 +215,8 @@ playSound file = do
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
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
@ -217,16 +232,18 @@ runVolumeMute :: SometimesX
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
--------------------------------------------------------------------------------
-- | Notification control
-- Notification control
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
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 = runNotificationCmd "close notification" "close"
@ -244,11 +261,14 @@ 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 (FIO (P.Process () () ()))
runNetAppDaemon cl = Sometimes "network applet" xpfVPN
runNetAppDaemon cl =
Sometimes
"network applet"
xpfVPN
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
where
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
@ -256,35 +276,46 @@ runNetAppDaemon cl = Sometimes "network applet" xpfVPN
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
runToggleBluetooth :: Maybe SysClient -> SometimesX
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
runToggleBluetooth cl =
Sometimes
"bluetooth toggle"
xpfBluetooth
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
where
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
cmd _ = S.spawn
$ fmtCmd myBluetooth ["show"]
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" }
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
runToggleEthernet :: SometimesX
runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
runToggleEthernet =
Sometimes
"ethernet toggle"
xpfEthernet
[Subfeature root "nmcli"]
where
root = IORoot 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 = S.spawn
$ fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
cmd iface =
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" }
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
--------------------------------------------------------------------------------
-- | Configuration commands
-- Configuration commands
runRestart :: X ()
runRestart = restart "xmonad" True
@ -294,14 +325,14 @@ runRecompile :: X ()
runRecompile = do
-- assume that the conf directory contains a valid stack project
confDir <- asks (cfgDir . directories)
spawn
$ fmtCmd "cd" [T.pack confDir]
spawn $
fmtCmd "cd" [T.pack confDir]
#!&& fmtCmd "stack" ["install"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" }
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" }
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
#!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}
--------------------------------------------------------------------------------
-- | Screen capture commands
-- Screen capture commands
getCaptureDir :: IO FilePath
getCaptureDir = do
@ -321,8 +352,10 @@ runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
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
@ -338,7 +371,10 @@ runScreenCapture :: Maybe SesClient -> SometimesX
runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
(Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
runCaptureBrowser = sometimesIO_
"screen capture browser"
"feh"
(Only_ $ sysExe [Package Official "feh"] myImageBrowser)
$ do
dir <- io getCaptureDir
spawnCmd myImageBrowser [T.pack dir]

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

@ -1,10 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Commands for controlling power
-- Commands for controlling power
module XMonad.Internal.Command.Power
-- commands
-- commands
( runHibernate
, runOptimusPrompt
, runPowerOff
@ -14,10 +14,8 @@ module XMonad.Internal.Command.Power
, runSuspend
, runSuspendPrompt
, runQuitPrompt
-- daemons
, runAutolock
-- functions
, hasBattery
, suspendPrompt
@ -25,23 +23,19 @@ module XMonad.Internal.Command.Power
, powerPrompt
, defFontPkgs
, promptFontDep
) where
import Data.Internal.Dependency
)
where
import Data.Either
import Data.Internal.Dependency
import qualified Data.Map as M
import Graphics.X11.Types
import RIO
import RIO.FilePath
import qualified RIO.Process as P
import qualified RIO.Text as T
import System.Directory
import System.IO.Error
import XMonad.Core hiding (spawn)
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as XT
@ -49,8 +43,7 @@ import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt
--------------------------------------------------------------------------------
-- | Executables
-- Executables
myScreenlock :: FilePath
myScreenlock = "screenlock"
@ -61,17 +54,22 @@ 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 = spawn "systemctl poweroff"
@ -86,17 +84,19 @@ runReboot :: X ()
runReboot = spawn "systemctl reboot"
--------------------------------------------------------------------------------
-- | Autolock
-- Autolock
runAutolock :: Sometimes (FIO (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
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
@ -124,7 +124,7 @@ 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
@ -148,26 +148,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.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" }
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
@ -202,10 +208,12 @@ powerPrompt :: X () -> XT.FontBuilder -> X ()
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)
theme = (XT.promptTheme fb) {promptKeymap = keymap}
keymap =
M.fromList $
((controlMask, xK_g), quit)
: map
(first $ (,) 0)
[ (xK_p, sendMaybeAction Poweroff)
, (xK_s, sendMaybeAction Shutdown)
, (xK_h, sendMaybeAction Hibernate)

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

@ -2,21 +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
)
where
import Data.Internal.Dependency
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
@ -24,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)
@ -45,18 +44,18 @@ 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)
parseLine :: ByteString -> Maybe ACPIEvent
parseLine line =
case splitLine line of
(_:"PBTN":_) -> Just Power
(_:"PWRF":_) -> Just Power
(_:"SLPB":_) -> Just Sleep
(_:"SBTN":_) -> Just Sleep
(_:"LID":"close":_) -> Just LidClose
(_ : "PBTN" : _) -> Just Power
(_ : "PWRF" : _) -> Just Power
(_ : "SLPB" : _) -> Just Sleep
(_ : "SBTN" : _) -> Just Sleep
(_ : "LID" : "close" : _) -> Just LidClose
_ -> Nothing
where
splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
@ -103,7 +102,7 @@ handleACPI fb lock tag = do
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
@ -114,7 +113,9 @@ 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

20
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
@ -16,29 +16,29 @@
-- much like something from X even though it isn't
module XMonad.Internal.Concurrent.ClientMessage
( XMsgType(..)
( 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 Graphics.X11.Xlib.Types
import RIO hiding (Display)
--------------------------------------------------------------------------------
-- | 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)
@ -53,13 +53,13 @@ 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
splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
splitXMsg [] = (Unknown, "")
splitXMsg (x:xs) = (xtype, tag)
splitXMsg (x : xs) = (xtype, tag)
where
xtype = toEnum $ fromIntegral x
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
@ -91,7 +91,7 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
-- longer will be clipped to 19, and anything less than 19 will be padded
-- with 0 (note this used to be random garbage before). See this function
-- for more details.
setClientMessageEvent' e root bITMAP 8 (x:t)
setClientMessageEvent' e root bITMAP 8 (x : t)
sendEvent dpy root False substructureNotifyMask e
where
x = fromIntegral $ fromEnum xtype

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

@ -1,5 +1,5 @@
--------------------------------------------------------------------------------
-- | 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
@ -24,41 +24,35 @@
-- 3) Virtualbox (should always be by itself anyways)
module XMonad.Internal.Concurrent.DynamicWorkspaces
( DynWorkspace(..)
( DynWorkspace (..)
, appendShift
, appendViewShift
, removeDynamicWorkspace
, runWorkspaceMon
, spawnOrSwitch
, doSink
) where
import Data.List (deleteBy, find)
import qualified Data.Map as M
import Data.Maybe
)
where
-- import Control.Concurrent
import Control.Monad
import Control.Monad.Reader
import Data.List (deleteBy, find)
import qualified Data.Map as M
import Data.Maybe
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 qualified RIO.Set as S
import System.Process
import XMonad.Actions.DynamicWorkspaces
import XMonad.Core
( ManageHook
@ -75,8 +69,8 @@ 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
@ -89,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
@ -120,22 +114,23 @@ runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
where
withEvents dpy e = do
ps <- newMVar S.empty
let c = WConf { display = dpy, dynWorkspaces = dws, curPIDs = ps }
runRIO c
$ forever
$ handleEvent =<< io (nextEvent dpy e >> getEvent e)
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
runRIO c $
forever $
handleEvent =<< io (nextEvent dpy e >> getEvent e)
handleEvent :: Event -> W ()
-- | assume this fires at least once when a new window is created (also could
-- use CreateNotify but that is really noisy)
handleEvent MapNotifyEvent { ev_window = w } = do
handleEvent MapNotifyEvent {ev_window = w} = do
dpy <- asks display
hint <- io $ getClassHint dpy w
dws <- asks dynWorkspaces
let tag = M.lookup (resClass hint)
$ M.fromList
$ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
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
@ -143,28 +138,32 @@ handleEvent MapNotifyEvent { ev_window = w } = do
-- ASSUMPTION windows will only have one PID at one time
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
_ -> return ()
handleEvent _ = return ()
withUniquePid :: Pid -> String -> W ()
withUniquePid pid tag = do
ps <- asks curPIDs
pids <- readMVar ps
io $ unless (pid `elem` pids) $ bracket_
io
$ unless (pid `elem` pids)
$ bracket_
(modifyMVar_ ps (return . S.insert pid))
(modifyMVar_ ps (return . S.delete pid))
$ waitUntilExit pid >> sendXMsg Workspace 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
@ -172,7 +171,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)
@ -197,25 +196,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) }
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

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

@ -2,23 +2,21 @@
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | VirtualBox-specific functions
-- VirtualBox-specific functions
module XMonad.Internal.Concurrent.VirtualBox
( vmExists
, vmInstanceConfig
, qual
) where
)
where
import Data.Internal.Dependency
import Text.XML.Light
import RIO hiding (try)
import RIO.Directory
import RIO.FilePath
import qualified RIO.Text as T
import Text.XML.Light
import XMonad.Internal.Shell
vmExists :: T.Text -> IO (Maybe Msg)
@ -41,15 +39,17 @@ vmDirectory = do
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
qual :: Element -> String -> QName
qual e n = (elName e) { qName = n }
qual e n = (elName e) {qName = n}
vmConfig :: IO FilePath
vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml"

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

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | DBus module for Clevo Keyboard control
-- DBus module for Clevo Keyboard control
module XMonad.Internal.DBus.Brightness.ClevoKeyboard
( callGetBrightnessCK
@ -10,24 +10,21 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
, clevoKeyboardControls
, clevoKeyboardSignalDep
, blPath
) where
)
where
import Control.Monad (when)
import DBus
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
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
@ -84,7 +81,7 @@ decBrightness bounds = do
return b
--------------------------------------------------------------------------------
-- | DBus interface
-- DBus interface
blPath :: ObjectPath
blPath = objectPath_ "/clevo_keyboard"
@ -93,7 +90,8 @@ interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness"
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
clevoKeyboardConfig = BrightnessConfig
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"]
@ -119,8 +117,12 @@ clevoKeyboardSignalDep :: DBusDependency_ SesClient
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
exportClevoKeyboard :: Maybe SesClient -> SometimesIO
exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
[stateFileDep, brightnessFileDep] clevoKeyboardConfig
exportClevoKeyboard =
brightnessExporter
xpfClevoBacklight
[]
[stateFileDep, brightnessFileDep]
clevoKeyboardConfig
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig

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

@ -1,35 +1,32 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | DBus module for DBus brightness controls
-- DBus module for DBus brightness controls
module XMonad.Internal.DBus.Brightness.Common
( BrightnessConfig(..)
, BrightnessControls(..)
( BrightnessConfig (..)
, BrightnessControls (..)
, brightnessControls
, brightnessExporter
, callGetBrightness
, matchSignal
, signalDep
) where
)
where
import Control.Monad (void)
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
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
@ -56,7 +53,10 @@ data BrightnessControls = BrightnessControls
, bctlDec :: SometimesX
}
brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
brightnessControls
:: XPQuery
-> BrightnessConfig a b
-> Maybe SesClient
-> BrightnessControls
brightnessControls q bc cl =
BrightnessControls
@ -68,34 +68,48 @@ brightnessControls q bc cl =
where
cb = callBacklight q cl bc
callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c
callGetBrightness
:: (SafeClient c, Num n)
=> BrightnessConfig a b
-> c
-> IO (Maybe n)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
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 BrightnessConfig { bcPath = p, bcInterface = i } cb =
matchSignal
:: (SafeClient c, Num n)
=> BrightnessConfig a b
-> (Maybe n -> IO ())
-> c
-> IO ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
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 q ful deps bc@BrightnessConfig { bcName = n } cl =
brightnessExporter
:: RealFrac b
=> XPQuery
-> [Fulfillment]
-> [IODependency_]
-> BrightnessConfig a b
-> Maybe SesClient
-> SometimesIO
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
@ -108,7 +122,10 @@ exportBrightnessControls' bc cl = io $ do
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
export
ses
(bcPath bc)
defaultInterface
{ interfaceName = bcInterface bc
, interfaceMethods =
[ autoMethod' memMax bcMax
@ -120,11 +137,11 @@ exportBrightnessControls' bc cl = io $ do
, interfaceSignals = [sig]
}
where
sig = I.Signal
sig =
I.Signal
{ I.signalName = memCur
, I.signalArgs =
[
I.SignalArg
[ I.SignalArg
{ I.signalArgName = "brightness"
, I.signalArgType = TypeInt32
}
@ -132,16 +149,28 @@ exportBrightnessControls' bc cl = io $ do
}
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
emit client $ sig { signalBody = [toVariant (round cur :: Int32)] }
emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
where
sig = signal p i memCur
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text
-> MemberName -> SometimesX
callBacklight q cl BrightnessConfig { bcPath = p
callBacklight
:: XPQuery
-> Maybe SesClient
-> BrightnessConfig a b
-> T.Text
-> MemberName
-> SometimesX
callBacklight
q
cl
BrightnessConfig
{ bcPath = p
, bcInterface = i
, bcName = n } controlName m =
, 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
@ -152,7 +181,7 @@ bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
bodyGetBrightness _ = Nothing
--------------------------------------------------------------------------------
-- | DBus Members
-- DBus Members
memCur :: MemberName
memCur = memberName_ "CurrentBrightness"

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

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | DBus module for Intel Backlight control
-- DBus module for Intel Backlight control
module XMonad.Internal.DBus.Brightness.IntelBacklight
( callGetBrightnessIB
@ -10,22 +10,20 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
, intelBacklightControls
, intelBacklightSignalDep
, blPath
) where
)
where
import DBus
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
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
@ -66,7 +64,7 @@ decBrightness :: RawBounds -> IO Brightness
decBrightness = decPercent steps curFile
--------------------------------------------------------------------------------
-- | DBus interface
-- DBus interface
blPath :: ObjectPath
blPath = objectPath_ "/intelbacklight"
@ -75,7 +73,8 @@ interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness"
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
intelBacklightConfig = BrightnessConfig
intelBacklightConfig =
BrightnessConfig
{ bcMin = minBrightness
, bcMax = maxBrightness
, bcInc = incBrightness
@ -89,7 +88,7 @@ intelBacklightConfig = BrightnessConfig
}
--------------------------------------------------------------------------------
-- | Exported haskell API
-- Exported haskell API
curFileDep :: IODependency_
curFileDep = pathRW curFile []
@ -101,8 +100,12 @@ intelBacklightSignalDep :: DBusDependency_ SesClient
intelBacklightSignalDep = signalDep intelBacklightConfig
exportIntelBacklight :: Maybe SesClient -> SometimesIO
exportIntelBacklight = brightnessExporter xpfIntelBacklight []
[curFileDep, maxFileDep] intelBacklightConfig
exportIntelBacklight =
brightnessExporter
xpfIntelBacklight
[]
[curFileDep, maxFileDep]
intelBacklightConfig
intelBacklightControls :: Maybe SesClient -> BrightnessControls
intelBacklightControls = brightnessControls xpfIntelBacklight 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"

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

@ -1,11 +1,11 @@
{-# 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(..)
, DBusState (..)
, connectDBus
, connectDBusX
, disconnectDBus
@ -15,16 +15,14 @@ module XMonad.Internal.DBus.Control
, withDBusClient_
, disconnect
, dbusExporters
) where
)
where
import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
@ -41,7 +39,7 @@ connectDBus :: IO DBusState
connectDBus = do
ses <- getDBusClient
sys <- getDBusClient
return DBusState { dbSesClient = ses, dbSysClient = sys }
return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus
disconnectDBus :: DBusState -> IO ()
@ -73,10 +71,12 @@ requestXMonadName :: SesClient -> IO ()
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
let msg
| res == NamePrimaryOwner = Nothing
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
| res == NameInQueue
|| res == NameExists = Just $ "another process owns " ++ xn
|| res == NameExists =
Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg putStrLn
where

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

@ -1,7 +1,7 @@
{-# 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.
@ -9,14 +9,11 @@
module XMonad.Internal.DBus.Removable (runRemovableMon) where
import Control.Monad
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Map.Strict (Map, member)
import DBus
import DBus.Client
import XMonad.Core (io)
import XMonad.Internal.Command.Desktop
@ -51,7 +48,8 @@ driveRemovedSound :: FilePath
driveRemovedSound = "smb_pipe.wav"
ruleUdisks :: MatchRule
ruleUdisks = matchAny
ruleUdisks =
matchAny
{ matchPath = Just path
, matchInterface = Just interface
}
@ -60,12 +58,18 @@ driveFlag :: String
driveFlag = "org.freedesktop.UDisks2.Drive"
addedHasDrive :: [Variant] -> Bool
addedHasDrive [_, a] = maybe False (member driveFlag)
addedHasDrive [_, a] =
maybe
False
(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
@ -81,8 +85,10 @@ 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 =
void $
addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
playSoundMaybe p . f . signalBody
runRemovableMon :: Maybe SysClient -> SometimesIO
runRemovableMon cl =

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

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | DBus module for X11 screensave/DPMS control
-- DBus module for X11 screensave/DPMS control
module XMonad.Internal.DBus.Screensaver
( exportScreensaver
@ -9,25 +9,22 @@ module XMonad.Internal.DBus.Screensaver
, callQuery
, matchSignal
, ssSignalDep
) where
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO
)
where
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
import Data.Internal.Dependency
import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display
import RIO
import XMonad.Internal.DBus.Common
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
-- | Low-level functions
-- Low-level functions
type SSState = Bool -- true is enabled
@ -50,13 +47,13 @@ query = do
xssi <- xScreenSaverQueryInfo dpy
closeDisplay dpy
return $ case xssi of
Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False
Just XScreenSaverInfo { xssi_state = _ } -> True
Just XScreenSaverInfo {xssi_state = ScreenSaverDisabled} -> False
Just XScreenSaverInfo {xssi_state = _} -> True
-- TODO handle errors better (at least log them?)
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,28 +78,34 @@ 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 client sss = 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 ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
where
cmd cl = let cl' = toClient cl in
liftIO $ export cl' ssPath defaultInterface
cmd cl =
let cl' = toClient cl
in liftIO $
export
cl'
ssPath
defaultInterface
{ interfaceName = interface
, interfaceMethods =
[ autoMethod memToggle $ emitState cl' =<< toggle
@ -110,11 +113,11 @@ exportScreensaver ses =
]
, interfaceSignals = [sig]
}
sig = I.Signal
sig =
I.Signal
{ I.signalName = memState
, I.signalArgs =
[
I.SignalArg
[ I.SignalArg
{ I.signalArgName = "enabled"
, I.signalArgType = TypeBoolean
}
@ -124,8 +127,15 @@ exportScreensaver ses =
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
callToggle :: Maybe SesClient -> SometimesX
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
xmonadBusName ssPath interface memToggle
callToggle =
sometimesEndpoint
"screensaver toggle"
"dbus switch"
[]
xmonadBusName
ssPath
interface
memToggle
callQuery :: SesClient -> IO (Maybe SSState)
callQuery ses = do
@ -133,8 +143,12 @@ callQuery ses = do
return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
matchSignal cb ses = void $ addMatchCallback ruleCurrentState
(cb . bodyGetCurrentState) ses
matchSignal cb ses =
void $
addMatchCallback
ruleCurrentState
(cb . bodyGetCurrentState)
ses
ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState

39
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.
@ -19,32 +19,31 @@ module XMonad.Internal.IO
, incPercent
-- , isReadable
-- , isWritable
, PermResult(..)
, PermResult (..)
, getPermissionsSafe
, waitUntilExit
) where
)
where
import Data.Char
import Data.Text (pack, unpack)
import Data.Text.IO as T (readFile, writeFile)
import RIO
import RIO.Directory
import RIO.FilePath
import System.IO.Error
--------------------------------------------------------------------------------
-- | read
-- read
readInt :: (Read a, Integral a) => FilePath -> IO a
readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
readBool :: FilePath -> IO Bool
readBool = fmap (==(1 :: Int)) . readInt
readBool = fmap (== (1 :: Int)) . readInt
--------------------------------------------------------------------------------
-- | write
-- write
writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
writeInt f = T.writeFile f . pack . show
@ -53,16 +52,16 @@ writeBool :: FilePath -> Bool -> IO ()
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
@ -71,12 +70,14 @@ readPercent bounds path = do
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 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)
@ -88,9 +89,15 @@ writePercentMin bounds path = writePercent bounds path 0
writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO 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
:: (Integral a, RealFrac b)
=> (b -> b -> b)
-> Int
-> FilePath
-> (a, a)
-> IO b
shiftPercent f steps path bounds =
writePercent bounds path . f stepsize
=<< readPercent bounds path
where
stepsize = 100 / fromIntegral steps
@ -102,7 +109,7 @@ decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
decPercent = shiftPercent subtract -- silly (-) operator thingy error
--------------------------------------------------------------------------------
-- | permission query
-- permission query
data PermResult a = PermResult a | NotFoundError | PermError
deriving (Show, Eq)

35
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
@ -9,38 +9,41 @@
-- decide to switch to using the DBus it will be easy.
module XMonad.Internal.Notify
( Note(..)
, Body(..)
( Note (..)
, Body (..)
, defNote
, defNoteInfo
, defNoteError
, fmtNotifyCmd
, spawnNotify
) where
)
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\"" }
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
@ -56,8 +59,8 @@ fmtNotifyArgs :: Note -> [T.Text]
fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
where
-- TODO add the rest of the options as needed
getSummary = (:[]) . doubleQuote . T.pack . summary
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'

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

@ -1,17 +0,0 @@
--------------------------------------------------------------------------------
-- | Functions for managing processes
module XMonad.Internal.Process where
-- import Control.Exception
-- import Control.Monad
-- import Control.Monad.IO.Class
-- import qualified RIO.Text as T
-- import System.Exit
-- import System.IO
-- import System.Process
-- import XMonad.Core hiding (spawn)

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

@ -1,58 +1,7 @@
-- | Functions for formatting and spawning shell commands
--
-- TLDR: spawning a "command" in xmonad is complicated for weird reasons, and
-- this solution is the most sane (for me) given the constraints of the xmonad
-- codebase.
--
-- 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 that 'System.Process.waitForProcess' (and similar)
-- will not work since these call wait() on the child process, which will fail
-- because the child has already been cleared and thus there is nothing on which
-- to wait. By extension this also means we don't have access to a child's exit
-- code.
--
-- 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
-- 3) call setsid()
-- 4) start new thing with exec()
--
-- In practice, I'm guessing the main reason for 2 and 3 is so that child
-- processes don't inherit the weird SIGCHLD behavior of xmonad itself. The
-- setsid thing is one way to guarantee that killing the child thread will also
-- kill its children (if any). Note that this obviously will not block since
-- we are calling fork() without wait() (which would throw an error anyways).
--
-- What if I actually want the 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 (since it actually will be blocking). NOTE: I
-- shouldn't use this to replace the existing functions in xmonad since
-- 'spawning' a new process in a non-blocking manner with a higher-level API
-- will produce lots of Haskell objects that need to be cleaned, and it will be
-- hard (perhaps impossible) to keep track and deal with these after spawning.
--
-- This works, albeit with the cost of using almost every process API in Haskell.
--
-- Briefly:
-- 1) 'System.Process.Posix' (where xmonad lives)
-- 2) 'System.Process' (wraps 1)
-- 2) 'System.Process.Typed' (wraps 2, which I prefer for getting exit codes)
-- 3) 'RIO.Process' (wraps 3, which I prefer at the app level)
{-# LANGUAGE OverloadedStrings #-}
-- Functions for formatting and spawning shell commands
module XMonad.Internal.Shell
( fmtCmd
, spawnCmd
@ -68,80 +17,117 @@ module XMonad.Internal.Shell
, (#!||)
, (#!|)
, (#!>>)
) where
)
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
--------------------------------------------------------------------------------
-- | Opening subshell
-- https://github.com/xmonad/xmonad/issues/113
-- | 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 :: P.ProcessConfig a b c -> IO ExitCode
runProcess = withDefaultSignalHandlers . P.runProcess
-- | Run an action without xmonad's signal handlers.
withDefaultSignalHandlers :: IO a -> IO 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
runProcess :: P.ProcessConfig a b c -> IO ExitCode
runProcess = withDefaultSignalHandlers . P.runProcess
-- | 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
-- spawnAt :: MonadIO m => FilePath -> T.Text -> m ()
-- spawnAt fp = liftIO . void . startProcess . P.setWorkingDir fp . shell
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
spawnPipe :: MonadIO m => T.Text -> m Handle
spawnPipe = XR.spawnPipe . T.unpack
-- | Run 'XMonad.Core.spawn' with a command and arguments
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
spawnCmd cmd = spawn . fmtCmd cmd
--------------------------------------------------------------------------------
-- | Formatting commands
-- | 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, "'"]

64
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
@ -18,9 +18,9 @@ module XMonad.Internal.Theme
, backdropTextColor
, blend'
, darken'
, Slant(..)
, Weight(..)
, FontData(..)
, Slant (..)
, Weight (..)
, FontData (..)
, FontBuilder
, buildFont
, fallbackFont
@ -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,37 +170,35 @@ defFontFamily = "DejaVu Sans"
-- defFontTree = fontTree "DejaVu Sans"
--------------------------------------------------------------------------------
-- | Complete themes
-- Complete themes
tabbedTheme :: FontBuilder -> D.Theme
tabbedTheme fb = D.def
{ D.fontName = T.unpack $ fb $ defFontData { weight = Just Bold }
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
{ P.font = T.unpack $ fb $ defFontData { size = Just 12 }
promptTheme fb =
P.def
{ P.font = T.unpack $ fb $ defFontData {size = Just 12}
, P.bgColor = T.unpack bgColor
, P.fgColor = T.unpack fgColor
, P.fgHLight = T.unpack selectedFgColor

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

@ -1,21 +1,22 @@
{-# 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 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
:: 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

74
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
--
@ -33,26 +33,23 @@
-- adapter changing.
module Xmobar.Plugins.Bluetooth
( Bluetooth(..)
( Bluetooth (..)
, btAlias
, btDep
) where
)
where
import Control.Concurrent.MVar
import Control.Monad
import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.List
import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
import DBus
import DBus.Client
import qualified RIO.Text as T
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
@ -61,8 +58,9 @@ 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)
@ -90,7 +88,7 @@ startAdapter is cs cb cl = do
display
--------------------------------------------------------------------------------
-- | 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"
@ -111,7 +109,7 @@ 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
@ -133,7 +131,8 @@ data BtState = BtState
type MutableBtState = MVar BtState
emptyState :: BtState
emptyState = BtState
emptyState =
BtState
{ btDevices = M.empty
, btPowered = Nothing
}
@ -145,7 +144,7 @@ readState state = do
return (p, anyDevicesConnected c)
--------------------------------------------------------------------------------
-- | Object manager
-- Object manager
findAdapter :: ObjectTree -> Maybe ObjectPath
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
@ -159,7 +158,7 @@ adaptorHasDevice adaptor device = case splitPath device of
_ -> False
splitPath :: ObjectPath -> [T.Text]
splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
getBtObjectTree :: SysClient -> IO ObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
@ -191,7 +190,7 @@ pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
pathCallback _ _ _ _ = return ()
--------------------------------------------------------------------------------
-- | Adapter
-- Adapter
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
initAdapter state adapter client = do
@ -201,7 +200,11 @@ initAdapter state adapter client = do
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
addAdaptorListener
:: MutableBtState
-> IO ()
-> ObjectPath
-> SysClient
-> IO (Maybe SignalHandler)
addAdaptorListener state display adaptor sys = do
rule <- matchBTProperty sys adaptor
@ -210,14 +213,16 @@ addAdaptorListener state display adaptor sys = do
procMatch = withSignalMatch $ \b -> putPowered state b >> display
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
$ memberName_ $ T.unpack adaptorPowered
callGetPowered adapter =
callPropertyGet btBus adapter adapterInterface $
memberName_ $
T.unpack adaptorPowered
matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
putPowered :: MutableBtState -> Maybe Bool -> IO ()
putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
readPowered :: MutableBtState -> IO (Maybe Bool)
readPowered = fmap btPowered . readMVar
@ -229,7 +234,7 @@ adaptorPowered :: T.Text
adaptorPowered = "Powered"
--------------------------------------------------------------------------------
-- | Devices
-- Devices
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addAndInitDevice state display device client = do
@ -240,12 +245,18 @@ addAndInitDevice state display device client = do
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
void $
insertDevice state device $
BTDevice
{ btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh
}
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
addDeviceListener
:: MutableBtState
-> IO ()
-> ObjectPath
-> SysClient
-> IO (Maybe SignalHandler)
addDeviceListener state display device sys = do
rule <- matchBTProperty sys device
@ -257,18 +268,19 @@ matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
callGetConnected p = callPropertyGet btBus p devInterface
$ memberName_ (T.unpack devConnected)
callGetConnected p =
callPropertyGet btBus p devInterface $
memberName_ (T.unpack devConnected)
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
insertDevice m device dev = modifyMVar m $ \s -> do
let new = M.insert device dev $ btDevices s
return (s { btDevices = new }, anyDevicesConnected new)
return (s {btDevices = new}, anyDevicesConnected new)
updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
updateDevice m device status = modifyMVar m $ \s -> do
let new = M.update (\d -> Just d { btDevConnected = status }) device $ btDevices s
return (s { btDevices = new }, anyDevicesConnected new)
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
@ -276,7 +288,7 @@ anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
removeDevice m device = modifyMVar m $ \s -> do
let devs = btDevices s
return (s { btDevices = M.delete device devs }, M.lookup device devs)
return (s {btDevices = M.delete device devs}, M.lookup device devs)
readDevices :: MutableBtState -> IO ConnectedDevices
readDevices = fmap btDevices . readMVar

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

@ -1,23 +1,21 @@
{-# 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
module Xmobar.Plugins.ClevoKeyboard
( 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)

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

@ -8,22 +8,18 @@ module Xmobar.Plugins.Common
, fromSingletonVariant
, withDBusClientConnection
, Callback
, Colors(..)
, Colors (..)
, displayMaybe
, displayMaybe'
, xmobarFGColor
)
where
where
import Control.Monad
import Data.Internal.DBus
import DBus
import DBus.Client
import Data.Internal.DBus
import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor)
-- use string here since all the callbacks in xmobar use strings :(
@ -35,9 +31,15 @@ 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
:: (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
displayMaybe cb toColor $ fromSingletonVariant reply
@ -49,8 +51,8 @@ procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
colorText :: Colors -> Bool -> T.Text -> T.Text
colorText Colors { colorsOn = c } True = xmobarFGColor c
colorText Colors { colorsOff = c } False = xmobarFGColor c
colorText Colors {colorsOn = c} True = xmobarFGColor c
colorText Colors {colorsOff = c} False = xmobarFGColor c
xmobarFGColor :: T.Text -> T.Text -> T.Text
xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack

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

@ -1,26 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Device plugin
-- Device plugin
--
-- Display different text depending on whether or not the interface has
-- connectivity
module Xmobar.Plugins.Device
( Device(..)
( Device (..)
, devDep
) where
)
where
import Control.Monad
import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import Data.Word
import DBus
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
@ -44,19 +41,23 @@ 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
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 path =
callPropertyGet networkManagerBus path nmDeviceInterface $
memberName_ $
T.unpack devSignal
matchStatus :: [Variant] -> SignalMatch Word32
matchStatus = matchPropertyChanged nmDeviceInterface devSignal

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

@ -1,23 +1,21 @@
{-# 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
module Xmobar.Plugins.IntelBacklight
( 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)

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

@ -1,21 +1,20 @@
{-# 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
module Xmobar.Plugins.Screensaver
( Screensaver(..)
( Screensaver (..)
, ssAlias
) where
)
where
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)
@ -31,4 +30,3 @@ instance Exec Screensaver where
display =<< callQuery sys
where
display = displayMaybe cb $ return . (\s -> colorText colors s text)

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

@ -1,31 +1,28 @@
{-# 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
-- "org.freedesktop.NetworkManager.Device.Tun".
module Xmobar.Plugins.VPN
( VPN(..)
( VPN (..)
, vpnAlias
, vpnDep
) where
)
where
import Control.Concurrent.MVar
import Control.Monad
import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
import DBus
import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import Xmobar
@ -47,7 +44,7 @@ instance Exec VPN 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
@ -65,13 +62,15 @@ initState client = do
readState :: MutableVPNState -> IO Bool
readState = fmap (not . null) . readMVar
updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-> ObjectPath -> IO ()
updateState
:: (ObjectPath -> VPNState -> VPNState)
-> MutableVPNState
-> ObjectPath
-> IO ()
updateState f state op = modifyMVar_ state $ return . f op
--------------------------------------------------------------------------------
-- | Tunnel Device Detection
--
-- Tunnel Device Detection
getVPNObjectTree :: SysClient -> IO ObjectTree
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
@ -100,16 +99,21 @@ removedCallback state display [device, interfaces] = update >> display
update = updateDevice S.delete state device is
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)
-> MutableVPNState
-> Variant
-> [T.Text]
-> IO ()
updateDevice f state device interfaces =
when (vpnDeviceTun `elem` interfaces) $
forM_ d $
updateState f state
where
d = fromVariant device :: Maybe ObjectPath
--------------------------------------------------------------------------------
-- | DBus Interface
--
-- DBus Interface
vpnBus :: BusName
vpnBus = busName_ "org.freedesktop.NetworkManager"
@ -124,5 +128,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

2
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/*