From fb9b9fa65e48c3d8e31804681417d2694ec882f6 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 28 Dec 2022 12:19:44 -0500 Subject: [PATCH] WIP kinda get rio process to work for all subprocesses --- bin/xmonad.hs | 124 +++++++----------- lib/Data/Internal/Dependency.hs | 6 +- lib/XMonad/Internal/Command/Desktop.hs | 10 +- lib/XMonad/Internal/Command/Power.hs | 10 +- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 2 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 14 +- lib/XMonad/Internal/DBus/Removable.hs | 2 +- lib/XMonad/Internal/DBus/Screensaver.hs | 8 +- 8 files changed, 69 insertions(+), 107 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 19e292a..133598c 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -21,23 +22,13 @@ import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Extras import RIO - ( async - , bracket - , handleIO - ) +import RIO.Directory import RIO.Process import qualified RIO.Text as T -import System.Directory import System.Environment -import System.IO hiding - ( hPutStrLn - ) -import System.IO.Error -import System.Process hiding - ( createPipe - , proc - ) +import System.Posix.Signals +import System.Process (getPid) import XMonad import XMonad.Actions.CopyWindow @@ -61,7 +52,6 @@ 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 (killHandle) import XMonad.Internal.Shell import qualified XMonad.Internal.Theme as XT import XMonad.Layout.MultiToggle @@ -103,10 +93,7 @@ run = do uninstallSignalHandlers hSetBuffering stdout LineBuffering withCache $ do - bracket (io connectDBusX) (io . disconnectDBus) $ \db -> do - -- conf <- evalConf db - -- ds <- io getCreateDirectories - -- io $ launch conf ds + withDBusX $ \db -> do let sys = dbSysClient db let fs = features sys startDBusInterfaces db fs @@ -136,8 +123,7 @@ run = do , normalBorderColor = T.unpack XT.bordersColor , focusedBorderColor = T.unpack XT.selectedBordersColor } - dirs <- io getCreateDirectories - io $ launch conf dirs + io $ runXMonad conf where startRemovableMon db fs = void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db @@ -147,6 +133,11 @@ run = do void $ io $ async $ runWorkspaceMon dws return dws +runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO () +runXMonad conf = do + dirs <- getCreateDirectories + launch conf dirs + startDBusInterfaces :: DBusState -> FeatureSet -> FIO () startDBusInterfaces db fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $ fsDBusExporters fs @@ -159,7 +150,7 @@ 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 () @@ -169,7 +160,7 @@ data FeatureSet = FeatureSet , fsDBusExporters :: [Maybe SesClient -> SometimesIO] , fsPowerMon :: SometimesIO , fsRemovableMon :: Maybe SysClient -> SometimesIO - , fsDaemons :: [Sometimes (IO ProcessHandle)] + , fsDaemons :: [Sometimes (FIO (Process () () ()))] , fsACPIHandler :: Always (String -> X ()) , fsTabbedTheme :: Always Theme , fsDynWorkspaces :: [Sometimes DynWorkspace] @@ -196,67 +187,35 @@ features cl = FeatureSet , fsDaemons = [runNetAppDaemon cl, runAutolock] } --- evalConf db@DBusState { dbSysClient = cl } = do --- -- start DBus interfaces first since many features after this test these --- -- interfaces as dependencies --- let fs = features cl --- tt <- evalAlways $ fsTabbedTheme fs --- startDBusInterfaces fs --- ts <- startChildDaemons fs --- startRemovableMon fs --- startPowerMon fs --- dws <- startDynWorkspaces 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 = maybe logViewports myLoghook $ tsXmobar ts --- , 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 --- p <- proc "xmobar" [] (startProcess . setStdin createPipe) --- io $ hSetBuffering (getStdin p) LineBuffering --- ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs) --- return $ ThreadState ps $ Just p --- 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 - startXmobar :: FIO (Process Handle () ()) startXmobar = do p <- proc "xmobar" [] (startProcess . setStdin createPipe) io $ hSetBuffering (getStdin p) LineBuffering return p -startChildDaemons :: FeatureSet -> FIO [ProcessHandle] +startChildDaemons :: FeatureSet -> FIO [Process () () ()] startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs) -withChildDaemons :: FeatureSet -> ([ProcessHandle] -> FIO a) -> FIO a -withChildDaemons fs = bracket (startChildDaemons fs) (mapM_ (io . killHandle)) +withDBusX :: (DBusState -> FIO a) -> FIO a +withDBusX = bracket (io connectDBusX) cleanup + where + cleanup db = do + logInfo "unregistering xmonad from DBus" + io $ disconnectDBus db + +withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a +withChildDaemons fs = bracket (startChildDaemons fs) cleanup + where + cleanup ps = do + logInfo "stopping child processes" + mapM_ stopProcess ps withXmobar :: (Process Handle () () -> FIO a) -> FIO a -withXmobar = bracket startXmobar stopProcess +withXmobar = bracket startXmobar cleanup + where + cleanup p = do + logInfo "stopping xmobar child process" + stopProcess p printDeps :: FIO () printDeps = do @@ -290,18 +249,23 @@ usage = putStrLn $ intercalate "\n" -- | Concurrency configuration data ThreadState = ThreadState - { tsChildPIDs :: [ProcessHandle] + { tsChildPIDs :: [Process () () ()] , tsXmobar :: Maybe (Process Handle () ()) } --- TODO shouldn't this be run by a signal handler? runCleanup :: ThreadState -> DBusState -> X () runCleanup ts db = io $ do - mapM_ stopNoWait $ tsXmobar ts - mapM_ killHandle $ tsChildPIDs ts - disconnectDBusX db + mapM_ killNoWait $ tsXmobar ts + finally (mapM_ killNoWait $ tsChildPIDs ts) $ + disconnectDBusX db where stopNoWait p = handleIO (\_ -> return ()) $ stopProcess p + killNoWait p = do + let ph = unsafeProcessHandle p + i <- getPid ph + forM_ i $ signalProcess sigTERM + -- terminateProcess ph + stopNoWait p -------------------------------------------------------------------------------- -- | Startuphook configuration @@ -777,14 +741,14 @@ externalBindings ts db = , 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-" "toggle screensaver" $ Left $ 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 = (getter . ctl) ses ib = Left . brightessControls intelBacklightControls ck = Left . brightessControls clevoKeyboardControls ftrAlways n = Right . Always n . Always_ . FallbackAlone diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 4a5ef65..4814dc2 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -162,8 +162,8 @@ executeAlways :: Always (IO a) -> FIO 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 (FIO a) -> FIO (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) @@ -228,7 +228,7 @@ type AlwaysIO = Always (IO ()) type SometimesX = Sometimes (X ()) -type SometimesIO = Sometimes (IO ()) +type SometimesIO = Sometimes (FIO ()) type Feature a = Either (Sometimes a) (Always a) diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index b5270a0..eb6d58f 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -41,7 +41,6 @@ module XMonad.Internal.Command.Desktop , networkManagerPkgs ) where -import Control.Monad (void) import Control.Monad.IO.Class import Data.Internal.DBus @@ -49,19 +48,20 @@ import Data.Internal.Dependency import DBus +import RIO import RIO.FilePath +import RIO.Process 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.Process hiding (createPipe, proc) import XMonad.Internal.Shell import XMonad.Operations @@ -251,13 +251,13 @@ runNotificationContext = -- | System commands -- this is required for some vpn's to work properly with network-manager -runNetAppDaemon :: Maybe SysClient -> Sometimes (IO ProcessHandle) +runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (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 _ = spawnProcess "nm-applet" [] + cmd _ = proc "nm-applet" [] startProcess runToggleBluetooth :: Maybe SysClient -> SometimesX runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index df4b86a..2af7922 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -27,8 +27,6 @@ module XMonad.Internal.Command.Power , promptFontDep ) where -import Control.Arrow (first) - import Data.Internal.Dependency import Data.Either @@ -36,13 +34,13 @@ import qualified Data.Map as M import Graphics.X11.Types +import RIO import RIO.FilePath +import RIO.Process import qualified RIO.Text as T import System.Directory -import System.Exit import System.IO.Error -import System.Process (ProcessHandle, spawnProcess) import XMonad.Core import XMonad.Internal.Shell @@ -90,12 +88,12 @@ runReboot = spawn "systemctl reboot" -------------------------------------------------------------------------------- -- | Autolock -runAutolock :: Sometimes (IO ProcessHandle) +runAutolock :: Sometimes (FIO (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 = spawnProcess "xss-lock" ["--ignore-sleep", "screenlock"] + cmd = proc "xss-lock" ["--ignore-sleep", "screenlock"] startProcess -------------------------------------------------------------------------------- -- | Confirmation prompts diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index 4e12f36..1c9761b 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -113,7 +113,7 @@ handleACPI fb lock tag = do -- | 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 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 7e43837..8146055 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -50,10 +50,10 @@ data BrightnessConfig a b = BrightnessConfig } data BrightnessControls = BrightnessControls - { bctlMax :: SometimesIO - , bctlMin :: SometimesIO - , bctlInc :: SometimesIO - , bctlDec :: SometimesIO + { bctlMax :: SometimesX + , bctlMin :: SometimesX + , bctlInc :: SometimesX + , bctlDec :: SometimesX } brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient @@ -101,8 +101,8 @@ brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl = root = DBusRoot_ (exportBrightnessControls' bc) tree cl tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps -exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> IO () -exportBrightnessControls' bc cl = do +exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> FIO () +exportBrightnessControls' bc cl = io $ do let ses = toClient cl maxval <- bcGetMax bc -- assume the max value will never change let bounds = (bcMinRaw bc, maxval) @@ -138,7 +138,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = sig = signal p i memCur callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text - -> MemberName -> SometimesIO + -> MemberName -> SometimesX callBacklight q cl BrightnessConfig { bcPath = p , bcInterface = i , bcName = n } controlName m = diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index f909346..e891314 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -86,6 +86,6 @@ listenDevices cl = do runRemovableMon :: Maybe SysClient -> SometimesIO runRemovableMon cl = - sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices + sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices where deps = toAnd_ addedDep removedDep diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 83463f2..56dd086 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -11,11 +11,11 @@ module XMonad.Internal.DBus.Screensaver , ssSignalDep ) where -import Control.Monad (void) - import Data.Internal.DBus import Data.Internal.Dependency +import RIO + import DBus import DBus.Client import qualified DBus.Introspection as I @@ -102,7 +102,7 @@ exportScreensaver ses = sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd where cmd cl = let cl' = toClient cl in - export cl' ssPath defaultInterface + liftIO $ export cl' ssPath defaultInterface { interfaceName = interface , interfaceMethods = [ autoMethod memToggle $ emitState cl' =<< toggle @@ -123,7 +123,7 @@ exportScreensaver ses = bus = Bus [] xmonadBusName ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable -callToggle :: Maybe SesClient -> SometimesIO +callToggle :: Maybe SesClient -> SometimesX callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" [] xmonadBusName ssPath interface memToggle