2022-06-26 19:05:25 -04:00
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
2022-06-21 00:56:42 -04:00
|
|
|
{-# LANGUAGE GADTs #-}
|
2021-11-21 22:47:43 -05:00
|
|
|
|
2021-11-07 13:35:08 -05:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Functions for handling dependencies
|
|
|
|
|
|
|
|
module XMonad.Internal.Dependency
|
2022-06-26 19:05:25 -04:00
|
|
|
-- feature types
|
|
|
|
( Feature
|
2022-06-21 00:56:42 -04:00
|
|
|
, Always(..)
|
2022-06-26 19:05:25 -04:00
|
|
|
, Sometimes
|
|
|
|
, AlwaysX
|
|
|
|
, AlwaysIO
|
2022-06-21 00:56:42 -04:00
|
|
|
, SometimesX
|
|
|
|
, SometimesIO
|
2022-06-26 19:05:25 -04:00
|
|
|
, PostPass(..)
|
|
|
|
, Subfeature(..)
|
|
|
|
, LogLevel(..)
|
|
|
|
|
|
|
|
-- dependency tree types
|
|
|
|
, Root(..)
|
|
|
|
, Tree(..)
|
|
|
|
, Tree_(..)
|
|
|
|
, IODependency(..)
|
|
|
|
, IODependency_(..)
|
|
|
|
, SystemDependency(..)
|
|
|
|
, DBusDependency_(..)
|
|
|
|
, DBusMember(..)
|
|
|
|
, UnitType(..)
|
|
|
|
, Result
|
|
|
|
|
|
|
|
-- testing
|
2022-06-22 01:28:46 -04:00
|
|
|
, evalFeature
|
2022-06-21 00:56:42 -04:00
|
|
|
, executeSometimes
|
|
|
|
, executeAlways
|
|
|
|
, evalAlways
|
|
|
|
, evalSometimes
|
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- lifting
|
|
|
|
, ioSometimes
|
|
|
|
, ioAlways
|
2022-06-21 00:56:42 -04:00
|
|
|
|
|
|
|
-- feature construction
|
|
|
|
, sometimes1
|
|
|
|
, sometimesIO
|
|
|
|
, sometimesDBus
|
|
|
|
, sometimesExe
|
|
|
|
, sometimesExeArgs
|
|
|
|
, sometimesEndpoint
|
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- dependency construction
|
|
|
|
, sysExe
|
|
|
|
, localExe
|
|
|
|
, sysdSystem
|
|
|
|
, sysdUser
|
2022-06-21 00:56:42 -04:00
|
|
|
, listToAnds
|
|
|
|
, toAnd
|
2021-11-07 18:41:25 -05:00
|
|
|
, pathR
|
|
|
|
, pathRW
|
2022-06-21 00:56:42 -04:00
|
|
|
, pathW
|
2022-06-26 19:05:25 -04:00
|
|
|
, sysTest
|
2021-11-07 13:35:08 -05:00
|
|
|
) where
|
|
|
|
|
|
|
|
import Control.Monad.IO.Class
|
2021-11-22 23:02:23 -05:00
|
|
|
import Control.Monad.Identity
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2022-06-16 18:50:24 -04:00
|
|
|
-- import Data.Aeson
|
2022-06-21 00:56:42 -04:00
|
|
|
import Data.Bifunctor
|
2021-11-27 01:02:22 -05:00
|
|
|
import Data.List (find)
|
2022-06-17 00:37:12 -04:00
|
|
|
import Data.Maybe
|
2022-06-16 18:50:24 -04:00
|
|
|
-- import qualified Data.Text as T
|
2021-11-07 20:16:53 -05:00
|
|
|
|
|
|
|
import DBus
|
|
|
|
import DBus.Client
|
2021-11-27 01:02:22 -05:00
|
|
|
import DBus.Internal
|
|
|
|
import qualified DBus.Introspection as I
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2021-11-27 01:02:22 -05:00
|
|
|
import System.Directory (findExecutable, readable, writable)
|
2022-06-26 19:05:25 -04:00
|
|
|
import System.Environment
|
2021-11-07 13:35:08 -05:00
|
|
|
import System.Exit
|
|
|
|
|
2021-11-27 01:02:22 -05:00
|
|
|
import XMonad.Core (X, io)
|
2021-11-07 18:41:25 -05:00
|
|
|
import XMonad.Internal.IO
|
2021-11-07 13:35:08 -05:00
|
|
|
import XMonad.Internal.Process
|
|
|
|
import XMonad.Internal.Shell
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Feature Evaluation
|
|
|
|
--
|
|
|
|
-- Here we attempt to build and return the monadic actions encoded by each
|
|
|
|
-- feature.
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Execute an Always immediately
|
|
|
|
executeAlways :: MonadIO m => Always (m a) -> m a
|
|
|
|
executeAlways = join . evalAlways
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Execute a Sometimes immediately (or do nothing if failure)
|
|
|
|
executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
|
|
|
|
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
|
2022-06-22 01:28:46 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Possibly return the action of an Always/Sometimes
|
|
|
|
evalFeature :: MonadIO m => Feature a -> m (Maybe a)
|
|
|
|
evalFeature (Right a) = Just <$> evalAlways a
|
|
|
|
evalFeature (Left s) = evalSometimes s
|
2022-06-22 01:28:46 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Possibly return the action of a Sometimes
|
|
|
|
evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a)
|
|
|
|
evalSometimes x = io $ either goFail goPass =<< evalSometimesMsg x
|
|
|
|
where
|
|
|
|
goPass (PostPass a ws) = putErrors ws >> return (Just a)
|
|
|
|
goFail es = putErrors es >> return Nothing
|
|
|
|
putErrors = mapM_ putStrLn
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Return the action of an Always
|
|
|
|
evalAlways :: MonadIO m => Always a -> m a
|
|
|
|
evalAlways a = do
|
|
|
|
(PostPass x ws) <- evalAlwaysMsg a
|
|
|
|
io $ mapM_ putStrLn ws
|
|
|
|
return x
|
2022-06-16 18:50:24 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Feature status
|
2021-11-21 22:47:43 -05:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Dump the status of an Always to stdout
|
|
|
|
-- dumpAlways :: MonadIO m => Always a -> m ()
|
|
|
|
-- dumpAlways = undefined
|
2021-11-21 10:26:28 -05:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Dump the status of a Sometimes to stdout
|
|
|
|
-- dumpSometimes :: MonadIO m => Sometimes a -> m ()
|
|
|
|
-- dumpSometimes = undefined
|
2021-11-11 00:11:15 -05:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Wrapper types
|
2021-11-20 01:15:04 -05:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
type AlwaysX = Always (X ())
|
2022-06-17 00:37:12 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
type AlwaysIO = Always (IO ())
|
2021-11-21 18:18:09 -05:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
type SometimesX = Sometimes (X ())
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
type SometimesIO = Sometimes (IO ())
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
type Feature a = Either (Sometimes a) (Always a)
|
2021-11-22 23:46:51 -05:00
|
|
|
|
2022-06-21 00:56:42 -04:00
|
|
|
--------------------------------------------------------------------------------
|
2022-06-26 19:05:25 -04: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)
|
|
|
|
data Always a = Option (SubfeatureRoot a) (Always a) | Always a
|
|
|
|
|
|
|
|
-- | Feature that might not be present
|
|
|
|
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
|
|
|
-- action
|
|
|
|
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
|
2022-06-21 00:56:42 -04:00
|
|
|
, sfName :: String
|
|
|
|
, sfLevel :: LogLevel
|
|
|
|
}
|
2022-06-17 00:37:12 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
type SubfeatureRoot a = Subfeature (Root a)
|
2021-11-22 23:46:51 -05:00
|
|
|
|
2022-06-26 19:05:25 -04: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)
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | An action and its dependencies
|
|
|
|
-- May be a plain old monad or be DBus-dependent, in which case a client is
|
|
|
|
-- needed
|
|
|
|
data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p)
|
|
|
|
| IORoot_ a (Tree_ IODependency_)
|
|
|
|
| forall p. DBusRoot (p -> Client -> a) (Tree IODependency DBusDependency_ p) (Maybe Client)
|
|
|
|
| DBusRoot_ (Client -> a) (Tree_ DBusDependency_) (Maybe Client)
|
|
|
|
|
|
|
|
-- | The dependency tree with rules to merge results
|
|
|
|
data Tree d d_ p =
|
|
|
|
And12 (p -> p -> p) (Tree d d_ p) (Tree d d_ p)
|
|
|
|
| And1 (p -> p) (Tree d d_ p) (Tree_ d_)
|
|
|
|
| And2 (p -> p) (Tree_ d_) (Tree d d_ p)
|
|
|
|
| Or (p -> p) (p -> p) (Tree d d_ p) (Tree d d_ p)
|
|
|
|
| Only (d p)
|
|
|
|
|
|
|
|
-- | A dependency tree without functions to merge results
|
|
|
|
data Tree_ d =
|
|
|
|
And_ (Tree_ d) (Tree_ d)
|
|
|
|
| Or_ (Tree_ d) (Tree_ d)
|
|
|
|
| Only_ d
|
|
|
|
|
|
|
|
-- | A dependency that only requires IO to evaluate
|
|
|
|
data IODependency p = IORead String (IO (Result p))
|
|
|
|
| forall a. IOAlways (Always 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
|
|
|
|
data DBusDependency_ = Bus BusName
|
|
|
|
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
|
|
|
| DBusIO IODependency_
|
2021-11-21 10:26:28 -05:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | A dependency that only requires IO to evaluate (no payload)
|
|
|
|
data IODependency_ = IOSystem_ SystemDependency | forall a. IOSometimes_ (Sometimes a)
|
2022-06-17 00:37:12 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
data SystemDependency = Executable Bool FilePath
|
2021-11-21 10:26:28 -05:00
|
|
|
| AccessiblePath FilePath Bool Bool
|
2022-06-16 18:50:24 -04:00
|
|
|
| IOTest String (IO (Maybe String))
|
2021-11-21 10:26:28 -05:00
|
|
|
| Systemd UnitType String
|
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | The type of a systemd service
|
2021-11-21 10:26:28 -05:00
|
|
|
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
|
|
|
|
2022-06-26 19:05:25 -04: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)
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Tested dependency tree
|
2021-11-21 10:26:28 -05:00
|
|
|
--
|
2022-06-26 19:05:25 -04: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)
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Tested Always feature
|
|
|
|
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always a)
|
|
|
|
| Fallback a [SubfeatureFail]
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Tested Sometimes feature
|
|
|
|
data PostSometimes a = PostSometimes
|
|
|
|
{ psSuccess :: Maybe (SubfeaturePass a)
|
|
|
|
, psFailed :: [SubfeatureFail]
|
|
|
|
}
|
2022-06-22 01:28:46 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Passing subfeature
|
|
|
|
type SubfeaturePass a = Subfeature (PostPass a)
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Failed subfeature
|
|
|
|
type SubfeatureFail = Subfeature PostFail
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | An action that passed
|
|
|
|
data PostPass a = PostPass a [String] deriving (Functor)
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
addMsgs :: PostPass a -> [String] -> PostPass a
|
|
|
|
addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | An action that failed
|
|
|
|
data PostFail = PostFail [String] | PostMissing String
|
2022-06-21 00:56:42 -04:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2022-06-26 19:05:25 -04:00
|
|
|
-- | Testing pipeline
|
2021-11-07 13:35:08 -05:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
|
|
|
|
evalSometimesMsg x = io $ do
|
|
|
|
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes x
|
|
|
|
case s of
|
|
|
|
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False fs
|
|
|
|
_ -> Left <$> failedMsgs True fs
|
|
|
|
|
|
|
|
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
|
|
|
|
evalAlwaysMsg x = io $ do
|
|
|
|
r <- testAlways x
|
|
|
|
case r of
|
|
|
|
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False fs
|
|
|
|
(Fallback act fs) -> PostPass act <$> failedMsgs False fs
|
|
|
|
|
|
|
|
testAlways :: Always a -> IO (PostAlways a)
|
2022-06-21 00:56:42 -04:00
|
|
|
testAlways = go []
|
|
|
|
where
|
|
|
|
go failed (Option fd next) = do
|
|
|
|
r <- testSubfeature fd
|
|
|
|
case r of
|
2022-06-26 19:05:25 -04:00
|
|
|
(Left l) -> go (l:failed) next
|
|
|
|
(Right pass) -> return $ Primary pass failed next
|
2022-06-21 00:56:42 -04:00
|
|
|
go failed (Always a) = return $ Fallback a failed
|
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
testSometimes :: Sometimes a -> IO (PostSometimes a)
|
|
|
|
testSometimes = go (PostSometimes Nothing [])
|
2022-06-21 00:56:42 -04:00
|
|
|
where
|
|
|
|
go ts [] = return ts
|
|
|
|
go ts (x:xs) = do
|
2022-06-26 19:05:25 -04:00
|
|
|
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 -> IO (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 -> IO (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"
|
2022-06-21 00:56:42 -04:00
|
|
|
where
|
2022-06-26 19:05:25 -04:00
|
|
|
go a f_ f t = 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 :: (d_ -> IO Result_) -> (d p -> IO (Result p)) -> Tree d d_ p
|
|
|
|
-> IO (Either [String] (PostPass p))
|
|
|
|
testTree test_ test = go
|
|
|
|
-- TODO clean this up
|
2022-06-21 00:56:42 -04:00
|
|
|
where
|
2022-06-26 19:05:25 -04:00
|
|
|
go (And12 f a b) = either (return . Left) (\ra -> (and2nd f ra =<<) <$> go b)
|
|
|
|
=<< go a
|
|
|
|
go (And1 f a b) = do
|
|
|
|
ra <- go a
|
|
|
|
case ra of
|
|
|
|
(Right (PostPass pa wa)) -> do
|
|
|
|
rb <- testTree_ test_ b
|
|
|
|
return $ case rb of
|
|
|
|
(Left es) -> Left es
|
|
|
|
(Right wb) -> Right $ PostPass (f pa) $ wa ++ wb
|
|
|
|
l -> return l
|
|
|
|
go (And2 f a b) = do
|
|
|
|
ra <- testTree_ test_ a
|
|
|
|
case ra of
|
|
|
|
(Right wa) -> do
|
|
|
|
rb <- go b
|
|
|
|
return $ case rb of
|
|
|
|
(Left es) -> Left es
|
|
|
|
(Right (PostPass pb wb)) -> Right $ PostPass (f pb) $ wa ++ wb
|
|
|
|
(Left l) -> return $ Left l
|
2022-06-21 00:56:42 -04:00
|
|
|
go (Or fa fb a b) = do
|
2022-06-26 19:05:25 -04:00
|
|
|
ra <- go a
|
|
|
|
case ra of
|
|
|
|
(Right (PostPass pa wa)) -> return $ Right $ PostPass (fa pa) wa
|
|
|
|
(Left ea) -> (or2nd fb ea =<<) <$> go b
|
|
|
|
go (Only a) = test a
|
|
|
|
and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
|
|
|
|
or2nd f es (PostPass pb wb) = Right $ PostPass (f pb) $ es ++ wb
|
|
|
|
|
|
|
|
testIODependency :: IODependency p -> IO (Result p)
|
|
|
|
testIODependency (IORead _ t) = t
|
|
|
|
testIODependency (IOAlways a f) = Right . fmap f <$> evalAlwaysMsg a
|
|
|
|
testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Standalone dependency testing
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
type Result_ = Either [String] [String]
|
2022-06-21 00:56:42 -04:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
testTree_ :: (d -> IO Result_) -> Tree_ d -> IO (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_ -> IO Result_
|
|
|
|
testIODependency_ (IOSystem_ s) = maybe (Right []) (Left . (:[])) <$> testSysDependency s
|
|
|
|
testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
|
|
|
|
|
|
|
|
testSysDependency :: SystemDependency -> IO (Maybe String)
|
|
|
|
testSysDependency (IOTest _ t) = t
|
|
|
|
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
|
|
|
<$> findExecutable bin
|
|
|
|
where
|
|
|
|
msg = unwords [e, "executable", quote bin, "not found"]
|
|
|
|
e = if sys then "system" else "local"
|
|
|
|
testSysDependency (Systemd t n) = do
|
2021-11-07 13:35:08 -05:00
|
|
|
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
|
|
|
return $ case rc of
|
2022-06-26 19:05:25 -04:00
|
|
|
ExitSuccess -> Nothing
|
|
|
|
_ -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"
|
2021-11-07 13:35:08 -05:00
|
|
|
where
|
2022-06-21 00:56:42 -04:00
|
|
|
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
2021-11-19 00:35:54 -05:00
|
|
|
unitType SystemUnit = "system"
|
|
|
|
unitType UserUnit = "user"
|
2022-06-26 19:05:25 -04:00
|
|
|
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
2021-11-07 18:41:25 -05:00
|
|
|
where
|
2022-06-21 00:56:42 -04:00
|
|
|
testPerm False _ _ = Nothing
|
|
|
|
testPerm True f res = Just $ f res
|
2022-06-26 19:05:25 -04:00
|
|
|
permMsg NotFoundError = Just "file not found"
|
|
|
|
permMsg PermError = Just "could not get permissions"
|
2022-06-21 00:56:42 -04:00
|
|
|
permMsg (PermResult res) =
|
|
|
|
case (testPerm r readable res, testPerm w writable res) of
|
2022-06-26 19:05:25 -04:00
|
|
|
(Just False, Just False) -> Just "file not readable or writable"
|
|
|
|
(Just False, _) -> Just "file not readable"
|
|
|
|
(_, Just False) -> Just "file not writable"
|
|
|
|
_ -> Nothing
|
|
|
|
|
|
|
|
testDBusDependency_ :: Client -> DBusDependency_ -> IO Result_
|
|
|
|
testDBusDependency_ client (Bus bus) = do
|
2021-11-21 17:54:00 -05:00
|
|
|
ret <- callMethod client queryBus queryPath queryIface queryMem
|
2021-11-20 19:35:24 -05:00
|
|
|
return $ case ret of
|
2022-06-21 00:56:42 -04:00
|
|
|
Left e -> smryFail e
|
2021-11-20 19:35:24 -05:00
|
|
|
Right b -> let ns = bodyGetNames b in
|
2022-06-26 19:05:25 -04:00
|
|
|
if bus' `elem` ns then Right []
|
2022-06-21 00:56:42 -04:00
|
|
|
else smryFail $ unwords ["name", singleQuote bus', "not found on dbus"]
|
2021-11-07 20:16:53 -05:00
|
|
|
where
|
2021-11-20 19:35:24 -05:00
|
|
|
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 _ = []
|
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
testDBusDependency_ client (Endpoint busname objpath iface mem) = do
|
2021-11-21 22:47:43 -05:00
|
|
|
ret <- callMethod client busname objpath introspectInterface introspectMethod
|
2021-11-20 19:35:24 -05:00
|
|
|
return $ case ret of
|
2022-06-21 00:56:42 -04:00
|
|
|
Left e -> smryFail e
|
2021-11-20 19:35:24 -05:00
|
|
|
Right body -> procBody body
|
|
|
|
where
|
|
|
|
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
|
|
|
|
=<< listToMaybe body in
|
|
|
|
case res of
|
2022-06-26 19:05:25 -04:00
|
|
|
Just True -> Right []
|
2022-06-21 00:56:42 -04:00
|
|
|
_ -> smryFail $ fmtMsg' mem
|
2021-11-20 19:35:24 -05:00
|
|
|
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"
|
2021-11-21 22:47:43 -05:00
|
|
|
, formatBusName busname
|
2021-11-20 19:35:24 -05:00
|
|
|
]
|
2021-11-26 23:35:03 -05:00
|
|
|
|
2022-06-26 19:05:25 -04:00
|
|
|
testDBusDependency_ _ (DBusIO i) = testIODependency_ i
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Constructor functions
|
|
|
|
|
|
|
|
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
|
|
|
|
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
|
|
|
|
|
|
|
-- always1_ :: LogLevel -> String -> Root a Tree -> a -> Always a
|
|
|
|
-- always1_ l n t x =
|
|
|
|
-- Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x)
|
|
|
|
|
|
|
|
sometimes1 :: String -> Root a -> Sometimes a
|
|
|
|
sometimes1 = sometimes1_ Error
|
|
|
|
|
|
|
|
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
|
|
|
|
sometimesIO n t x = sometimes1 n $ IORoot_ x t
|
|
|
|
|
|
|
|
sometimesDBus :: Maybe Client -> String -> Tree_ DBusDependency_
|
|
|
|
-> (Client -> a) -> Sometimes a
|
|
|
|
sometimesDBus c n t x = sometimes1 n $ DBusRoot_ x t c
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | 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 }
|
|
|
|
|
|
|
|
-- 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 i = foldr (And_ . Only_) (Only_ i)
|
|
|
|
|
|
|
|
toAnd :: d -> d -> Tree_ d
|
|
|
|
toAnd a b = And_ (Only_ a) (Only_ b)
|
|
|
|
|
|
|
|
smryFail :: String -> Either [String] a
|
|
|
|
smryFail msg = Left [msg]
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | IO Dependency
|
|
|
|
|
|
|
|
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 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
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | 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.
|
2022-06-17 00:37:12 -04:00
|
|
|
|
2022-06-16 18:50:24 -04:00
|
|
|
--------------------------------------------------------------------------------
|
2022-06-21 00:56:42 -04:00
|
|
|
-- | Printing
|
|
|
|
|
2022-06-22 01:28:46 -04:00
|
|
|
-- printMsgs :: LogLevel -> [Msg] -> IO ()
|
|
|
|
-- printMsgs lvl ms = do
|
|
|
|
-- pn <- getProgName
|
|
|
|
-- mapM_ (printMsg pn lvl) ms
|
|
|
|
|
|
|
|
-- printMsg :: String -> LogLevel -> Msg -> IO ()
|
|
|
|
-- printMsg pname lvl (Msg ml mn msg)
|
|
|
|
-- | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
|
|
|
|
-- | otherwise = skip
|
|
|
|
-- where
|
|
|
|
-- bracket s = "[" ++ s ++ "]"
|
2022-06-26 19:05:25 -04:00
|
|
|
|
|
|
|
bracket :: String -> String
|
|
|
|
bracket s = "[" ++ s ++ "]"
|
|
|
|
|
|
|
|
quote :: String -> String
|
|
|
|
quote s = "'" ++ s ++ "'"
|
|
|
|
|
|
|
|
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
|
|
|
|
failedMsgs err = fmap concat . mapM (failedMsg err)
|
|
|
|
|
|
|
|
failedMsg :: Bool -> SubfeatureFail -> IO [String]
|
|
|
|
failedMsg err Subfeature { sfData = d, sfName = n } = do
|
|
|
|
mapM (fmtMsg err n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
|
|
|
|
|
|
|
|
fmtMsg :: Bool -> String -> String -> IO String
|
|
|
|
fmtMsg err n msg = do
|
|
|
|
let e = if err then "ERROR" else "WARNING"
|
|
|
|
p <- getProgName
|
|
|
|
return $ unwords [bracket p, bracket e, bracket n, msg]
|