xmonad-config/lib/Data/Internal/XIO.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

--------------------------------------------------------------------------------
-- Functions for handling dependencies

module Data.Internal.XIO
-- feature types
  ( Feature
  , Always (..)
  , Always_ (..)
  , FallbackRoot (..)
  , FallbackStack (..)
  , Sometimes (..)
  , Sometimes_
  , AlwaysX
  , AlwaysIO
  , SometimesX
  , SometimesIO
  , PostPass (..)
  , Subfeature (..)
  , SubfeatureRoot
  , Msg (..)
  -- configuration
  , XEnv (..)
  , XParams (..)
  , XPFeatures (..)
  , XPQuery
  -- dependency tree types
  , Root (..)
  , Tree (..)
  , Tree_ (..)
  , IOTree
  , IOTree_
  , DBusTree
  , DBusTree_
  , SafeClient (..)
  , IODependency (..)
  , IODependency_ (..)
  , SystemDependency (..)
  , DBusDependency_ (..)
  , DBusMember (..)
  , UnitType (..)
  , Result
  , Fulfillment (..)
  , ArchPkg (..)
  -- dumping
  , dumpFeature
  , dumpAlways
  , dumpSometimes
  , showFulfillment
  -- testing
  , XIO
  , runXIO
  , evalFeature
  , executeSometimes
  , executeAlways
  , evalAlways
  , evalSometimes
  , fontTreeAlt
  , fontTree
  , fontTree_
  , fontAlways
  , fontSometimes
  , readEthernet
  , readWireless
  , socketExists
  -- lifting
  -- , ioSometimes
  -- , ioAlways
  -- feature construction
  , always1
  , sometimes1
  , sometimesIO
  , sometimesIO_
  , sometimesDBus
  , sometimesExe
  , sometimesExeArgs
  , sometimesEndpoint
  -- dependency construction
  , sysExe
  , localExe
  , sysdSystem
  , sysdUser
  , listToAnds
  , toAnd_
  , toFallback
  , pathR
  , pathRW
  , pathW
  , voidResult
  , voidRead
  , process
  -- misc
  , shellTest
  )
where

import DBus hiding (typeOf)
import qualified DBus.Introspection as I
import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key
import Data.Internal.DBus
import Data.Yaml
import GHC.IO.Exception (ioe_description)
import RIO hiding (bracket, fromString)
import RIO.Directory
import RIO.FilePath
import RIO.List
import RIO.Process hiding (findExecutable)
import qualified RIO.Text as T
import System.Posix.Files
import System.Process.Typed (nullStream)
import UnliftIO.Environment
import XMonad.Core (X, io)
import XMonad.Internal.IO
import XMonad.Internal.Shell hiding (proc, runProcess)
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)
runXIO :: XIO a -> IO a
runXIO x = do
  logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle stderr False
  pc <- mkDefaultProcessContext
  withLogFunc logOpts $ \f -> do
    p <- getParams
    let s = XEnv f pc p
    runRIO s x

-- | Execute an Always immediately
executeAlways :: Always (IO a) -> XIO a
executeAlways = io <=< evalAlways

-- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a

-- | Possibly return the action of an Always/Sometimes
evalFeature :: Feature a -> XIO (Maybe a)
evalFeature (Right a) = Just <$> evalAlways a
evalFeature (Left s) = evalSometimes s

-- | Possibly return the action of a Sometimes
evalSometimes :: Sometimes a -> XIO (Maybe a)
evalSometimes x = either goFail goPass =<< evalSometimesMsg x
  where
    goPass (a, ws) = putErrors ws >> return (Just a)
    goFail es = putErrors es >> return Nothing
    putErrors = mapM_ logMsg

-- | Return the action of an Always
evalAlways :: Always a -> XIO a
evalAlways a = do
  (x, ws) <- evalAlwaysMsg a
  mapM_ logMsg ws
  return x

logMsg :: FMsg -> XIO ()
logMsg (FMsg fn n (Msg ll m)) = do
  p <- io getProgName
  f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
  where
    llFun LevelError = ("ERROR", logError)
    llFun LevelInfo = ("INFO", logInfo)
    llFun LevelWarn = ("WARN", logWarn)
    llFun _ = ("DEBUG", logDebug)
    (s, f) = llFun ll
    fmt p l =
      [ bracket p
      , bracket l
      , bracket fn
      ]
        ++ maybe [] ((: []) . bracket) n
        ++ [m]

--------------------------------------------------------------------------------
-- Package status

showFulfillment :: Fulfillment -> Utf8Builder
showFulfillment (Package t n) =
  displayShow t <> "\t" <> Utf8Builder (encodeUtf8Builder n)

dumpFeature :: Feature a -> [Fulfillment]
dumpFeature = either dumpSometimes dumpAlways

dumpAlways :: Always a -> [Fulfillment]
dumpAlways (Always _ x) = case x of
  (Option o _) -> nub $ dataSubfeatureRoot o
  _ -> []

dumpSometimes :: Sometimes a -> [Fulfillment]
dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs

--------------------------------------------------------------------------------
-- Wrapper types

type AlwaysX = Always (X ())

type AlwaysIO = Always (IO ())

type SometimesX = Sometimes (X ())

type SometimesIO = Sometimes (XIO ())

type Feature a = Either (Sometimes a) (Always a)

--------------------------------------------------------------------------------
-- 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 = Always T.Text (Always_ a)

-- | Feature that is guaranteed to work (inner data)
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.
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
data Sometimes a = Sometimes T.Text XPQuery (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 :: T.Text
  }

type SubfeatureRoot a = Subfeature (Root a)

-- | 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) (IOTree p)
  | IORoot_ a IOTree_
  | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
  | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)

-- | The dependency tree with rule to merge results when needed
data Tree d d_ p
  = forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
  | 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
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 c p = Tree IODependency (DBusDependency_ c) p

type IOTree_ = Tree_ IODependency_

type DBusTree_ c = Tree_ (DBusDependency_ c)

-- | A dependency that only requires IO to evaluate (with payload)
data IODependency p
  = -- an IO action that yields a payload
    IORead T.Text [Fulfillment] (XIO (Result p))
  | -- always yields a payload
    IOConst p
  | -- an always that yields a payload
    forall a. IOAlways (Always a) (a -> p)
  | -- a sometimes that yields a payload
    forall a. IOSometimes (Sometimes a) (a -> p)

-- | A dependency pertaining to the DBus
data DBusDependency_ c
  = Bus [Fulfillment] BusName
  | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
  | DBusIO IODependency_
  deriving (Generic)

-- | A dependency that only requires IO to evaluate (no payload)
data IODependency_
  = IOSystem_ [Fulfillment] SystemDependency
  | IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg))
  | forall a. IOSometimes_ (Sometimes a)

-- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious
data SystemDependency
  = Executable Bool FilePath
  | AccessiblePath FilePath Bool Bool
  | Systemd UnitType T.Text
  | Process T.Text
  deriving (Eq, Show, Generic)

-- | The type of a systemd service
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)

-- | Wrapper type to describe and endpoint
data DBusMember
  = Method_ MemberName
  | Signal_ MemberName
  | Property_ T.Text
  deriving (Eq, Show, Generic)

-- | A means to fulfill a dependency
-- For now this is just the name of an Arch Linux package (AUR or official)
data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)

data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)

--------------------------------------------------------------------------------
-- Tested dependency tree
--
-- 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)

-- | A message with criteria for when to show it
data Msg = Msg LogLevel T.Text

-- | A message annotated with subfeature and feature name
data FMsg = FMsg T.Text (Maybe T.Text) Msg

-- | Tested Always feature
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 [Msg] deriving (Functor)

addMsgs :: PostPass a -> [Msg] -> PostPass a
addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'

-- | An action that failed
data PostFail = PostFail [Msg] | PostMissing Msg

--------------------------------------------------------------------------------
-- Configuration

type XIO a = RIO XEnv a

data XEnv = XEnv
  { xLogFun :: !LogFunc
  , xProcCxt :: !ProcessContext
  , xParams :: !XParams
  }

instance HasLogFunc XEnv where
  logFuncL = lens xLogFun (\x y -> x {xLogFun = y})

instance HasProcessContext XEnv where
  processContextL = lens xProcCxt (\x y -> x {xProcCxt = y})

data XParams = XParams
  { xpLogLevel :: LogLevel
  , xpFeatures :: XPFeatures
  }

data JLogLevel = Error | Warn | Debug | Info
  deriving (Eq, Show, Ord, Generic)

instance FromJSON JLogLevel

instance FromJSON XParams where
  parseJSON = withObject "parameters" $ \o -> do
    ll <- mapLevel <$> o .: fromString "loglevel"
    fs <- o .: fromString "features"
    return $ XParams ll fs
    where
      mapLevel Info = LevelInfo
      mapLevel Error = LevelError
      mapLevel Warn = LevelWarn
      mapLevel Debug = LevelDebug

data XPFeatures = XPFeatures
  { xpfOptimus :: Bool
  , xpfVirtualBox :: Bool
  , xpfXSANE :: Bool
  , xpfEthernet :: Bool
  , xpfWireless :: Bool
  , xpfVPN :: Bool
  , xpfBluetooth :: Bool
  , xpfIntelBacklight :: Bool
  , xpfClevoBacklight :: Bool
  , xpfBattery :: Bool
  , xpfF5VPN :: Bool
  }

instance FromJSON XPFeatures where
  parseJSON = withObject "features" $ \o ->
    XPFeatures
      <$> o
      .:+ "optimus"
      <*> o
      .:+ "virtualbox"
      <*> o
      .:+ "xsane"
      <*> o
      .:+ "ethernet"
      <*> o
      .:+ "wireless"
      <*> o
      .:+ "vpn"
      <*> o
      .:+ "bluetooth"
      <*> o
      .:+ "intel_backlight"
      <*> o
      .:+ "clevo_backlight"
      <*> o
      .:+ "battery"
      <*> o
      .:+ "f5vpn"

defParams :: XParams
defParams =
  XParams
    { xpLogLevel = LevelError
    , xpFeatures = defXPFeatures
    }

defXPFeatures :: XPFeatures
defXPFeatures =
  XPFeatures
    { xpfOptimus = False
    , xpfVirtualBox = False
    , xpfXSANE = False
    , xpfEthernet = False
    , xpfWireless = False
    , -- TODO this might be broken down into different flags (expressvpn, etc)
      xpfVPN = False
    , xpfBluetooth = False
    , xpfIntelBacklight = False
    , xpfClevoBacklight = False
    , xpfBattery = False
    , xpfF5VPN = False
    }

type XPQuery = XPFeatures -> Bool

getParams :: MonadIO m => m XParams
getParams = do
  p <- getParamFile
  maybe (return defParams) (liftIO . decodeYaml) p
  where
    decodeYaml p =
      either (\e -> print e >> return defParams) return
        =<< decodeFileEither p

getParamFile :: MonadIO m => m (Maybe FilePath)
getParamFile = do
  e <- lookupEnv "XDG_CONFIG_HOME"
  parent <- case e of
    Nothing -> fallback
    Just path
      | isRelative path -> fallback
      | otherwise -> return path
  let full = parent </> "xmonad.yml"
  (\x -> if x then Just full else Nothing) <$> doesFileExist full
  where
    fallback = (</> ".config") <$> getHomeDirectory

(.:+) :: Object -> String -> Parser Bool
(.:+) o n = o .:? fromString n .!= False

infix 9 .:+

--------------------------------------------------------------------------------
-- Testing pipeline

evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do
  r <- asks (u . xpFeatures . xParams)
  if not r
    then return $ Left [dis n]
    else do
      PostSometimes {psSuccess = s, psFailed = fs} <- testSometimes xs
      let fs' = failedMsgs n fs
      return $ case s of
        (Just p) -> Right $ second (++ fs') $ passActMsg n p
        _ -> Left fs'
  where
    dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")

evalAlwaysMsg :: Always a -> XIO (a, [FMsg])
evalAlwaysMsg (Always n x) = do
  r <- testAlways x
  return $ case r of
    (Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p
    (Fallback act fs) -> (act, failedMsgs n fs)

passActMsg :: T.Text -> SubfeaturePass a -> (a, [FMsg])
passActMsg fn Subfeature {sfData = PostPass a ws, sfName = n} = (a, fmap (FMsg fn (Just n)) ws)

failedMsgs :: T.Text -> [SubfeatureFail] -> [FMsg]
failedMsgs n = concatMap (failedMsg n)

failedMsg :: T.Text -> SubfeatureFail -> [FMsg]
failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
  (PostFail es) -> f es
  (PostMissing e) -> f [e]
  where
    f = fmap (FMsg fn (Just n))

testAlways :: Always_ a -> XIO (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 -> XIO a
evalFallbackRoot (FallbackAlone a) = return a
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s

evalFallbackStack :: FallbackStack p -> XIO 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 -> XIO (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 -> XIO (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 -> XIO (Either PostFail (PostPass a))
testRoot r = do
  case r of
    (IORoot a t) -> go a testIODep_ testIODep t
    (IORoot_ a t) -> go_ a testIODep_ t
    (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t
    (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
    _ ->
      return $
        Left $
          PostMissing $
            Msg LevelError "client not available"
  where
    -- rank N polymorphism is apparently undecidable...gross
    go a f_ (f :: forall q. d q -> XIO (MResult q)) 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 [Msg] (PostPass p)

type MResult p = Memoized (Result p)

testTree
  :: forall d d_ p
   . (d_ -> XIO MResult_)
  -> (forall q. d q -> XIO (MResult q))
  -> Tree d d_ p
  -> XIO (Either [Msg] (PostPass p))
testTree test_ test = go
  where
    go :: forall q. Tree d d_ q -> XIO (Result q)
    go (And12 f a b) = do
      ra <- go a
      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
      liftRight (\wa -> fmap (`addMsgs` wa) <$> go b) ra
    go (Or a b) = do
      ra <- go a
      either (\ea -> fmap (`addMsgs` ea) <$> go b) (return . Right) ra
    go (Only a) = runMemoized =<< test a
    and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
    liftRight = either (return . Left)

testIODep :: IODependency p -> XIO (MResult p)
testIODep d = memoizeMVar $ case d of
  IORead _ _ t -> t
  IOConst c -> return $ Right $ PostPass c []
  -- 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
  IOAlways a f ->
    Right
      . uncurry PostPass
      -- TODO this is wetter than Taco Bell shit
      . bimap f (fmap stripMsg)
      <$> evalAlwaysMsg a
  IOSometimes x f ->
    bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
      <$> evalSometimesMsg x

stripMsg :: FMsg -> Msg
stripMsg (FMsg _ _ m) = m

--------------------------------------------------------------------------------

-- | Standalone dependency testing
type Result_ = Either [Msg] [Msg]

type MResult_ = Memoized Result_

testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
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) = runMemoized =<< test a
    test2nd ws = fmap ((Right . (ws ++)) =<<) . go

testIODep_ :: IODependency_ -> XIO MResult_
testIODep_ d = memoizeMVar $ testIODepNoCache_ d

testIODepNoCache_ :: IODependency_ -> XIO Result_
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
testIODepNoCache_ (IOSometimes_ x) =
  bimap (fmap stripMsg) (fmap stripMsg . snd)
    <$> evalSometimesMsg x

--------------------------------------------------------------------------------
-- System Dependency Testing

testSysDependency
  :: (MonadUnliftIO m, MonadReader env m, HasProcessContext env, HasLogFunc env)
  => SystemDependency
  -> m (Maybe Msg)
testSysDependency (Executable sys bin) =
  io $
    maybe (Just msg) (const Nothing)
      <$> findExecutable bin
  where
    msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
    e = if sys then "system" else "local"
testSysDependency (Systemd t n) = shellTest "systemctl" args msg
  where
    msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
    args = ["--user" | t == UserUnit] ++ ["status", n]
testSysDependency (Process n) =
  shellTest "pidof" [n] $
    T.unwords ["Process", singleQuote n, "not found"]
testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
  where
    testPerm False _ _ = Nothing
    testPerm True f res = Just $ f res
    mkErr = Just . Msg LevelError
    permMsg NotFoundError = mkErr "file not found"
    permMsg PermError = mkErr "could not get permissions"
    permMsg (PermResult res) =
      case (testPerm r readable res, testPerm w writable res) of
        (Just False, Just False) -> mkErr "file not readable or writable"
        (Just False, _) -> mkErr "file not readable"
        (_, Just False) -> mkErr "file not writable"
        _ -> Nothing

shellTest
  :: (MonadReader env m, HasProcessContext env, HasLogFunc env, MonadUnliftIO m)
  => FilePath
  -> [T.Text]
  -> T.Text
  -> m (Maybe Msg)
shellTest cmd args msg = do
  rc <- proc cmd (T.unpack <$> args) (runProcess . setStdout nullStream)
  return $ case rc of
    ExitSuccess -> Nothing
    _ -> Just $ Msg LevelError msg

unitType :: UnitType -> T.Text
unitType SystemUnit = "system"
unitType UserUnit = "user"

--------------------------------------------------------------------------------
-- Font 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 :: T.Text -> T.Text -> [Fulfillment] -> Always FontBuilder
fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont
  where
    root = IORoot id $ fontTree fam ful

fontSometimes :: T.Text -> T.Text -> [Fulfillment] -> Sometimes FontBuilder
fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root
  where
    root = IORoot id $ fontTree fam ful

fontFeatureName :: T.Text -> T.Text
fontFeatureName n = T.unwords ["Font family for", singleQuote n]

fontTreeAlt :: T.Text -> [Fulfillment] -> Tree IODependency d_ FontBuilder
fontTreeAlt fam ful = Or (fontTree fam ful) $ Only $ IOConst fallbackFont

fontTree :: T.Text -> [Fulfillment] -> Tree IODependency d_ FontBuilder
fontTree n = Only . fontDependency n

fontTree_ :: T.Text -> [Fulfillment] -> IOTree_
fontTree_ n = Only_ . fontDependency_ n

fontDependency :: T.Text -> [Fulfillment] -> IODependency FontBuilder
fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam

fontDependency_ :: T.Text -> [Fulfillment] -> IODependency_
fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont fam

fontTestName :: T.Text -> T.Text
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]

-- testFont :: T.Text -> XIO (Result FontBuilder)
-- testFont = liftIO . testFont'

testFont
  :: (MonadUnliftIO m, MonadReader env m, HasProcessContext env, HasLogFunc env)
  => T.Text
  -> m (Result FontBuilder)
testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
  where
    msg = T.unwords ["font family", qFam, "not found"]
    args = [qFam]
    qFam = singleQuote fam
    pass = Right $ PostPass (buildFont $ Just fam) []

--------------------------------------------------------------------------------
-- Network Testers
--
-- ASSUME that the system uses systemd in which case ethernet interfaces always
-- start with "en" and wireless interfaces always start with "wl"

readEthernet :: IODependency T.Text
readEthernet = readInterface "get ethernet interface" isEthernet

readWireless :: IODependency T.Text
readWireless = readInterface "get wireless interface" isWireless

isWireless :: T.Text -> Bool
isWireless = T.isPrefixOf "wl"

isEthernet :: T.Text -> Bool
isEthernet = T.isPrefixOf "en"

listInterfaces :: MonadUnliftIO m => m [T.Text]
listInterfaces =
  fromRight []
    <$> tryIO (fmap T.pack <$> listDirectory sysfsNet)

sysfsNet :: FilePath
sysfsNet = "/sys/class/net"

-- ASSUME there are no (non-base) packages required to make these interfaces
-- work (all at the kernel level)
readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
readInterface n f = IORead n [] go
  where
    go = io $ do
      ns <- filter f <$> listInterfaces
      case ns of
        [] -> return $ Left [Msg LevelError "no interfaces found"]
        (x : xs) -> do
          return $
            Right $
              PostPass x $
                fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs

--------------------------------------------------------------------------------
-- Misc testers

socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
socketExists n ful =
  IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'

socketExists' :: MonadUnliftIO m => m FilePath -> m (Maybe Msg)
socketExists' getPath = do
  p <- getPath
  r <- tryIO $ liftIO $ getFileStatus p
  return $ case r of
    Left e -> toErr $ T.pack $ ioe_description e
    Right s | isSocket s -> Nothing
    _ -> toErr $ T.append (T.pack p) " is not a socket"
  where
    toErr = Just . Msg LevelError

--------------------------------------------------------------------------------
-- DBus Dependency Testing

introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"

introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"

testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d

testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = io $ do
  ret <- callMethod cl queryBus queryPath queryIface queryMem
  return $ case ret of
    Left e -> Left [Msg LevelError e]
    Right b ->
      let ns = bodyGetNames b
       in if bus' `elem` ns
            then Right []
            else
              Left
                [ Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
                ]
  where
    bus' = T.pack $ formatBusName bus
    queryBus = busName_ "org.freedesktop.DBus"
    queryIface = interfaceName_ "org.freedesktop.DBus"
    queryPath = objectPath_ "/"
    queryMem = memberName_ "ListNames"
    bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
    bodyGetNames _ = []
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
  ret <- callMethod cl busname objpath introspectInterface introspectMethod
  return $ case ret of
    Left e -> Left [Msg LevelError e]
    Right body -> procBody body
  where
    procBody body =
      let res =
            findMem
              =<< I.parseXML objpath
              =<< fromVariant
              =<< listToMaybe body
       in case res of
            Just True -> Right []
            _ -> Left [Msg LevelError $ 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 (T.pack . I.propertyName) I.interfaceProperties
    elemMember n fname fmember = elem n . fmap fname . fmember
    fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)]
    fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)]
    fmtMem (Property_ n) = T.unwords ["property", singleQuote n]
    fmtMsg' m =
      T.unwords
        [ "could not find"
        , fmtMem m
        , "on interface"
        , singleQuote $ T.pack $ formatInterfaceName iface
        , "on bus"
        , T.pack $ formatBusName busname
        ]
testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i

--------------------------------------------------------------------------------
-- IO Lifting functions

-- ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
-- ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs

-- ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
-- ioAlways (Always n x) = Always n $ ioAlways' x

-- ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a)
-- ioAlways' (Always_ ar) = Always_ $ ioFallbackRoot ar
-- ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a

-- ioFallbackRoot :: MonadIO m => FallbackRoot (IO a) -> FallbackRoot (m a)
-- ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a
-- ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s

-- 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_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a
sometimes1_ x fn n t =
  Sometimes
    fn
    x
    [Subfeature {sfData = t, sfName = n}]

always1_ :: T.Text -> T.Text -> Root a -> a -> Always a
always1_ fn n t x =
  Always fn $
    Option (Subfeature {sfData = t, sfName = n}) (Always_ $ FallbackAlone x)

sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a
sometimes1 = sometimes1_ (const True)

always1 :: T.Text -> T.Text -> Root a -> a -> Always a
always1 = always1_

sometimesIO_ :: T.Text -> T.Text -> IOTree_ -> a -> Sometimes a
sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t

sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t

sometimesExe
  :: MonadIO m
  => T.Text
  -> T.Text
  -> [Fulfillment]
  -> Bool
  -> FilePath
  -> Sometimes (m ())
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []

sometimesExeArgs
  :: MonadIO m
  => T.Text
  -> T.Text
  -> [Fulfillment]
  -> Bool
  -> FilePath
  -> [T.Text]
  -> Sometimes (m ())
sometimesExeArgs fn n ful sys path args =
  sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args

sometimesDBus
  :: SafeClient c
  => Maybe c
  -> T.Text
  -> T.Text
  -> Tree_ (DBusDependency_ c)
  -> (c -> a)
  -> Sometimes a
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c

sometimesEndpoint
  :: (SafeClient c, MonadIO m)
  => T.Text
  -> T.Text
  -> [Fulfillment]
  -> BusName
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> Maybe c
  -> Sometimes (m ())
sometimesEndpoint fn name ful busname path iface mem cl =
  sometimesDBus cl fn name deps cmd
  where
    deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
    cmd c = io $ void $ callMethod c busname path iface mem

--------------------------------------------------------------------------------
-- 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 Msg
voidRead (Left []) = Just $ Msg LevelError "unspecified error"
voidRead (Left (e : _)) = Just e
voidRead (Right _) = Nothing

readResult_ :: Maybe Msg -> Result_
readResult_ (Just w) = Left [w]
readResult_ _ = Right []

--------------------------------------------------------------------------------
-- IO Dependency Constructors

exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_
exe b ful = IOSystem_ ful . Executable b

sysExe :: [Fulfillment] -> FilePath -> IODependency_
sysExe = exe True

localExe :: [Fulfillment] -> FilePath -> IODependency_
localExe = exe False

path' :: Bool -> Bool -> FilePath -> [Fulfillment] -> IODependency_
path' r w n ful = IOSystem_ ful $ AccessiblePath n r w

pathR :: FilePath -> [Fulfillment] -> IODependency_
pathR = path' True False

pathW :: FilePath -> [Fulfillment] -> IODependency_
pathW = path' False True

pathRW :: FilePath -> [Fulfillment] -> IODependency_
pathRW = path' True True

sysd :: UnitType -> [Fulfillment] -> T.Text -> IODependency_
sysd u ful = IOSystem_ ful . Systemd u

sysdUser :: [Fulfillment] -> T.Text -> IODependency_
sysdUser = sysd UserUnit

sysdSystem :: [Fulfillment] -> T.Text -> IODependency_
sysdSystem = sysd SystemUnit

process :: [Fulfillment] -> T.Text -> IODependency_
process ful = IOSystem_ ful . Process

--------------------------------------------------------------------------------
-- Dependency data for JSON

type DependencyData = [Fulfillment]

dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData
dataSubfeatureRoot Subfeature {sfData = r} = dataRoot r

dataRoot :: Root a -> DependencyData
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
  :: forall d d_ p
   . (forall q. d q -> DependencyData)
  -> (d_ -> DependencyData)
  -> Tree d d_ p
  -> DependencyData
dataTree f f_ = go
  where
    go :: forall q. Tree d d_ q -> DependencyData
    go (And12 _ a b) = go a ++ go b
    go (And1 a b) = go a ++ dataTree_ f_ b
    go (And2 a b) = dataTree_ f_ a ++ go b
    go (Or a _) = go a
    go (Only d) = f d

dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> DependencyData
dataTree_ f_ = go
  where
    go (And_ a b) = go a ++ go b
    go (Or_ a _) = go a
    go (Only_ d) = f_ d

dataIODependency :: IODependency p -> DependencyData
dataIODependency d = case d of
  (IORead _ f _) -> f
  (IOSometimes x _) -> dumpSometimes x
  (IOAlways x _) -> dumpAlways x
  _ -> []

dataIODependency_ :: IODependency_ -> DependencyData
dataIODependency_ d = case d of
  (IOSystem_ f _) -> f
  (IOTest_ _ f _) -> f
  (IOSometimes_ x) -> dumpSometimes x

dataDBusDependency :: DBusDependency_ c -> DependencyData
dataDBusDependency d = case d of
  (Bus f _) -> f
  (Endpoint f _ _ _ _) -> f
  (DBusIO x) -> dataIODependency_ x

--------------------------------------------------------------------------------
-- formatting

bracket :: T.Text -> T.Text
bracket s = T.concat ["[", s, "]"]