ENH use rio process for deps
This commit is contained in:
parent
23956e063b
commit
6526f5e309
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue