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

ENH use rio process for deps

This commit is contained in:
Nathan Dwarshuis 2022-12-27 19:39:16 -05:00
parent 23956e063b
commit 6526f5e309
3 changed files with 37 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/xmobar.hs
View File

@ -214,14 +214,14 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
where where
root useIcon = IORoot_ (batteryCmd useIcon) root useIcon = IORoot_ (batteryCmd useIcon)
tree = Only_ $ IOTest_ "Test if battery is present" [] tree = Only_ $ IOTest_ "Test if battery is present" []
$ fmap (Msg LevelError) <$> hasBattery $ io $ fmap (Msg LevelError) <$> hasBattery
getVPN :: Maybe SysClient -> BarFeature getVPN :: Maybe SysClient -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
where where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
networkManagerPkgs vpnPresent networkManagerPkgs $ io vpnPresent
getBt :: Maybe SysClient -> BarFeature getBt :: Maybe SysClient -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd

26
bin/xmonad.hs
View File

@ -79,7 +79,6 @@ parse ["--deps"] = withCache printDeps
parse ["--test"] = void $ withCache . evalConf =<< connectDBusX parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
parse _ = usage parse _ = usage
run :: IO () run :: IO ()
run = do run = do
-- These first two commands are only significant when xmonad is restarted. -- These first two commands are only significant when xmonad is restarted.
@ -150,38 +149,17 @@ features cl = FeatureSet
evalConf db@DBusState { dbSysClient = cl } = do evalConf db@DBusState { dbSysClient = cl } = do
-- start DBus interfaces first since many features after this test these -- start DBus interfaces first since many features after this test these
-- interfaces as dependencies -- interfaces as dependencies
io $ putStrLn "hi"
-- io $ hFlush stdout
let fs = features cl let fs = features cl
tt <- evalAlways $ fsTabbedTheme fs tt <- evalAlways $ fsTabbedTheme fs
io $ putStrLn "tabbed theme started"
-- io $ hFlush stdout
-- io $ print =<< readCreateProcessWithExitCode (proc "echo" ["hi"]) ""
startDBusInterfaces fs startDBusInterfaces fs
io $ putStrLn "dbus started"
-- io $ hFlush stdout
(xmobarHandle, ts) <- startChildDaemons fs (xmobarHandle, ts) <- startChildDaemons fs
io $ putStrLn "child daemons started"
-- io $ hFlush stdout
startRemovableMon fs startRemovableMon fs
io $ putStrLn "removemon started"
-- io $ hFlush stdout
startPowerMon fs startPowerMon fs
io $ putStrLn "powermon started"
-- io $ hFlush stdout
dws <- startDynWorkspaces fs dws <- startDynWorkspaces fs
io $ putStrLn "dyn workspace started"
-- io $ hFlush stdout
-- fb <- evalAlways $ fsFontBuilder features -- fb <- evalAlways $ fsFontBuilder features
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db) kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
io $ putStrLn "keys started"
-- io $ hFlush stdout
sk <- evalAlways $ fsShowKeys fs sk <- evalAlways $ fsShowKeys fs
io $ putStrLn "showkeys started"
-- io $ hFlush stdout
ha <- evalAlways $ fsACPIHandler fs ha <- evalAlways $ fsACPIHandler fs
io $ putStrLn "acpi handler started"
-- io $ hFlush stdout
return $ ewmh return $ ewmh
$ addKeymap dws sk kbs $ addKeymap dws sk kbs
$ docks $ docks
@ -207,9 +185,7 @@ evalConf db@DBusState { dbSysClient = cl } = do
io $ case h of io $ case h of
Just h' -> hSetBuffering h' LineBuffering Just h' -> hSetBuffering h' LineBuffering
Nothing -> return () Nothing -> return ()
--installSignalHandlers
ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs) ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
-- uninstallSignalHandlers
return (h, ThreadState (p:ps) $ maybeToList h) return (h, ThreadState (p:ps) $ maybeToList h)
startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
$ dbSysClient db $ dbSysClient db
@ -315,7 +291,7 @@ vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
[Subfeature root "windows 8 VM"] [Subfeature root "windows 8 VM"]
where where
root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
$ IOTest_ name [] $ vmExists vm $ IOTest_ name [] $ io $ vmExists vm
name = T.unwords ["test if", vm, "exists"] name = T.unwords ["test if", vm, "exists"]
c = "VirtualBoxVM" c = "VirtualBoxVM"
vm = "win8raw" vm = "win8raw"

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

@ -110,7 +110,7 @@ import Control.Monad.IO.Class
import Control.Monad.Identity import Control.Monad.Identity
import Control.Monad.Reader import Control.Monad.Reader
import Data.Aeson hiding (Error, Result) import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key import Data.Aeson.Key
import Data.Bifunctor import Data.Bifunctor
import Data.Either import Data.Either
@ -119,23 +119,23 @@ import Data.List
import Data.Maybe import Data.Maybe
import Data.Yaml import Data.Yaml
import GHC.IO.Exception (ioe_description) import GHC.IO.Exception (ioe_description)
import DBus hiding (typeOf) import DBus hiding (typeOf)
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import RIO hiding (bracket, fromString) import RIO hiding (bracket, fromString)
import RIO.FilePath import RIO.FilePath
import qualified RIO.Text as T import RIO.Process hiding (findExecutable)
import qualified RIO.Text as T
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.IO.Error import System.IO.Error
import System.Posix.Files import System.Posix.Files
import XMonad.Core (X, io) import XMonad.Core (X, io)
import XMonad.Internal.IO import XMonad.Internal.IO
import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.Internal.Theme import XMonad.Internal.Theme
@ -150,9 +150,10 @@ import XMonad.Internal.Theme
withCache :: FIO a -> IO a withCache :: FIO a -> IO a
withCache x = do withCache x = do
logOpts <- logOptionsHandle stderr False logOpts <- logOptionsHandle stderr False
pc <- mkDefaultProcessContext
withLogFunc logOpts $ \f -> do withLogFunc logOpts $ \f -> do
p <- getParams p <- getParams
let s = DepStage f p let s = DepStage f pc p
runRIO s x runRIO s x
-- | Execute an Always immediately -- | Execute an Always immediately
@ -315,7 +316,7 @@ data DBusDependency_ c = Bus [Fulfillment] BusName
-- | A dependency that only requires IO to evaluate (no payload) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
| IOTest_ T.Text [Fulfillment] (IO (Maybe Msg)) | IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a) | forall a. IOSometimes_ (Sometimes a)
-- | A system component to an IODependency -- | A system component to an IODependency
@ -385,13 +386,16 @@ data PostFail = PostFail [Msg] | PostMissing Msg
type FIO a = RIO DepStage a type FIO a = RIO DepStage a
data DepStage = DepStage data DepStage = DepStage
{ dsLogFun :: !LogFunc { dsLogFun :: !LogFunc
, dsParams :: !XParams , dsProcCxt :: !ProcessContext
, dsParams :: !XParams
} }
instance HasLogFunc DepStage where instance HasLogFunc DepStage where
logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y }) logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y })
instance HasProcessContext DepStage where
processContextL = lens dsProcCxt (\x y -> x { dsProcCxt = y })
data XParams = XParams data XParams = XParams
{ xpLogLevel :: LogLevel { xpLogLevel :: LogLevel
@ -645,27 +649,27 @@ testIODep_ :: IODependency_ -> FIO MResult_
testIODep_ d = memoizeMVar $ testIODepNoCache_ d testIODep_ d = memoizeMVar $ testIODepNoCache_ d
testIODepNoCache_ :: IODependency_ -> FIO Result_ testIODepNoCache_ :: IODependency_ -> FIO Result_
testIODepNoCache_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = io $ readResult_ <$> t testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd) testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
<$> evalSometimesMsg x <$> evalSometimesMsg x
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | System Dependency Testing -- | System Dependency Testing
testSysDependency :: SystemDependency -> IO (Maybe Msg) testSysDependency :: SystemDependency -> FIO (Maybe Msg)
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing) testSysDependency (Executable sys bin) = io $ maybe (Just msg) (const Nothing)
<$> findExecutable bin <$> findExecutable bin
where where
msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"] msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
e = if sys then "system" else "local" e = if sys then "system" else "local"
testSysDependency (Systemd t n) = shellTest cmd msg testSysDependency (Systemd t n) = shellTest "systemctl" args msg
where where
msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"] msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n] args = ["--user" | t == UserUnit] ++ ["status", n]
testSysDependency (Process n) = shellTest (fmtCmd "pidof" [n]) testSysDependency (Process n) = shellTest "pidof" [n]
$ T.unwords ["Process", singleQuote n, "not found"] $ T.unwords ["Process", singleQuote n, "not found"]
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
where where
testPerm False _ _ = Nothing testPerm False _ _ = Nothing
testPerm True f res = Just $ f res testPerm True f res = Just $ f res
@ -679,9 +683,9 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
(_, Just False) -> mkErr "file not writable" (_, Just False) -> mkErr "file not writable"
_ -> Nothing _ -> Nothing
shellTest :: T.Text -> T.Text -> IO (Maybe Msg) shellTest :: FilePath -> [T.Text] -> T.Text -> FIO (Maybe Msg)
shellTest cmd msg = do shellTest cmd args msg = do
(rc, _, _) <- readCreateProcessWithExitCode (shell $ T.unpack cmd) "" rc <- proc cmd (T.unpack <$> args) runProcess
return $ case rc of return $ case rc of
ExitSuccess -> Nothing ExitSuccess -> Nothing
_ -> Just $ Msg LevelError msg _ -> Just $ Msg LevelError msg
@ -722,19 +726,19 @@ fontDependency :: T.Text -> [Fulfillment] -> IODependency FontBuilder
fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam
fontDependency_ :: T.Text -> [Fulfillment] -> IODependency_ 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 :: T.Text -> T.Text
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"] fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
testFont :: T.Text -> FIO (Result FontBuilder) -- testFont :: T.Text -> FIO (Result FontBuilder)
testFont = liftIO . testFont' -- testFont = liftIO . testFont'
testFont' :: T.Text -> IO (Result FontBuilder) testFont :: T.Text -> FIO (Result FontBuilder)
testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg
where where
msg = T.unwords ["font family", qFam, "not found"] msg = T.unwords ["font family", qFam, "not found"]
cmd = fmtCmd "fc-list" ["-q", qFam] args = [qFam]
qFam = singleQuote fam qFam = singleQuote fam
pass = Right $ PostPass (buildFont $ Just fam) [] pass = Right $ PostPass (buildFont $ Just fam) []
@ -781,7 +785,7 @@ readInterface n f = IORead n [] go
socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_ socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_
socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
. socketExists' . io . socketExists'
socketExists' :: IO FilePath -> IO (Maybe Msg) socketExists' :: IO FilePath -> IO (Maybe Msg)
socketExists' getPath = do socketExists' getPath = do