ENH allow generic IO tests as dependencies

This commit is contained in:
Nathan Dwarshuis 2021-11-11 22:38:25 -05:00
parent 802de6965e
commit 77ab59b72c
1 changed files with 11 additions and 10 deletions

View File

@ -71,6 +71,7 @@ data DBusMember = Method_ MemberName
data DependencyData = Executable String data DependencyData = Executable String
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| IOTest (IO Bool)
| DBusEndpoint | DBusEndpoint
{ ddDbusBus :: BusName { ddDbusBus :: BusName
, ddDbusSystem :: Bool , ddDbusSystem :: Bool
@ -79,27 +80,24 @@ data DependencyData = Executable String
, ddDbusMember :: DBusMember , ddDbusMember :: DBusMember
} }
| Systemd UnitType String | Systemd UnitType String
deriving (Eq, Show)
-- data Dependency = Dependency
-- { depRequired :: Bool
-- , depData :: DependencyData
-- }
-- deriving (Eq, Show)
data Dependency a = SubFeature (Feature a a) data Dependency a = SubFeature (Feature a a)
| Dependency | Dependency
-- TODO when would this ever be false?
{ depRequired :: Bool { depRequired :: Bool
, depData :: DependencyData , depData :: DependencyData
} deriving (Eq, Show) }
data Feature a b = Feature data Feature a b = Feature
{ ftrAction :: a { ftrAction :: a
-- TODO add a 'default' action that will proceed in case of failure
, ftrSilent :: Bool , ftrSilent :: Bool
-- TODO this should be a semigroup
, ftrChildren :: [Dependency b] , ftrChildren :: [Dependency b]
} deriving (Eq, Show) } | ConstFeature a
evalFeature :: Feature a b -> IO (MaybeExe a) evalFeature :: Feature a b -> IO (MaybeExe a)
evalFeature (ConstFeature x) = return $ Installed x []
evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
c' <- concat <$> mapM go c c' <- concat <$> mapM go c
return $ case foldl groupResult ([], []) c' of return $ case foldl groupResult ([], []) c' of
@ -107,6 +105,7 @@ evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
(req, opt) -> if s then Ignore else Missing req opt (req, opt) -> if s then Ignore else Missing req opt
where where
go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs
go (SubFeature (ConstFeature _)) = return []
go Dependency { depRequired = r, depData = d } = do go Dependency { depRequired = r, depData = d } = do
i <- depInstalled d i <- depInstalled d
return [(r, d) | not i ] return [(r, d) | not i ]
@ -151,7 +150,7 @@ userUnit = unit UserUnit
data MaybeExe a = Installed a [DependencyData] data MaybeExe a = Installed a [DependencyData]
| Missing [DependencyData] [DependencyData] | Missing [DependencyData] [DependencyData]
| Ignore | Ignore
deriving (Eq, Show, Foldable, Traversable) deriving (Foldable, Traversable)
instance Functor MaybeExe where instance Functor MaybeExe where
fmap f (Installed x ds) = Installed (f x) ds fmap f (Installed x ds) = Installed (f x) ds
@ -228,6 +227,7 @@ dbusInstalled bus usesystem objpath iface mem = do
-- TODO somehow get this to preserve error messages if something isn't found -- TODO somehow get this to preserve error messages if something isn't found
depInstalled :: DependencyData -> IO Bool depInstalled :: DependencyData -> IO Bool
depInstalled (Executable n) = exeInstalled n depInstalled (Executable n) = exeInstalled n
depInstalled (IOTest t) = t
depInstalled (Systemd t n) = unitInstalled t n depInstalled (Systemd t n) = unitInstalled t n
depInstalled (AccessiblePath p r w) = pathAccessible p r w depInstalled (AccessiblePath p r w) = pathAccessible p r w
depInstalled DBusEndpoint { ddDbusBus = b depInstalled DBusEndpoint { ddDbusBus = b
@ -293,6 +293,7 @@ partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
fmtMissing :: DependencyData -> String fmtMissing :: DependencyData -> String
-- TODO this error message is lame -- TODO this error message is lame
fmtMissing (IOTest _) = "some random test failed"
fmtMissing DBusEndpoint {} = "some random dbus path is missing" fmtMissing DBusEndpoint {} = "some random dbus path is missing"
fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable" fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable" fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"