ENH dump feature configuration

This commit is contained in:
Nathan Dwarshuis 2022-06-28 21:24:21 -04:00
parent caefbfc78a
commit 98a8da5168
2 changed files with 357 additions and 117 deletions

View File

@ -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

View File

@ -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]