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

Merge branch 'fix_rio_run'

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

357
.stylish-haskell.yaml
View File

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

53
bin/vbox-start.hs
View File

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

633
bin/xmobar.hs
View File

@ -1,8 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
--------------------------------------------------------------------------------
-- | Xmobar binary
--
-- Features:
@ -12,67 +9,81 @@ 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.Text as T
import System.Environment
import System.IO
import System.IO.Error
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
import System.Posix.Signals
import XMonad.Core hiding (config)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Command.Power
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import XMonad.Internal.Process hiding (CmdSpec)
import qualified XMonad.Internal.Theme as XT
import Xmobar hiding
( iconOffset
, run
)
import Xmobar.Plugins.Common
import Data.Internal.DBus
import Data.Internal.XIO
import Options.Applicative
import RIO hiding (hFlush)
import qualified RIO.ByteString.Lazy as BL
import RIO.List
import RIO.Process
import qualified RIO.Text as T
import XMonad.Core hiding (config)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.Command.Power
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import qualified XMonad.Internal.Theme as XT
import Xmobar hiding
( iconOffset
, run
)
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Common
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
main :: IO ()
main = getArgs >>= parse
main = parse >>= xio
parse :: [String] -> IO ()
parse [] = run
parse ["--deps"] = withCache printDeps
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
parse _ = usage
parse :: IO XOpts
parse = execParser opts
where
parseOpts = parseDeps <|> parseTest <|> pure XRun
opts =
info (parseOpts <**> helper) $
fullDesc <> header "xmobar: the best taskbar ever"
run :: IO ()
data XOpts = XDeps | XTest | XRun
parseDeps :: Parser XOpts
parseDeps =
flag'
XDeps
(long "deps" <> short 'd' <> help "print dependencies")
parseTest :: Parser XOpts
parseTest =
flag'
XTest
(long "test" <> short 't' <> help "test dependencies without running")
xio :: XOpts -> IO ()
xio o = case o of
XDeps -> hRunXIO False stderr printDeps
XTest -> hRunXIO False stderr $ withDBus_ evalConfig
XRun -> runXIO "xmobar.log" run
run :: XIO ()
run = do
db <- connectDBus
c <- withCache $ evalConfig db
disconnectDBus db
-- this is needed to prevent waitForProcess error when forking in plugins (eg
-- alsacmd)
_ <- installHandler sigCHLD Default Nothing
-- this is needed to see any printed messages
hFlush stdout
xmobar c
-- IDK why this is needed, I thought this was default
liftIO $ hSetBuffering stdout LineBuffering
-- this isn't totally necessary except for the fact that killing xmobar
-- will make it print something about catching SIGTERM, and without
-- linebuffering it usually only prints the first few characters (even then
-- it only prints 10-20% of the time)
liftIO $ hSetBuffering stderr LineBuffering
withDBus_ $ \db -> do
c <- evalConfig db
liftIO $ xmobar c
evalConfig :: DBusState -> FIO Config
evalConfig :: DBusState -> XIO Config
evalConfig db = do
cs <- getAllCommands <$> rightPlugins db
bf <- getTextFont
@ -80,21 +91,17 @@ evalConfig db = do
d <- io $ cfgDir <$> getDirectories
return $ config bf ifs ios cs d
printDeps :: FIO ()
printDeps = do
db <- io connectDBus
let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
io $ mapM_ (putStrLn . T.unpack) ps
io $ disconnectDBus db
usage :: IO ()
usage = putStrLn $ intercalate "\n"
[ "xmobar: run greatest taskbar"
, "xmobar --deps: print dependencies"
]
printDeps :: XIO ()
printDeps = withDBus_ $ \db ->
mapM_ logInfo $
fmap showFulfillment $
sort $
nub $
concatMap dumpFeature $
allFeatures db
--------------------------------------------------------------------------------
-- | toplevel configuration
-- toplevel configuration
-- | The text font family
textFont :: Always XT.FontBuilder
@ -106,88 +113,93 @@ 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"
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
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)
iconOffset :: BarFont -> Int
iconOffset IconSmall = 0
iconOffset IconSmall = 0
iconOffset IconMedium = 1
iconOffset IconLarge = 1
iconOffset IconLarge = 1
iconOffset IconXLarge = 2
-- | Sizes (in pixels) for the icon fonts
iconSize :: BarFont -> Int
iconSize IconSmall = 13
iconSize IconSmall = 13
iconSize IconMedium = 15
iconSize IconLarge = 18
iconSize IconLarge = 18
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
{ font = T.unpack bf
, additionalFonts = fmap T.unpack ifs
, textOffset = textFontOffset
, textOffsets = ios
, bgColor = T.unpack XT.bgColor
, fgColor = T.unpack XT.fgColor
, 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"
, commands = csRunnable <$> concatRegions br
}
config bf ifs ios br confDir =
defaultConfig
{ font = T.unpack bf
, additionalFonts = fmap T.unpack ifs
, textOffset = textFontOffset
, textOffsets = ios
, bgColor = T.unpack XT.bgColor
, fgColor = T.unpack XT.fgColor
, 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"
, 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
{ csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader
}
]
, brCenter = []
, brRight = catMaybes right
}
getAllCommands right =
BarRegions
{ brLeft =
[ CmdSpec
{ csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader
}
]
, brCenter = []
, brRight = catMaybes right
}
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins db = mapM evalFeature $ allFeatures db
++ [always' "date indicator" dateCmd]
rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
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
@ -204,8 +216,11 @@ type BarFeature = Sometimes CmdSpec
-- TODO what if I don't have a wireless card?
getWireless :: BarFeature
getWireless = Sometimes "wireless status indicator" xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getWireless =
Sometimes
"wireless status indicator"
xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getEthernet :: Maybe SysClient -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
@ -217,32 +232,49 @@ getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
where
root useIcon = IORoot_ (batteryCmd useIcon)
tree = Only_ $ IOTest_ "Test if battery is present" []
$ fmap (Msg LevelError) <$> hasBattery
tree =
Only_ $
IOTest_ "Test if battery is present" [] $
io $
fmap (Msg LevelError) <$> hasBattery
getVPN :: Maybe SysClient -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
networkManagerPkgs vpnPresent
test =
DBusIO $
IOTest_
"Use nmcli to test if VPN is present"
networkManagerPkgs
vpnPresent
getBt :: Maybe SysClient -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
getAlsa :: BarFeature
getAlsa = iconIO_ "volume level indicator" (const True) root
$ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl"
getAlsa =
iconIO_ "volume level indicator" (const True) root $
Only_ $
sysExe [Package Official "alsa-utils"] "alsactl"
where
root useIcon = IORoot_ (alsaCmd useIcon)
getBl :: Maybe SesClient -> BarFeature
getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
intelBacklightSignalDep blCmd
getBl =
xmobarDBus
"Intel backlight indicator"
xpfIntelBacklight
intelBacklightSignalDep
blCmd
getCk :: Maybe SesClient -> BarFeature
getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
clevoKeyboardSignalDep ckCmd
getCk =
xmobarDBus
"Clevo keyboard indicator"
xpfClevoBacklight
clevoKeyboardSignalDep
ckCmd
getSs :: Maybe SesClient -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
@ -253,158 +285,232 @@ 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
[ Subfeature icon "icon indicator"
, Subfeature text "text indicator"
]
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"
]
where
icon = r fontifyIcon $ c t $ d iconDependency
text = r fontifyAlt t
--------------------------------------------------------------------------------
-- | command specifications
-- command specifications
data BarRegions = BarRegions
{ brLeft :: [CmdSpec]
{ brLeft :: [CmdSpec]
, brCenter :: [CmdSpec]
, brRight :: [CmdSpec]
} deriving Show
, brRight :: [CmdSpec]
}
deriving (Show)
data CmdSpec = CmdSpec
{ csAlias :: T.Text
{ 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
{ csAlias = T.append iface "wi"
, csRunnable = Run $ Wireless (T.unpack iface) args 5
}
wirelessCmd iface =
CmdSpec
{ csAlias = T.append iface "wi"
, csRunnable = Run $ Wireless (T.unpack iface) args 5
}
where
args = fmap T.unpack
[ "-t", "<qualityipat><essid>"
, "--"
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
]
args =
fmap
T.unpack
[ "-t"
, "<qualityipat><essid>"
, "--"
, "--quality-icon-pattern"
, "<icon=wifi_%%.xpm/>"
]
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
ethernetCmd fontify iface = CmdSpec
{ csAlias = iface
, csRunnable = Run
$ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
}
ethernetCmd fontify iface =
CmdSpec
{ csAlias = iface
, csRunnable =
Run $
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
}
batteryCmd :: Fontifier -> CmdSpec
batteryCmd fontify = CmdSpec
{ csAlias = "battery"
, csRunnable = Run $ Battery args 50
}
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
, "--"
, "-P"
, "-o" , fontify' "\xf0e7" "BAT"
, "-O" , fontify' "\xf1e6" "AC"
, "-i" , fontify' "\xf1e6" "AC"
]
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"
]
vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify = CmdSpec
{ csAlias = vpnAlias
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
}
vpnCmd fontify =
CmdSpec
{ csAlias = vpnAlias
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
}
btCmd :: Fontifier -> CmdSpec
btCmd fontify = CmdSpec
{ csAlias = btAlias
, csRunnable = Run
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
}
btCmd fontify =
CmdSpec
{ csAlias = btAlias
, csRunnable =
Run $
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
}
where
fontify' i = fontify IconLarge i . T.append "BT"
alsaCmd :: Fontifier -> CmdSpec
alsaCmd fontify = CmdSpec
{ csAlias = "alsa:default:Master"
, 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
]
}
alsaCmd fontify =
CmdSpec
{ csAlias = "alsa:default:Master"
, 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
]
}
where
fontify' i = fontify IconSmall i . T.append "VOL"
blCmd :: Fontifier -> CmdSpec
blCmd fontify = CmdSpec
{ csAlias = blAlias
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
}
blCmd fontify =
CmdSpec
{ csAlias = blAlias
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
}
ckCmd :: Fontifier -> CmdSpec
ckCmd fontify = CmdSpec
{ csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
}
ckCmd fontify =
CmdSpec
{ csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
}
ssCmd :: Fontifier -> CmdSpec
ssCmd fontify = CmdSpec
{ csAlias = ssAlias
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
}
ssCmd fontify =
CmdSpec
{ csAlias = ssAlias
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
}
lockCmd :: Fontifier -> 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", " "
]
}
lockCmd fontify =
CmdSpec
{ csAlias = "locks"
, csRunnable =
Run $
Locks $
fmap
T.unpack
[ "-N"
, numIcon
, "-n"
, disabledColor numIcon
, "-C"
, capIcon
, "-c"
, disabledColor capIcon
, "-s"
, ""
, "-S"
, ""
, "-d"
, " "
]
}
where
numIcon = fontify' "\xf8a5" "N"
capIcon = fontify' "\xf657" "C"
@ -412,51 +518,61 @@ lockCmd fontify = CmdSpec
disabledColor = xmobarFGColor XT.backdropFgColor
dateCmd :: CmdSpec
dateCmd = CmdSpec
{ csAlias = "date"
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
}
dateCmd =
CmdSpec
{ csAlias = "date"
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
}
--------------------------------------------------------------------------------
-- | low-level testing functions
-- low-level testing functions
vpnPresent :: IO (Maybe Msg)
vpnPresent =
go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
vpnPresent :: XIO (Maybe Msg)
vpnPresent = do
res <- proc "nmcli" args readProcess
return $ case res of
(ExitSuccess, out, _)
| "vpn" `elem` BL.split 10 out -> Nothing
| otherwise -> Just $ Msg LevelError "vpn not found"
(ExitFailure c, _, err) ->
Just $
Msg LevelError $
T.concat
[ "vpn search exited with code "
, T.pack $ show c
, ": "
, T.decodeUtf8With T.lenientDecode $
BL.toStrict err
]
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` T.lines out then Nothing
else Just $ Msg LevelError "vpn not found"
go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError
$ T.concat ["vpn search exited with code "
, T.pack $ show c
, ": "
, err]
go (Left e) = Just $ Msg LevelError $ T.pack $ show e
--------------------------------------------------------------------------------
-- | text font
-- text font
--
-- ASSUME there is only one text font for this entire configuration. This
-- will correspond to the first font/offset parameters in the config record.
getTextFont :: FIO T.Text
getTextFont :: XIO T.Text
getTextFont = do
fb <- evalAlways textFont
return $ fb textFontData
--------------------------------------------------------------------------------
-- | icon fonts
-- icon fonts
getIconFonts :: FIO ([T.Text], [Int])
getIconFonts :: XIO ([T.Text], [Int])
getIconFonts = do
fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb
where
apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
<$> iconFonts
apply fb =
unzip $
(\i -> (iconString fb i, iconOffset i + textFontOffset))
<$> iconFonts
data BarFont = IconSmall
data BarFont
= IconSmall
| IconMedium
| IconLarge
| IconXLarge
@ -484,10 +600,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 " : "
@ -504,8 +620,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 $
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]
fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
T.concat
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]

1133
bin/xmonad.hs
View File

File diff suppressed because it is too large Load Diff

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

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

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

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

File diff suppressed because it is too large Load Diff

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

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

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

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

181
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,35 +23,25 @@ module XMonad.Internal.Command.Power
, powerPrompt
, defFontPkgs
, promptFontDep
) where
)
where
import Control.Arrow (first)
import Data.Internal.Dependency
import Data.Either
import qualified Data.Map as M
import Graphics.X11.Types
import RIO.FilePath
import qualified RIO.Text as T
import System.Directory
import System.Exit
import System.IO.Error
import System.Process (ProcessHandle)
import XMonad.Core
import XMonad.Internal.Process (spawnPipeArgs)
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as XT
import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt
import Data.Internal.XIO
import Graphics.X11.Types
import RIO
import RIO.Directory
import RIO.FilePath
import qualified RIO.Map as M
import qualified RIO.Process as P
import qualified RIO.Text as T
import XMonad.Core hiding (spawn)
import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as XT
import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt
--------------------------------------------------------------------------------
-- | Executables
-- Executables
myScreenlock :: FilePath
myScreenlock = "screenlock"
@ -64,42 +52,49 @@ myPrimeOffload :: FilePath
myPrimeOffload = "prime-offload"
--------------------------------------------------------------------------------
-- | Packages
-- Packages
optimusPackages :: [Fulfillment]
optimusPackages = [Package AUR "optimus-manager"]
--------------------------------------------------------------------------------
-- | Core commands
-- Core commands
runScreenLock :: SometimesX
runScreenLock = sometimesExe "screen locker" "i3lock script"
[Package AUR "i3lock-color"] False myScreenlock
runScreenLock =
sometimesExe
"screen locker"
"i3lock script"
[Package AUR "i3lock-color"]
False
myScreenlock
runPowerOff :: X ()
runPowerOff :: MonadUnliftIO m => m ()
runPowerOff = spawn "systemctl poweroff"
runSuspend :: X ()
runSuspend :: MonadUnliftIO m => m ()
runSuspend = spawn "systemctl suspend"
runHibernate :: X ()
runHibernate :: MonadUnliftIO m => m ()
runHibernate = spawn "systemctl hibernate"
runReboot :: X ()
runReboot :: MonadUnliftIO m => m ()
runReboot = spawn "systemctl reboot"
--------------------------------------------------------------------------------
-- | Autolock
-- Autolock
runAutolock :: Sometimes (IO ProcessHandle)
runAutolock :: Sometimes (XIO (P.Process () () ()))
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where
tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
$ Only_ $ IOSometimes_ runScreenLock
cmd = snd <$> spawnPipeArgs "xss-lock" ["--ignore-sleep", "screenlock"]
tree =
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
Only_ $
IOSometimes_ runScreenLock
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
--------------------------------------------------------------------------------
-- | Confirmation prompts
-- Confirmation prompts
promptFontDep :: IOTree XT.FontBuilder
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
@ -111,7 +106,7 @@ confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
suspendPrompt :: XT.FontBuilder -> X ()
suspendPrompt = confirmPrompt' "suspend?" runSuspend
suspendPrompt = confirmPrompt' "suspend?" $ liftIO runSuspend
quitPrompt :: XT.FontBuilder -> X ()
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
@ -127,21 +122,24 @@ runQuitPrompt :: SometimesX
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
--------------------------------------------------------------------------------
-- | Nvidia Optimus
-- Nvidia Optimus
-- TODO for some reason the screen never wakes up after suspend when
-- the nvidia card is up, so block suspend if nvidia card is running
-- and warn user
isUsingNvidia :: IO Bool
isUsingNvidia :: MonadUnliftIO m => m Bool
isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
hasBattery :: IO (Maybe T.Text)
hasBattery :: MonadUnliftIO m => m (Maybe T.Text)
hasBattery = do
ps <- fromRight [] <$> tryIOError (listDirectory syspath)
ts <- mapM readType ps
return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
ps <- fromRight [] <$> tryIO (listDirectory syspath)
ts <- catMaybes <$> mapM readType ps
return $
if any (T.isPrefixOf "Battery") ts
then Nothing
else Just "battery not found"
where
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
readType p = either (const Nothing) Just <$> tryIO (readFileUtf8 $ syspath </> p </> "type")
syspath = "/sys/class/power_supply"
runOptimusPrompt' :: XT.FontBuilder -> X ()
@ -151,31 +149,36 @@ runOptimusPrompt' fb = do
where
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
prompt mode = T.concat ["gpu switch to ", mode, "?"]
cmd mode = spawn $
T.unpack
$ T.pack myPrimeOffload
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad"
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
| Shutdown
| Hibernate
| Reboot
deriving (Eq)
data PowerMaybeAction
= Poweroff
| Shutdown
| Hibernate
| Reboot
deriving (Eq)
instance Enum PowerMaybeAction where
toEnum 0 = Poweroff
@ -184,15 +187,15 @@ instance Enum PowerMaybeAction where
toEnum 3 = Reboot
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
fromEnum Poweroff = 0
fromEnum Shutdown = 1
fromEnum Poweroff = 0
fromEnum Shutdown = 1
fromEnum Hibernate = 2
fromEnum Reboot = 3
fromEnum Reboot = 3
data PowerPrompt = PowerPrompt
instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
runPowerPrompt :: SometimesX
runPowerPrompt = Sometimes "power prompt" (const True) [sf]
@ -206,20 +209,22 @@ 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)
[ (xK_p, sendMaybeAction Poweroff)
, (xK_s, sendMaybeAction Shutdown)
, (xK_h, sendMaybeAction Hibernate)
, (xK_r, sendMaybeAction Reboot)
, (xK_Return, quit)
, (xK_Escape, quit)
]
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)
, (xK_r, sendMaybeAction Reboot)
, (xK_Return, quit)
, (xK_Escape, quit)
]
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeMaybeAction a = case toEnum $ read a of
Poweroff -> runPowerOff
Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate
Reboot -> runReboot
Poweroff -> liftIO runPowerOff
Shutdown -> lock >> liftIO runSuspend
Hibernate -> lock >> liftIO runHibernate
Reboot -> liftIO runReboot

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

@ -1,43 +1,37 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
{-# 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 Control.Exception
import Control.Monad
import Data.ByteString hiding (readFile)
import Data.ByteString.Char8 as C hiding (readFile)
import Data.Connection
import Data.Internal.Dependency
import Text.Read (readMaybe)
import System.IO.Streams as S (read)
import System.IO.Streams.UnixSocket
import XMonad.Core
import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Shell
import XMonad.Internal.Theme (FontBuilder)
import Data.Internal.XIO
import Network.Socket
import Network.Socket.ByteString
import RIO
import qualified RIO.ByteString as B
import XMonad.Core
import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage
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
| Sleep
| LidClose
deriving (Eq)
data ACPIEvent
= Power
| Sleep
| LidClose
deriving (Eq)
instance Enum ACPIEvent where
toEnum 0 = Power
@ -45,26 +39,28 @@ instance Enum ACPIEvent where
toEnum 2 = LidClose
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
fromEnum Power = 0
fromEnum Sleep = 1
fromEnum Power = 0
fromEnum Sleep = 1
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
_ -> Nothing
(_ : "PBTN" : _) -> Just Power
(_ : "PWRF" : _) -> Just Power
(_ : "SLPB" : _) -> Just Sleep
(_ : "SBTN" : _) -> Just Sleep
(_ : "LID" : "close" : _) -> Just LidClose
_ -> Nothing
where
splitLine = C.words . C.reverse . C.dropWhile (== '\n') . C.reverse
splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
newline = 10
space = 32
-- | Send an ACPIEvent to the X server as a ClientMessage
sendACPIEvent :: ACPIEvent -> IO ()
@ -72,20 +68,18 @@ sendACPIEvent = sendXMsg ACPI . show . fromEnum
isDischarging :: IO (Maybe Bool)
isDischarging = do
status <- try $ readFile "/sys/class/power_supply/BAT0/status"
:: IO (Either IOException String)
status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
case status of
Left _ -> return Nothing
Left _ -> return Nothing
Right s -> return $ Just (s == "Discharging")
listenACPI :: IO ()
listenACPI = do
Connection { source = s } <- connect acpiPath
forever $ readStream s
where
readStream s = do
out <- S.read s
mapM_ sendACPIEvent $ parseLine =<< out
sock <- socket AF_UNIX Stream defaultProtocol
connect sock $ SockAddrUnix acpiPath
forever $ do
out <- recv sock 1024
mapM_ sendACPIEvent $ parseLine out
acpiPath :: FilePath
acpiPath = "/var/run/acpid.socket"
@ -104,22 +98,24 @@ handleACPI fb lock tag = do
LidClose -> do
status <- io isDischarging
-- only run suspend if battery exists and is discharging
forM_ status $ flip when runSuspend
forM_ status $ flip when $ liftIO runSuspend
lock
--------------------------------------------------------------------------------
-- | Exported API
-- Exported API
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them
runPowermon :: SometimesIO
runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI
runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep $ io listenACPI
runHandleACPI :: Always (String -> X ())
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
where
sf = Subfeature withLock "acpid prompt"
withLock = IORoot (uncurry handleACPI)
$ And12 (,) promptFontDep $ Only
$ IOSometimes runScreenLock id
withLock =
IORoot (uncurry handleACPI) $
And12 (,) promptFontDep $
Only $
IOSometimes runScreenLock id
fallback = Always_ $ FallbackAlone $ const skip

51
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,55 +16,56 @@
-- 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 Data.Char
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import XMonad.Internal.IO
--------------------------------------------------------------------------------
-- | Data structure for the ClientMessage
-- Data structure for the ClientMessage
--
-- These are the "types" of client messages to send; add more here as needed
-- TODO is there a way to do this in the libraries that import this one?
data XMsgType = ACPI
| Workspace
| Unknown
deriving (Eq, Show)
data XMsgType
= ACPI
| Workspace
| Unknown
deriving (Eq, Show)
instance Enum XMsgType where
toEnum 0 = ACPI
toEnum 1 = Workspace
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
fromEnum ACPI = 0
fromEnum ACPI = 0
fromEnum Workspace = 1
fromEnum Unknown = 2
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 $ fromInteger $ toInteger x
tag = map (chr . fromInteger . toInteger) $ takeWhile (/= 0) xs
xtype = toEnum $ fromIntegral x
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
-- | Emit a ClientMessage event to the X server with the given type and payloud
sendXMsg :: XMsgType -> String -> IO ()
sendXMsg xtype tag = do
dpy <- openDisplay ""
sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
root <- rootWindow dpy $ defaultScreen dpy
allocaXEvent $ \e -> do
setEventType e clientMessage
@ -82,10 +83,8 @@ sendXMsg xtype tag = 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
flush dpy
closeDisplay dpy
where
x = fromIntegral $ fromEnum xtype
t = fmap (fromIntegral . fromEnum) tag

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

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

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

@ -1,28 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | VirtualBox-specific functions
-- VirtualBox-specific functions
module XMonad.Internal.Concurrent.VirtualBox
( vmExists
, vmInstanceConfig
, qual
) where
)
where
import Control.Exception
import Data.Internal.Dependency
import Text.XML.Light
import RIO hiding (try)
import RIO.FilePath
import qualified RIO.Text as T
import System.Directory
import XMonad.Internal.Shell
import Data.Internal.XIO
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)
vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm
@ -35,24 +30,26 @@ vmInstanceConfig vmName = do
findInstance dir = do
res <- findFile [dir] path
return $ case res of
Just p -> Right p
Just p -> Right p
Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName
vmDirectory :: IO (Either String String)
vmDirectory = do
p <- vmConfig
(s :: Either IOException String) <- try $ readFile p
s <- tryIO $ readFile p
return $ case s of
(Left _) -> Left "could not read VirtualBox config file"
(Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
$ findDir =<< parseXMLDoc x
(Right x) ->
maybe (Left "Could not parse VirtualBox config file") Right $
findDir =<< parseXMLDoc x
where
findDir e = findAttr (unqual "defaultMachineFolder")
=<< findChild (qual e "SystemProperties")
=<< findChild (qual e "Global") e
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"

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

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

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

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

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

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

8
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,9 +7,10 @@ module XMonad.Internal.DBus.Common
, notifyBus
, notifyPath
, networkManagerBus
) where
)
where
import DBus
import DBus
xmonadBusName :: BusName
xmonadBusName = busName_ "org.xmonad"
@ -25,4 +26,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
networkManagerBus :: BusName
networkManagerBus = busName_ "org.freedesktop.NetworkManager"

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

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

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

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

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

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

131
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,86 +19,124 @@ module XMonad.Internal.IO
, incPercent
-- , isReadable
-- , isWritable
, PermResult(..)
, PermResult (..)
, getPermissionsSafe
) where
, waitUntilExit
, withOpenDisplay
)
where
import Data.Char
import Data.Text (pack, unpack)
import Data.Text.IO as T (readFile, writeFile)
import System.Directory
import System.IO.Error
import Data.Char
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Types
import RIO hiding (Display)
import RIO.Directory
import RIO.FilePath
import qualified RIO.Text as T
import System.IO.Error
import System.Process
--------------------------------------------------------------------------------
-- | read
-- read
readInt :: (Read a, Integral a) => FilePath -> IO a
readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
readInt = fmap (read . takeWhile isDigit . T.unpack) . readFileUtf8
readBool :: FilePath -> IO Bool
readBool = fmap (==(1 :: Int)) . readInt
readBool :: MonadIO m => FilePath -> m Bool
readBool = fmap (== (1 :: Int)) . readInt
--------------------------------------------------------------------------------
-- | write
-- write
writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
writeInt f = T.writeFile f . pack . show
writeInt :: MonadIO m => (Show a, Integral a) => FilePath -> a -> m ()
writeInt f = writeFileUtf8 f . T.pack . show
writeBool :: FilePath -> Bool -> IO ()
writeBool :: MonadIO m => FilePath -> Bool -> m ()
writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
--------------------------------------------------------------------------------
-- | percent-based read/write
-- percent-based read/write
--
-- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
-- value. Assume that the file being read has a min of 0 and an unchanging max
-- given by a runtime argument, which is scaled linearly to the range 0-100
-- (percent).
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
rawToPercent (lower, upper) raw =
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
readPercent :: MonadIO m => (Integral a, RealFrac b) => (a, a) -> FilePath -> m b
readPercent bounds path = do
i <- readInt path
return $ rawToPercent bounds (i :: Integer)
percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
percentToRaw (lower, upper) perc = round $
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
percentToRaw (lower, upper) perc =
round $
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
writePercent
:: (MonadIO m, Integral a, RealFrac b)
=> (a, a)
-> FilePath
-> b
-> m b
writePercent bounds path perc = do
let t | perc > 100 = 100
let t
| perc > 100 = 100
| perc < 0 = 0
| otherwise = perc
writeInt path (percentToRaw bounds t :: Int)
return t
writePercentMin :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
writePercentMin
:: (MonadIO m, Integral a, RealFrac b)
=> (a, a)
-> FilePath
-> m b
writePercentMin bounds path = writePercent bounds path 0
writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
writePercentMax
:: (MonadIO m, Integral a, RealFrac b)
=> (a, a)
-> FilePath
-> m b
writePercentMax bounds path = writePercent bounds path 100
shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath
-> (a, a) -> IO b
shiftPercent f steps path bounds = writePercent bounds path . f stepsize
shiftPercent
:: (MonadIO m, Integral a, RealFrac b)
=> (b -> b -> b)
-> Int
-> FilePath
-> (a, a)
-> m b
shiftPercent f steps path bounds =
writePercent bounds path . f stepsize
=<< readPercent bounds path
where
stepsize = 100 / fromIntegral steps
incPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
incPercent
:: (MonadIO m, Integral a, RealFrac b)
=> Int
-> FilePath
-> (a, a)
-> m b
incPercent = shiftPercent (+)
decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
decPercent
:: (MonadIO m, Integral a, RealFrac b)
=> Int
-> FilePath
-> (a, a)
-> m b
decPercent = shiftPercent subtract -- silly (-) operator thingy error
--------------------------------------------------------------------------------
-- | permission query
-- permission query
data PermResult a = PermResult a | NotFoundError | PermError
deriving (Show, Eq)
@ -108,19 +146,36 @@ data PermResult a = PermResult a | NotFoundError | PermError
-- fmap _ NotFoundError = NotFoundError
-- fmap _ PermError = PermError
getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
getPermissionsSafe :: MonadUnliftIO m => FilePath -> m (PermResult Permissions)
getPermissionsSafe f = do
r <- tryIOError $ getPermissions f
r <- tryIO $ getPermissions f
return $ case r of
Right z -> PermResult z
Left (isPermissionError -> True) -> PermError
Right z -> PermResult z
Left (isPermissionError -> True) -> PermError
Left (isDoesNotExistError -> True) -> NotFoundError
-- the above error should be the only ones thrown by getPermission,
-- so the catchall case should never happen
_ -> error "Unknown permission error"
_ -> error "Unknown permission error"
-- isReadable :: FilePath -> IO (PermResult Bool)
-- isReadable = fmap (fmap readable) . getPermissionsSafe
-- isWritable :: FilePath -> IO (PermResult Bool)
-- isWritable = fmap (fmap writable) . getPermissionsSafe
-- | Block until a PID has exited.
-- Use this to control flow based on a process that was not explicitly started
-- by the Haskell runtime itself, and thus has no data structures to query.
waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
waitUntilExit pid = do
res <- doesDirectoryExist $ "/proc" </> show pid
when res $ do
threadDelay 100000
waitUntilExit pid
withOpenDisplay :: MonadUnliftIO m => (Display -> m a) -> m a
withOpenDisplay = bracket (liftIO $ openDisplay "") cleanup
where
cleanup dpy = liftIO $ do
flush dpy
closeDisplay dpy

47
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,44 +9,45 @@
-- 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 Control.Monad.IO.Class
import Data.Maybe
import DBus.Notify
import qualified RIO.Text as T
import XMonad.Internal.Shell
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
parseBody _ = Nothing
parseBody _ = Nothing
fmtNotifyCmd :: Note -> T.Text
fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs
@ -58,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'

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

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

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

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

188
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
import Data.Colour
import Data.Colour.SRGB
import qualified RIO.Text as T
)
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
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,64 +92,73 @@ sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
sRGB24showT = T.pack . sRGB24show
--------------------------------------------------------------------------------
-- | Fonts
-- Fonts
data Slant = Roman
| Italic
| Oblique
deriving (Eq, Show)
data Slant
= Roman
| Italic
| Oblique
deriving (Eq, Show)
data Weight = Light
| Medium
| Demibold
| Bold
| Black
deriving (Eq, Show)
data Weight
= Light
| Medium
| Demibold
| Bold
| Black
deriving (Eq, Show)
data FontData = FontData
{ weight :: Maybe Weight
, slant :: Maybe Slant
, size :: Maybe Int
, pixelsize :: Maybe Int
, antialias :: Maybe Bool
}
{ weight :: Maybe Weight
, slant :: Maybe Slant
, size :: Maybe Int
, pixelsize :: Maybe Int
, antialias :: Maybe Bool
}
type FontBuilder = FontData -> T.Text
buildFont :: Maybe T.Text -> FontData -> T.Text
buildFont Nothing _ = "fixed"
buildFont (Just fam) FontData { weight = w
, slant = l
, size = s
, pixelsize = p
, antialias = a
}
= T.intercalate ":" $ ["xft", fam] ++ elems
where
elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w)
, ("slant", showLower l)
, ("size", showLower s)
, ("pixelsize", showLower p)
, ("antialias", showLower a)
]
]
showLower :: Show a => Maybe a -> Maybe T.Text
showLower = fmap (T.toLower . T.pack . show)
buildFont
(Just fam)
FontData
{ weight = w
, slant = l
, size = s
, pixelsize = p
, antialias = a
} =
T.intercalate ":" $ ["xft", fam] ++ elems
where
elems =
[ T.concat [k, "=", v]
| (k, Just v) <-
[ ("weight", showLower w)
, ("slant", showLower l)
, ("size", showLower s)
, ("pixelsize", showLower p)
, ("antialias", showLower a)
]
]
showLower :: Show a => Maybe a -> Maybe T.Text
showLower = fmap (T.toLower . T.pack . show)
fallbackFont :: FontBuilder
fallbackFont = buildFont Nothing
--------------------------------------------------------------------------------
-- | Default font and data
-- Default font and data
defFontData :: FontData
defFontData = FontData
{ size = Just 10
, antialias = Just True
, weight = Nothing
, slant = Nothing
, pixelsize = Nothing
}
defFontData =
FontData
{ size = Just 10
, antialias = Just True
, weight = Nothing
, slant = Nothing
, pixelsize = Nothing
}
defFontFamily :: T.Text
defFontFamily = "DejaVu Sans"
@ -162,44 +170,42 @@ 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
-- , D.activeBorderWidth = 0
-- , D.inactiveBorderWidth = 0
-- , D.urgentBorderWidth = 0
, 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
-- , D.activeBorderWidth = 0
-- , D.inactiveBorderWidth = 0
-- , D.urgentBorderWidth = 0
, D.decoHeight = 20
, D.windowTitleAddons = []
, D.windowTitleIcons = []
}
D.decoHeight = 20
, D.windowTitleAddons = []
, D.windowTitleIcons = []
}
promptTheme :: FontBuilder -> P.XPConfig
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
, P.bgHLight = T.unpack selectedBgColor
, P.borderColor = T.unpack bordersColor
, P.promptBorderWidth = 1
, P.height = 35
, P.position = P.CenteredAt 0.5 0.5
, P.historySize = 0
}
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
, P.bgHLight = T.unpack selectedBgColor
, P.borderColor = T.unpack bordersColor
, P.promptBorderWidth = 1
, P.height = 35
, P.position = P.CenteredAt 0.5 0.5
, P.historySize = 0
}

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

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

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

20
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 qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import Xmobar
import Xmobar.Plugins.BacklightCommon
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
@ -27,4 +25,4 @@ ckAlias = "clevokeyboard"
instance Exec ClevoKeyboard where
alias (ClevoKeyboard _) = T.unpack ckAlias
start (ClevoKeyboard icon) =
startBacklight matchSignalCK callGetBrightnessCK icon
startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon

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

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

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

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

20
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 qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.IntelBacklight
import Xmobar
import Xmobar.Plugins.BacklightCommon
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
@ -27,4 +25,4 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where
alias (IntelBacklight _) = T.unpack blAlias
start (IntelBacklight icon) =
startBacklight matchSignalIB callGetBrightnessIB icon
startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon

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

@ -1,22 +1,22 @@
{-# 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.Plugins.Common
import Data.Internal.DBus
import qualified RIO.Text as T
import XMonad.Internal.DBus.Screensaver
import Xmobar
import Xmobar.Plugins.Common
newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
@ -25,10 +25,9 @@ ssAlias = "screensaver"
instance Exec Screensaver where
alias (Screensaver _) = T.unpack ssAlias
start (Screensaver (text, colors)) cb = do
withDBusClientConnection cb $ \sys -> do
matchSignal display sys
display =<< callQuery sys
start (Screensaver (text, colors)) cb =
withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
matchSignal dpy
dpy =<< callQuery
where
display = displayMaybe cb $ return . (\s -> colorText colors s text)
dpy = displayMaybe cb $ return . (\s -> colorText colors s text)

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

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

15
package.yaml
View File

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