xmonad-config/lib/XMonad/Internal/Dependency.hs

1105 lines
38 KiB
Haskell
Raw Normal View History

2022-07-01 23:15:44 -04:00
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
2022-07-01 23:15:44 -04:00
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
--------------------------------------------------------------------------------
-- | Functions for handling dependencies
module XMonad.Internal.Dependency
-- feature types
( Feature
, Always(..)
2022-06-28 23:27:55 -04:00
, Always_(..)
, FallbackRoot(..)
, FallbackStack(..)
2022-06-28 23:27:55 -04:00
, Sometimes(..)
, Sometimes_
, AlwaysX
, AlwaysIO
, SometimesX
, SometimesIO
, PostPass(..)
, Subfeature(..)
2022-06-26 19:27:04 -04:00
, SubfeatureRoot
, LogLevel(..)
-- dependency tree types
, Root(..)
, Tree(..)
, Tree_(..)
2022-07-02 17:09:21 -04:00
, IOTree
, IOTree_
, DBusTree
, DBusTree_
, IODependency(..)
, IODependency_(..)
, SystemDependency(..)
, DBusDependency_(..)
, DBusMember(..)
, UnitType(..)
, Result
2022-06-28 21:24:21 -04:00
-- dumping
, dumpFeature
, dumpAlways
, dumpSometimes
, jsonArray
, JSONQuotable(..)
, JSONUnquotable(..)
, JSONMixed(..)
-- testing
, FIO
, withCache
, evalFeature
, executeSometimes
, executeAlways
, evalAlways
, evalSometimes
, fontTreeAlt
, fontTree
, fontTree_
, fontAlways
, fontSometimes
-- lifting
, ioSometimes
, ioAlways
-- feature construction
, always1
, sometimes1
, sometimesIO
2022-07-02 17:09:21 -04:00
, sometimesIO_
, sometimesDBus
, sometimesExe
, sometimesExeArgs
, sometimesEndpoint
-- dependency construction
, sysExe
, localExe
, sysdSystem
, sysdUser
, listToAnds
, toAnd_
, toFallback
, pathR
, pathRW
, pathW
-- , sysTest
, voidResult
, voidRead
2022-07-03 18:23:32 -04:00
-- misc
, shellTest
) where
import Control.Monad.IO.Class
2021-11-22 23:02:23 -05:00
import Control.Monad.Identity
import Control.Monad.State
import Data.Bifunctor
import qualified Data.HashMap.Strict as H
import Data.Hashable
2022-06-28 21:24:21 -04:00
import Data.List
import Data.Maybe
2021-11-07 20:16:53 -05:00
import GHC.Generics (Generic)
import DBus hiding (typeOf)
2021-11-07 20:16:53 -05:00
import DBus.Client
import DBus.Internal
import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable)
import System.Environment
import System.Exit
import XMonad.Core (X, io)
import XMonad.Internal.IO
import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Internal.Theme
--------------------------------------------------------------------------------
-- | Feature Evaluation
--
-- Here we attempt to build and return the monadic actions encoded by each
-- feature.
-- | Run feature evaluation(s) with the cache
-- Currently there is no easy way to not use this (oh well)
withCache :: FIO a -> IO a
withCache x = evalStateT x emptyCache
-- | Execute an Always immediately
executeAlways :: Always (IO a) -> FIO a
executeAlways = io <=< evalAlways
-- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: Sometimes (IO a) -> FIO (Maybe a)
executeSometimes a = maybe (return Nothing) (io . fmap Just) =<< evalSometimes a
-- | Possibly return the action of an Always/Sometimes
evalFeature :: Feature a -> FIO (Maybe a)
evalFeature (Right a) = Just <$> evalAlways a
evalFeature (Left s) = evalSometimes s
-- | Possibly return the action of a Sometimes
evalSometimes :: Sometimes a -> FIO (Maybe a)
evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where
goPass (PostPass a ws) = putErrors ws >> return (Just a)
goFail es = putErrors es >> return Nothing
putErrors = io . mapM_ putStrLn
-- | Return the action of an Always
evalAlways :: Always a -> FIO a
evalAlways a = do
(PostPass x ws) <- evalAlwaysMsg a
io $ mapM_ putStrLn ws
return x
--------------------------------------------------------------------------------
-- | Feature status
2022-06-28 21:24:21 -04:00
-- | Dump the status of a Feature
dumpFeature :: Feature a -> FIO JSONUnquotable
2022-06-28 21:24:21 -04:00
dumpFeature = either dumpSometimes dumpAlways
-- | Dump the status of an Always to stdout
dumpAlways :: Always a -> FIO JSONUnquotable
2022-06-28 23:27:55 -04:00
dumpAlways (Always n x) = go [] x
2022-06-28 21:24:21 -04:00
where
go failed (Option o os) = do
(s, r) <- dumpSubfeatureRoot o
if r
2022-06-28 23:27:55 -04:00
then return $ jsonAlways (Q n) (Just s) failed $ untested [] os
2022-06-28 21:24:21 -04:00
else go (s:failed) os
2022-06-28 23:27:55 -04:00
go failed (Always_ _) = return $ jsonAlways (Q n) (Just (UQ "true")) failed []
untested acc (Always_ _) = acc
2022-06-28 21:24:21 -04:00
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
2021-11-21 10:26:28 -05:00
-- | Dump the status of a Sometimes to stdout
dumpSometimes :: Sometimes a -> FIO JSONUnquotable
2022-06-28 23:27:55 -04:00
dumpSometimes (Sometimes n a) = go [] a
2022-06-28 21:24:21 -04:00
where
2022-06-28 23:27:55 -04:00
go failed [] = return $ jsonSometimes (Q n) Nothing failed []
2022-06-28 21:24:21 -04:00
go failed (x:xs) = do
(s, r) <- dumpSubfeatureRoot x
if r
2022-06-28 23:27:55 -04:00
then return $ jsonSometimes (Q n) (Just s) failed $ fmap dataSubfeatureRoot xs
2022-06-28 21:24:21 -04:00
else go (s:failed) xs
2021-11-11 00:11:15 -05:00
--------------------------------------------------------------------------------
-- | Wrapper types
2021-11-20 01:15:04 -05:00
type AlwaysX = Always (X ())
type AlwaysIO = Always (IO ())
type SometimesX = Sometimes (X ())
type SometimesIO = Sometimes (IO ())
type Feature a = Either (Sometimes a) (Always a)
2021-11-22 23:46:51 -05:00
--------------------------------------------------------------------------------
-- | Feature declaration
-- | Feature that is guaranteed to work
-- This is composed of sub-features that are tested in order, and if all fail
-- the fallback is a monadic action (eg a plain haskell function)
2022-06-28 23:27:55 -04:00
data Always a = Always String (Always_ a)
-- | Feature that is guaranteed to work (inner data)
2022-07-02 17:09:21 -04:00
data Always_ a = Option (SubfeatureRoot a) (Always_ a)
| Always_ (FallbackRoot a)
-- | Root of a fallback action for an always
-- This may either be a lone action or a function that depends on the results
-- from other Always features.
2022-07-02 17:09:21 -04:00
data FallbackRoot a = FallbackAlone a
| forall p. FallbackTree (p -> a) (FallbackStack p)
-- | Always features that are used as a payload for a fallback action
data FallbackStack p = FallbackBottom (Always p)
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
-- | Feature that might not be present
-- This is like an Always except it doesn't fall back on a guaranteed monadic
-- action
2022-06-28 23:27:55 -04:00
data Sometimes a = Sometimes String (Sometimes_ a)
-- | Feature that might not be present (inner data)
type Sometimes_ a = [SubfeatureRoot a]
-- | Individually tested sub-feature data for Always/sometimes
-- The polymorphism allows representing tested and untested states. Includes
-- the 'action' itself to be tested and any auxilary data for describing the
-- sub-feature.
data Subfeature f = Subfeature
{ sfData :: f
, sfName :: String
, sfLevel :: LogLevel
}
type SubfeatureRoot a = Subfeature (Root a)
2021-11-22 23:46:51 -05:00
-- | Loglevel at which feature testing should be reported
-- This is currently not used for anything important
data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
-- | An action and its dependencies
-- May be a plain old monad or be DBus-dependent, in which case a client is
-- needed
2022-07-02 17:09:21 -04:00
data Root a = forall p. IORoot (p -> a) (IOTree p)
| IORoot_ a IOTree_
| forall p. DBusRoot (p -> Client -> a) (DBusTree p) (Maybe Client)
| DBusRoot_ (Client -> a) DBusTree_ (Maybe Client)
2022-07-02 17:09:21 -04:00
-- | The dependency tree with rule to merge results when needed
data Tree d d_ p =
2022-07-01 23:15:44 -04:00
forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
2022-06-26 20:48:26 -04:00
| And1 (Tree d d_ p) (Tree_ d_)
| And2 (Tree_ d_) (Tree d d_ p)
| Or (Tree d d_ p) (Tree d d_ p)
| Only (d p)
-- | A dependency tree without functions to merge results
2022-07-02 17:09:21 -04:00
data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
-- | Shorthand tree types for lazy typers
type IOTree p = Tree IODependency IODependency_ p
type DBusTree p = Tree IODependency DBusDependency_ p
type IOTree_ = Tree_ IODependency_
type DBusTree_ = Tree_ DBusDependency_
2022-07-03 18:23:32 -04:00
-- | A dependency that only requires IO to evaluate (with payload)
data IODependency p =
-- a cachable IO action that yields a payload
IORead String (FIO (Result p))
2022-07-03 18:23:32 -04:00
-- always yields a payload
| IOConst p
-- an always that yields a payload
| forall a. IOAlways (Always a) (a -> p)
2022-07-03 18:23:32 -04:00
-- a sometimes that yields a payload
| forall a. IOSometimes (Sometimes a) (a -> p)
-- | A dependency pertaining to the DBus
data DBusDependency_ = Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_
deriving (Eq, Generic)
instance Hashable DBusDependency_ where
hashWithSalt s (Bus b) = hashWithSalt s $ formatBusName b
hashWithSalt s (Endpoint b o i m) = s `hashWithSalt` formatBusName b
`hashWithSalt` formatObjectPath o
`hashWithSalt` formatInterfaceName i
`hashWithSalt` m
hashWithSalt s (DBusIO i) = hashWithSalt s i
2021-11-21 10:26:28 -05:00
-- | A dependency that only requires IO to evaluate (no payload)
2022-06-26 19:27:04 -04:00
data IODependency_ = IOSystem_ SystemDependency
| IOTest_ String (IO (Maybe String))
2022-06-26 19:27:04 -04:00
| forall a. IOSometimes_ (Sometimes a)
instance Eq IODependency_ where
(==) (IOSystem_ s0) (IOSystem_ s1) = s0 == s1
(==) (IOTest_ _ _) (IOTest_ _ _) = False
(==) (IOSometimes_ _) (IOSometimes_ _) = False
(==) _ _ = False
instance Hashable IODependency_ where
hashWithSalt s (IOSystem_ y) = hashWithSalt s y
hashWithSalt s (IOTest_ n _) = hashWithSalt s n
hashWithSalt s (IOSometimes_ (Sometimes n _)) = hashWithSalt s n
2022-07-03 18:23:32 -04:00
-- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious
data SystemDependency =
Executable Bool FilePath
2021-11-21 10:26:28 -05:00
| AccessiblePath FilePath Bool Bool
| Systemd UnitType String
deriving (Eq, Show, Generic)
instance Hashable SystemDependency
2021-11-21 10:26:28 -05:00
-- | The type of a systemd service
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
instance Hashable UnitType
2021-11-21 10:26:28 -05:00
-- | Wrapper type to describe and endpoint
2021-11-22 23:46:51 -05:00
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show, Generic)
instance Hashable DBusMember where
hashWithSalt s (Method_ m) = hashWithSalt s $ formatMemberName m
hashWithSalt s (Signal_ m) = hashWithSalt s $ formatMemberName m
hashWithSalt s (Property_ p) = hashWithSalt s p
2021-11-22 23:46:51 -05:00
--------------------------------------------------------------------------------
-- | Tested dependency tree
2021-11-21 10:26:28 -05:00
--
-- The main reason I need this is so I have a "result" I can convert to JSON
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
-- | Tested Always feature
2022-06-28 23:27:55 -04:00
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
| Fallback a [SubfeatureFail]
-- | Tested Sometimes feature
data PostSometimes a = PostSometimes
{ psSuccess :: Maybe (SubfeaturePass a)
, psFailed :: [SubfeatureFail]
}
-- | Passing subfeature
type SubfeaturePass a = Subfeature (PostPass a)
-- | Failed subfeature
type SubfeatureFail = Subfeature PostFail
-- | An action that passed
data PostPass a = PostPass a [String] deriving (Functor)
addMsgs :: PostPass a -> [String] -> PostPass a
addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
-- | An action that failed
data PostFail = PostFail [String] | PostMissing String
--------------------------------------------------------------------------------
-- | Evaluation cache
--
-- Setting up trees like this usually entails having some repeated dependencies.
-- Testing the same dependency multiple times is stupid, so cache the results.
-- Note this is basically memorization, except that the results are IO-dependent
-- and this may technically change with each invocation. The assumption here is
-- that each repeated test without caching would be run in such close succession
-- that the results will always be the same.
type FIO a = StateT Cache IO a
data Cache = Cache
{ --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
cIO_ :: H.HashMap IODependency_ Result_
, cDBus_ :: H.HashMap DBusDependency_ Result_
, cFont :: H.HashMap String (Result FontBuilder)
}
-- class Memoizable a
-- cache :: a ->
emptyCache :: Cache
emptyCache = Cache H.empty H.empty H.empty
memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_
memoizeIO_ f d = do
m <- gets cIO_
case H.lookup d m of
(Just r) -> return r
Nothing -> do
-- io $ putStrLn $ "not using cache for " ++ show d
r <- f d
modify (\s -> s { cIO_ = H.insert d r (cIO_ s) })
return r
memoizeDBus_ :: (DBusDependency_ -> FIO Result_) -> DBusDependency_ -> FIO Result_
memoizeDBus_ f d = do
m <- gets cDBus_
case H.lookup d m of
(Just r) -> return r
Nothing -> do
-- io $ putStrLn $ "not using cache for " ++ show d
r <- f d
modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) })
return r
memoizeFont :: (String -> IO (Result FontBuilder)) -> String -> FIO (Result FontBuilder)
memoizeFont f d = do
m <- gets cFont
case H.lookup d m of
(Just r) -> return r
Nothing -> do
-- io $ putStrLn $ "not using cache for " ++ show d
r <- io $ f d
modify (\s -> s { cFont = H.insert d r (cFont s) })
return r
--------------------------------------------------------------------------------
-- | Testing pipeline
evalSometimesMsg :: Sometimes a -> FIO (Result a)
evalSometimesMsg (Sometimes n xs) = do
2022-06-28 23:27:55 -04:00
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
case s of
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgsIO False n fs
_ -> Left <$> failedMsgsIO True n fs
evalAlwaysMsg :: Always a -> FIO (PostPass a)
evalAlwaysMsg (Always n x) = do
r <- testAlways x
case r of
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgsIO False n fs
(Fallback act fs) -> PostPass act <$> failedMsgsIO False n fs
testAlways :: Always_ a -> FIO (PostAlways a)
testAlways = go []
where
go failed (Option fd next) = do
r <- testSubfeature fd
case r of
(Left l) -> go (l:failed) next
(Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
evalFallbackRoot :: FallbackRoot a -> FIO a
evalFallbackRoot (FallbackAlone a) = return a
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
evalFallbackStack :: FallbackStack p -> FIO p
evalFallbackStack (FallbackBottom a) = evalAlways a
evalFallbackStack (FallbackStack f a as) = do
ps <- evalFallbackStack as
p <- evalAlways a
return $ f p ps
testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing [])
where
go ts [] = return ts
go ts (x:xs) = do
sf <- testSubfeature x
case sf of
(Left l) -> go (ts { psFailed = l:psFailed ts }) xs
(Right pass) -> return $ ts { psSuccess = Just pass }
testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
testSubfeature sf@Subfeature{ sfData = t } = do
t' <- testRoot t
-- monomorphism restriction :(
return $ bimap (\n -> sf { sfData = n }) (\n -> sf { sfData = n }) t'
testRoot :: Root a -> FIO (Either PostFail (PostPass a))
testRoot r = do
case r of
(IORoot a t) -> go a testIODependency_ testIODependency t
(IORoot_ a t) -> go_ a testIODependency_ t
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDependency_ cl) testIODependency t
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t
_ -> return $ Left $ PostMissing "client not available"
where
2022-07-01 23:15:44 -04:00
-- rank N polymorphism is apparently undecidable...gross
go a f_ (f :: forall q. d q -> FIO (Result q)) t =
2022-07-01 23:15:44 -04:00
bimap PostFail (fmap a) <$> testTree f_ f t
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
--------------------------------------------------------------------------------
-- | Payloaded dependency testing
type Result p = Either [String] (PostPass p)
testTree :: forall d d_ p. (d_ -> FIO Result_) -> (forall q. d q -> FIO (Result q))
-> Tree d d_ p -> FIO (Either [String] (PostPass p))
testTree test_ test = go
where
go :: forall q. Tree d d_ q -> FIO (Either [String] (PostPass q))
2022-06-26 20:48:26 -04:00
go (And12 f a b) = do
ra <- go a
2022-06-26 20:48:26 -04:00
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
go (And1 a b) = do
ra <- go a
liftRight (\p -> fmap (addMsgs p) <$> testTree_ test_ b) ra
go (And2 a b) = do
ra <- testTree_ test_ a
2022-06-26 20:48:26 -04:00
liftRight (\wa -> fmap (`addMsgs` wa) <$> go b) ra
go (Or a b) = do
ra <- go a
2022-06-26 20:48:26 -04:00
either (\ea -> fmap (`addMsgs` ea) <$> go b) (return . Right) ra
go (Only a) = test a
and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
2022-06-26 20:48:26 -04:00
liftRight = either (return . Left)
testIODependency :: IODependency p -> FIO (Result p)
testIODependency (IORead _ t) = t
2022-07-03 18:23:32 -04:00
testIODependency (IOConst c) = return $ Right $ PostPass c []
2022-06-28 21:24:21 -04:00
-- 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 (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
--------------------------------------------------------------------------------
-- | Standalone dependency testing
type Result_ = Either [String] [String]
testTree_ :: (d -> FIO Result_) -> Tree_ d -> FIO (Either [String] [String])
testTree_ test = go
where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a
go (Only_ a) = test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODependency_ :: IODependency_ -> FIO Result_
testIODependency_ = memoizeIO_ testIODependency'_
testIODependency'_ :: IODependency_ -> FIO Result_
testIODependency'_ (IOSystem_ s) = io $ readResult_ <$> testSysDependency s
testIODependency'_ (IOTest_ _ t) = io $ readResult_ <$> t
testIODependency'_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
-- | System Dependency Testing
testSysDependency :: SystemDependency -> IO (Maybe String)
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
<$> findExecutable bin
where
2022-06-28 21:24:21 -04:00
msg = unwords [e, "executable", singleQuote bin, "not found"]
e = if sys then "system" else "local"
2022-07-02 17:09:21 -04:00
testSysDependency (Systemd t n) = shellTest cmd msg
where
2022-07-02 17:09:21 -04:00
msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
where
testPerm False _ _ = Nothing
testPerm True f res = Just $ f res
permMsg NotFoundError = Just "file not found"
permMsg PermError = Just "could not get permissions"
permMsg (PermResult res) =
case (testPerm r readable res, testPerm w writable res) of
(Just False, Just False) -> Just "file not readable or writable"
(Just False, _) -> Just "file not readable"
(_, Just False) -> Just "file not writable"
_ -> Nothing
2022-07-02 17:09:21 -04:00
shellTest :: String -> String -> IO (Maybe String)
shellTest cmd msg = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Nothing
_ -> Just msg
2022-06-28 21:24:21 -04:00
unitType :: UnitType -> String
unitType SystemUnit = "system"
unitType UserUnit = "user"
--------------------------------------------------------------------------------
-- | IO testers
--
-- Make a special case for these since we end up testing the font alot, and it
-- would be nice if I can cache them.
fontAlways :: String -> String -> Always FontBuilder
fontAlways n fam = always1 n (fontFeatureName fam) root fallbackFont
where
root = IORoot id $ fontTree fam
fontSometimes :: String -> String -> Sometimes FontBuilder
fontSometimes n fam = sometimes1 n (fontFeatureName fam) root
where
root = IORoot id $ fontTree fam
fontFeatureName :: String -> String
fontFeatureName n = unwords ["Font family for", singleQuote n]
fontTreeAlt :: String -> Tree IODependency d_ FontBuilder
fontTreeAlt fam = Or (fontTree fam) $ Only $ IOConst fallbackFont
fontTree :: String -> Tree IODependency d_ FontBuilder
fontTree = Only . fontDependency
fontTree_ :: String -> IOTree_
fontTree_ = Only_ . fontDependency_
fontDependency :: String -> IODependency FontBuilder
fontDependency fam = IORead (fontTestName fam) $ testFont fam
fontDependency_ :: String -> IODependency_
fontDependency_ fam = IOTest_ (fontTestName fam) $ voidRead <$> testFont' fam
fontTestName :: String -> String
fontTestName fam = unwords ["test if font", singleQuote fam, "exists"]
testFont :: String -> FIO (Result FontBuilder)
testFont = memoizeFont testFont'
testFont' :: String -> IO (Result FontBuilder)
testFont' fam = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Right $ PostPass (buildFont $ Just fam) []
_ -> Left [msg]
where
msg = unwords ["font family", qFam, "not found"]
cmd = fmtCmd "fc-list" ["-q", qFam]
qFam = singleQuote fam
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
-- | DBus Dependency Testing
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl)
testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency'_ client (Bus bus) = io $ do
2021-11-21 17:54:00 -05:00
ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of
2022-06-28 21:24:21 -04:00
Left e -> Left [e]
Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Right []
2022-06-28 21:24:21 -04:00
else Left [unwords ["name", singleQuote bus', "not found on dbus"]]
2021-11-07 20:16:53 -05:00
where
bus' = formatBusName bus
queryBus = busName_ "org.freedesktop.DBus"
queryIface = interfaceName_ "org.freedesktop.DBus"
queryPath = objectPath_ "/"
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = []
testDBusDependency'_ client (Endpoint busname objpath iface mem) = io $ do
ret <- callMethod client busname objpath introspectInterface introspectMethod
return $ case ret of
2022-06-28 21:24:21 -04:00
Left e -> Left [e]
Right body -> procBody body
where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in
case res of
Just True -> Right []
2022-06-28 21:24:21 -04:00
_ -> Left [fmtMsg' mem]
findMem = fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface)
. I.objectInterfaces
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals
matchMem (Property_ n) = elemMember n I.propertyName I.interfaceProperties
elemMember n fname fmember = elem n . fmap fname . fmember
fmtMem (Method_ n) = "method " ++ singleQuote (formatMemberName n)
fmtMem (Signal_ n) = "signal " ++ singleQuote (formatMemberName n)
fmtMem (Property_ n) = "property " ++ singleQuote n
fmtMsg' m = unwords
[ "could not find"
, fmtMem m
, "on interface"
, singleQuote $ formatInterfaceName iface
, "on bus"
, formatBusName busname
]
testDBusDependency'_ _ (DBusIO i) = testIODependency_ i
--------------------------------------------------------------------------------
2022-06-28 21:24:21 -04:00
-- | IO Lifting functions
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
2022-06-28 23:27:55 -04:00
ioSometimes (Sometimes n xs) = Sometimes n $ fmap ioSubfeature xs
2022-06-28 21:24:21 -04:00
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
2022-06-28 23:27:55 -04:00
ioAlways (Always n x) = Always n $ ioAlways' x
ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a)
ioAlways' (Always_ ar) = Always_ $ ioFallbackRoot ar
2022-06-28 23:27:55 -04:00
ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a
2022-06-28 21:24:21 -04:00
ioFallbackRoot :: MonadIO m => FallbackRoot (IO a) -> FallbackRoot (m a)
ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a
ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s
2022-06-28 21:24:21 -04:00
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
2022-06-28 23:27:55 -04:00
sometimes1_ :: LogLevel -> String -> String -> Root a -> Sometimes a
sometimes1_ l fn n t = Sometimes fn
[Subfeature{ sfData = t, sfName = n, sfLevel = l }]
2022-06-28 23:27:55 -04:00
always1_ :: LogLevel -> String -> String -> Root a -> a -> Always a
always1_ l fn n t x = Always fn
$ Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always_ $ FallbackAlone x)
2022-06-28 23:27:55 -04:00
sometimes1 :: String -> String -> Root a -> Sometimes a
sometimes1 = sometimes1_ Error
2022-06-28 23:27:55 -04:00
always1 :: String -> String -> Root a -> a -> Always a
always1 = always1_ Error
2022-07-02 17:09:21 -04:00
sometimesIO_ :: String -> String -> IOTree_ -> a -> Sometimes a
sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
sometimesIO :: String -> String -> IOTree p -> (p -> a) -> Sometimes a
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
2022-06-28 23:27:55 -04:00
sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ())
sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
2022-06-28 21:24:21 -04:00
2022-06-28 23:27:55 -04:00
sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath
-> [String] -> Sometimes (m ())
sometimesExeArgs fn n sys path args =
2022-07-02 17:09:21 -04:00
sometimesIO_ fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
2022-06-28 21:24:21 -04:00
2022-06-28 23:27:55 -04:00
sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
-> (Client -> a) -> Sometimes a
2022-06-28 23:27:55 -04:00
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
2022-06-28 23:27:55 -04:00
sometimesEndpoint :: MonadIO m => String -> String -> BusName -> ObjectPath -> InterfaceName
2022-06-28 21:24:21 -04:00
-> MemberName -> Maybe Client -> Sometimes (m ())
2022-06-28 23:27:55 -04:00
sometimesEndpoint fn name busname path iface mem client =
sometimesDBus client fn name deps cmd
2022-06-28 21:24:21 -04:00
where
deps = Only_ $ Endpoint busname path iface $ Method_ mem
cmd c = io $ void $ callMethod c busname path iface mem
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
-- | Dependency Tree Constructors
listToAnds :: d -> [d] -> Tree_ d
listToAnds i = foldr (And_ . Only_) (Only_ i)
toAnd_ :: d -> d -> Tree_ d
toAnd_ a b = And_ (Only_ a) (Only_ b)
toFallback :: IODependency p -> p -> Tree IODependency d_ p
toFallback a = Or (Only a) . Only . IOConst
voidResult :: Result p -> Result_
voidResult (Left es) = Left es
voidResult (Right (PostPass _ ws)) = Right ws
voidRead :: Result p -> Maybe String
voidRead (Left []) = Just "unspecified error"
voidRead (Left (e:_)) = Just e
voidRead (Right _) = Nothing
readResult_ :: Maybe String -> Result_
readResult_ (Just w) = Left [w]
readResult_ _ = Right []
--------------------------------------------------------------------------------
2022-06-28 21:24:21 -04:00
-- | IO Dependency Constructors
exe :: Bool -> String -> IODependency_
exe b = IOSystem_ . Executable b
sysExe :: String -> IODependency_
sysExe = exe True
localExe :: String -> IODependency_
localExe = exe False
pathR :: String -> IODependency_
pathR n = IOSystem_ $ AccessiblePath n True False
pathW :: String -> IODependency_
pathW n = IOSystem_ $ AccessiblePath n False True
pathRW :: String -> IODependency_
pathRW n = IOSystem_ $ AccessiblePath n True True
sysd :: UnitType -> String -> IODependency_
sysd u = IOSystem_ . Systemd u
sysdUser :: String -> IODependency_
sysdUser = sysd UserUnit
sysdSystem :: String -> IODependency_
sysdSystem = sysd SystemUnit
-- sysTest :: String -> IO (Maybe String) -> IODependency_
-- sysTest n = IOSystem_ . IOTest n
--------------------------------------------------------------------------------
2022-06-28 21:24:21 -04:00
-- | Printing
dumpSubfeatureRoot :: SubfeatureRoot a -> FIO (JSONUnquotable, Bool)
2022-06-28 21:24:21 -04:00
dumpSubfeatureRoot Subfeature { sfData = r, sfName = n } =
first (jsonSubfeature $ Q n) <$> dumpRoot r
dumpRoot :: Root a -> FIO (JSONUnquotable, Bool)
2022-06-28 21:24:21 -04:00
dumpRoot (IORoot _ t) = first jsonIORoot <$>
dumpTree testIODependency testIODependency_ dataIODependency dataIODependency_ t
dumpRoot (IORoot_ _ t) = first jsonIORoot <$>
dumpTree_ testIODependency_ dataIODependency_ t
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 :: forall d d_ p. (forall q. d q -> FIO (Result q))
-> (d_ -> FIO Result_) -> (forall q. d q -> DependencyData)
-> (d_ -> DependencyData) -> Tree d d_ p -> FIO (JSONUnquotable, Bool)
2022-06-28 21:24:21 -04:00
dumpTree test test_ dd dd_ = go
where
go :: forall q. Tree d d_ q -> FIO (JSONUnquotable, Bool)
2022-06-28 21:24:21 -04:00
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)
2022-07-01 23:15:44 -04:00
data' :: forall q. Tree d d_ q -> JSONUnquotable
2022-06-28 21:24:21 -04:00
data' = dataTree dd dd_
2022-07-01 23:15:44 -04:00
dump_' = dumpTree_ test_ dd_
2022-06-28 21:24:21 -04:00
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_ -> FIO Result_) -> (d_ -> DependencyData) -> Tree_ d_
-> FIO (JSONUnquotable, Bool)
2022-06-28 21:24:21 -04:00
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)
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
-- | Dependency data for JSON
2022-06-28 21:24:21 -04:00
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
2022-07-01 23:15:44 -04:00
dataTree :: forall d d_ p. (forall q. d q -> DependencyData)
-> (d_ -> DependencyData) -> Tree d d_ p -> JSONUnquotable
2022-06-28 21:24:21 -04:00
dataTree f f_ = go
where
2022-07-01 23:15:44 -04:00
go :: forall q. Tree d d_ q -> JSONUnquotable
2022-06-28 21:24:21 -04:00
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
2022-07-02 17:09:21 -04:00
dataIODependency d = first Q $ case d of
2022-07-03 18:23:32 -04:00
(IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)])
(IOConst _) -> ("const", [])
(IOSometimes (Sometimes n _) _) -> ("sometimes", [("name", JSON_Q $ Q n)])
(IOAlways (Always n _) _) -> ("always", [("name", JSON_Q $ Q n)])
2022-06-28 21:24:21 -04:00
dataIODependency_ :: IODependency_ -> DependencyData
dataIODependency_ d = case d of
(IOSystem_ s) -> dataSysDependency s
(IOSometimes_ _) -> (Q "sometimes", [])
(IOTest_ desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)])
2022-06-28 21:24:21 -04:00
dataSysDependency :: SystemDependency -> DependencyData
2022-07-02 17:09:21 -04:00
dataSysDependency d = first Q $
2022-06-28 21:24:21 -04:00
case d of
2022-07-02 17:09:21 -04:00
(Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys)
2022-06-28 21:24:21 -04:00
, ("path", JSON_Q $ Q path)
])
2022-07-02 17:09:21 -04:00
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
, ("readable", JSON_UQ $ jsonBool r)
, ("writable", JSON_UQ $ jsonBool w)
])
(Systemd t n) -> ("systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
, ("unit", JSON_Q $ Q n)])
2022-06-28 21:24:21 -04:00
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,)
--------------------------------------------------------------------------------
2022-06-28 21:24:21 -04:00
-- | JSON formatting
--
2022-06-28 21:24:21 -04:00
-- I could use Aeson...but I don't feel like it (too many intermediate types)
2022-06-28 21:24:21 -04:00
newtype JSONQuotable = Q String
newtype JSONUnquotable = UQ String
data JSONMixed = JSON_UQ JSONUnquotable | JSON_Q JSONQuotable
2022-06-28 23:27:55 -04:00
jsonAlways :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> [JSONUnquotable] -> JSONUnquotable
2022-06-28 21:24:21 -04:00
jsonAlways = jsonFeature True
2022-06-28 23:27:55 -04:00
jsonSometimes :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> [JSONUnquotable] -> JSONUnquotable
2022-06-28 21:24:21 -04:00
jsonSometimes = jsonFeature False
2022-06-28 23:27:55 -04:00
jsonFeature :: Bool -> JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
2022-06-28 21:24:21 -04:00
-> [JSONUnquotable] -> JSONUnquotable
2022-06-28 23:27:55 -04:00
jsonFeature isalways name success failed untested = jsonObject
2022-06-28 21:24:21 -04:00
[ ("type", JSON_Q $ Q $ if isalways then "always" else "sometimes")
2022-06-28 23:27:55 -04:00
, ("name", JSON_Q name)
2022-06-28 21:24:21 -04:00
, ("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)
]
2022-06-28 21:24:21 -04:00
jsonIORoot :: JSONUnquotable -> JSONUnquotable
jsonIORoot = jsonRoot True
2022-06-28 21:24:21 -04:00
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 s = "[" ++ s ++ "]"
2022-06-28 21:24:21 -04:00
curly :: String -> String
curly s = "{" ++ s ++ "}"
--------------------------------------------------------------------------------
-- | Other random formatting
failedMsgsIO :: Bool -> String -> [SubfeatureFail] -> FIO [String]
failedMsgsIO err fn = io . failedMsgs err fn
2022-06-28 23:27:55 -04:00
failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String]
failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
2022-06-28 23:27:55 -04:00
failedMsg :: Bool -> String -> SubfeatureFail -> IO [String]
failedMsg err fn Subfeature { sfData = d, sfName = n } = do
mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
2022-06-28 23:27:55 -04:00
fmtMsg :: Bool -> String -> String -> String -> IO String
fmtMsg err fn n msg = do
let e = if err then "ERROR" else "WARNING"
p <- getProgName
2022-06-28 23:27:55 -04:00
return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]
2022-06-28 21:24:21 -04:00