ENH dump feature configuration
This commit is contained in:
parent
caefbfc78a
commit
98a8da5168
|
@ -119,32 +119,27 @@ run = do
|
||||||
forkIO_ = void . forkIO
|
forkIO_ = void . forkIO
|
||||||
|
|
||||||
printDeps :: IO ()
|
printDeps :: IO ()
|
||||||
printDeps = skip
|
printDeps = do
|
||||||
-- (i, x) <- allFeatures
|
ses <- getDBusClient False
|
||||||
-- mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
|
sys <- getDBusClient True
|
||||||
-- where
|
let db = DBusState ses sys
|
||||||
-- extractFeatures (Feature f _) = dtDeps $ ftrDepTree f
|
(i, f) <- allFeatures db
|
||||||
-- extractFeatures (Always _) = []
|
is <- mapM dumpSometimes i
|
||||||
-- dtDeps (GenTree _ ds) = ds
|
fs <- mapM dumpFeature f
|
||||||
-- dtDeps (DBusTree _ _ ds) = ds
|
let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs
|
||||||
-- printDep (FullDep d) = putStrLn . depName d
|
putStrLn u
|
||||||
|
forM_ ses disconnect
|
||||||
|
forM_ sys disconnect
|
||||||
|
|
||||||
-- allFeatures :: IO ([FeatureIO], [FeatureX])
|
allFeatures :: DBusState -> IO ([SometimesIO], [FeatureX])
|
||||||
-- allFeatures = do
|
allFeatures db = do
|
||||||
-- ses <- getDBusClient False
|
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
||||||
-- sys <- getDBusClient True
|
$ externalBindings ts db
|
||||||
-- let db = DBusState ses sys
|
let dbus = fmap (\f -> f $ dbSessionClient db) dbusExporters
|
||||||
-- lockRes <- evalFeature runScreenLock
|
let others = [runRemovableMon $ dbSystemClient db, runPowermon]
|
||||||
-- let lock = whenSatisfied lockRes
|
return (dbus ++ others, Left runScreenLock:bfs)
|
||||||
-- let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
where
|
||||||
-- $ externalBindings ts db lock
|
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
||||||
-- let dbus = fmap (\f -> f ses) dbusExporters
|
|
||||||
-- let others = [runRemovableMon sys, runPowermon]
|
|
||||||
-- forM_ ses disconnect
|
|
||||||
-- forM_ sys disconnect
|
|
||||||
-- return (dbus ++ others, bfs)
|
|
||||||
-- where
|
|
||||||
-- ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
|
||||||
|
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
usage = putStrLn $ intercalate "\n"
|
usage = putStrLn $ intercalate "\n"
|
||||||
|
@ -538,13 +533,13 @@ data KeyGroup a = KeyGroup
|
||||||
, kgBindings :: [KeyBinding a]
|
, kgBindings :: [KeyBinding a]
|
||||||
}
|
}
|
||||||
|
|
||||||
evalExternal :: [KeyGroup (FeatureX)] -> IO [KeyGroup MaybeX]
|
evalExternal :: [KeyGroup FeatureX] -> IO [KeyGroup MaybeX]
|
||||||
evalExternal = mapM go
|
evalExternal = mapM go
|
||||||
where
|
where
|
||||||
go k@KeyGroup { kgBindings = bs } =
|
go k@KeyGroup { kgBindings = bs } =
|
||||||
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
|
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
|
||||||
|
|
||||||
evalKeyBinding :: KeyBinding (FeatureX) -> IO (KeyBinding MaybeX)
|
evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
|
||||||
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
|
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
|
||||||
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
|
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for handling dependencies
|
-- | Functions for handling dependencies
|
||||||
|
@ -30,6 +31,15 @@ module XMonad.Internal.Dependency
|
||||||
, UnitType(..)
|
, UnitType(..)
|
||||||
, Result
|
, Result
|
||||||
|
|
||||||
|
-- dumping
|
||||||
|
, dumpFeature
|
||||||
|
, dumpAlways
|
||||||
|
, dumpSometimes
|
||||||
|
, jsonArray
|
||||||
|
, JSONQuotable(..)
|
||||||
|
, JSONUnquotable(..)
|
||||||
|
, JSONMixed(..)
|
||||||
|
|
||||||
-- testing
|
-- testing
|
||||||
, evalFeature
|
, evalFeature
|
||||||
, executeSometimes
|
, executeSometimes
|
||||||
|
@ -66,11 +76,9 @@ module XMonad.Internal.Dependency
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Identity
|
import Control.Monad.Identity
|
||||||
|
|
||||||
-- import Data.Aeson
|
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.List (find)
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
-- import qualified Data.Text as T
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
@ -123,13 +131,33 @@ evalAlways a = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature status
|
-- | Feature status
|
||||||
|
|
||||||
|
-- | Dump the status of a Feature
|
||||||
|
dumpFeature :: Feature a -> IO JSONUnquotable
|
||||||
|
dumpFeature = either dumpSometimes dumpAlways
|
||||||
|
|
||||||
-- | Dump the status of an Always to stdout
|
-- | Dump the status of an Always to stdout
|
||||||
-- dumpAlways :: MonadIO m => Always a -> m ()
|
dumpAlways :: Always a -> IO JSONUnquotable
|
||||||
-- dumpAlways = undefined
|
dumpAlways = go []
|
||||||
|
where
|
||||||
|
go failed (Option o os) = do
|
||||||
|
(s, r) <- dumpSubfeatureRoot o
|
||||||
|
if r
|
||||||
|
then return $ jsonAlways (Just s) failed $ untested [] os
|
||||||
|
else go (s:failed) os
|
||||||
|
go failed (Always _) = return $ jsonAlways (Just (UQ "true")) failed []
|
||||||
|
untested acc (Always _) = acc
|
||||||
|
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
|
||||||
|
|
||||||
-- | Dump the status of a Sometimes to stdout
|
-- | Dump the status of a Sometimes to stdout
|
||||||
-- dumpSometimes :: MonadIO m => Sometimes a -> m ()
|
dumpSometimes :: Sometimes a -> IO JSONUnquotable
|
||||||
-- dumpSometimes = undefined
|
dumpSometimes = go []
|
||||||
|
where
|
||||||
|
go failed [] = return $ jsonSometimes Nothing failed []
|
||||||
|
go failed (x:xs) = do
|
||||||
|
(s, r) <- dumpSubfeatureRoot x
|
||||||
|
if r
|
||||||
|
then return $ jsonSometimes (Just s) failed $ fmap dataSubfeatureRoot xs
|
||||||
|
else go (s:failed) xs
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Wrapper types
|
-- | Wrapper types
|
||||||
|
@ -201,12 +229,6 @@ data IODependency p = IORead String (IO (Result p))
|
||||||
| forall a. IOAlways (Always a) (a -> p)
|
| forall a. IOAlways (Always a) (a -> p)
|
||||||
| forall a. IOSometimes (Sometimes a) (a -> p)
|
| forall a. IOSometimes (Sometimes a) (a -> p)
|
||||||
|
|
||||||
-- | A dependency pertaining to the DBus
|
|
||||||
-- data DBusDependency p =
|
|
||||||
-- -- Bus BusName
|
|
||||||
-- -- | Endpoint BusName ObjectPath InterfaceName DBusMember
|
|
||||||
-- DBusIO (IODependency p)
|
|
||||||
|
|
||||||
-- | A dependency pertaining to the DBus
|
-- | A dependency pertaining to the DBus
|
||||||
data DBusDependency_ = Bus BusName
|
data DBusDependency_ = Bus BusName
|
||||||
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
||||||
|
@ -343,6 +365,10 @@ testTree test_ test = go
|
||||||
|
|
||||||
testIODependency :: IODependency p -> IO (Result p)
|
testIODependency :: IODependency p -> IO (Result p)
|
||||||
testIODependency (IORead _ t) = t
|
testIODependency (IORead _ t) = t
|
||||||
|
-- TODO this is a bit odd because this is a dependency that will always
|
||||||
|
-- succeed, which kinda makes this pointless. The only reason I would want this
|
||||||
|
-- is if I want to have a built-in logic to "choose" a payload to use in
|
||||||
|
-- building a higher-level feature
|
||||||
testIODependency (IOAlways a f) = Right . fmap f <$> evalAlwaysMsg a
|
testIODependency (IOAlways a f) = Right . fmap f <$> evalAlwaysMsg a
|
||||||
testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
|
testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
|
||||||
|
|
||||||
|
@ -363,12 +389,15 @@ testIODependency_ :: IODependency_ -> IO Result_
|
||||||
testIODependency_ (IOSystem_ s) = maybe (Right []) (Left . (:[])) <$> testSysDependency s
|
testIODependency_ (IOSystem_ s) = maybe (Right []) (Left . (:[])) <$> testSysDependency s
|
||||||
testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
|
testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | System Dependency Testing
|
||||||
|
|
||||||
testSysDependency :: SystemDependency -> IO (Maybe String)
|
testSysDependency :: SystemDependency -> IO (Maybe String)
|
||||||
testSysDependency (IOTest _ t) = t
|
testSysDependency (IOTest _ t) = t
|
||||||
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
||||||
<$> findExecutable bin
|
<$> findExecutable bin
|
||||||
where
|
where
|
||||||
msg = unwords [e, "executable", quote bin, "not found"]
|
msg = unwords [e, "executable", singleQuote bin, "not found"]
|
||||||
e = if sys then "system" else "local"
|
e = if sys then "system" else "local"
|
||||||
testSysDependency (Systemd t n) = do
|
testSysDependency (Systemd t n) = do
|
||||||
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
||||||
|
@ -377,8 +406,6 @@ testSysDependency (Systemd t n) = do
|
||||||
_ -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"
|
_ -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"
|
||||||
where
|
where
|
||||||
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
||||||
unitType SystemUnit = "system"
|
|
||||||
unitType UserUnit = "user"
|
|
||||||
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
||||||
where
|
where
|
||||||
testPerm False _ _ = Nothing
|
testPerm False _ _ = Nothing
|
||||||
|
@ -392,14 +419,28 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
||||||
(_, Just False) -> Just "file not writable"
|
(_, Just False) -> Just "file not writable"
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
|
unitType :: UnitType -> String
|
||||||
|
unitType SystemUnit = "system"
|
||||||
|
unitType UserUnit = "user"
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | DBus Dependency Testing
|
||||||
|
|
||||||
|
introspectInterface :: InterfaceName
|
||||||
|
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||||
|
|
||||||
|
introspectMethod :: MemberName
|
||||||
|
introspectMethod = memberName_ "Introspect"
|
||||||
|
|
||||||
testDBusDependency_ :: Client -> DBusDependency_ -> IO Result_
|
testDBusDependency_ :: Client -> DBusDependency_ -> IO Result_
|
||||||
testDBusDependency_ client (Bus bus) = do
|
testDBusDependency_ client (Bus bus) = do
|
||||||
ret <- callMethod client queryBus queryPath queryIface queryMem
|
ret <- callMethod client queryBus queryPath queryIface queryMem
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
Left e -> smryFail e
|
Left e -> Left [e]
|
||||||
Right b -> let ns = bodyGetNames b in
|
Right b -> let ns = bodyGetNames b in
|
||||||
if bus' `elem` ns then Right []
|
if bus' `elem` ns then Right []
|
||||||
else smryFail $ unwords ["name", singleQuote bus', "not found on dbus"]
|
else Left [unwords ["name", singleQuote bus', "not found on dbus"]]
|
||||||
where
|
where
|
||||||
bus' = formatBusName bus
|
bus' = formatBusName bus
|
||||||
queryBus = busName_ "org.freedesktop.DBus"
|
queryBus = busName_ "org.freedesktop.DBus"
|
||||||
|
@ -412,14 +453,14 @@ testDBusDependency_ client (Bus bus) = do
|
||||||
testDBusDependency_ client (Endpoint busname objpath iface mem) = do
|
testDBusDependency_ client (Endpoint busname objpath iface mem) = do
|
||||||
ret <- callMethod client busname objpath introspectInterface introspectMethod
|
ret <- callMethod client busname objpath introspectInterface introspectMethod
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
Left e -> smryFail e
|
Left e -> Left [e]
|
||||||
Right body -> procBody body
|
Right body -> procBody body
|
||||||
where
|
where
|
||||||
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
|
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
|
||||||
=<< listToMaybe body in
|
=<< listToMaybe body in
|
||||||
case res of
|
case res of
|
||||||
Just True -> Right []
|
Just True -> Right []
|
||||||
_ -> smryFail $ fmtMsg' mem
|
_ -> Left [fmtMsg' mem]
|
||||||
findMem = fmap (matchMem mem)
|
findMem = fmap (matchMem mem)
|
||||||
. find (\i -> I.interfaceName i == iface)
|
. find (\i -> I.interfaceName i == iface)
|
||||||
. I.objectInterfaces
|
. I.objectInterfaces
|
||||||
|
@ -442,7 +483,26 @@ testDBusDependency_ client (Endpoint busname objpath iface mem) = do
|
||||||
testDBusDependency_ _ (DBusIO i) = testIODependency_ i
|
testDBusDependency_ _ (DBusIO i) = testIODependency_ i
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Constructor functions
|
-- | IO Lifting functions
|
||||||
|
|
||||||
|
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
||||||
|
ioSometimes = fmap ioSubfeature
|
||||||
|
|
||||||
|
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
||||||
|
ioAlways (Always x) = Always $ io x
|
||||||
|
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
||||||
|
|
||||||
|
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||||
|
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
||||||
|
|
||||||
|
ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
|
||||||
|
ioRoot (IORoot a t) = IORoot (io . a) t
|
||||||
|
ioRoot (IORoot_ a t) = IORoot_ (io a) t
|
||||||
|
ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
|
||||||
|
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Feature constructors
|
||||||
|
|
||||||
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
|
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
|
||||||
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
||||||
|
@ -460,33 +520,27 @@ always1 = always1_ Error
|
||||||
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
|
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
|
||||||
sometimesIO n t x = sometimes1 n $ IORoot_ x t
|
sometimesIO n t x = sometimes1 n $ IORoot_ x t
|
||||||
|
|
||||||
|
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
|
||||||
|
sometimesExe n sys path = sometimesExeArgs n sys path []
|
||||||
|
|
||||||
|
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
|
||||||
|
sometimesExeArgs n sys path args =
|
||||||
|
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
||||||
|
|
||||||
sometimesDBus :: Maybe Client -> String -> Tree_ DBusDependency_
|
sometimesDBus :: Maybe Client -> String -> Tree_ DBusDependency_
|
||||||
-> (Client -> a) -> Sometimes a
|
-> (Client -> a) -> Sometimes a
|
||||||
sometimesDBus c n t x = sometimes1 n $ DBusRoot_ x t c
|
sometimesDBus c n t x = sometimes1 n $ DBusRoot_ x t c
|
||||||
|
|
||||||
|
sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
|
||||||
|
-> MemberName -> Maybe Client -> Sometimes (m ())
|
||||||
|
sometimesEndpoint name busname path iface mem client =
|
||||||
|
sometimesDBus client name deps cmd
|
||||||
|
where
|
||||||
|
deps = Only_ $ Endpoint busname path iface $ Method_ mem
|
||||||
|
cmd c = io $ void $ callMethod c busname path iface mem
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | IO Lifting functions
|
-- | Dependency Tree Constructors
|
||||||
|
|
||||||
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
|
||||||
ioSometimes = fmap ioSubfeature
|
|
||||||
|
|
||||||
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
|
||||||
ioAlways (Always x) = Always $ io x
|
|
||||||
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
|
||||||
|
|
||||||
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
|
||||||
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
|
||||||
|
|
||||||
-- data Msg = Msg LogLevel String String
|
|
||||||
|
|
||||||
ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
|
|
||||||
ioRoot (IORoot a t) = IORoot (io . a) t
|
|
||||||
ioRoot (IORoot_ a t) = IORoot_ (io a) t
|
|
||||||
ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
|
|
||||||
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
|
||||||
|
|
||||||
-- --------------------------------------------------------------------------------
|
|
||||||
-- | Dependency Tree
|
|
||||||
|
|
||||||
listToAnds :: d -> [d] -> Tree_ d
|
listToAnds :: d -> [d] -> Tree_ d
|
||||||
listToAnds i = foldr (And_ . Only_) (Only_ i)
|
listToAnds i = foldr (And_ . Only_) (Only_ i)
|
||||||
|
@ -494,18 +548,8 @@ listToAnds i = foldr (And_ . Only_) (Only_ i)
|
||||||
toAnd :: d -> d -> Tree_ d
|
toAnd :: d -> d -> Tree_ d
|
||||||
toAnd a b = And_ (Only_ a) (Only_ b)
|
toAnd a b = And_ (Only_ a) (Only_ b)
|
||||||
|
|
||||||
smryFail :: String -> Either [String] a
|
|
||||||
smryFail msg = Left [msg]
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | IO Dependency
|
-- | IO Dependency Constructors
|
||||||
|
|
||||||
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
|
|
||||||
sometimesExe n sys path = sometimesExeArgs n sys path []
|
|
||||||
|
|
||||||
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
|
|
||||||
sometimesExeArgs n sys path args =
|
|
||||||
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
|
||||||
|
|
||||||
exe :: Bool -> String -> IODependency_
|
exe :: Bool -> String -> IODependency_
|
||||||
exe b = IOSystem_ . Executable b
|
exe b = IOSystem_ . Executable b
|
||||||
|
@ -537,50 +581,250 @@ sysdSystem = sysd SystemUnit
|
||||||
sysTest :: String -> IO (Maybe String) -> IODependency_
|
sysTest :: String -> IO (Maybe String) -> IODependency_
|
||||||
sysTest n = IOSystem_ . IOTest n
|
sysTest n = IOSystem_ . IOTest n
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | DBus Dependency Result
|
|
||||||
|
|
||||||
introspectInterface :: InterfaceName
|
|
||||||
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
|
||||||
|
|
||||||
introspectMethod :: MemberName
|
|
||||||
introspectMethod = memberName_ "Introspect"
|
|
||||||
|
|
||||||
sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
|
|
||||||
-> MemberName -> Maybe Client -> Sometimes (m ())
|
|
||||||
sometimesEndpoint name busname path iface mem client =
|
|
||||||
sometimesDBus client name deps cmd
|
|
||||||
where
|
|
||||||
deps = Only_ $ Endpoint busname path iface $ Method_ mem
|
|
||||||
cmd c = io $ void $ callMethod c busname path iface mem
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | Dependency Testing
|
|
||||||
--
|
|
||||||
-- Here we test all dependencies and keep the tree structure so we can print it
|
|
||||||
-- for diagnostic purposes. This obviously has overlap with feature evaluation
|
|
||||||
-- since we need to resolve dependencies to build each feature.
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Printing
|
-- | Printing
|
||||||
|
|
||||||
-- printMsgs :: LogLevel -> [Msg] -> IO ()
|
dumpSubfeatureRoot :: SubfeatureRoot a -> IO (JSONUnquotable, Bool)
|
||||||
-- printMsgs lvl ms = do
|
dumpSubfeatureRoot Subfeature { sfData = r, sfName = n } =
|
||||||
-- pn <- getProgName
|
first (jsonSubfeature $ Q n) <$> dumpRoot r
|
||||||
-- mapM_ (printMsg pn lvl) ms
|
|
||||||
|
|
||||||
-- printMsg :: String -> LogLevel -> Msg -> IO ()
|
dumpRoot :: Root a -> IO (JSONUnquotable, Bool)
|
||||||
-- printMsg pname lvl (Msg ml mn msg)
|
dumpRoot (IORoot _ t) = first jsonIORoot <$>
|
||||||
-- | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
|
dumpTree testIODependency testIODependency_ dataIODependency dataIODependency_ t
|
||||||
-- | otherwise = skip
|
dumpRoot (IORoot_ _ t) = first jsonIORoot <$>
|
||||||
-- where
|
dumpTree_ testIODependency_ dataIODependency_ t
|
||||||
-- bracket s = "[" ++ s ++ "]"
|
dumpRoot (DBusRoot _ t (Just cl)) = first jsonDBusRoot <$>
|
||||||
|
dumpTree testIODependency (testDBusDependency_ cl) dataIODependency dataDBusDependency t
|
||||||
|
dumpRoot (DBusRoot_ _ t (Just cl)) = first jsonDBusRoot <$>
|
||||||
|
dumpTree_ (testDBusDependency_ cl) dataDBusDependency t
|
||||||
|
-- TODO somehow return a message here that these failed
|
||||||
|
dumpRoot (DBusRoot _ t Nothing) =
|
||||||
|
return (jsonDBusRoot $ dataTree dataIODependency dataDBusDependency t, False)
|
||||||
|
dumpRoot (DBusRoot_ _ t Nothing) =
|
||||||
|
return (jsonDBusRoot $ dataTree_ dataDBusDependency t, False)
|
||||||
|
|
||||||
|
dumpTree :: (d p -> IO (Result p)) -> (d_ -> IO Result_)
|
||||||
|
-> (d p -> DependencyData) -> (d_ -> DependencyData) -> Tree d d_ p
|
||||||
|
-> IO (JSONUnquotable, Bool)
|
||||||
|
dumpTree test test_ dd dd_ = go
|
||||||
|
where
|
||||||
|
go (And12 _ a b) = doAnd go go data' a b
|
||||||
|
go (And1 a b) = doAnd go dump_' (dataTree_ dd_) a b
|
||||||
|
go (And2 a b) = doAnd dump_' go data' a b
|
||||||
|
go (Or a b) = do
|
||||||
|
(sa, ra) <- go a
|
||||||
|
let j = jsonOr sa
|
||||||
|
if ra then return (j $ data' b, ra) else first j <$> go b
|
||||||
|
go (Only d) = do
|
||||||
|
r <- fromResult <$> test d
|
||||||
|
let (x, y) = dd d
|
||||||
|
return (jsonLeaf (Just r) x y, fst r)
|
||||||
|
dump_' = dumpTree_ test_ dd_
|
||||||
|
data' = dataTree dd dd_
|
||||||
|
doAnd fa fb fb_ a b = do
|
||||||
|
(sa, ra) <- fa a
|
||||||
|
let j = jsonAnd sa
|
||||||
|
if ra then first j <$> fb b else return (j $ fb_ b, ra)
|
||||||
|
|
||||||
|
dumpTree_ :: (d_ -> IO Result_) -> (d_ -> DependencyData) -> Tree_ d_
|
||||||
|
-> IO (JSONUnquotable, Bool)
|
||||||
|
dumpTree_ test_ dd_ = go
|
||||||
|
where
|
||||||
|
go (And_ a b) = do
|
||||||
|
(sa, ra) <- go a
|
||||||
|
let j = jsonAnd sa
|
||||||
|
if ra then first j <$> go b else return (j $ dataTree_ dd_ b, ra)
|
||||||
|
go (Or_ a b) = do
|
||||||
|
(sa, ra) <- go a
|
||||||
|
let j = jsonAnd sa
|
||||||
|
if ra then return (j $ dataTree_ dd_ b, ra) else first j <$> go b
|
||||||
|
go (Only_ d) = do
|
||||||
|
r <- fromResult_ <$> test_ d
|
||||||
|
let (x, y) = dd_ d
|
||||||
|
return (jsonLeaf (Just r) x y, fst r)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Dependency data for JSON
|
||||||
|
|
||||||
|
type DependencyData = (JSONQuotable, [(String, JSONMixed)])
|
||||||
|
|
||||||
|
dataSubfeatureRoot :: SubfeatureRoot a -> JSONUnquotable
|
||||||
|
dataSubfeatureRoot Subfeature { sfData = r, sfName = n } =
|
||||||
|
jsonSubfeature (Q n) $ dataRoot r
|
||||||
|
|
||||||
|
dataRoot :: Root a -> JSONUnquotable
|
||||||
|
dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t
|
||||||
|
dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t
|
||||||
|
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
|
||||||
|
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
|
||||||
|
|
||||||
|
dataTree :: (d p -> DependencyData) -> (d_ -> DependencyData) -> Tree d d_ p -> JSONUnquotable
|
||||||
|
dataTree f f_ = go
|
||||||
|
where
|
||||||
|
go (And12 _ a b) = jsonAnd (go a) (go b)
|
||||||
|
go (And1 a b) = jsonAnd (go a) (dataTree_ f_ b)
|
||||||
|
go (And2 a b) = jsonAnd (dataTree_ f_ a) (go b)
|
||||||
|
go (Or a b) = jsonOr (go a) (go b)
|
||||||
|
go (Only d) = uncurry jsonLeafUntested $ f d
|
||||||
|
|
||||||
|
dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> JSONUnquotable
|
||||||
|
dataTree_ f_ = go
|
||||||
|
where
|
||||||
|
go (And_ a b) = jsonAnd (go a) (go b)
|
||||||
|
go (Or_ a b) = jsonOr (go a) (go b)
|
||||||
|
go (Only_ d) = uncurry jsonLeafUntested $ f_ d
|
||||||
|
|
||||||
|
dataIODependency :: IODependency p -> DependencyData
|
||||||
|
dataIODependency d = case d of
|
||||||
|
(IORead n _) -> (Q "ioread", [("desc", JSON_Q $ Q n)])
|
||||||
|
-- TODO make this actually useful (I actually need to name my features)
|
||||||
|
(IOSometimes _ _) -> (Q "sometimes", [])
|
||||||
|
(IOAlways _ _) -> (Q "always", [])
|
||||||
|
|
||||||
|
dataIODependency_ :: IODependency_ -> DependencyData
|
||||||
|
dataIODependency_ d = case d of
|
||||||
|
(IOSystem_ s) -> dataSysDependency s
|
||||||
|
(IOSometimes_ _) -> (Q "sometimes", [])
|
||||||
|
|
||||||
|
dataSysDependency :: SystemDependency -> DependencyData
|
||||||
|
dataSysDependency d = do
|
||||||
|
case d of
|
||||||
|
(Executable sys path) -> (Q "executable", [ ("system", JSON_UQ $ jsonBool sys)
|
||||||
|
, ("path", JSON_Q $ Q path)
|
||||||
|
])
|
||||||
|
(IOTest desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)])
|
||||||
|
(AccessiblePath p r w) -> (Q "path", [ ("path", JSON_Q $ Q p)
|
||||||
|
, ("readable", JSON_UQ $ jsonBool r)
|
||||||
|
, ("writable", JSON_UQ $ jsonBool w)
|
||||||
|
])
|
||||||
|
(Systemd t n) -> (Q "systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
|
||||||
|
, ("unit", JSON_Q $ Q n)])
|
||||||
|
|
||||||
|
dataDBusDependency :: DBusDependency_ -> DependencyData
|
||||||
|
dataDBusDependency d =
|
||||||
|
case d of
|
||||||
|
(DBusIO i) -> dataIODependency_ i
|
||||||
|
(Bus b) -> (Q "bus", [("busname", JSON_Q $ Q $ formatBusName b)])
|
||||||
|
(Endpoint b o i m) -> let (mt, mn) = memberData m
|
||||||
|
in (Q "endpoint", [ ("busname", JSON_Q $ Q $ formatBusName b)
|
||||||
|
, ("objectpath", JSON_Q $ Q $ formatObjectPath o)
|
||||||
|
, ("interface", JSON_Q $ Q $ formatInterfaceName i)
|
||||||
|
, ("membertype", JSON_Q $ Q mt)
|
||||||
|
, ("membername", JSON_Q $ Q mn)
|
||||||
|
])
|
||||||
|
where
|
||||||
|
memberData (Method_ n) = ("method", formatMemberName n)
|
||||||
|
memberData (Signal_ n) = ("signal", formatMemberName n)
|
||||||
|
memberData (Property_ n) = ("property", n)
|
||||||
|
|
||||||
|
fromResult :: Result a -> (Bool, [JSONQuotable])
|
||||||
|
fromResult = second (fmap Q) . either (False,) (\(PostPass _ ws) -> (True, ws))
|
||||||
|
|
||||||
|
fromResult_ :: Result_ -> (Bool, [JSONQuotable])
|
||||||
|
fromResult_ = second (fmap Q) . either (False,) (True,)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | JSON formatting
|
||||||
|
--
|
||||||
|
-- I could use Aeson...but I don't feel like it (too many intermediate types)
|
||||||
|
|
||||||
|
newtype JSONQuotable = Q String
|
||||||
|
|
||||||
|
newtype JSONUnquotable = UQ String
|
||||||
|
|
||||||
|
data JSONMixed = JSON_UQ JSONUnquotable | JSON_Q JSONQuotable
|
||||||
|
|
||||||
|
jsonAlways :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
|
||||||
|
-> JSONUnquotable
|
||||||
|
jsonAlways = jsonFeature True
|
||||||
|
|
||||||
|
jsonSometimes :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
|
||||||
|
-> JSONUnquotable
|
||||||
|
jsonSometimes = jsonFeature False
|
||||||
|
|
||||||
|
jsonFeature :: Bool -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||||
|
-> [JSONUnquotable] -> JSONUnquotable
|
||||||
|
jsonFeature isalways success failed untested = jsonObject
|
||||||
|
[ ("type", JSON_Q $ Q $ if isalways then "always" else "sometimes")
|
||||||
|
, ("success", JSON_UQ $ fromMaybe (UQ "null") success)
|
||||||
|
, ("failed", JSON_UQ $ jsonArray $ fmap JSON_UQ failed)
|
||||||
|
, ("untested", JSON_UQ $ jsonArray $ fmap JSON_UQ untested)
|
||||||
|
]
|
||||||
|
|
||||||
|
jsonSubfeature :: JSONQuotable -> JSONUnquotable -> JSONUnquotable
|
||||||
|
jsonSubfeature n r = jsonObject
|
||||||
|
[ ("name", JSON_Q n)
|
||||||
|
, ("root", JSON_UQ r)
|
||||||
|
]
|
||||||
|
|
||||||
|
jsonIORoot :: JSONUnquotable -> JSONUnquotable
|
||||||
|
jsonIORoot = jsonRoot True
|
||||||
|
|
||||||
|
jsonDBusRoot :: JSONUnquotable -> JSONUnquotable
|
||||||
|
jsonDBusRoot = jsonRoot False
|
||||||
|
|
||||||
|
jsonRoot :: Bool -> JSONUnquotable -> JSONUnquotable
|
||||||
|
jsonRoot isIO tree = jsonObject
|
||||||
|
[ ("type", JSON_Q $ Q $ if isIO then "io" else "dbus")
|
||||||
|
, ("tree", JSON_UQ tree)
|
||||||
|
]
|
||||||
|
|
||||||
|
jsonLeafUntested :: JSONQuotable -> [(String, JSONMixed)] -> JSONUnquotable
|
||||||
|
jsonLeafUntested = jsonLeaf Nothing
|
||||||
|
|
||||||
|
jsonLeaf :: Maybe (Bool, [JSONQuotable]) -> JSONQuotable -> [(String, JSONMixed)]
|
||||||
|
-> JSONUnquotable
|
||||||
|
jsonLeaf status deptype depdata = jsonObject
|
||||||
|
[ ("type", JSON_Q deptype)
|
||||||
|
, ("status", jsonMaybe (JSON_UQ . uncurry jsonStatus) status)
|
||||||
|
, ("data", JSON_UQ $ jsonObject depdata)
|
||||||
|
]
|
||||||
|
|
||||||
|
jsonStatus :: Bool -> [JSONQuotable] -> JSONUnquotable
|
||||||
|
jsonStatus present messages = jsonObject
|
||||||
|
[ ("present", JSON_UQ $ jsonBool present)
|
||||||
|
, ("messages", JSON_UQ $ jsonArray $ fmap JSON_Q messages)
|
||||||
|
]
|
||||||
|
|
||||||
|
jsonAnd :: JSONUnquotable -> JSONUnquotable -> JSONUnquotable
|
||||||
|
jsonAnd = jsonBranch True
|
||||||
|
|
||||||
|
jsonOr :: JSONUnquotable -> JSONUnquotable -> JSONUnquotable
|
||||||
|
jsonOr = jsonBranch False
|
||||||
|
|
||||||
|
jsonBranch :: Bool -> JSONUnquotable -> JSONUnquotable -> JSONUnquotable
|
||||||
|
jsonBranch isAnd l r = jsonObject
|
||||||
|
[ ("test", JSON_Q $ Q $ if isAnd then "and" else "or")
|
||||||
|
, ("left", JSON_UQ l)
|
||||||
|
, ("right",JSON_UQ r)
|
||||||
|
]
|
||||||
|
|
||||||
|
jsonMaybe :: (a -> JSONMixed) -> Maybe a -> JSONMixed
|
||||||
|
jsonMaybe = maybe (JSON_UQ $ UQ "null")
|
||||||
|
|
||||||
|
jsonBool :: Bool -> JSONUnquotable
|
||||||
|
jsonBool True = UQ "true"
|
||||||
|
jsonBool False = UQ "false"
|
||||||
|
|
||||||
|
jsonArray :: [JSONMixed] -> JSONUnquotable
|
||||||
|
jsonArray = UQ . bracket . intercalate "," . fmap quoteMaybe
|
||||||
|
|
||||||
|
jsonObject :: [(String, JSONMixed)] -> JSONUnquotable
|
||||||
|
jsonObject = UQ . curly . intercalate ","
|
||||||
|
. fmap (\(k, v) -> doubleQuote k ++ ":" ++ quoteMaybe v)
|
||||||
|
|
||||||
|
quoteMaybe :: JSONMixed -> String
|
||||||
|
quoteMaybe (JSON_Q (Q s)) = doubleQuote s
|
||||||
|
quoteMaybe (JSON_UQ (UQ s)) = s
|
||||||
|
|
||||||
bracket :: String -> String
|
bracket :: String -> String
|
||||||
bracket s = "[" ++ s ++ "]"
|
bracket s = "[" ++ s ++ "]"
|
||||||
|
|
||||||
quote :: String -> String
|
curly :: String -> String
|
||||||
quote s = "'" ++ s ++ "'"
|
curly s = "{" ++ s ++ "}"
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Other random formatting
|
||||||
|
|
||||||
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
|
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
|
||||||
failedMsgs err = fmap concat . mapM (failedMsg err)
|
failedMsgs err = fmap concat . mapM (failedMsg err)
|
||||||
|
@ -594,3 +838,4 @@ fmtMsg err n msg = do
|
||||||
let e = if err then "ERROR" else "WARNING"
|
let e = if err then "ERROR" else "WARNING"
|
||||||
p <- getProgName
|
p <- getProgName
|
||||||
return $ unwords [bracket p, bracket e, bracket n, msg]
|
return $ unwords [bracket p, bracket e, bracket n, msg]
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue