diff --git a/bin/xmobar.hs b/bin/xmobar.hs index ac22d4f..c0eb163 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -16,7 +16,7 @@ import Data.Either import Data.List import Data.Maybe -import DBus +import DBus.Client import System.Directory import System.Exit @@ -41,6 +41,8 @@ import XMonad.Hooks.DynamicLog import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.IntelBacklight +import XMonad.Internal.DBus.Common +import XMonad.Internal.DBus.Control import XMonad.Internal.Shell -- import XMonad.Internal.DBus.Common (xmonadBus) -- import XMonad.Internal.DBus.Control (pathExists) @@ -52,12 +54,15 @@ import Xmobar main :: IO () main = do - rs <- sequence rightPlugins + sysClient <- getDBusClient True + sesClient <- getDBusClient False + rs <- rightPlugins sysClient sesClient warnMissing rs cs <- getAllCommands rs d <- getXMonadDir -- this is needed to see any printed messages hFlush stdout + mapM_ (maybe skip disconnect) [sysClient, sesClient] xmobar $ config cs d config :: BarRegions -> String -> Config @@ -225,8 +230,8 @@ dateCmd = CmdSpec -- some commands depend on the presence of interfaces that can only be -- determined at runtime; define these checks here -dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency -dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem) +-- dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency +-- dbusDep usesys bus obj iface mem = DBusEndpoint (Bus usesys bus) (Endpoint obj iface mem) -- in the case of network interfaces, assume that the system uses systemd in -- which case ethernet interfaces always start with "en" and wireless @@ -245,15 +250,15 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet) sysfsNet :: FilePath sysfsNet = "/sys/class/net" -readInterface :: (String -> Bool) -> IO (Maybe String) +readInterface :: (String -> Bool) -> IO (Either [String] String) readInterface f = do ns <- filter f <$> listInterfaces case ns of + [] -> return $ Left ["no interfaces found"] (x:xs) -> do unless (null xs) $ putStrLn $ "WARNING: extra interfaces found, using " ++ x - return $ Just x - _ -> return Nothing + return $ Right x vpnPresent :: IO (Maybe String) vpnPresent = do @@ -265,96 +270,96 @@ vpnPresent = do where args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] -rightPlugins :: [IO (MaybeAction CmdSpec)] -rightPlugins = +rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec] +rightPlugins sysClient sesClient = mapM evalFeature [ getWireless , getEthernet - , evalFeature getVPN - , evalFeature getBt - , evalFeature getAlsa - , evalFeature getBattery - , evalFeature getBl - , evalFeature getCk - , evalFeature getSs - , nocheck lockCmd - , nocheck dateCmd + , getVPN + , getBt sysClient + , getAlsa + , getBattery + , getBl sesClient + , getCk sesClient + , getSs sesClient + , ConstFeature lockCmd + , ConstFeature dateCmd ] - where - nocheck = return . Right -getWireless :: IO (MaybeAction CmdSpec) -getWireless = do - i <- readInterface isWireless - return $ maybe (Left []) (Right . wirelessCmd) i +getWireless :: BarFeature +getWireless = Feature + { ftrMaybeAction = Chain wirelessCmd $ readInterface isWireless + , ftrName = "wireless status indicator" + , ftrWarning = Default + } + -- i <- readInterface isWireless + -- return $ maybe (Left []) (Right . wirelessCmd) i -getEthernet :: IO (MaybeAction CmdSpec) -getEthernet = do - i <- readInterface isEthernet - evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i - where - dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP +-- TODO this needs a dbus interface +getEthernet :: BarFeature +getEthernet = Feature + { ftrMaybeAction = Chain ethernetCmd (readInterface isEthernet) + , ftrName = "ethernet status indicator" + , ftrWarning = Default + } + + -- i <- readInterface isEthernet + -- evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i + -- where + -- dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP getBattery :: BarFeature getBattery = Feature - { ftrMaybeAction = batteryCmd + { ftrMaybeAction = Parent batteryCmd [IOTest hasBattery] , ftrName = "battery level indicator" , ftrWarning = Default - , ftrChildren = [IOTest hasBattery] } type BarFeature = Feature CmdSpec getVPN :: BarFeature getVPN = Feature - { ftrMaybeAction = vpnCmd + { ftrMaybeAction = Parent vpnCmd [v] , ftrName = "VPN status indicator" , ftrWarning = Default - , ftrChildren = [d, v] } where - d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType + -- d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType v = IOTest vpnPresent -getBt :: BarFeature -getBt = Feature - { ftrMaybeAction = btCmd +getBt :: Maybe Client -> BarFeature +getBt client = Feature + { ftrMaybeAction = DBusEndpoint_ (const btCmd) btBus client + [Endpoint btPath btInterface $ Property_ btPowered] , ftrName = "bluetooth status indicator" , ftrWarning = Default - , ftrChildren = [dep] } - where - dep = dbusDep True btBus btPath btInterface $ Property_ btPowered getAlsa :: BarFeature getAlsa = Feature - { ftrMaybeAction = alsaCmd + { ftrMaybeAction = Parent alsaCmd [Executable "alsactl"] , ftrName = "volume level indicator" , ftrWarning = Default - , ftrChildren = [Executable "alsactl"] } -getBl :: BarFeature -getBl = Feature - { ftrMaybeAction = blCmd +getBl :: Maybe Client -> BarFeature +getBl client = Feature + { ftrMaybeAction = DBusEndpoint_ (const blCmd) xmonadBusName client [intelBacklightSignalDep] , ftrName = "Intel backlight indicator" , ftrWarning = Default - , ftrChildren = [intelBacklightSignalDep] } -getCk :: BarFeature -getCk = Feature - { ftrMaybeAction = ckCmd +getCk :: Maybe Client -> BarFeature +getCk client = Feature + { ftrMaybeAction = DBusEndpoint_ (const ckCmd) xmonadBusName client [clevoKeyboardSignalDep] , ftrName = "Clevo keyboard indicator" , ftrWarning = Default - , ftrChildren = [clevoKeyboardSignalDep] } -getSs :: BarFeature -getSs = Feature - { ftrMaybeAction = ssCmd +getSs :: Maybe Client -> BarFeature +getSs client = Feature + { ftrMaybeAction = DBusEndpoint_ (const ssCmd) xmonadBusName client [ssSignalDep] , ftrName = "screensaver indicator" , ftrWarning = Default - , ftrChildren = [ssSignalDep] } getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 217a0ef..0855d80 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -76,12 +76,14 @@ import XMonad.Util.WorkspaceCompare main :: IO () main = do - cl <- startXMonadService + sesClient <- startXMonadService + sysClient <- getDBusClient True (h, p) <- spawnPipe "xmobar" - mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon] + mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon sysClient] forkIO_ $ runWorkspaceMon allDWs let ts = ThreadState - { tsClient = cl + { tsSessionClient = sesClient + , tsSystemClient = sysClient , tsChildPIDs = [p] , tsChildHandles = [h] } @@ -114,16 +116,18 @@ main = do -- | Concurrency configuration data ThreadState = ThreadState - { tsClient :: Maybe Client - , tsChildPIDs :: [ProcessHandle] - , tsChildHandles :: [Handle] + { tsSessionClient :: Maybe Client + , tsSystemClient :: Maybe Client + , tsChildPIDs :: [ProcessHandle] + , tsChildHandles :: [Handle] } -- TODO shouldn't this be run by a signal handler? runCleanup :: ThreadState -> X () runCleanup ts = io $ do mapM_ killHandle $ tsChildPIDs ts - forM_ (tsClient ts) stopXMonadService + forM_ (tsSessionClient ts) stopXMonadService + forM_ (tsSystemClient ts) disconnect -------------------------------------------------------------------------------- -- | Startuphook configuration @@ -568,12 +572,12 @@ externalBindings ts lock = , KeyBinding "M-" "select autorandr profile" runAutorandrMenu , KeyBinding "M-" "toggle ethernet" runToggleEthernet , KeyBinding "M-" "toggle bluetooth" runToggleBluetooth - , KeyBinding "M-" "toggle screensaver" $ maybe BlankFeature (ioFeature . callToggle) cl + , KeyBinding "M-" "toggle screensaver" $ ioFeature $ callToggle cl , KeyBinding "M-" "switch gpu" runOptimusPrompt ] ] where - cl = tsClient ts - brightessControls ctl getter = maybe BlankFeature (ioFeature . getter . ctl) cl + cl = tsSessionClient ts + brightessControls ctl getter = (ioFeature . getter . ctl) cl ib = brightessControls intelBacklightControls ck = brightessControls clevoKeyboardControls diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 3d12a64..aa14ab9 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -33,13 +33,17 @@ memAdded = memberName_ "InterfacesAdded" memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" -dbusDep :: MemberName -> Dependency -dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m) +-- dbusDep :: MemberName -> Dependency +-- dbusDep m = DBusEndpoint (Bus True bus) (Endpoint path interface $ Signal_ m) +dbusDep :: MemberName -> Endpoint +dbusDep m = Endpoint path interface $ Signal_ m -addedDep :: Dependency +-- addedDep :: Dependency +addedDep :: Endpoint addedDep = dbusDep memAdded -removedDep :: Dependency +-- removedDep :: Dependency +removedDep :: Endpoint removedDep = dbusDep memRemoved driveInsertedSound :: FilePath @@ -84,6 +88,9 @@ listenDevices = do addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m } $ playSoundMaybe p . f . signalBody -runRemovableMon :: FeatureIO -runRemovableMon = - featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices +runRemovableMon :: Maybe Client -> FeatureIO +runRemovableMon client = Feature + { ftrMaybeAction = DBusEndpoint_ (const listenDevices) bus client [addedDep, removedDep] + , ftrName = "removeable device monitor" + , ftrWarning = Default + } diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 8e15252..c6f6601 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -113,14 +113,15 @@ stateFileDep = pathRW stateFile brightnessFileDep :: Dependency brightnessFileDep = pathR brightnessFile -clevoKeyboardSignalDep :: Dependency +-- clevoKeyboardSignalDep :: Dependency +clevoKeyboardSignalDep :: Endpoint clevoKeyboardSignalDep = signalDep clevoKeyboardConfig -exportClevoKeyboard :: Client -> FeatureIO +exportClevoKeyboard :: Maybe Client -> FeatureIO exportClevoKeyboard = brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig -clevoKeyboardControls :: Client -> BrightnessControls +clevoKeyboardControls :: Maybe Client -> BrightnessControls clevoKeyboardControls = brightnessControls clevoKeyboardConfig callGetBrightnessCK :: Client -> IO (Maybe Brightness) diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index d8f45f4..3cc2355 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -50,7 +50,7 @@ data BrightnessControls = BrightnessControls , bctlDec :: FeatureIO } -brightnessControls :: BrightnessConfig a b -> Client -> BrightnessControls +brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls brightnessControls bc client = BrightnessControls { bctlMax = cb "max brightness" memMax @@ -67,9 +67,10 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = do reply <- callMethod client xmonadBusName p i memGet return $ either (const Nothing) bodyGetBrightness reply -signalDep :: BrightnessConfig a b -> Dependency +-- signalDep :: BrightnessConfig a b -> Dependency +signalDep :: BrightnessConfig a b -> Endpoint signalDep BrightnessConfig { bcPath = p, bcInterface = i } = - DBusEndpoint xmonadBus $ Endpoint p i $ Signal_ memCur + Endpoint p i $ Signal_ memCur matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do @@ -88,12 +89,11 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do -- | Internal DBus Crap brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b - -> Client -> FeatureIO + -> Maybe Client -> FeatureIO brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature - { ftrMaybeAction = exportBrightnessControls' bc client + { ftrMaybeAction = DBusBus_ (exportBrightnessControls' bc) xmonadBusName client deps , ftrName = n ++ " exporter" , ftrWarning = Default - , ftrChildren = DBusBus xmonadBus:deps } exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO () @@ -131,7 +131,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = where sig = signal p i memCur -callBacklight :: Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO +callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO callBacklight client BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m = (featureEndpoint xmonadBusName p i m client) { ftrName = unwords [n, controlName] } diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index aad4d6c..db882ef 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -95,14 +95,15 @@ curFileDep = pathRW curFile maxFileDep :: Dependency maxFileDep = pathR maxFile -intelBacklightSignalDep :: Dependency +-- intelBacklightSignalDep :: Dependency +intelBacklightSignalDep :: Endpoint intelBacklightSignalDep = signalDep intelBacklightConfig -exportIntelBacklight :: Client -> FeatureIO +exportIntelBacklight :: Maybe Client -> FeatureIO exportIntelBacklight = brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig -intelBacklightControls :: Client -> BrightnessControls +intelBacklightControls :: Maybe Client -> BrightnessControls intelBacklightControls = brightnessControls intelBacklightConfig callGetBrightnessIB :: Client -> IO (Maybe Brightness) diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 861c2fe..bc93167 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -7,7 +7,7 @@ module XMonad.Internal.DBus.Common ( addMatchCallback , xmonadBus , xmonadBusName - , xDbusDep + -- , xDbusDep -- , initControls ) where @@ -22,8 +22,8 @@ xmonadBusName = busName_ "org.xmonad" xmonadBus :: Bus xmonadBus = Bus False xmonadBusName -xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency -xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m +-- xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency +-- xDbusDep o i m = DBusEndpoint xmonadBus $ Endpoint o i m -- -- | Call a method and return its result if successful -- callMethod :: MethodCall -> IO (Maybe [Variant]) diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 46f59be..6c2816e 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -6,9 +6,11 @@ module XMonad.Internal.DBus.Control ( Client , startXMonadService + , getDBusClient , stopXMonadService , pathExists , xmonadBus + , disconnect ) where import Control.Exception @@ -33,21 +35,21 @@ introspectMethod = memberName_ "Introspect" startXMonadService :: IO (Maybe Client) startXMonadService = do - client <- getDBusClient - forM_ client $ \c -> do - requestXMonadName c - mapM_ (\f -> executeFeature_ $ f c) - [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] + client <- getDBusClient False + forM_ client requestXMonadName + mapM_ (\f -> executeFeature_ $ f client) exporters return client + where + exporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] stopXMonadService :: Client -> IO () stopXMonadService client = do void $ releaseName client xmonadBusName disconnect client -getDBusClient :: IO (Maybe Client) -getDBusClient = do - res <- try connectSession +getDBusClient :: Bool -> IO (Maybe Client) +getDBusClient sys = do + res <- try $ if sys then connectSystem else connectSession case res of Left e -> putStrLn (clientErrorMessage e) >> return Nothing Right c -> return $ Just c diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 00893a3..7bd0d36 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -93,18 +93,17 @@ bodyGetCurrentState _ = Nothing -------------------------------------------------------------------------------- -- | Exported haskell API -exportScreensaver :: Client -> FeatureIO +exportScreensaver :: Maybe Client -> FeatureIO exportScreensaver client = Feature - { ftrMaybeAction = cmd + { ftrMaybeAction = DBusBus_ cmd xmonadBusName client [Executable ssExecutable] , ftrName = "screensaver interface" , ftrWarning = Default - , ftrChildren = [Executable ssExecutable, DBusBus xmonadBus] } where - cmd = export client ssPath defaultInterface + cmd cl = export cl ssPath defaultInterface { interfaceName = interface , interfaceMethods = - [ autoMethod memToggle $ emitState client =<< toggle + [ autoMethod memToggle $ emitState cl =<< toggle , autoMethod memQuery query ] , interfaceSignals = [sig] @@ -120,7 +119,7 @@ exportScreensaver client = Feature ] } -callToggle :: Client -> FeatureIO +callToggle :: Maybe Client -> FeatureIO callToggle client = (featureEndpoint xmonadBusName ssPath interface memToggle client) { ftrName = "screensaver toggle" } @@ -141,6 +140,8 @@ callQuery client = do matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState -ssSignalDep :: Dependency -ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface - $ Signal_ memState +-- ssSignalDep :: Dependency +ssSignalDep :: Endpoint +-- ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface +-- $ Signal_ memState +ssSignalDep = Endpoint ssPath interface $ Signal_ memState diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 25d4048..6c4db28 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -1,9 +1,18 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} + -------------------------------------------------------------------------------- -- | Functions for handling dependencies module XMonad.Internal.Dependency ( MaybeAction , MaybeX + , Parent(..) + -- , ConstFeature(..) + , Chain(..) + , DBusEndpoint_(..) + , DBusBus_(..) , FeatureX , FeatureIO , Feature(..) @@ -37,7 +46,7 @@ module XMonad.Internal.Dependency import Control.Monad (void) import Control.Monad.IO.Class -import Data.Bifunctor (bimap) +import Data.Bifunctor (bimap, first, second) import Data.List (find) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) @@ -67,14 +76,34 @@ import XMonad.Internal.Shell -- dependencies that target the output/state of another feature; this is more -- robust anyways, at the cost of being a bit slower. -data Feature a = Feature - { ftrMaybeAction :: a +data Feature a = forall e. Evaluable e => Feature + { ftrMaybeAction :: e a , ftrName :: String , ftrWarning :: Warning - , ftrChildren :: [Dependency] + -- , ftrChildren :: [Dependency] } | ConstFeature a - | BlankFeature + -- | BlankFeature + +-- TODO this name sucks +data Parent a = Parent a [Dependency] deriving (Functor) + +-- newtype ConstFeature a = ConstFeature a deriving (Functor) + +data Chain a = forall b. Chain (b -> a) (IO (Either [String] b)) + +instance Functor Chain where + fmap f (Chain a b) = Chain (f . a) b + +data DBusEndpoint_ a = DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint] + +instance Functor DBusEndpoint_ where + fmap f (DBusEndpoint_ a b c eps) = DBusEndpoint_ (f . a) b c eps + +data DBusBus_ a = DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency] + +instance Functor DBusBus_ where + fmap f (DBusBus_ a b c eps) = DBusBus_ (f . a) b c eps -- TODO this is silly as is, and could be made more useful by representing -- loglevels @@ -84,17 +113,21 @@ type FeatureX = Feature (X ()) type FeatureIO = Feature (IO ()) -ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a) -ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a } -ioFeature (ConstFeature f) = ConstFeature $ liftIO f -ioFeature BlankFeature = BlankFeature +ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b) +ioFeature (ConstFeature a) = ConstFeature $ liftIO a +ioFeature Feature {..} = + -- HACK just doing a normal record update here will make GHC complain about + -- an 'insufficiently polymorphic record update' ...I guess because my + -- GADT isn't polymorphic enough (which is obviously BS) + Feature {ftrMaybeAction = liftIO <$> ftrMaybeAction, ..} featureDefault :: String -> [Dependency] -> a -> Feature a featureDefault n ds x = Feature - { ftrMaybeAction = x + -- { ftrMaybeAction = x + { ftrMaybeAction = Parent x ds , ftrName = n , ftrWarning = Default - , ftrChildren = ds + -- , ftrChildren = ds } featureExe :: MonadIO m => String -> String -> Feature (m ()) @@ -104,17 +137,18 @@ featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ()) featureExeArgs n cmd args = featureDefault n [Executable cmd] $ spawnCmd cmd args --- TODO the bus and client might refer to different things featureEndpoint :: BusName -> ObjectPath -> InterfaceName -> MemberName - -> Client -> FeatureIO + -> Maybe Client -> FeatureIO featureEndpoint busname path iface mem client = Feature - { ftrMaybeAction = cmd + -- { ftrMaybeAction = cmd + { ftrMaybeAction = DBusEndpoint_ cmd busname client deps , ftrName = "screensaver toggle" , ftrWarning = Default - , ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem] + -- , ftrChildren = [DBusEndpoint (Bus False busname) $ Endpoint path iface $ Method_ mem] } where - cmd = void $ callMethod client busname path iface mem + cmd = \c -> void $ callMethod c busname path iface mem + deps = [Endpoint path iface $ Method_ mem] -------------------------------------------------------------------------------- -- | Feature evaluation @@ -123,24 +157,62 @@ featureEndpoint busname path iface mem client = Feature -- either the action of the feature or 0 or more error messages that signify -- what dependencies are missing and why. +class Functor e => Evaluable e where + eval :: e a -> IO (MaybeAction a) + type MaybeAction a = Either [String] a type MaybeX = MaybeAction (X ()) +instance Evaluable Parent where + eval (Parent a ds) = do + es <- catMaybes <$> mapM evalDependency ds + return $ case es of + [] -> Right a + es' -> Left es' + +-- instance Evaluable ConstFeature where +-- eval (ConstFeature a) = return $ Right a + +instance Evaluable Chain where + eval (Chain a b) = second a <$> b + +instance Evaluable DBusEndpoint_ where + eval (DBusEndpoint_ _ _ Nothing _) = return $ Left ["client not available"] + eval (DBusEndpoint_ action busname (Just client) deps) = do + es <- catMaybes <$> mapM (endpointSatisfied client busname) deps + return $ case es of + [] -> Right $ action client + es' -> Left es' + +instance Evaluable DBusBus_ where + eval (DBusBus_ _ _ Nothing _) = return $ Left ["client not available"] + eval (DBusBus_ action busname (Just client) deps) = do + res <- busSatisfied client busname + es <- catMaybes . (res:) <$> mapM evalDependency deps + return $ case es of + [] -> Right $ action client + es' -> Left es' + +-- instance Evaluable BlankFeature where +-- eval (BlankFeature a) = Left ["hopefully a useful error message"] + evalFeature :: Feature a -> IO (MaybeAction a) evalFeature (ConstFeature x) = return $ Right x -evalFeature BlankFeature = return $ Left [] +-- evalFeature BlankFeature = return $ Left [] evalFeature Feature { ftrMaybeAction = a , ftrName = n , ftrWarning = w - , ftrChildren = c + -- , ftrChildren = c } = do procName <- getProgName - es <- catMaybes <$> mapM evalDependency c - return $ case es of - [] -> Right a - es' -> Left $ fmtWarnings procName es' + res <- eval a + return $ first (fmtWarnings procName) res + -- es <- catMaybes <$> mapM evalDependency c + -- return $ case res of + -- [] -> Right a + -- es' -> Left $ fmtWarnings procName es' where fmtWarnings procName es = case w of Silent -> [] @@ -173,10 +245,11 @@ ifSatisfied _ alt = alt data Dependency = Executable String | AccessiblePath FilePath Bool Bool | IOTest (IO (Maybe String)) - | DBusEndpoint Bus Endpoint - | DBusBus Bus + -- | DBusEndpoint Bus Endpoint + -- | DBusBus Bus | Systemd UnitType String + data UnitType = SystemUnit | UserUnit deriving (Eq, Show) data DBusMember = Method_ MemberName @@ -214,8 +287,8 @@ evalDependency (Executable n) = exeSatisfied n evalDependency (IOTest t) = t evalDependency (Systemd t n) = unitSatisfied t n evalDependency (AccessiblePath p r w) = pathSatisfied p r w -evalDependency (DBusEndpoint b e) = endpointSatisfied b e -evalDependency (DBusBus b) = busSatisfied b +-- evalDependency (DBusEndpoint b e) = endpointSatisfied b e +-- evalDependency (DBusBus b) = busSatisfied b exeSatisfied :: String -> IO (Maybe String) exeSatisfied x = do @@ -266,11 +339,11 @@ callMethod client bus path iface mem = do { methodCallDestination = Just bus } return $ bimap methodErrorMessage methodReturnBody reply -busSatisfied :: Bus -> IO (Maybe String) -busSatisfied (Bus usesystem bus) = do - client <- if usesystem then connectSystem else connectSession +busSatisfied :: Client -> BusName -> IO (Maybe String) +busSatisfied client bus = do + -- client <- if usesystem then connectSystem else connectSession ret <- callMethod client queryBus queryPath queryIface queryMem - disconnect client + -- disconnect client return $ case ret of Left e -> Just e Right b -> let ns = bodyGetNames b in @@ -285,11 +358,11 @@ busSatisfied (Bus usesystem bus) = do bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames _ = [] -endpointSatisfied :: Bus -> Endpoint -> IO (Maybe String) -endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do - client <- if u then connectSystem else connectSession - ret <- callMethod client bus objpath introspectInterface introspectMethod - disconnect client +endpointSatisfied :: Client -> BusName -> Endpoint -> IO (Maybe String) +endpointSatisfied client busname (Endpoint objpath iface mem) = do + -- client <- if u then connectSystem else connectSession + ret <- callMethod client busname objpath introspectInterface introspectMethod + -- disconnect client return $ case ret of Left e -> Just e Right body -> procBody body @@ -315,7 +388,7 @@ endpointSatisfied (Bus u bus) (Endpoint objpath iface mem) = do , "on interface" , singleQuote $ formatInterfaceName iface , "on bus" - , formatBusName bus + , formatBusName busname ] --------------------------------------------------------------------------------