diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 index 26770c1..0000000 --- a/.stylish-haskell.yaml +++ /dev/null @@ -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'. - # - # - : 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 diff --git a/bin/vbox-start.hs b/bin/vbox-start.hs index 59cc599..b911726 100644 --- a/bin/vbox-start.hs +++ b/bin/vbox-start.hs @@ -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 diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 3cd0e36..b1a35e3 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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", "" - , "--" - , "--quality-icon-pattern", "" - ] + args = + fmap + T.unpack + [ "-t" + , "" + , "--" + , "--quality-icon-pattern" + , "" + ] 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", "" - , "--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" + , "" + , "--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", "%" - , "--" - , "-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" + , "%" + , "--" + , "-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] diff --git a/bin/xmonad.hs b/bin/xmonad.hs index d84b8d6..917de35 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -1,93 +1,160 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} -------------------------------------------------------------------------------- --- | XMonad binary +-- XMonad binary module Main (main) where -import Control.Monad - -import Data.Internal.DBus -import Data.Internal.Dependency -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Text.IO (hPutStrLn) - -import Graphics.X11.Types -import Graphics.X11.Xlib.Atom -import Graphics.X11.Xlib.Extras - -import RIO (async) -import qualified RIO.Text as T - -import System.Directory -import System.Environment -import System.IO hiding - ( hPutStrLn - ) -import System.IO.Error -import System.Process - -import XMonad -import XMonad.Actions.CopyWindow -import XMonad.Actions.CycleWS -import XMonad.Actions.PhysicalScreens -import XMonad.Actions.Warp -import XMonad.Hooks.DynamicLog -import XMonad.Hooks.EwmhDesktops -import XMonad.Hooks.ManageDocks -import XMonad.Hooks.ManageHelpers -import XMonad.Internal.Command.DMenu -import XMonad.Internal.Command.Desktop -import XMonad.Internal.Command.Power -import XMonad.Internal.Concurrent.ACPIEvent -import XMonad.Internal.Concurrent.ClientMessage -import XMonad.Internal.Concurrent.DynamicWorkspaces -import XMonad.Internal.Concurrent.VirtualBox -import XMonad.Internal.DBus.Brightness.ClevoKeyboard -import XMonad.Internal.DBus.Brightness.Common -import XMonad.Internal.DBus.Brightness.IntelBacklight -import XMonad.Internal.DBus.Control -import XMonad.Internal.DBus.Removable -import XMonad.Internal.DBus.Screensaver -import XMonad.Internal.Process -import XMonad.Internal.Shell -import qualified XMonad.Internal.Theme as XT -import XMonad.Layout.MultiToggle -import XMonad.Layout.NoBorders -import XMonad.Layout.NoFrillsDecoration -import XMonad.Layout.PerWorkspace -import XMonad.Layout.Renamed -import XMonad.Layout.Tabbed -import qualified XMonad.Operations as O -import qualified XMonad.StackSet as W -import XMonad.Util.Cursor -import XMonad.Util.EZConfig -import qualified XMonad.Util.ExtensibleState as E -import XMonad.Util.NamedActions -import XMonad.Util.WorkspaceCompare +import Data.Internal.DBus +import Data.Internal.XIO +import Data.Monoid +import Data.Text.IO (hPutStrLn) +import Graphics.X11.Types +import Graphics.X11.Xlib.Atom +import Graphics.X11.Xlib.Extras +import Options.Applicative hiding (action) +import RIO +import RIO.Directory +import RIO.List +import RIO.Process +import qualified RIO.Text as T +import System.Posix.Signals +import System.Process + ( getPid + , getProcessExitCode + ) +import XMonad +import XMonad.Actions.CopyWindow +import XMonad.Actions.CycleWS +import XMonad.Actions.PhysicalScreens +import XMonad.Actions.Warp +import XMonad.Hooks.DynamicLog +import XMonad.Hooks.EwmhDesktops +import XMonad.Hooks.ManageDocks +import XMonad.Hooks.ManageHelpers +import XMonad.Internal.Command.DMenu +import XMonad.Internal.Command.Desktop +import XMonad.Internal.Command.Power +import XMonad.Internal.Concurrent.ACPIEvent +import XMonad.Internal.Concurrent.ClientMessage +import XMonad.Internal.Concurrent.DynamicWorkspaces +import XMonad.Internal.Concurrent.VirtualBox +import XMonad.Internal.DBus.Brightness.ClevoKeyboard +import XMonad.Internal.DBus.Brightness.Common +import XMonad.Internal.DBus.Brightness.IntelBacklight +import XMonad.Internal.DBus.Control +import XMonad.Internal.DBus.Removable +import XMonad.Internal.DBus.Screensaver +import XMonad.Internal.Shell hiding (proc) +import qualified XMonad.Internal.Theme as XT +import XMonad.Layout.MultiToggle +import XMonad.Layout.NoBorders +import XMonad.Layout.NoFrillsDecoration +import XMonad.Layout.PerWorkspace +import XMonad.Layout.Renamed +import XMonad.Layout.Tabbed +import qualified XMonad.Operations as O +import qualified XMonad.StackSet as W +import XMonad.Util.Cursor +import XMonad.Util.EZConfig +import qualified XMonad.Util.ExtensibleState as E +import XMonad.Util.NamedActions +import XMonad.Util.WorkspaceCompare main :: IO () -main = getArgs >>= parse +main = parse >>= xio -parse :: [String] -> IO () -parse [] = run -parse ["--deps"] = withCache printDeps -parse ["--test"] = void $ withCache . evalConf =<< connectDBusX -parse _ = usage +parse :: IO XOpts +parse = execParser opts + where + parseOpts = parseDeps <|> parseTest <|> pure XRun + opts = + info (parseOpts <**> helper) $ + fullDesc <> header "xmonad: the best window manager ever" +data XOpts = XDeps | XTest | XRun -run :: IO () +parseDeps :: Parser XOpts +parseDeps = + flag' + XDeps + (long "deps" <> short 'd' <> help "print dependencies") + +parseTest :: Parser XOpts +parseTest = + flag' + XTest + (long "test" <> short 't' <> help "test dependencies without running") + +xio :: XOpts -> IO () +xio o = case o of + XDeps -> hRunXIO False stderr printDeps + XTest -> undefined + XRun -> runXIO "xmonad.log" run + +run :: XIO () run = do - db <- connectDBusX - conf <- withCache $ evalConf db - ds <- getCreateDirectories - -- IDK why this is necessary; nothing prior to this will print if missing - hFlush stdout - launch conf ds + -- These first two commands are only significant when xmonad is restarted. + -- The 'launch' function below this will turn off buffering (so flushes are + -- required to see stdout) and will also install xmonad's silly signal + -- handlers (which set the handlers for sigCHLD and sigPIPE to SIG_IGN). + -- Ignoring sigCHLD is particularly bad since most of my setup entails + -- spawning processes and waiting for their exit code, which totally breaks + -- when sigCHLD is ignored (since children are killed immediately without + -- the parent invoking 'wait'). Since the 'launch' function is called last + -- here, everything before should be fine except for the case where xmonad + -- is restarted, which uses 'exec' and thus should cause the buffering and + -- signal handlers to carry over to the top. + uninstallSignalHandlers + hSetBuffering stdout LineBuffering + withDBusX_ $ \db -> do + let fs = features $ dbSysClient db + withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do + withXmobar $ \xmobarP -> do + withChildDaemons fs $ \ds -> do + let toClean = Cleanup ds (Just xmobarP) unexporters + void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db + void $ async $ void $ executeSometimes $ fsPowerMon fs + dws <- startDynWorkspaces fs + runIO <- askRunInIO + let cleanup = runCleanup runIO toClean db + kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db) + sk <- evalAlways $ fsShowKeys fs + ha <- evalAlways $ fsACPIHandler fs + tt <- evalAlways $ fsTabbedTheme fs + let conf = + ewmh $ + addKeymap dws (liftIO . runIO . sk) kbs $ + docks $ + def + { terminal = myTerm + , modMask = myModMask + , layoutHook = myLayouts tt + , manageHook = myManageHook dws + , handleEventHook = myEventHook runIO ha + , startupHook = myStartupHook + , workspaces = myWorkspaces + , logHook = myLoghook xmobarP + , clickJustFocuses = False + , focusFollowsMouse = False + , normalBorderColor = T.unpack XT.bordersColor + , focusedBorderColor = T.unpack XT.selectedBordersColor + } + io $ runXMonad conf + where + startDynWorkspaces fs = do + dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) + void $ async $ runWorkspaceMon dws + return dws + +runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO () +runXMonad conf = do + dirs <- getCreateDirectories + launch conf dirs getCreateDirectories :: IO Directories getCreateDirectories = do @@ -97,21 +164,21 @@ getCreateDirectories = do where createIfMissing ds f = do let d = f ds - r <- tryIOError $ createDirectoryIfMissing True d + r <- tryIO $ createDirectoryIfMissing True d case r of (Left e) -> print e - _ -> return () + _ -> return () data FeatureSet = FeatureSet - { fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX] - , fsDBusExporters :: [Maybe SesClient -> SometimesIO] - , fsPowerMon :: SometimesIO - , fsRemovableMon :: Maybe SysClient -> SometimesIO - , fsDaemons :: [Sometimes (IO ProcessHandle)] - , fsACPIHandler :: Always (String -> X ()) - , fsTabbedTheme :: Always Theme + { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX] + , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())] + , fsPowerMon :: SometimesIO + , fsRemovableMon :: Maybe SysClient -> SometimesIO + , fsDaemons :: [Sometimes (XIO (Process () () ()))] + , fsACPIHandler :: Always (String -> X ()) + , fsTabbedTheme :: Always Theme , fsDynWorkspaces :: [Sometimes DynWorkspace] - , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) + , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> XIO ()) } tabbedFeature :: Always Theme @@ -122,119 +189,157 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont features :: Maybe SysClient -> FeatureSet -features cl = FeatureSet - { fsKeys = externalBindings - , fsDBusExporters = dbusExporters - , fsPowerMon = runPowermon - , fsRemovableMon = runRemovableMon - , fsACPIHandler = runHandleACPI - , fsDynWorkspaces = allDWs' - , fsTabbedTheme = tabbedFeature - , fsShowKeys = runShowKeys - , fsDaemons = [runNetAppDaemon cl, runAutolock] - } - -evalConf db@DBusState { dbSysClient = cl } = do - -- start DBus interfaces first since many features after this test these - -- interfaces as dependencies - let fs = features cl - startDBusInterfaces fs - (xmobarHandle, ts) <- startChildDaemons fs - startRemovableMon fs - startPowerMon fs - dws <- startDynWorkspaces fs - tt <- evalAlways $ fsTabbedTheme fs - -- fb <- evalAlways $ fsFontBuilder features - kbs <- filterExternal <$> evalExternal (fsKeys fs ts db) - sk <- evalAlways $ fsShowKeys fs - ha <- evalAlways $ fsACPIHandler fs - return $ ewmh - $ addKeymap dws sk kbs - $ docks - $ def { terminal = myTerm - , modMask = myModMask - , layoutHook = myLayouts tt - , manageHook = myManageHook dws - , handleEventHook = myEventHook ha - , startupHook = myStartupHook - , workspaces = myWorkspaces - , logHook = myLoghook xmobarHandle - , clickJustFocuses = False - , focusFollowsMouse = False - , normalBorderColor = T.unpack XT.bordersColor - , focusedBorderColor = T.unpack XT.selectedBordersColor - } - where - forkIO_ = void . async - startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) - $ fsDBusExporters fs - startChildDaemons fs = do - (h, p) <- io $ spawnPipe "xmobar" - ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs) - return (h, ThreadState (p:ps) [h]) - startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs - $ dbSysClient db - startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs - startDynWorkspaces fs = do - dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) - io $ forkIO_ $ runWorkspaceMon dws - return dws - -printDeps :: FIO () -printDeps = do - db <- io connectDBus - (i, f, d) <- allFeatures db - io $ mapM_ (putStrLn . T.unpack) - $ fmap showFulfillment - $ sort - $ nub - $ concat - $ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d - io $ disconnectDBus db - -allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) -allFeatures db = do - let bfs = concatMap (fmap kbMaybeAction . kgBindings) - $ externalBindings ts db - let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters - let others = [runRemovableMon $ dbSysClient db, runPowermon] - return (dbus ++ others, Left runScreenLock:bfs, allDWs') - where - ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] } - -usage :: IO () -usage = putStrLn $ intercalate "\n" - [ "xmonad: run greatest window manager" - , "xmonad --deps: print dependencies" - ] - --------------------------------------------------------------------------------- --- | Concurrency configuration - -data ThreadState = ThreadState - { tsChildPIDs :: [ProcessHandle] - , tsChildHandles :: [Handle] +features cl = + FeatureSet + { fsKeys = externalBindings + , fsDBusExporters = dbusExporters + , fsPowerMon = runPowermon + , fsRemovableMon = runRemovableMon + , fsACPIHandler = runHandleACPI + , fsDynWorkspaces = allDWs' + , fsTabbedTheme = tabbedFeature + , fsShowKeys = runShowKeys + , fsDaemons = [runNetAppDaemon cl, runAutolock] } --- TODO shouldn't this be run by a signal handler? -runCleanup :: ThreadState -> DBusState -> X () -runCleanup ts db = io $ do - mapM_ killHandle $ tsChildPIDs ts - disconnectDBusX db +withXmobar :: (Process Handle () () -> XIO a) -> XIO a +withXmobar = bracket startXmobar stopXmobar + +startXmobar :: XIO (Process Handle () ()) +startXmobar = do + logInfo "starting xmobar child process" + p <- proc "xmobar" [] start + io $ hSetBuffering (getStdin p) LineBuffering + return p + where + start = + startProcess + . setStdin createPipe + . setCreateGroup True + +stopXmobar + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => Process Handle () () + -> m () +stopXmobar p = do + logInfo "stopping xmobar child process" + io $ killNoWait p + +withChildDaemons + :: FeatureSet + -> ([(Utf8Builder, Process () () ())] -> XIO a) + -> XIO a +withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons + +startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())] +startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs) + where + start s@(Sometimes sname _ _) = do + let sname_ = Utf8Builder $ encodeUtf8Builder sname + res <- executeSometimes s + case res of + Just p -> do + logInfo $ "starting child process: " <> sname_ + return $ Just (sname_, p) + -- don't log anything here since presumably the feature itself will log + -- an error if it fails during execution + _ -> return Nothing + +stopChildDaemons + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => [(Utf8Builder, Process () () ())] + -> m () +stopChildDaemons = mapM_ stop + where + stop (n, p) = do + logInfo $ "stopping child process: " <> n + liftIO $ killNoWait p + +printDeps :: XIO () +printDeps = withDBus_ $ \db -> do + runIO <- askRunInIO + let mockCleanup = runCleanup runIO mockClean db + let bfs = + concatMap (fmap kbMaybeAction . kgBindings) $ + externalBindings runIO mockCleanup db + let dbus = + fmap (\f -> f $ dbSesClient db) dbusExporters + :: [Sometimes (XIO (), XIO ())] + let others = [runRemovableMon $ dbSysClient db, runPowermon] + -- TODO might be better to use glog for this? + mapM_ logInfo $ + fmap showFulfillment $ + sort $ + nub $ + concat $ + fmap dumpSometimes dbus + ++ fmap dumpSometimes others + ++ fmap dumpSometimes allDWs' + ++ fmap dumpFeature bfs + where + mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []} -------------------------------------------------------------------------------- --- | Startuphook configuration +-- Concurrency configuration + +data Cleanup = Cleanup + { clChildren :: [(Utf8Builder, Process () () ())] + , clXmobar :: Maybe (Process Handle () ()) + , clDBusUnexporters :: [XIO ()] + } + +runCleanup + :: (XIO () -> IO ()) + -> Cleanup + -> DBusState + -> X () +runCleanup runIO ts db = liftIO $ runIO $ do + mapM_ stopXmobar $ clXmobar ts + stopChildDaemons $ clChildren ts + sequence_ $ clDBusUnexporters ts + disconnectDBusX db + +-- | Kill a process (group) after xmonad has already started +-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad +-- sets the handler for sigCHLD to Ignore which breaks 'waitForProcess' (which +-- in turn will break 'stopProcess') and b) because I want to kill off entire +-- process groups since they may spawn child processes themselves. NOTE: +-- for reasons unknown I cannot just turn off/on the signal handlers here. +killNoWait :: Process a () () -> IO () +killNoWait p = do + -- this strategy is outlined/sanctioned in RIO.Process under + -- 'unsafeProcessHandle': + -- + -- get the handle (unsafely, since it breaks the semantics of RIO) + let ph = unsafeProcessHandle p + -- check if the process has already exited (if so, do nothing since trying + -- to kill it will open wormholes + ec <- getProcessExitCode ph + unless (isJust ec) $ do + -- send SIGTERM to the entire group (NOTE: 'System.Process.terminateProcess' + -- does not actually do this despite what the docs say) + i <- getPid ph + forM_ i $ signalProcessGroup sigTERM + -- actually call 'stopProcess' which will clean up associated data and + -- then try to wait for the exit, which will fail because we are assuming + -- this function is called when the handler for SIGCHLD is Ignore. Ignore + -- the failure and move on with life. + handleIO (\_ -> return ()) $ stopProcess p + +-------------------------------------------------------------------------------- +-- Startuphook configuration -- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED? myStartupHook :: X () -myStartupHook = setDefaultCursor xC_left_ptr - <+> startupHook def +myStartupHook = + setDefaultCursor xC_left_ptr + <+> startupHook def -------------------------------------------------------------------------------- --- | Workspace configuration +-- Workspace configuration myWorkspaces :: [WorkspaceId] -myWorkspaces = map show [1..10 :: Int] +myWorkspaces = map show [1 .. 10 :: Int] gimpTag :: String gimpTag = "GIMP" @@ -252,122 +357,148 @@ gimpDynamicWorkspace :: Sometimes DynWorkspace gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw where tree = Only_ $ sysExe [Package Official "gimp"] exe - dw = DynWorkspace - { dwName = "Gimp" - , dwTag = gimpTag - , dwClass = c - , dwHook = - [ matchGimpRole "gimp-image-window" -?> appendViewShift gimpTag - , matchGimpRole "gimp-dock" -?> doF W.swapDown - , matchGimpRole "gimp-toolbox" -?> doF W.swapDown - , className =? c -?> appendViewShift gimpTag - ] - , dwKey = 'g' - , dwCmd = Just $ spawnCmd exe [] - } + dw = + DynWorkspace + { dwName = "Gimp" + , dwTag = gimpTag + , dwClass = c + , dwHook = + [ matchGimpRole "gimp-image-window" -?> appendViewShift gimpTag + , matchGimpRole "gimp-dock" -?> doF W.swapDown + , matchGimpRole "gimp-toolbox" -?> doF W.swapDown + , className =? c -?> appendViewShift gimpTag + ] + , dwKey = 'g' + , dwCmd = Just $ spawnCmd exe [] + } exe = "gimp-2.10" - matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE" - <&&> className =? c + matchGimpRole role = + isPrefixOf role + <$> stringProperty "WM_WINDOW_ROLE" + <&&> className + =? c c = "Gimp-2.10" -- TODO I don't feel like changing the version long term -- TODO don't hardcode the VM name/title/shortcut vmDynamicWorkspace :: Sometimes DynWorkspace -vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox - [Subfeature root "windows 8 VM"] +vmDynamicWorkspace = + Sometimes + "virtualbox workspace" + xpfVirtualBox + [Subfeature root "windows 8 VM"] where - root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") - $ IOTest_ name [] $ vmExists vm + root = + IORoot_ dw $ + toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") $ + IOTest_ name [] $ + io $ + vmExists vm name = T.unwords ["test if", vm, "exists"] c = "VirtualBoxVM" vm = "win8raw" - dw = DynWorkspace - { dwName = "Windows VirtualBox" - , dwTag = vmTag - , dwClass = c - , dwHook = [ className =? c -?> appendViewShift vmTag ] - , dwKey = 'v' - , dwCmd = Just $ spawnCmd "vbox-start" [vm] - } + dw = + DynWorkspace + { dwName = "Windows VirtualBox" + , dwTag = vmTag + , dwClass = c + , dwHook = [className =? c -?> appendViewShift vmTag] + , dwKey = 'v' + , dwCmd = Just $ spawnCmd "vbox-start" [vm] + } xsaneDynamicWorkspace :: Sometimes DynWorkspace -xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE - [Subfeature (IORoot_ dw tree) "xsane"] +xsaneDynamicWorkspace = + Sometimes + "scanner workspace" + xpfXSANE + [Subfeature (IORoot_ dw tree) "xsane"] where tree = Only_ $ sysExe [Package Official "xsane"] "xsane" - dw = DynWorkspace - { dwName = "XSane" - , dwTag = xsaneTag - , dwClass = c - , dwHook = [ className =? c -?> appendViewShift xsaneTag >> doFloat ] - , dwKey = 'x' - , dwCmd = Just $ spawnCmd "xsane" [] - } + dw = + DynWorkspace + { dwName = "XSane" + , dwTag = xsaneTag + , dwClass = c + , dwHook = [className =? c -?> appendViewShift xsaneTag >> doFloat] + , dwKey = 'x' + , dwCmd = Just $ spawnCmd "xsane" [] + } c = "Xsane" f5vpnDynamicWorkspace :: Sometimes DynWorkspace -f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN - [Subfeature (IORoot_ dw tree) "f5vpn"] +f5vpnDynamicWorkspace = + Sometimes + "F5 VPN workspace" + xpfF5VPN + [Subfeature (IORoot_ dw tree) "f5vpn"] where tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn" - dw = DynWorkspace - { dwName = "F5Vpn" - , dwTag = f5Tag - , dwClass = c - , dwHook = [ className =? c -?> appendShift f5Tag ] - , dwKey = 'i' - , dwCmd = Just skip - } + dw = + DynWorkspace + { dwName = "F5Vpn" + , dwTag = f5Tag + , dwClass = c + , dwHook = [className =? c -?> appendShift f5Tag] + , dwKey = 'i' + , dwCmd = Just skip + } c = "F5 VPN" allDWs' :: [Sometimes DynWorkspace] -allDWs' = [xsaneDynamicWorkspace - , vmDynamicWorkspace - , gimpDynamicWorkspace - , f5vpnDynamicWorkspace - ] +allDWs' = + [ xsaneDynamicWorkspace + , vmDynamicWorkspace + , gimpDynamicWorkspace + , f5vpnDynamicWorkspace + ] -------------------------------------------------------------------------------- --- | Layout configuration +-- Layout configuration -- NOTE this will have all available layouts, even those that may be for -- features that failed. Trying to dynamically take out a layout seems to -- make a new type :/ -myLayouts tt = onWorkspace vmTag vmLayout - $ onWorkspace gimpTag gimpLayout - $ mkToggle (single HIDE) - $ tall ||| fulltab ||| full +myLayouts tt = + onWorkspace vmTag vmLayout $ + onWorkspace gimpTag gimpLayout $ + mkToggle (single HIDE) $ + tall ||| fulltab ||| full where addTopBar = noFrillsDeco shrinkText tt - tall = renamed [Replace "Tall"] - $ avoidStruts - $ addTopBar - $ noBorders - $ Tall 1 0.03 0.5 - fulltab = renamed [Replace "Tabbed"] - $ avoidStruts - $ noBorders - $ tabbedAlways shrinkText tt - full = renamed [Replace "Full"] - $ noBorders Full + tall = + renamed [Replace "Tall"] $ + avoidStruts $ + addTopBar $ + noBorders $ + Tall 1 0.03 0.5 + fulltab = + renamed [Replace "Tabbed"] $ + avoidStruts $ + noBorders $ + tabbedAlways shrinkText tt + full = + renamed [Replace "Full"] $ + noBorders Full vmLayout = noBorders Full -- TODO use a tabbed layout for multiple master windows - gimpLayout = renamed [Replace "Gimp Layout"] - $ avoidStruts - $ noBorders - $ addTopBar - $ Tall 1 0.025 0.8 + gimpLayout = + renamed [Replace "Gimp Layout"] $ + avoidStruts $ + noBorders $ + addTopBar $ + Tall 1 0.025 0.8 -- | Make a new empty layout and add a message to show/hide it. This is useful -- for quickly showing conky. data EmptyLayout a = EmptyLayout - deriving (Show, Read) + deriving (Show, Read) instance LayoutClass EmptyLayout a where doLayout a b _ = emptyLayout a b description _ = "Desktop" data HIDE = HIDE - deriving (Read, Show, Eq, Typeable) + deriving (Read, Show, Eq, Typeable) instance Transformer HIDE Window where transform _ x k = k EmptyLayout (\EmptyLayout -> x) @@ -377,10 +508,9 @@ runHide :: X () runHide = sendMessage $ Toggle HIDE -------------------------------------------------------------------------------- --- | Loghook configuration --- +-- Loghook configuration -myLoghook :: Handle -> X () +myLoghook :: Process Handle () () -> X () myLoghook h = do logXinerama h logViewports @@ -396,10 +526,10 @@ myLoghook h = do -- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why -- bother...(if that were necessary it would go in the startup hook) newtype DesktopViewports = DesktopViewports [Int] - deriving Eq + deriving (Eq) instance ExtensionClass DesktopViewports where - initialValue = DesktopViewports [] + initialValue = DesktopViewports [] logViewports :: X () logViewports = withWindowSet $ \s -> do @@ -407,28 +537,29 @@ logViewports = withWindowSet $ \s -> do let ws = sort' $ W.workspaces s let desktopViewports = concatMap (wsToViewports s) ws whenChanged (DesktopViewports desktopViewports) $ - setDesktopViewports desktopViewports + setDesktopViewports desktopViewports where - wsToViewports s w = let cur = W.current s in - if W.tag w == currentTag cur then currentPos cur else [0, 0] + wsToViewports s w = + let cur = W.current s + in if W.tag w == currentTag cur then currentPos cur else [0, 0] currentTag = W.tag . W.workspace currentPos = rectXY . screenRect . W.screenDetail rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y] setDesktopViewports :: [Int] -> X () setDesktopViewports vps = withDisplay $ \dpy -> do - r <- asks theRoot - a <- getAtom "_NET_DESKTOP_VIEWPORT" - c <- getAtom "CARDINAL" - io $ changeProperty32 dpy r a c propModeReplace $ map fromIntegral vps + r <- asks theRoot + a <- getAtom "_NET_DESKTOP_VIEWPORT" + c <- getAtom "CARDINAL" + io $ changeProperty32 dpy r a c propModeReplace $ map fromIntegral vps -- stolen from XMonad.Hooks.EwmhDesktops whenChanged :: (Eq a, ExtensionClass a) => a -> X () -> X () whenChanged v action = do - v0 <- E.get - unless (v == v0) $ do - action - E.put v + v0 <- E.get + unless (v == v0) $ do + action + E.put v -- | Xinerama loghook (for xmobar) -- The format will be like "[<1> 2 3] 4 5 | LAYOUT (N)" where each digit is the @@ -436,156 +567,184 @@ whenChanged v action = do -- currently visible and the order reflects the physical location of each -- screen. The "<>" is the workspace that currently has focus. N is the number -- of windows on the current workspace. - -logXinerama :: Handle -> X () -logXinerama h = withWindowSet $ \ws -> io - $ hPutStrLn h - $ T.unwords - $ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws] +logXinerama :: Process Handle () () -> X () +logXinerama p = withWindowSet $ \ws -> + io $ + hPutStrLn (getStdin p) $ + T.unwords $ + filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws] where - onScreen ws = xmobarColor_ hilightFgColor hilightBgColor - $ (T.pack . pad . T.unpack) - $ T.unwords - $ map (fmtTags ws . W.tag . W.workspace) - $ sortBy compareXCoord - $ W.current ws : W.visible ws - offScreen = xmobarColor_ XT.backdropFgColor "" - . T.unwords - . fmap (T.pack . W.tag) - . filter (isJust . W.stack) - . sortOn W.tag - . W.hidden + onScreen ws = + xmobarColor_ hilightFgColor hilightBgColor $ + (T.pack . pad . T.unpack) $ + T.unwords $ + map (fmtTags ws . W.tag . W.workspace) $ + sortBy compareXCoord $ + W.current ws : W.visible ws + offScreen = + xmobarColor_ XT.backdropFgColor "" + . T.unwords + . fmap (T.pack . W.tag) + . filter (isJust . W.stack) + . sortOn W.tag + . W.hidden sep = xmobarColor_ XT.backdropFgColor "" ":" layout = T.pack . description . W.layout . W.workspace . W.current - nWindows = (\x -> T.concat ["(", x, ")"]) - . T.pack - . show - . length - . W.integrate' - . W.stack - . W.workspace - . W.current + nWindows = + (\x -> T.concat ["(", x, ")"]) + . T.pack + . show + . length + . W.integrate' + . W.stack + . W.workspace + . W.current hilightBgColor = "#A6D3FF" hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor - fmtTags ws t = let t_ = T.pack t in - if t == W.currentTag ws - then xmobarColor_ XT.fgColor hilightBgColor t_ - else t_ + fmtTags ws t = + let t_ = T.pack t + in if t == W.currentTag ws + then xmobarColor_ XT.fgColor hilightBgColor t_ + else t_ xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c) compareXCoord :: W.Screen i1 l1 a1 ScreenId ScreenDetail - -> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering + -> W.Screen i2 l2 a2 ScreenId ScreenDetail + -> Ordering compareXCoord s0 s1 = compare (go s0) (go s1) where go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle -------------------------------------------------------------------------------- --- | Managehook configuration +-- Managehook configuration myManageHook :: [DynWorkspace] -> ManageHook myManageHook dws = manageApps dws <+> manageHook def manageApps :: [DynWorkspace] -> ManageHook -manageApps dws = composeOne $ concatMap dwHook dws ++ - [ isDialog -?> doCenterFloat - -- the seafile applet - , className =? "Seafile Client" -?> doFloat - -- gnucash - , (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat - -- plots and graphics - , className =? "R_x11" -?> doFloat - , className =? "Matplotlib" -?> doFloat - , className =? "mpv" -?> doFloat - -- the floating windows created by the brave browser - , stringProperty "WM_NAME" =? "Brave" -?> doFloat - -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up" - -- <&&> className =? "Brave-browser") -?> doFloat - -- the dialog windows created by the zotero addon in Google Docs - , (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat - ] +manageApps dws = + composeOne $ + concatMap dwHook dws + ++ [ isDialog -?> doCenterFloat + , -- the seafile applet + className =? "Seafile Client" -?> doFloat + , -- gnucash + (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat + , -- plots and graphics + className =? "R_x11" -?> doFloat + , className =? "Matplotlib" -?> doFloat + , className =? "mpv" -?> doFloat + , -- the floating windows created by the brave browser + stringProperty "WM_NAME" =? "Brave" -?> doFloat + , -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up" + -- <&&> className =? "Brave-browser") -?> doFloat + -- the dialog windows created by the zotero addon in Google Docs + (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat + ] -------------------------------------------------------------------------------- --- | Eventhook configuration +-- Eventhook configuration -myEventHook :: (String -> X ()) -> Event -> X All -myEventHook handler = xMsgEventHook handler <+> handleEventHook def +myEventHook + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (m () -> IO ()) + -> (String -> X ()) + -> Event + -> X All +myEventHook runIO handler = xMsgEventHook runIO handler <+> handleEventHook def -- | React to ClientMessage events from concurrent threads -xMsgEventHook :: (String -> X ()) -> Event -> X All -xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d } +xMsgEventHook + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (m () -> IO ()) + -> (String -> X ()) + -> Event + -> X All +xMsgEventHook runIO handler ClientMessageEvent {ev_message_type = t, ev_data = d} | t == bITMAP = do - let (xtype, tag) = splitXMsg d - case xtype of - Workspace -> removeDynamicWorkspace tag - ACPI -> handler tag - Unknown -> io $ putStrLn "WARNING: unknown concurrent message" - return (All True) -xMsgEventHook _ _ = return (All True) + let (xtype, tag) = splitXMsg d + case xtype of + Workspace -> removeDynamicWorkspace tag + ACPI -> handler tag + Unknown -> liftIO $ runIO $ logWarn "unknown concurrent message" + return (All True) +xMsgEventHook _ _ _ = return (All True) -------------------------------------------------------------------------------- --- | Keymap configuration +-- Keymap configuration myModMask :: KeyMask myModMask = mod4Mask -addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ()) - -> [KeyGroup (X ())] -> XConfig l -> XConfig l -addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys) - (\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external) +addKeymap + :: [DynWorkspace] + -> ([((KeyMask, KeySym), NamedAction)] -> X ()) + -> [KeyGroup (X ())] + -> XConfig l + -> XConfig l +addKeymap dws showKeys external = + addDescrKeys' + ((myModMask, xK_F1), showKeys) + (\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external) internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())] internalBindings dws c = - [ KeyGroup "Window Layouts" - [ KeyBinding "M-j" "focus down" $ windows W.focusDown - , KeyBinding "M-k" "focus up" $ windows W.focusUp - , KeyBinding "M-m" "focus master" $ windows W.focusMaster - , KeyBinding "M-d" "focus master" runHide - , KeyBinding "M-S-j" "swap down" $ windows W.swapDown - , KeyBinding "M-S-k" "swap up" $ windows W.swapUp - , KeyBinding "M-S-m" "swap master" $ windows W.swapMaster - , KeyBinding "M-" "next layout" $ sendMessage NextLayout - , KeyBinding "M-S-" "reset layout" $ setLayout $ layoutHook c - , KeyBinding "M-t" "sink tiling" $ withFocused $ windows . W.sink - , KeyBinding "M-S-t" "float tiling" $ withFocused O.float - , KeyBinding "M--" "shrink" $ sendMessage Shrink - , KeyBinding "M-=" "expand" $ sendMessage Expand - , KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1) - , KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1 - ] - - , KeyGroup "Workspaces" - -- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get - -- valid keysyms) - ([ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces - , (mods, msg, f) <- - [ ("M-", "switch to workspace ", windows . W.view) - , ("M-S-", "move client to workspace ", windows . W.shift) - , ("M-C-", "follow client to workspace ", \n' -> do - windows $ W.shift n' - windows $ W.view n') + [ KeyGroup + "Window Layouts" + [ KeyBinding "M-j" "focus down" $ windows W.focusDown + , KeyBinding "M-k" "focus up" $ windows W.focusUp + , KeyBinding "M-m" "focus master" $ windows W.focusMaster + , KeyBinding "M-d" "focus master" runHide + , KeyBinding "M-S-j" "swap down" $ windows W.swapDown + , KeyBinding "M-S-k" "swap up" $ windows W.swapUp + , KeyBinding "M-S-m" "swap master" $ windows W.swapMaster + , KeyBinding "M-" "next layout" $ sendMessage NextLayout + , KeyBinding "M-S-" "reset layout" $ setLayout $ layoutHook c + , KeyBinding "M-t" "sink tiling" $ withFocused $ windows . W.sink + , KeyBinding "M-S-t" "float tiling" $ withFocused O.float + , KeyBinding "M--" "shrink" $ sendMessage Shrink + , KeyBinding "M-=" "expand" $ sendMessage Expand + , KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1) + , KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1 + ] + , KeyGroup + "Workspaces" + -- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get + -- valid keysyms) + ( [ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces, (mods, msg, f) <- + [ ("M-", "switch to workspace ", windows . W.view) + , ("M-S-", "move client to workspace ", windows . W.shift) + , + ( "M-C-" + , "follow client to workspace " + , \n' -> do + windows $ W.shift n' + windows $ W.view n' + ) + ] ] - ] ++ - [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS) - , KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS) - ]) - - , KeyGroup "Dynamic Workspaces" - [ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd - | DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- dws, - let cmd = case a of - Just a' -> spawnOrSwitch t a' - Nothing -> windows $ W.view t - ] - - , KeyGroup "Screens" - [ KeyBinding "M-l" "move up screen" nextScr - , KeyBinding "M-h" "move down screen" prevScr - , KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift - , KeyBinding "M-C-h" "follow client down screen" $ prevScr' W.shift - , KeyBinding "M-S-l" "shift workspace up screen" $ nextScr' W.greedyView - , KeyBinding "M-S-h" "shift workspace down screen" $ prevScr' W.greedyView - ] + ++ [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS) + , KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS) + ] + ) + , KeyGroup + "Dynamic Workspaces" + [ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd + | DynWorkspace {dwTag = t, dwKey = k, dwCmd = a, dwName = n} <- dws + , let cmd = case a of + Just a' -> spawnOrSwitch t a' + Nothing -> windows $ W.view t + ] + , KeyGroup + "Screens" + [ KeyBinding "M-l" "move up screen" nextScr + , KeyBinding "M-h" "move down screen" prevScr + , KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift + , KeyBinding "M-C-h" "follow client down screen" $ prevScr' W.shift + , KeyBinding "M-S-l" "shift workspace up screen" $ nextScr' W.greedyView + , KeyBinding "M-S-h" "shift workspace down screen" $ prevScr' W.greedyView + ] ] where prev = onPrevNeighbour horizontalScreenOrderer @@ -595,120 +754,126 @@ internalBindings dws c = prevScr' f = prev f >> prevScr nextScr' f = next f >> nextScr -mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)] -mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } = - (subtitle h:) $ mkNamedKeymap c - $ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a)) - <$> b +mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)] +mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} = + (subtitle h :) $ + mkNamedKeymap c $ + (\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a)) + <$> b data KeyBinding a = KeyBinding - { kbSyms :: String - , kbDesc :: String + { kbSyms :: String + , kbDesc :: String , kbMaybeAction :: a } data KeyGroup a = KeyGroup - { kgHeader :: String + { kgHeader :: String , kgBindings :: [KeyBinding a] } -evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX] +evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX] evalExternal = mapM go where - go k@KeyGroup { kgBindings = bs } = - (\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs + go k@KeyGroup {kgBindings = bs} = + (\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs -evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX) -evalKeyBinding k@KeyBinding { kbMaybeAction = a } = - (\f -> k { kbMaybeAction = f }) <$> evalFeature a +evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX) +evalKeyBinding k@KeyBinding {kbMaybeAction = a} = + (\f -> k {kbMaybeAction = f}) <$> evalFeature a filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())] filterExternal = fmap go where - go k@KeyGroup { kgBindings = bs } = - k { kgBindings = [ kb { kbMaybeAction = x } - | kb@KeyBinding { kbMaybeAction = Just x } <- bs - ] + go k@KeyGroup {kgBindings = bs} = + k + { kgBindings = + [ kb {kbMaybeAction = x} + | kb@KeyBinding {kbMaybeAction = Just x} <- bs + ] } -externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX] -externalBindings ts db = - [ KeyGroup "Launchers" - [ KeyBinding "" "select/launch app" $ Left runAppMenu - , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu - , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys - , KeyBinding "M-w" "launch window selector" $ Left runWinMenu - , KeyBinding "M-u" "launch device selector" $ Left runDevMenu - , KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses - , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu - , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu - , KeyBinding "M-C-e" "launch editor" $ Left runEditor - , KeyBinding "M-C-w" "launch browser" $ Left runBrowser - , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux - , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm - , KeyBinding "M-C-q" "launch calc" $ Left runCalc - , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager - ] - - , KeyGroup "Actions" - [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1 - , KeyBinding "M-r" "run program" $ Left runCmdMenu - , KeyBinding "M-" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5 - , KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses - , KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses - , KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses - , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser - -- , ("M-C-S-s", "capture focused window", spawn myWindowCap) - ] - - , KeyGroup "Multimedia" - [ KeyBinding "" "toggle play/pause" $ Left runTogglePlay - , KeyBinding "" "previous track" $ Left runPrevTrack - , KeyBinding "" "next track" $ Left runNextTrack - , KeyBinding "" "stop" $ Left runStopPlay - , KeyBinding "" "volume down" $ Left runVolumeDown - , KeyBinding "" "volume up" $ Left runVolumeUp - , KeyBinding "" "volume mute" $ Left runVolumeMute - ] - - , KeyGroup "Dunst" - [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses - , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses - , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses - , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses - ] - - , KeyGroup "System" - [ KeyBinding "M-." "backlight up" $ ib bctlInc - , KeyBinding "M-," "backlight down" $ ib bctlDec - , KeyBinding "M-M1-," "backlight min" $ ib bctlMin - , KeyBinding "M-M1-." "backlight max" $ ib bctlMax - , KeyBinding "M-S-." "keyboard up" $ ck bctlInc - , KeyBinding "M-S-," "keyboard down" $ ck bctlDec - , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin - , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax - , KeyBinding "M-" "power menu" $ Left runPowerPrompt - , KeyBinding "M-" "quit xmonad" $ Left runQuitPrompt - , KeyBinding "M-" "lock screen" $ Left runScreenLock - -- M- reserved for showing the keymap - , KeyBinding "M-" "restart xmonad" restartf - , KeyBinding "M-" "recompile xmonad" recompilef - , KeyBinding "M-" "select autorandr profile" $ Left runAutorandrMenu - , KeyBinding "M-" "toggle ethernet" $ Left runToggleEthernet - , KeyBinding "M-" "toggle bluetooth" $ Left $ runToggleBluetooth sys - , KeyBinding "M-" "toggle screensaver" $ Left $ ioSometimes $ callToggle ses - , KeyBinding "M-" "switch gpu" $ Left runOptimusPrompt - ] +externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX] +externalBindings runIO cleanup db = + [ KeyGroup + "Launchers" + [ KeyBinding "" "select/launch app" $ Left $ toX runAppMenu + , KeyBinding "M-g" "launch clipboard manager" $ Left $ toX runClipMenu + , KeyBinding "M-a" "launch network selector" $ Left $ toX $ runNetMenu sys + , KeyBinding "M-w" "launch window selector" $ Left $ toX runWinMenu + , KeyBinding "M-u" "launch device selector" $ Left $ toX runDevMenu + , KeyBinding "M-b" "launch bitwarden selector" $ Left $ toX $ runBwMenu ses + , KeyBinding "M-v" "launch ExpressVPN selector" $ Left $ toX runVPNMenu + , KeyBinding "M-e" "launch bluetooth selector" $ Left $ toX runBTMenu + , KeyBinding "M-C-e" "launch editor" $ Left $ toX runEditor + , KeyBinding "M-C-w" "launch browser" $ Left $ toX runBrowser + , KeyBinding "M-C-t" "launch terminal with tmux" $ Left $ toX runTMux + , KeyBinding "M-C-S-t" "launch terminal" $ Left $ toX runTerm + , KeyBinding "M-C-q" "launch calc" $ Left $ toX runCalc + , KeyBinding "M-C-f" "launch file manager" $ Left $ toX runFileManager + ] + , KeyGroup + "Actions" + [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1 + , KeyBinding "M-r" "run program" $ Left $ toX runCmdMenu + , KeyBinding "M-" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5 + , KeyBinding "M-C-s" "capture area" $ Left $ toX $ runAreaCapture ses + , KeyBinding "M-C-S-s" "capture screen" $ Left $ toX $ runScreenCapture ses + , KeyBinding "M-C-d" "capture desktop" $ Left $ toX $ runDesktopCapture ses + , KeyBinding "M-C-b" "browse captures" $ Left $ toX runCaptureBrowser + -- , ("M-C-S-s", "capture focused window", spawn myWindowCap) + ] + , KeyGroup + "Multimedia" + [ KeyBinding "" "toggle play/pause" $ Left $ toX runTogglePlay + , KeyBinding "" "previous track" $ Left $ toX runPrevTrack + , KeyBinding "" "next track" $ Left $ toX runNextTrack + , KeyBinding "" "stop" $ Left $ toX runStopPlay + , KeyBinding "" "volume down" $ Left $ toX runVolumeDown + , KeyBinding "" "volume up" $ Left $ toX runVolumeUp + , KeyBinding "" "volume mute" $ Left $ toX runVolumeMute + ] + , KeyGroup + "Dunst" + [ KeyBinding "M-`" "dunst history" $ Left $ toX $ runNotificationHistory ses + , KeyBinding "M-S-`" "dunst close" $ Left $ toX $ runNotificationClose ses + , KeyBinding "M-M1-`" "dunst context menu" $ Left $ toX $ runNotificationContext ses + , KeyBinding "M-C-`" "dunst close all" $ Left $ toX $ runNotificationCloseAll ses + ] + , KeyGroup + "System" + [ KeyBinding "M-." "backlight up" $ ib bctlInc + , KeyBinding "M-," "backlight down" $ ib bctlDec + , KeyBinding "M-M1-," "backlight min" $ ib bctlMin + , KeyBinding "M-M1-." "backlight max" $ ib bctlMax + , KeyBinding "M-S-." "keyboard up" $ ck bctlInc + , KeyBinding "M-S-," "keyboard down" $ ck bctlDec + , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin + , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax + , KeyBinding "M-" "power menu" $ Left runPowerPrompt + , KeyBinding "M-" "quit xmonad" $ Left runQuitPrompt + , KeyBinding "M-" "lock screen" $ Left runScreenLock + , -- M- reserved for showing the keymap + KeyBinding "M-" "restart xmonad" restartf + , KeyBinding "M-" "recompile xmonad" recompilef + , KeyBinding "M-" "select autorandr profile" $ Left $ toX runAutorandrMenu + , KeyBinding "M-" "toggle ethernet" $ Left $ toX runToggleEthernet + , KeyBinding "M-" "toggle bluetooth" $ Left $ toX $ runToggleBluetooth sys + , KeyBinding "M-" "toggle screensaver" $ Left $ toX $ callToggle ses + , KeyBinding "M-" "switch gpu" $ Left runOptimusPrompt + ] ] where ses = dbSesClient db sys = dbSysClient db - brightessControls ctl getter = (ioSometimes . getter . ctl) ses + brightessControls ctl getter = (toX . getter . ctl) ses ib = Left . brightessControls intelBacklightControls ck = Left . brightessControls clevoKeyboardControls ftrAlways n = Right . Always n . Always_ . FallbackAlone - restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart) + restartf = ftrAlways "restart function" (cleanup >> runRestart) recompilef = ftrAlways "recompile function" runRecompile + toX_ = liftIO . runIO + toX = fmap toX_ type MaybeX = Maybe (X ()) diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..190e1ca --- /dev/null +++ b/fourmolu.yaml @@ -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 diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 0bfe459..18cc40e 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -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 <> "'" diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/XIO.hs similarity index 53% rename from lib/Data/Internal/Dependency.hs rename to lib/Data/Internal/XIO.hs index 2e3f0a8..b516e6a 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/XIO.hs @@ -1,64 +1,64 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- --- | Functions for handling dependencies +-- Functions for handling dependencies -module Data.Internal.Dependency - -- feature types +module Data.Internal.XIO +-- feature types ( Feature - , Always(..) - , Always_(..) - , FallbackRoot(..) - , FallbackStack(..) - , Sometimes(..) + , Always (..) + , Always_ (..) + , FallbackRoot (..) + , FallbackStack (..) + , Sometimes (..) , Sometimes_ , AlwaysX , AlwaysIO , SometimesX , SometimesIO - , PostPass(..) - , Subfeature(..) + , PostPass (..) + , Subfeature (..) , SubfeatureRoot - , Msg(..) - + , Msg (..) -- configuration - , XParams(..) - , XPFeatures(..) + , XEnv (..) + , XParams (..) + , XPFeatures (..) , XPQuery - -- dependency tree types - , Root(..) - , Tree(..) - , Tree_(..) + , Root (..) + , Tree (..) + , Tree_ (..) , IOTree , IOTree_ , DBusTree , DBusTree_ - , SafeClient(..) - , IODependency(..) - , IODependency_(..) - , SystemDependency(..) - , DBusDependency_(..) - , DBusMember(..) - , UnitType(..) + , SafeClient (..) + , IODependency (..) + , IODependency_ (..) + , SystemDependency (..) + , DBusDependency_ (..) + , DBusMember (..) + , UnitType (..) , Result - , Fulfillment(..) - , ArchPkg(..) - + , Fulfillment (..) + , ArchPkg (..) -- dumping , dumpFeature , dumpAlways , dumpSometimes , showFulfillment - -- testing - , FIO - , withCache + , XIO + , runXIO + , hRunXIO , evalFeature , executeSometimes , executeAlways @@ -72,11 +72,9 @@ module Data.Internal.Dependency , readEthernet , readWireless , socketExists - -- lifting - , ioSometimes - , ioAlways - + -- , ioSometimes + -- , ioAlways -- feature construction , always1 , sometimes1 @@ -86,7 +84,6 @@ module Data.Internal.Dependency , sometimesExe , sometimesExeArgs , sometimesEndpoint - -- dependency construction , sysExe , localExe @@ -101,75 +98,82 @@ module Data.Internal.Dependency , voidResult , voidRead , process - -- misc , shellTest - ) where + , withLogFile + ) +where -import Control.Monad.IO.Class -import Control.Monad.Identity -import Control.Monad.Reader - -import Data.Aeson hiding (Error, Result) -import Data.Aeson.Key -import Data.Bifunctor -import Data.Either -import Data.Internal.DBus -import Data.List -import Data.Maybe -import Data.Yaml - -import GHC.IO.Exception (ioe_description) - -import DBus hiding (typeOf) -import qualified DBus.Introspection as I - -import RIO hiding (bracket, fromString) -import RIO.FilePath -import qualified RIO.Text as T - -import System.Directory -import System.Environment -import System.IO.Error -import System.Posix.Files - -import XMonad.Core (X, io) -import XMonad.Internal.IO -import XMonad.Internal.Process -import XMonad.Internal.Shell -import XMonad.Internal.Theme +import DBus hiding (typeOf) +import qualified DBus.Introspection as I +import Data.Aeson hiding (Error, Result) +import Data.Aeson.Key +import Data.Internal.DBus +import Data.Yaml +import GHC.IO.Exception (ioe_description) +import RIO hiding (bracket, fromString) +import RIO.Directory +import RIO.FilePath +import RIO.List +import RIO.Process hiding (findExecutable) +import qualified RIO.Text as T +import System.Posix.Files +import System.Process.Typed (nullStream) +import UnliftIO.Environment +import XMonad.Core (X, dataDir, getDirectories, io) +import XMonad.Internal.IO +import XMonad.Internal.Shell hiding (proc, runProcess) +import XMonad.Internal.Theme -------------------------------------------------------------------------------- --- | Feature Evaluation +-- Feature Evaluation -- -- Here we attempt to build and return the monadic actions encoded by each -- feature. -- | Run feature evaluation(s) with the cache -- Currently there is no easy way to not use this (oh well) -withCache :: FIO a -> IO a -withCache x = do - logOpts <- logOptionsHandle stderr False +runXIO :: FilePath -> XIO a -> IO a +runXIO logfile x = withLogFile logfile $ \h -> hRunXIO True h x + +-- TODO use dhall to encode config file and log here to control the loglevel +withLogFile :: MonadUnliftIO m => FilePath -> (Handle -> m a) -> m a +withLogFile logfile f = do + p <- ( logfile) . dataDir <$> liftIO getDirectories + catchIO (withFile p AppendMode f) $ \e -> do + liftIO $ print e + liftIO $ putStrLn "could not open log file, falling back to stderr" + f stderr + +hRunXIO :: Bool -> Handle -> XIO a -> IO a +hRunXIO verbose h x = do + hSetBuffering h LineBuffering + logOpts <- logOptionsHandle_ verbose h + pc <- mkDefaultProcessContext withLogFunc logOpts $ \f -> do p <- getParams - let s = DepStage f p + let s = XEnv f pc p runRIO s x +logOptionsHandle_ :: MonadUnliftIO m => Bool -> Handle -> m LogOptions +logOptionsHandle_ v h = + setLogVerboseFormat v . setLogUseTime v <$> logOptionsHandle h False + -- | Execute an Always immediately -executeAlways :: Always (IO a) -> FIO a +executeAlways :: Always (IO a) -> XIO a executeAlways = io <=< evalAlways -- | Execute a Sometimes immediately (or do nothing if failure) -executeSometimes :: Sometimes (IO a) -> FIO (Maybe a) -executeSometimes a = maybe (return Nothing) (io . fmap Just) =<< evalSometimes a +executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a) +executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a -- | Possibly return the action of an Always/Sometimes -evalFeature :: Feature a -> FIO (Maybe a) +evalFeature :: Feature a -> XIO (Maybe a) evalFeature (Right a) = Just <$> evalAlways a -evalFeature (Left s) = evalSometimes s +evalFeature (Left s) = evalSometimes s -- | Possibly return the action of a Sometimes -evalSometimes :: Sometimes a -> FIO (Maybe a) +evalSometimes :: Sometimes a -> XIO (Maybe a) evalSometimes x = either goFail goPass =<< evalSometimesMsg x where goPass (a, ws) = putErrors ws >> return (Just a) @@ -177,34 +181,36 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x putErrors = mapM_ logMsg -- | Return the action of an Always -evalAlways :: Always a -> FIO a +evalAlways :: Always a -> XIO a evalAlways a = do (x, ws) <- evalAlwaysMsg a mapM_ logMsg ws return x -logMsg :: FMsg -> FIO () +logMsg :: FMsg -> XIO () logMsg (FMsg fn n (Msg ll m)) = do p <- io getProgName f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p) where llFun LevelError = ("ERROR", logError) - llFun LevelInfo = ("INFO", logInfo) - llFun LevelWarn = ("WARN", logWarn) - llFun _ = ("DEBUG", logDebug) + llFun LevelInfo = ("INFO", logInfo) + llFun LevelWarn = ("WARN", logWarn) + llFun _ = ("DEBUG", logDebug) (s, f) = llFun ll - fmt p l = [ bracket p - , bracket l - , bracket fn - ] - ++ maybe [] ((:[]) . bracket) n - ++ [m] + fmt p l = + [ bracket p + , bracket l + , bracket fn + ] + ++ maybe [] ((: []) . bracket) n + ++ [m] -------------------------------------------------------------------------------- --- | Package status +-- Package status -showFulfillment :: Fulfillment -> T.Text -showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n] +showFulfillment :: Fulfillment -> Utf8Builder +showFulfillment (Package t n) = + displayShow t <> "\t" <> Utf8Builder (encodeUtf8Builder n) dumpFeature :: Feature a -> [Fulfillment] dumpFeature = either dumpSometimes dumpAlways @@ -212,13 +218,13 @@ dumpFeature = either dumpSometimes dumpAlways dumpAlways :: Always a -> [Fulfillment] dumpAlways (Always _ x) = case x of (Option o _) -> nub $ dataSubfeatureRoot o - _ -> [] + _ -> [] dumpSometimes :: Sometimes a -> [Fulfillment] dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs -------------------------------------------------------------------------------- --- | Wrapper types +-- Wrapper types type AlwaysX = Always (X ()) @@ -226,36 +232,48 @@ type AlwaysIO = Always (IO ()) type SometimesX = Sometimes (X ()) -type SometimesIO = Sometimes (IO ()) +type SometimesIO = Sometimes (XIO ()) type Feature a = Either (Sometimes a) (Always a) -------------------------------------------------------------------------------- --- | Feature declaration +-- Feature declaration -- | Feature that is guaranteed to work -- This is composed of sub-features that are tested in order, and if all fail -- the fallback is a monadic action (eg a plain haskell function) -data Always a = Always T.Text (Always_ a) +data Always a = Always T.Text (Always_ a) deriving (Functor) -- | Feature that is guaranteed to work (inner data) -data Always_ a = Option (SubfeatureRoot a) (Always_ a) +data Always_ a + = Option (SubfeatureRoot a) (Always_ a) | Always_ (FallbackRoot a) + deriving (Functor) -- | Root of a fallback action for an always -- This may either be a lone action or a function that depends on the results -- from other Always features. -data FallbackRoot a = FallbackAlone a +data FallbackRoot a + = FallbackAlone a | forall p. FallbackTree (p -> a) (FallbackStack p) +instance Functor FallbackRoot where + fmap f (FallbackAlone a) = FallbackAlone (f a) + fmap f (FallbackTree g s) = FallbackTree (f . g) s + -- | Always features that are used as a payload for a fallback action -data FallbackStack p = FallbackBottom (Always p) +data FallbackStack p + = FallbackBottom (Always p) | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y) +instance Functor FallbackStack where + fmap f (FallbackBottom a) = FallbackBottom $ fmap f a + fmap f (FallbackStack g a s) = FallbackStack (\x -> f . g x) a s + -- | Feature that might not be present -- This is like an Always except it doesn't fall back on a guaranteed monadic -- action -data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) +data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) deriving (Functor) -- | Feature that might not be present (inner data) type Sometimes_ a = [SubfeatureRoot a] @@ -268,20 +286,28 @@ data Subfeature f = Subfeature { sfData :: f , sfName :: T.Text } + deriving (Functor) type SubfeatureRoot a = Subfeature (Root a) -- | An action and its dependencies -- May be a plain old monad or be DBus-dependent, in which case a client is -- needed -data Root a = forall p. IORoot (p -> a) (IOTree p) +data Root a + = forall p. IORoot (p -> a) (IOTree p) | IORoot_ a IOTree_ | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c) | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c) +instance Functor Root where + fmap f (IORoot a t) = IORoot (f . a) t + fmap f (IORoot_ a t) = IORoot_ (f a) t + fmap f (DBusRoot a t cl) = DBusRoot (\p c -> f $ a p c) t cl + fmap f (DBusRoot_ a t cl) = DBusRoot_ (f . a) t cl + -- | The dependency tree with rule to merge results when needed -data Tree d d_ p = - forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) +data Tree d d_ p + = forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) | And1 (Tree d d_ p) (Tree_ d_) | And2 (Tree_ d_) (Tree d d_ p) | Or (Tree d d_ p) (Tree d d_ p) @@ -292,58 +318,63 @@ data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d -- | Shorthand tree types for lazy typers type IOTree p = Tree IODependency IODependency_ p + type DBusTree c p = Tree IODependency (DBusDependency_ c) p + type IOTree_ = Tree_ IODependency_ + type DBusTree_ c = Tree_ (DBusDependency_ c) -- | A dependency that only requires IO to evaluate (with payload) -data IODependency p = - -- an IO action that yields a payload - IORead T.Text [Fulfillment] (FIO (Result p)) - -- always yields a payload - | IOConst p - -- an always that yields a payload - | forall a. IOAlways (Always a) (a -> p) - -- a sometimes that yields a payload - | forall a. IOSometimes (Sometimes a) (a -> p) +data IODependency p + = -- an IO action that yields a payload + IORead T.Text [Fulfillment] (XIO (Result p)) + | -- always yields a payload + IOConst p + | -- an always that yields a payload + forall a. IOAlways (Always a) (a -> p) + | -- a sometimes that yields a payload + forall a. IOSometimes (Sometimes a) (a -> p) -- | A dependency pertaining to the DBus -data DBusDependency_ c = Bus [Fulfillment] BusName +data DBusDependency_ c + = Bus [Fulfillment] BusName | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember | DBusIO IODependency_ - deriving (Generic) -- | A dependency that only requires IO to evaluate (no payload) -data IODependency_ = IOSystem_ [Fulfillment] SystemDependency - | IOTest_ T.Text [Fulfillment] (IO (Maybe Msg)) +data IODependency_ + = IOSystem_ [Fulfillment] SystemDependency + | IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg)) | forall a. IOSometimes_ (Sometimes a) -- | A system component to an IODependency -- This name is dumb, but most constructors should be obvious -data SystemDependency = - Executable Bool FilePath +data SystemDependency + = Executable Bool FilePath | AccessiblePath FilePath Bool Bool | Systemd UnitType T.Text | Process T.Text - deriving (Eq, Show, Generic) + deriving (Eq, Show) -- | The type of a systemd service -data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic) +data UnitType = SystemUnit | UserUnit deriving (Eq, Show) -- | Wrapper type to describe and endpoint -data DBusMember = Method_ MemberName +data DBusMember + = Method_ MemberName | Signal_ MemberName | Property_ T.Text - deriving (Eq, Show, Generic) + deriving (Eq, Show) -- | A means to fulfill a dependency -- For now this is just the name of an Arch Linux package (AUR or official) data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord) -data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord) +data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Ord) -------------------------------------------------------------------------------- --- | Tested dependency tree +-- Tested dependency tree -- -- The main reason I need this is so I have a "result" I can convert to JSON -- and dump on the CLI (unless there is a way to make Aeson work inside an IO) @@ -355,13 +386,14 @@ data Msg = Msg LogLevel T.Text data FMsg = FMsg T.Text (Maybe T.Text) Msg -- | Tested Always feature -data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a) +data PostAlways a + = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a) | Fallback a [SubfeatureFail] -- | Tested Sometimes feature data PostSometimes a = PostSometimes { psSuccess :: Maybe (SubfeaturePass a) - , psFailed :: [SubfeatureFail] + , psFailed :: [SubfeatureFail] } -- | Passing subfeature @@ -380,18 +412,27 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms' data PostFail = PostFail [Msg] | PostMissing Msg -------------------------------------------------------------------------------- --- | Configuration +-- Configuration -type FIO a = RIO DepStage a +type XIO a = RIO XEnv a -data DepStage = DepStage - { dsLogFun :: !LogFunc - , dsParams :: !XParams +data XEnv = XEnv + { xLogFun :: !LogFunc + , xProcCxt :: !ProcessContext + , xParams :: !XParams } -instance HasLogFunc DepStage where - logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y }) +instance HasLogFunc XEnv where + logFuncL = lens xLogFun (\x y -> x {xLogFun = y}) +instance SafeClient c => HasLogFunc (DBusEnv XEnv c) where + logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL + +instance HasProcessContext XEnv where + processContextL = lens xProcCxt (\x y -> x {xProcCxt = y}) + +instance HasClient (DBusEnv XEnv) where + clientL = lens dClient (\x y -> x {dClient = y}) data XParams = XParams { xpLogLevel :: LogLevel @@ -408,73 +449,88 @@ instance FromJSON XParams where ll <- mapLevel <$> o .: fromString "loglevel" fs <- o .: fromString "features" return $ XParams ll fs - where - mapLevel Info = LevelInfo - mapLevel Error = LevelError - mapLevel Warn = LevelWarn - mapLevel Debug = LevelDebug + where + mapLevel Info = LevelInfo + mapLevel Error = LevelError + mapLevel Warn = LevelWarn + mapLevel Debug = LevelDebug data XPFeatures = XPFeatures - { xpfOptimus :: Bool - , xpfVirtualBox :: Bool - , xpfXSANE :: Bool - , xpfEthernet :: Bool - , xpfWireless :: Bool - , xpfVPN :: Bool - , xpfBluetooth :: Bool + { xpfOptimus :: Bool + , xpfVirtualBox :: Bool + , xpfXSANE :: Bool + , xpfEthernet :: Bool + , xpfWireless :: Bool + , xpfVPN :: Bool + , xpfBluetooth :: Bool , xpfIntelBacklight :: Bool , xpfClevoBacklight :: Bool - , xpfBattery :: Bool - , xpfF5VPN :: Bool + , xpfBattery :: Bool + , xpfF5VPN :: Bool } instance FromJSON XPFeatures where - parseJSON = withObject "features" $ \o -> XPFeatures - <$> o .:+ "optimus" - <*> o .:+ "virtualbox" - <*> o .:+ "xsane" - <*> o .:+ "ethernet" - <*> o .:+ "wireless" - <*> o .:+ "vpn" - <*> o .:+ "bluetooth" - <*> o .:+ "intel_backlight" - <*> o .:+ "clevo_backlight" - <*> o .:+ "battery" - <*> o .:+ "f5vpn" + parseJSON = withObject "features" $ \o -> + XPFeatures + <$> o + .:+ "optimus" + <*> o + .:+ "virtualbox" + <*> o + .:+ "xsane" + <*> o + .:+ "ethernet" + <*> o + .:+ "wireless" + <*> o + .:+ "vpn" + <*> o + .:+ "bluetooth" + <*> o + .:+ "intel_backlight" + <*> o + .:+ "clevo_backlight" + <*> o + .:+ "battery" + <*> o + .:+ "f5vpn" defParams :: XParams -defParams = XParams - { xpLogLevel = LevelError - , xpFeatures = defXPFeatures - } +defParams = + XParams + { xpLogLevel = LevelError + , xpFeatures = defXPFeatures + } defXPFeatures :: XPFeatures -defXPFeatures = XPFeatures - { xpfOptimus = False - , xpfVirtualBox = False - , xpfXSANE = False - , xpfEthernet = False - , xpfWireless = False - -- TODO this might be broken down into different flags (expressvpn, etc) - , xpfVPN = False - , xpfBluetooth = False - , xpfIntelBacklight = False - , xpfClevoBacklight = False - , xpfBattery = False - , xpfF5VPN = False - } +defXPFeatures = + XPFeatures + { xpfOptimus = False + , xpfVirtualBox = False + , xpfXSANE = False + , xpfEthernet = False + , xpfWireless = False + , -- TODO this might be broken down into different flags (expressvpn, etc) + xpfVPN = False + , xpfBluetooth = False + , xpfIntelBacklight = False + , xpfClevoBacklight = False + , xpfBattery = False + , xpfF5VPN = False + } type XPQuery = XPFeatures -> Bool -getParams :: IO XParams +getParams :: MonadIO m => m XParams getParams = do p <- getParamFile - maybe (return defParams) decodeYaml p + maybe (return defParams) (liftIO . decodeYaml) p where - decodeYaml p = either (\e -> print e >> return defParams) return - =<< decodeFileEither p + decodeYaml p = + either (\e -> print e >> return defParams) return + =<< decodeFileEither p -getParamFile :: IO (Maybe FilePath) +getParamFile :: MonadIO m => m (Maybe FilePath) getParamFile = do e <- lookupEnv "XDG_CONFIG_HOME" parent <- case e of @@ -483,116 +539,123 @@ getParamFile = do | isRelative path -> fallback | otherwise -> return path let full = parent "xmonad.yml" - (\x -> if x then Just full else Nothing) <$> fileExist full + (\x -> if x then Just full else Nothing) <$> doesFileExist full where fallback = ( ".config") <$> getHomeDirectory (.:+) :: Object -> String -> Parser Bool (.:+) o n = o .:? fromString n .!= False -infix .:+ +infix 9 .:+ -------------------------------------------------------------------------------- --- | Testing pipeline +-- Testing pipeline -evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg])) +evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg])) evalSometimesMsg (Sometimes n u xs) = do - r <- asks (u . xpFeatures . dsParams) - if not r then return $ Left [dis n] else do - PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs - let fs' = failedMsgs n fs - return $ case s of - (Just p) -> Right $ second (++ fs') $ passActMsg n p - _ -> Left fs' + r <- asks (u . xpFeatures . xParams) + if not r + then return $ Left [dis n] + else do + PostSometimes {psSuccess = s, psFailed = fs} <- testSometimes xs + let fs' = failedMsgs n fs + return $ case s of + (Just p) -> Right $ second (++ fs') $ passActMsg n p + _ -> Left fs' where dis name = FMsg name Nothing (Msg LevelDebug "feature disabled") -evalAlwaysMsg :: Always a -> FIO (a, [FMsg]) +evalAlwaysMsg :: Always a -> XIO (a, [FMsg]) evalAlwaysMsg (Always n x) = do r <- testAlways x return $ case r of - (Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p + (Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p (Fallback act fs) -> (act, failedMsgs n fs) passActMsg :: T.Text -> SubfeaturePass a -> (a, [FMsg]) -passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn (Just n)) ws) +passActMsg fn Subfeature {sfData = PostPass a ws, sfName = n} = (a, fmap (FMsg fn (Just n)) ws) failedMsgs :: T.Text -> [SubfeatureFail] -> [FMsg] failedMsgs n = concatMap (failedMsg n) failedMsg :: T.Text -> SubfeatureFail -> [FMsg] -failedMsg fn Subfeature { sfData = d, sfName = n } = case d of - (PostFail es) -> f es +failedMsg fn Subfeature {sfData = d, sfName = n} = case d of + (PostFail es) -> f es (PostMissing e) -> f [e] where f = fmap (FMsg fn (Just n)) -testAlways :: Always_ a -> FIO (PostAlways a) +testAlways :: Always_ a -> XIO (PostAlways a) testAlways = go [] where go failed (Option fd next) = do r <- testSubfeature fd case r of - (Left l) -> go (l:failed) next + (Left l) -> go (l : failed) next (Right pass) -> return $ Primary pass failed next go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar -evalFallbackRoot :: FallbackRoot a -> FIO a -evalFallbackRoot (FallbackAlone a) = return a +evalFallbackRoot :: FallbackRoot a -> XIO a +evalFallbackRoot (FallbackAlone a) = return a evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s -evalFallbackStack :: FallbackStack p -> FIO p +evalFallbackStack :: FallbackStack p -> XIO p evalFallbackStack (FallbackBottom a) = evalAlways a evalFallbackStack (FallbackStack f a as) = do ps <- evalFallbackStack as p <- evalAlways a return $ f p ps -testSometimes :: Sometimes_ a -> FIO (PostSometimes a) +testSometimes :: Sometimes_ a -> XIO (PostSometimes a) testSometimes = go (PostSometimes Nothing []) where go ts [] = return ts - go ts (x:xs) = do + go ts (x : xs) = do sf <- testSubfeature x case sf of - (Left l) -> go (ts { psFailed = l:psFailed ts }) xs - (Right pass) -> return $ ts { psSuccess = Just pass } + (Left l) -> go (ts {psFailed = l : psFailed ts}) xs + (Right pass) -> return $ ts {psSuccess = Just pass} -testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a)) -testSubfeature sf@Subfeature{ sfData = t } = do +testSubfeature :: SubfeatureRoot a -> XIO (Either SubfeatureFail (SubfeaturePass a)) +testSubfeature sf@Subfeature {sfData = t} = do t' <- testRoot t -- monomorphism restriction :( - return $ bimap (\n -> sf { sfData = n }) (\n -> sf { sfData = n }) t' + return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t' -testRoot :: Root a -> FIO (Either PostFail (PostPass a)) +testRoot :: Root a -> XIO (Either PostFail (PostPass a)) testRoot r = do case r of - (IORoot a t) -> go a testIODep_ testIODep t - (IORoot_ a t) -> go_ a testIODep_ t - (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t + (IORoot a t) -> go a testIODep_ testIODep t + (IORoot_ a t) -> go_ a testIODep_ t + (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t - _ -> return $ Left $ PostMissing - $ Msg LevelError "client not available" + _ -> + return $ + Left $ + PostMissing $ + Msg LevelError "client not available" where -- rank N polymorphism is apparently undecidable...gross - go a f_ (f :: forall q. d q -> FIO (MResult q)) t = + go a f_ (f :: forall q. d q -> XIO (MResult q)) t = bimap PostFail (fmap a) <$> testTree f_ f t go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t -------------------------------------------------------------------------------- --- | Payloaded dependency testing +-- Payloaded dependency testing type Result p = Either [Msg] (PostPass p) type MResult p = Memoized (Result p) -testTree :: forall d d_ p. (d_ -> FIO MResult_) - -> (forall q. d q -> FIO (MResult q)) +testTree + :: forall d d_ p + . (d_ -> XIO MResult_) + -> (forall q. d q -> XIO (MResult q)) -> Tree d d_ p - -> FIO (Either [Msg] (PostPass p)) + -> XIO (Either [Msg] (PostPass p)) testTree test_ test = go where - go :: forall q. Tree d d_ q -> FIO (Result q) + go :: forall q. Tree d d_ q -> XIO (Result q) go (And12 f a b) = do ra <- go a liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra @@ -605,93 +668,109 @@ testTree test_ test = go go (Or a b) = do ra <- go a either (\ea -> fmap (`addMsgs` ea) <$> go b) (return . Right) ra - go (Only a) = runMemoized =<< test a + go (Only a) = runMemoized =<< test a and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb liftRight = either (return . Left) -testIODep :: IODependency p -> FIO (MResult p) +testIODep :: IODependency p -> XIO (MResult p) testIODep d = memoizeMVar $ case d of IORead _ _ t -> t - IOConst c -> return $ Right $ PostPass c [] + IOConst c -> return $ Right $ PostPass c [] -- TODO this is a bit odd because this is a dependency that will always -- succeed, which kinda makes this pointless. The only reason I would want -- this is if I want to have a built-in logic to "choose" a payload to use in -- building a higher-level feature - IOAlways a f -> Right . uncurry PostPass - -- TODO this is wetter than Taco Bell shit - . bimap f (fmap stripMsg) <$> evalAlwaysMsg a - IOSometimes x f -> bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg)) - <$> evalSometimesMsg x + IOAlways a f -> + Right + . uncurry PostPass + -- TODO this is wetter than Taco Bell shit + . bimap f (fmap stripMsg) + <$> evalAlwaysMsg a + IOSometimes x f -> + bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg)) + <$> evalSometimesMsg x stripMsg :: FMsg -> Msg stripMsg (FMsg _ _ m) = m -------------------------------------------------------------------------------- --- | Standalone dependency testing +-- | Standalone dependency testing type Result_ = Either [Msg] [Msg] type MResult_ = Memoized Result_ -testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_ +testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_ testTree_ test = go where go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a - go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a - go (Only_ a) = runMemoized =<< test a + go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a + go (Only_ a) = runMemoized =<< test a test2nd ws = fmap ((Right . (ws ++)) =<<) . go -testIODep_ :: IODependency_ -> FIO MResult_ +testIODep_ :: IODependency_ -> XIO MResult_ testIODep_ d = memoizeMVar $ testIODepNoCache_ d -testIODepNoCache_ :: IODependency_ -> FIO Result_ -testIODepNoCache_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s -testIODepNoCache_ (IOTest_ _ _ t) = io $ readResult_ <$> t -testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd) - <$> evalSometimesMsg x +testIODepNoCache_ :: IODependency_ -> XIO Result_ +testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s +testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t +testIODepNoCache_ (IOSometimes_ x) = + bimap (fmap stripMsg) (fmap stripMsg . snd) + <$> evalSometimesMsg x -------------------------------------------------------------------------------- --- | System Dependency Testing +-- System Dependency Testing -testSysDependency :: SystemDependency -> IO (Maybe Msg) -testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing) - <$> findExecutable bin +testSysDependency + :: (MonadUnliftIO m, MonadReader env m, HasProcessContext env, HasLogFunc env) + => SystemDependency + -> m (Maybe Msg) +testSysDependency (Executable sys bin) = + io $ + maybe (Just msg) (const Nothing) + <$> findExecutable bin where msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"] e = if sys then "system" else "local" -testSysDependency (Systemd t n) = shellTest cmd msg +testSysDependency (Systemd t n) = shellTest "systemctl" args msg where msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"] - cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n] -testSysDependency (Process n) = shellTest (fmtCmd "pidof" [n]) - $ T.unwords ["Process", singleQuote n, "not found"] -testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p + args = ["--user" | t == UserUnit] ++ ["status", n] +testSysDependency (Process n) = + shellTest "pidof" [n] $ + T.unwords ["Process", singleQuote n, "not found"] +testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p where - testPerm False _ _ = Nothing + testPerm False _ _ = Nothing testPerm True f res = Just $ f res mkErr = Just . Msg LevelError - permMsg NotFoundError = mkErr "file not found" - permMsg PermError = mkErr "could not get permissions" + permMsg NotFoundError = mkErr "file not found" + permMsg PermError = mkErr "could not get permissions" permMsg (PermResult res) = case (testPerm r readable res, testPerm w writable res) of (Just False, Just False) -> mkErr "file not readable or writable" - (Just False, _) -> mkErr "file not readable" - (_, Just False) -> mkErr "file not writable" - _ -> Nothing + (Just False, _) -> mkErr "file not readable" + (_, Just False) -> mkErr "file not writable" + _ -> Nothing -shellTest :: T.Text -> T.Text -> IO (Maybe Msg) -shellTest cmd msg = do - (rc, _, _) <- readCreateProcessWithExitCode' (shell $ T.unpack cmd) "" +shellTest + :: (MonadReader env m, HasProcessContext env, HasLogFunc env, MonadUnliftIO m) + => FilePath + -> [T.Text] + -> T.Text + -> m (Maybe Msg) +shellTest cmd args msg = do + rc <- proc cmd (T.unpack <$> args) (runProcess . setStdout nullStream) return $ case rc of ExitSuccess -> Nothing - _ -> Just $ Msg LevelError msg + _ -> Just $ Msg LevelError msg unitType :: UnitType -> T.Text unitType SystemUnit = "system" -unitType UserUnit = "user" +unitType UserUnit = "user" -------------------------------------------------------------------------------- --- | Font testers +-- Font testers -- -- Make a special case for these since we end up testing the font alot, and it -- would be nice if I can cache them. @@ -701,7 +780,7 @@ fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont where root = IORoot id $ fontTree fam ful -fontSometimes :: T.Text -> T.Text -> [Fulfillment]-> Sometimes FontBuilder +fontSometimes :: T.Text -> T.Text -> [Fulfillment] -> Sometimes FontBuilder fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root where root = IORoot id $ fontTree fam ful @@ -722,24 +801,27 @@ fontDependency :: T.Text -> [Fulfillment] -> IODependency FontBuilder fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam fontDependency_ :: T.Text -> [Fulfillment] -> IODependency_ -fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont' fam +fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont fam fontTestName :: T.Text -> T.Text fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"] -testFont :: T.Text -> FIO (Result FontBuilder) -testFont = liftIO . testFont' +-- testFont :: T.Text -> XIO (Result FontBuilder) +-- testFont = liftIO . testFont' -testFont' :: T.Text -> IO (Result FontBuilder) -testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg +testFont + :: (MonadUnliftIO m, MonadReader env m, HasProcessContext env, HasLogFunc env) + => T.Text + -> m (Result FontBuilder) +testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg where msg = T.unwords ["font family", qFam, "not found"] - cmd = fmtCmd "fc-list" ["-q", qFam] + args = [qFam] qFam = singleQuote fam pass = Right $ PostPass (buildFont $ Just fam) [] -------------------------------------------------------------------------------- --- | Network Testers +-- Network Testers -- -- ASSUME that the system uses systemd in which case ethernet interfaces always -- start with "en" and wireless interfaces always start with "wl" @@ -756,9 +838,10 @@ isWireless = T.isPrefixOf "wl" isEthernet :: T.Text -> Bool isEthernet = T.isPrefixOf "en" -listInterfaces :: IO [T.Text] -listInterfaces = fromRight [] - <$> tryIOError (fmap T.pack <$> listDirectory sysfsNet) +listInterfaces :: MonadUnliftIO m => m [T.Text] +listInterfaces = + fromRight [] + <$> tryIO (fmap T.pack <$> listDirectory sysfsNet) sysfsNet :: FilePath sysfsNet = "/sys/class/net" @@ -772,29 +855,32 @@ readInterface n f = IORead n [] go ns <- filter f <$> listInterfaces case ns of [] -> return $ Left [Msg LevelError "no interfaces found"] - (x:xs) -> do - return $ Right $ PostPass x - $ fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs + (x : xs) -> do + return $ + Right $ + PostPass x $ + fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs -------------------------------------------------------------------------------- --- | Misc testers +-- Misc testers -socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_ -socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful - . socketExists' +socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_ +socketExists n ful = + IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists' -socketExists' :: IO FilePath -> IO (Maybe Msg) +socketExists' :: MonadUnliftIO m => m FilePath -> m (Maybe Msg) socketExists' getPath = do p <- getPath - r <- tryIOError $ getFileStatus p + r <- tryIO $ liftIO $ getFileStatus p return $ case r of - Left e -> toErr $ T.pack $ ioe_description e - Right s -> if isSocket s then Nothing else toErr $ T.append (T.pack p) " is not a socket" + Left e -> toErr $ T.pack $ ioe_description e + Right s | isSocket s -> Nothing + _ -> toErr $ T.append (T.pack p) " is not a socket" where toErr = Just . Msg LevelError -------------------------------------------------------------------------------- --- | DBus Dependency Testing +-- DBus Dependency Testing introspectInterface :: InterfaceName introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" @@ -802,19 +888,22 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" -testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_ +testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_ testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d -testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ -testDBusDepNoCache_ cl (Bus _ bus) = io $ do - ret <- callMethod cl queryBus queryPath queryIface queryMem +testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_ +testDBusDepNoCache_ cl (Bus _ bus) = do + ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem return $ case ret of - Left e -> Left [Msg LevelError e] - Right b -> let ns = bodyGetNames b in - if bus' `elem` ns then Right [] - else Left [ - Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"] - ] + Left e -> Left [Msg LevelError e] + Right b -> + let ns = bodyGetNames b + in if bus' `elem` ns + then Right [] + else + Left + [ Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"] + ] where bus' = T.pack $ formatBusName bus queryBus = busName_ "org.freedesktop.DBus" @@ -822,76 +911,80 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do queryPath = objectPath_ "/" queryMem = memberName_ "ListNames" bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text] - bodyGetNames _ = [] - -testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do - ret <- callMethod cl busname objpath introspectInterface introspectMethod + bodyGetNames _ = [] +testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = do + ret <- + withDIO cl $ + callMethod busname objpath introspectInterface introspectMethod return $ case ret of - Left e -> Left [Msg LevelError e] - Right body -> procBody body + Left e -> Left [Msg LevelError e] + Right body -> procBody body where - procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant - =<< listToMaybe body in - case res of - Just True -> Right [] - _ -> Left [Msg LevelError $ fmtMsg' mem] - findMem = fmap (matchMem mem) - . find (\i -> I.interfaceName i == iface) - . I.objectInterfaces - matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods - matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals + procBody body = + let res = + findMem + =<< I.parseXML objpath + =<< fromVariant + =<< listToMaybe body + in case res of + Just True -> Right [] + _ -> Left [Msg LevelError $ fmtMsg' mem] + findMem = + fmap (matchMem mem) + . find (\i -> I.interfaceName i == iface) + . I.objectInterfaces + matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods + matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals matchMem (Property_ n) = elemMember n (T.pack . I.propertyName) I.interfaceProperties elemMember n fname fmember = elem n . fmap fname . fmember - fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)] - fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)] + fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)] + fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)] fmtMem (Property_ n) = T.unwords ["property", singleQuote n] - fmtMsg' m = T.unwords - [ "could not find" - , fmtMem m - , "on interface" - , singleQuote $ T.pack $ formatInterfaceName iface - , "on bus" - , T.pack $ formatBusName busname - ] - + fmtMsg' m = + T.unwords + [ "could not find" + , fmtMem m + , "on interface" + , singleQuote $ T.pack $ formatInterfaceName iface + , "on bus" + , T.pack $ formatBusName busname + ] testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i -------------------------------------------------------------------------------- --- | IO Lifting functions +-- IO Lifting functions -ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a) -ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs +-- ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a) +-- ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs -ioAlways :: MonadIO m => Always (IO a) -> Always (m a) -ioAlways (Always n x) = Always n $ ioAlways' x +-- ioAlways :: MonadIO m => Always (IO a) -> Always (m a) +-- ioAlways (Always n x) = Always n $ ioAlways' x -ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a) -ioAlways' (Always_ ar) = Always_ $ ioFallbackRoot ar -ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a +-- ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a) +-- ioAlways' (Always_ ar) = Always_ $ ioFallbackRoot ar +-- ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a -ioFallbackRoot :: MonadIO m => FallbackRoot (IO a) -> FallbackRoot (m a) -ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a -ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s +-- ioFallbackRoot :: MonadIO m => FallbackRoot (IO a) -> FallbackRoot (m a) +-- ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a +-- ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s -ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a) -ioSubfeature sf = sf { sfData = ioRoot $ sfData sf } - -ioRoot :: MonadIO m => Root (IO a) -> Root (m a) -ioRoot (IORoot a t) = IORoot (io . a) t -ioRoot (IORoot_ a t) = IORoot_ (io a) t -ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl -ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl +-- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a) +-- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf} -------------------------------------------------------------------------------- --- | Feature constructors +-- Feature constructors sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a -sometimes1_ x fn n t = Sometimes fn x - [Subfeature{ sfData = t, sfName = n }] +sometimes1_ x fn n t = + Sometimes + fn + x + [Subfeature {sfData = t, sfName = n}] always1_ :: T.Text -> T.Text -> Root a -> a -> Always a -always1_ fn n t x = Always fn - $ Option (Subfeature{ sfData = t, sfName = n }) (Always_ $ FallbackAlone x) +always1_ fn n t x = + Always fn $ + Option (Subfeature {sfData = t, sfName = n}) (Always_ $ FallbackAlone x) sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a sometimes1 = sometimes1_ (const True) @@ -905,30 +998,58 @@ sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a sometimesIO fn n t x = sometimes1 fn n $ IORoot x t -sometimesExe :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool - -> FilePath -> Sometimes (m ()) +sometimesExe + :: MonadIO m + => T.Text + -> T.Text + -> [Fulfillment] + -> Bool + -> FilePath + -> Sometimes (m ()) sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path [] -sometimesExeArgs :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool - -> FilePath -> [T.Text] -> Sometimes (m ()) +sometimesExeArgs + :: MonadIO m + => T.Text + -> T.Text + -> [Fulfillment] + -> Bool + -> FilePath + -> [T.Text] + -> Sometimes (m ()) sometimesExeArgs fn n ful sys path args = sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args -sometimesDBus :: SafeClient c => Maybe c -> T.Text -> T.Text - -> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a +sometimesDBus + :: SafeClient c + => Maybe c + -> T.Text + -> T.Text + -> Tree_ (DBusDependency_ c) + -> (c -> a) + -> Sometimes a sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c -sometimesEndpoint :: (SafeClient c, MonadIO m) => T.Text -> T.Text - -> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName - -> Maybe c -> Sometimes (m ()) +-- TODO do I need to hardcode XEnv? +sometimesEndpoint + :: (HasClient (DBusEnv env), SafeClient c, MonadReader env m, MonadUnliftIO m) + => T.Text + -> T.Text + -> [Fulfillment] + -> BusName + -> ObjectPath + -> InterfaceName + -> MemberName + -> Maybe c + -> Sometimes (m ()) sometimesEndpoint fn name ful busname path iface mem cl = sometimesDBus cl fn name deps cmd where deps = Only_ $ Endpoint ful busname path iface $ Method_ mem - cmd c = io $ void $ callMethod c busname path iface mem + cmd c = void $ withDIO c $ callMethod busname path iface mem -------------------------------------------------------------------------------- --- | Dependency Tree Constructors +-- Dependency Tree Constructors listToAnds :: d -> [d] -> Tree_ d listToAnds i = foldr (And_ . Only_) (Only_ i) @@ -940,20 +1061,20 @@ toFallback :: IODependency p -> p -> Tree IODependency d_ p toFallback a = Or (Only a) . Only . IOConst voidResult :: Result p -> Result_ -voidResult (Left es) = Left es +voidResult (Left es) = Left es voidResult (Right (PostPass _ ws)) = Right ws voidRead :: Result p -> Maybe Msg -voidRead (Left []) = Just $ Msg LevelError "unspecified error" -voidRead (Left (e:_)) = Just e -voidRead (Right _) = Nothing +voidRead (Left []) = Just $ Msg LevelError "unspecified error" +voidRead (Left (e : _)) = Just e +voidRead (Right _) = Nothing readResult_ :: Maybe Msg -> Result_ readResult_ (Just w) = Left [w] -readResult_ _ = Right [] +readResult_ _ = Right [] -------------------------------------------------------------------------------- --- | IO Dependency Constructors +-- IO Dependency Constructors exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_ exe b ful = IOSystem_ ful . Executable b @@ -989,59 +1110,62 @@ process :: [Fulfillment] -> T.Text -> IODependency_ process ful = IOSystem_ ful . Process -------------------------------------------------------------------------------- --- | Dependency data for JSON +-- Dependency data for JSON type DependencyData = [Fulfillment] dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData -dataSubfeatureRoot Subfeature { sfData = r } = dataRoot r +dataSubfeatureRoot Subfeature {sfData = r} = dataRoot r dataRoot :: Root a -> DependencyData -dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t -dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t -dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t +dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t +dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t +dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t -dataTree :: forall d d_ p. (forall q. d q -> DependencyData) - -> (d_ -> DependencyData) -> Tree d d_ p -> DependencyData +dataTree + :: forall d d_ p + . (forall q. d q -> DependencyData) + -> (d_ -> DependencyData) + -> Tree d d_ p + -> DependencyData dataTree f f_ = go where go :: forall q. Tree d d_ q -> DependencyData go (And12 _ a b) = go a ++ go b - go (And1 a b) = go a ++ dataTree_ f_ b - go (And2 a b) = dataTree_ f_ a ++ go b - go (Or a _) = go a - go (Only d) = f d + go (And1 a b) = go a ++ dataTree_ f_ b + go (And2 a b) = dataTree_ f_ a ++ go b + go (Or a _) = go a + go (Only d) = f d dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> DependencyData dataTree_ f_ = go where go (And_ a b) = go a ++ go b - go (Or_ a _) = go a - go (Only_ d) = f_ d + go (Or_ a _) = go a + go (Only_ d) = f_ d dataIODependency :: IODependency p -> DependencyData dataIODependency d = case d of - (IORead _ f _) -> f + (IORead _ f _) -> f (IOSometimes x _) -> dumpSometimes x - (IOAlways x _) -> dumpAlways x - _ -> [] + (IOAlways x _) -> dumpAlways x + _ -> [] dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ d = case d of - (IOSystem_ f _) -> f - (IOTest_ _ f _) -> f + (IOSystem_ f _) -> f + (IOTest_ _ f _) -> f (IOSometimes_ x) -> dumpSometimes x dataDBusDependency :: DBusDependency_ c -> DependencyData dataDBusDependency d = case d of - (Bus f _) -> f - (Endpoint f _ _ _ _) -> f - (DBusIO x) -> dataIODependency_ x + (Bus f _) -> f + (Endpoint f _ _ _ _) -> f + (DBusIO x) -> dataIODependency_ x -------------------------------------------------------------------------------- --- | JSON formatting +-- formatting bracket :: T.Text -> T.Text bracket s = T.concat ["[", s, "]"] - diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index bad578e..946bbd7 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -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 diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index babeb5b..af27524 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -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] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index b179cc9..b324339 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index 4e12f36..a543ade 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/ClientMessage.hs b/lib/XMonad/Internal/Concurrent/ClientMessage.hs index f380b3e..f8c0308 100644 --- a/lib/XMonad/Internal/Concurrent/ClientMessage.hs +++ b/lib/XMonad/Internal/Concurrent/ClientMessage.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs index b27d90b..3e18c11 100644 --- a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs +++ b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/VirtualBox.hs b/lib/XMonad/Internal/Concurrent/VirtualBox.hs index dddfb72..5997478 100644 --- a/lib/XMonad/Internal/Concurrent/VirtualBox.hs +++ b/lib/XMonad/Internal/Concurrent/VirtualBox.hs @@ -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" diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 3395f4b..a6796c5 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 7e43837..f0cf6dd 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -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" diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 9c29cae..eaf0a18 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 4fb4b0a..65c6006 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -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" - diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 719a4c4..a2c573b 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index f909346..2879465 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 83463f2..541d096 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -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 diff --git a/lib/XMonad/Internal/IO.hs b/lib/XMonad/Internal/IO.hs index 7fe81c8..4e3a712 100644 --- a/lib/XMonad/Internal/IO.hs +++ b/lib/XMonad/Internal/IO.hs @@ -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 diff --git a/lib/XMonad/Internal/Notify.hs b/lib/XMonad/Internal/Notify.hs index 91c1c61..cd2f540 100644 --- a/lib/XMonad/Internal/Notify.hs +++ b/lib/XMonad/Internal/Notify.hs @@ -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' diff --git a/lib/XMonad/Internal/Process.hs b/lib/XMonad/Internal/Process.hs deleted file mode 100644 index 9d92e8b..0000000 --- a/lib/XMonad/Internal/Process.hs +++ /dev/null @@ -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 diff --git a/lib/XMonad/Internal/Shell.hs b/lib/XMonad/Internal/Shell.hs index 9f3bc5b..e91a0ed 100644 --- a/lib/XMonad/Internal/Shell.hs +++ b/lib/XMonad/Internal/Shell.hs @@ -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, "'"] diff --git a/lib/XMonad/Internal/Theme.hs b/lib/XMonad/Internal/Theme.hs index 165b75a..4e38c47 100644 --- a/lib/XMonad/Internal/Theme.hs +++ b/lib/XMonad/Internal/Theme.hs @@ -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 + } diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index b8f9f7f..137928a 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 9a9dbd9..3b396e0 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -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" diff --git a/lib/Xmobar/Plugins/ClevoKeyboard.hs b/lib/Xmobar/Plugins/ClevoKeyboard.hs index 92a8f12..a4b8975 100644 --- a/lib/Xmobar/Plugins/ClevoKeyboard.hs +++ b/lib/Xmobar/Plugins/ClevoKeyboard.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index d28ee2b..abefb83 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 13abdb0..7f5fe97 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -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) diff --git a/lib/Xmobar/Plugins/IntelBacklight.hs b/lib/Xmobar/Plugins/IntelBacklight.hs index e60a0fd..55f293e 100644 --- a/lib/Xmobar/Plugins/IntelBacklight.hs +++ b/lib/Xmobar/Plugins/IntelBacklight.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index ef125cb..5ac35fc 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -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) diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 625abf8..e9c0652 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -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 diff --git a/package.yaml b/package.yaml index 4d2ae55..b471e6c 100644 --- a/package.yaml +++ b/package.yaml @@ -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/