diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 1afbe6d..e7b4358 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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 diff --git a/bin/xmonad.hs b/bin/xmonad.hs index f01daaa..4f9aa5f 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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" diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 9b7b563..e0b4a1c 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -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