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

View File

@ -214,14 +214,14 @@ 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
$ 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
networkManagerPkgs $ io vpnPresent
getBt :: Maybe SysClient -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd

View File

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

View File

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