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

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

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

module Data.Internal.Dependency
  -- feature types
  ( Feature
  , Always(..)
  , Always_(..)
  , FallbackRoot(..)
  , FallbackStack(..)
  , Sometimes(..)
  , Sometimes_
  , AlwaysX
  , AlwaysIO
  , SometimesX
  , SometimesIO
  , PostPass(..)
  , Subfeature(..)
  , SubfeatureRoot
  , Msg(..)

  -- configuration
  , 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
  , FIO
  , withCache
  , 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           Control.Monad.IO.Class
import           Control.Monad.Identity
import           Control.Monad.Reader

import           Data.Aeson             hiding (Error, Result)
import           Data.Aeson.Key
import           Data.Bifunctor
import           Data.Either
import           Data.Internal.DBus
import           Data.List
import           Data.Maybe
import           Data.Yaml

import           GHC.IO.Exception       (ioe_description)

import           DBus                   hiding (typeOf)
import qualified DBus.Introspection     as I

import           RIO                    hiding (bracket, fromString)
import           RIO.FilePath
import           RIO.Process            hiding (findExecutable)
import qualified RIO.Text               as T

import           System.Directory
import           System.Environment
import           System.IO.Error
import           System.Posix.Files
import           System.Process.Typed   (nullStream)

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)
withCache :: FIO a -> IO a
withCache x = do
  logOpts <- logOptionsHandle stderr False
  pc <- mkDefaultProcessContext
  withLogFunc logOpts $ \f -> do
    p <- getParams
    let s = DepStage f pc p
    runRIO s x

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

-- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
executeSometimes a = maybe (return Nothing) (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 (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 -> FIO a
evalAlways a = do
  (x, ws) <- evalAlwaysMsg a
  mapM_ logMsg ws
  return x

logMsg :: FMsg -> FIO ()
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 -> T.Text
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", 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 (FIO ())

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] (FIO (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] (FIO (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 FIO a = RIO DepStage a

data DepStage = DepStage
  { dsLogFun  :: !LogFunc
  , dsProcCxt :: !ProcessContext
  , dsParams  :: !XParams
  }

instance HasLogFunc DepStage where
  logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y })

instance HasProcessContext DepStage where
  processContextL = lens dsProcCxt (\x y -> x { dsProcCxt = 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 :: IO XParams
getParams = do
  p <- getParamFile
  maybe (return defParams) decodeYaml p
  where
    decodeYaml p = either (\e -> print e >> return defParams) return
      =<< decodeFileEither p

getParamFile :: IO (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) <$> fileExist full
  where
    fallback = (</> ".config") <$> getHomeDirectory

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

infix .:+

--------------------------------------------------------------------------------
-- | Testing pipeline

evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do
  r <- asks (u . xpFeatures . dsParams)
  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 -> FIO (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 -> 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 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 -> FIO (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_ -> FIO MResult_)
  -> (forall q. d q -> FIO (MResult q))
  -> Tree d d_ p
  -> FIO (Either [Msg] (PostPass p))
testTree test_ test = go
  where
    go :: forall q. Tree d d_ q -> FIO (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 -> FIO (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 -> FIO MResult_) -> Tree_ d -> FIO 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_ -> FIO MResult_
testIODep_ d = memoizeMVar $ testIODepNoCache_ d

testIODepNoCache_ :: IODependency_ -> FIO 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 :: SystemDependency -> FIO (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 :: FilePath -> [T.Text] -> T.Text -> FIO (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 -> FIO (Result FontBuilder)
-- testFont = liftIO . testFont'

testFont :: T.Text -> FIO (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 :: IO [T.Text]
listInterfaces = fromRight []
  <$> tryIOError (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] -> IO FilePath -> IODependency_
socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
  . io . socketExists'

socketExists' :: IO FilePath -> IO (Maybe Msg)
socketExists' getPath = do
  p <- getPath
  r <- tryIOError $ getFileStatus p
  return $ case r of
    Left e  -> toErr $ T.pack $ ioe_description e
    Right s -> if isSocket s then Nothing else 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 -> FIO MResult_
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d

testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO 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

--------------------------------------------------------------------------------
-- | JSON formatting

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