REF arrange dependency module sanely

This commit is contained in:
Nathan Dwarshuis 2021-11-21 10:26:28 -05:00
parent 31ef889762
commit da1e4a1c79
10 changed files with 193 additions and 164 deletions

View File

@ -40,6 +40,7 @@ import XMonad.Hooks.DynamicLog
)
import XMonad.Internal.Command.Power (hasBattery)
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.Shell
-- import XMonad.Internal.DBus.Common (xmonadBus)
-- import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
@ -263,7 +264,7 @@ vpnPresent = do
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
rightPlugins :: [IO (MaybeExe CmdSpec)]
rightPlugins :: [IO (MaybeAction CmdSpec)]
rightPlugins =
[ getWireless
, getEthernet
@ -280,21 +281,21 @@ rightPlugins =
where
nocheck = return . Right
getWireless :: IO (MaybeExe CmdSpec)
getWireless :: IO (MaybeAction CmdSpec)
getWireless = do
i <- readInterface isWireless
return $ maybe (Left []) (Right . wirelessCmd) i
getEthernet :: IO (MaybeExe CmdSpec)
getEthernet :: IO (MaybeAction CmdSpec)
getEthernet = do
i <- readInterface isEthernet
evalFeature $ maybe BlankFeature (featureRun "ethernet status indicator" [dep] . ethernetCmd) i
evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i
where
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
getBattery :: BarFeature
getBattery = Feature
{ ftrAction = batteryCmd
{ ftrMaybeAction = batteryCmd
, ftrName = "battery level indicator"
, ftrWarning = Default
, ftrChildren = [IOTest hasBattery]
@ -304,7 +305,7 @@ type BarFeature = Feature CmdSpec
getVPN :: BarFeature
getVPN = Feature
{ ftrAction = vpnCmd
{ ftrMaybeAction = vpnCmd
, ftrName = "VPN status indicator"
, ftrWarning = Default
, ftrChildren = [d, v]
@ -315,7 +316,7 @@ getVPN = Feature
getBt :: BarFeature
getBt = Feature
{ ftrAction = btCmd
{ ftrMaybeAction = btCmd
, ftrName = "bluetooth status indicator"
, ftrWarning = Default
, ftrChildren = [dep]
@ -325,7 +326,7 @@ getBt = Feature
getAlsa :: BarFeature
getAlsa = Feature
{ ftrAction = alsaCmd
{ ftrMaybeAction = alsaCmd
, ftrName = "volume level indicator"
, ftrWarning = Default
, ftrChildren = [Executable "alsactl"]
@ -333,7 +334,7 @@ getAlsa = Feature
getBl :: BarFeature
getBl = Feature
{ ftrAction = blCmd
{ ftrMaybeAction = blCmd
, ftrName = "Intel backlight indicator"
, ftrWarning = Default
, ftrChildren = [intelBacklightSignalDep]
@ -341,13 +342,13 @@ getBl = Feature
getSs :: BarFeature
getSs = Feature
{ ftrAction = ssCmd
{ ftrMaybeAction = ssCmd
, ftrName = "screensaver indicator"
, ftrWarning = Default
, ftrChildren = [ssSignalDep]
}
getAllCommands :: [MaybeExe CmdSpec] -> IO BarRegions
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
getAllCommands right = do
let left =
[ CmdSpec

View File

@ -86,7 +86,7 @@ main = do
, tsChildHandles = [h]
}
lockRes <- evalFeature runScreenLock
let lock = whenInstalled lockRes
let lock = whenSatisfied lockRes
ext <- evalExternal $ externalBindings ts lock
warnMissing $ externalToMissing ext
-- IDK why this is necessary; nothing prior to this line will print if missing
@ -464,13 +464,13 @@ internalBindings c =
mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } =
(subtitle h:) $ mkNamedKeymap c
$ (\KeyBinding{kbSyms = s, kbDesc = d, kbAction = a} -> (s, addName d a))
$ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
<$> b
data KeyBinding a = KeyBinding
{ kbSyms :: String
, kbDesc :: String
, kbAction :: a
, kbMaybeAction :: a
}
data KeyGroup a = KeyGroup
@ -485,23 +485,23 @@ evalExternal = mapM go
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbAction = a } =
(\f -> k { kbAction = f }) <$> evalFeature a
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go
where
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
externalToMissing :: [KeyGroup (MaybeExe a)] -> [MaybeExe a]
externalToMissing :: [KeyGroup (MaybeAction a)] -> [MaybeAction a]
externalToMissing = concatMap go
where
go KeyGroup { kgBindings = bs } = fmap kbAction bs
go KeyGroup { kgBindings = bs } = fmap kbMaybeAction bs
flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
(Right x) -> Just $ k{ kbAction = x }
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip }
flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
(Right x) -> Just $ k{ kbMaybeAction = x }
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
externalBindings :: ThreadState -> X () -> [KeyGroup FeatureX]
externalBindings ts lock =

View File

@ -24,6 +24,7 @@ import XMonad.Core hiding (spawn)
import XMonad.Internal.Dependency
import XMonad.Internal.Notify
import XMonad.Internal.Process
import XMonad.Internal.Shell
import XMonad.Util.NamedActions
--------------------------------------------------------------------------------
@ -48,7 +49,7 @@ myDmenuNetworks = "networkmanager_dmenu"
-- | Other internal functions
spawnDmenuCmd :: String -> [String] -> FeatureX
spawnDmenuCmd n = featureSpawnCmd n myDmenuCmd
spawnDmenuCmd n = featureExeArgs n myDmenuCmd
themeArgs :: String -> [String]
themeArgs hexColor =
@ -63,7 +64,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-- | Exported Commands
runDevMenu :: FeatureX
runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do
runDevMenu = featureDefault "device manager" [Executable myDmenuDevices] $ do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices
$ ["-c", c]
@ -71,20 +72,20 @@ runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do
++ myDmenuMatchingArgs
runBwMenu :: FeatureX
runBwMenu = featureRun "password manager" [Executable myDmenuPasswords] $
runBwMenu = featureDefault "password manager" [Executable myDmenuPasswords] $
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
-- TODO this is weirdly inverted
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
runShowKeys x = addName "Show Keybindings" $ do
s <- io $ evalFeature $ runDMenuShowKeys x
ifInstalled s
ifSatisfied s
$ spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" }
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
runDMenuShowKeys kbs =
featureRun "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do
featureDefault "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
where
@ -99,7 +100,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runClipMenu :: FeatureX
runClipMenu =
featureRun "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"]
featureDefault "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"]
$ spawnCmd myDmenuCmd args
where
args = [ "-modi", "\"clipboard:greenclip print\""
@ -112,8 +113,8 @@ runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: FeatureX
runNetMenu =
featureSpawnCmd "network control menu" myDmenuNetworks $ themeArgs "#ff3333"
featureExeArgs "network control menu" myDmenuNetworks $ themeArgs "#ff3333"
runAutorandrMenu :: FeatureX
runAutorandrMenu =
featureSpawnCmd "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066"
featureExeArgs "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066"

View File

@ -91,10 +91,10 @@ ethernetIface = "enp7s0f1"
-- | Some nice apps
runTerm :: FeatureX
runTerm = featureSpawn "terminal" myTerm
runTerm = featureExe "terminal" myTerm
runTMux :: FeatureX
runTMux = featureRun "terminal multiplexer" deps cmd
runTMux = featureDefault "terminal multiplexer" deps cmd
where
deps = [Executable myTerm, Executable "tmux", Executable "bash"]
cmd = spawn
@ -105,25 +105,25 @@ runTMux = featureRun "terminal multiplexer" deps cmd
msg = "could not connect to tmux session"
runCalc :: FeatureX
runCalc = featureRun "calculator" [Executable myTerm, Executable "R"]
runCalc = featureDefault "calculator" [Executable myTerm, Executable "R"]
$ spawnCmd myTerm ["-e", "R"]
runBrowser :: FeatureX
runBrowser = featureSpawn "web browser" myBrowser
runBrowser = featureExe "web browser" myBrowser
runEditor :: FeatureX
runEditor = featureSpawnCmd "text editor" myEditor
runEditor = featureExeArgs "text editor" myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
runFileManager :: FeatureX
runFileManager = featureSpawn "file browser" "pcmanfm"
runFileManager = featureExe "file browser" "pcmanfm"
--------------------------------------------------------------------------------
-- | Multimedia Commands
runMultimediaIfInstalled :: String -> String -> FeatureX
runMultimediaIfInstalled n cmd =
featureSpawnCmd (n ++ " multimedia control") myMultimediaCtl [cmd]
featureExeArgs (n ++ " multimedia control") myMultimediaCtl [cmd]
runTogglePlay :: FeatureX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
@ -151,7 +151,7 @@ playSound file = do
featureSound :: String -> FilePath -> X () -> X () -> FeatureX
featureSound n file pre post =
featureRun ("volume " ++ n ++ " control") [Executable "paplay"]
featureDefault ("volume " ++ n ++ " control") [Executable "paplay"]
$ pre >> playSound file >> post
runVolumeDown :: FeatureX
@ -168,7 +168,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
runNotificationCmd :: String -> String -> FeatureX
runNotificationCmd n cmd =
featureSpawnCmd (n ++ " control") myNotificationCtrl [cmd]
featureExeArgs (n ++ " control") myNotificationCtrl [cmd]
runNotificationClose :: FeatureX
runNotificationClose = runNotificationCmd "close notification" "close"
@ -190,7 +190,7 @@ runNotificationContext =
runToggleBluetooth :: FeatureX
runToggleBluetooth =
featureRun "bluetooth toggle" [Executable myBluetooth]
featureDefault "bluetooth toggle" [Executable myBluetooth]
$ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on"
@ -199,7 +199,7 @@ runToggleBluetooth =
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
runToggleEthernet :: FeatureX
runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"]
runToggleEthernet = featureDefault "ethernet toggle" [Executable "nmcli"]
$ spawn
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
#!&& "a=connect"
@ -208,14 +208,14 @@ runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: FeatureX
runStartISyncTimer = featureRun "isync timer" [userUnit "mbsync.timer"]
runStartISyncTimer = featureDefault "isync timer" [userUnit "mbsync.timer"]
$ spawn
$ "systemctl --user start mbsync.timer"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" }
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
runStartISyncService :: FeatureX
runStartISyncService = featureRun "isync" [userUnit "mbsync.service"]
runStartISyncService = featureDefault "isync" [userUnit "mbsync.service"]
$ spawn
$ "systemctl --user start mbsync.service"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@ -260,7 +260,7 @@ getCaptureDir = do
fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> String -> FeatureX
runFlameshot n mode = featureRun n [Executable myCapture] $ do
runFlameshot n mode = featureDefault n [Executable myCapture] $ do
ssDir <- io getCaptureDir
spawnCmd myCapture $ mode : ["-p", ssDir]
@ -279,6 +279,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: FeatureX
runCaptureBrowser =
featureRun "screen capture browser" [Executable myImageBrowser] $ do
featureDefault "screen capture browser" [Executable myImageBrowser] $ do
dir <- io getCaptureDir
spawnCmd myImageBrowser [dir]

View File

@ -46,7 +46,7 @@ myOptimusManager = "optimus-manager"
-- | Core commands
runScreenLock :: Feature (X ())
runScreenLock = featureSpawn "screen locker" myScreenlock
runScreenLock = featureExe "screen locker" myScreenlock
runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff"
@ -101,24 +101,24 @@ runOptimusPrompt' = do
#!&& "killall xmonad"
runOptimusPrompt :: FeatureX
runOptimusPrompt = featureRun "graphics switcher" [Executable myOptimusManager]
runOptimusPrompt = featureDefault "graphics switcher" [Executable myOptimusManager]
runOptimusPrompt'
--------------------------------------------------------------------------------
-- | Universal power prompt
data PowerAction = Poweroff
data PowerMaybeAction = Poweroff
| Shutdown
| Hibernate
| Reboot
deriving (Eq)
instance Enum PowerAction where
instance Enum PowerMaybeAction where
toEnum 0 = Poweroff
toEnum 1 = Shutdown
toEnum 2 = Hibernate
toEnum 3 = Reboot
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerAction.toEnum: bad argument"
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
fromEnum Poweroff = 0
fromEnum Shutdown = 1
@ -131,22 +131,22 @@ instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
runPowerPrompt :: X () -> X ()
runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeAction
runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction
where
comp = mkComplFunFromList []
theme = T.promptTheme { promptKeymap = keymap }
keymap = M.fromList
$ ((controlMask, xK_g), quit) :
map (first $ (,) 0)
[ (xK_p, sendAction Poweroff)
, (xK_s, sendAction Shutdown)
, (xK_h, sendAction Hibernate)
, (xK_r, sendAction Reboot)
[ (xK_p, sendMaybeAction Poweroff)
, (xK_s, sendMaybeAction Shutdown)
, (xK_h, sendMaybeAction Hibernate)
, (xK_r, sendMaybeAction Reboot)
, (xK_Return, quit)
, (xK_Escape, quit)
]
sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeAction a = case toEnum $ read a of
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeMaybeAction a = case toEnum $ read a of
Poweroff -> runPowerOff
Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate

View File

@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket"
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them
runPowermon :: FeatureIO
runPowermon = featureRun "ACPI event monitor" [pathR acpiPath] listenACPI
runPowermon = featureDefault "ACPI event monitor" [pathR acpiPath] listenACPI
-- | Handle ClientMessage event containing and ACPI event (to be used in
-- Xmonad's event hook)

View File

@ -86,4 +86,4 @@ listenDevices = do
runRemovableMon :: FeatureIO
runRemovableMon =
featureRun "removeable device monitor" [addedDep, removedDep] listenDevices
featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices

View File

@ -89,7 +89,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
-> Client -> FeatureIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
{ ftrAction = exportBrightnessControls' bc client
{ ftrMaybeAction = exportBrightnessControls' bc client
, ftrName = n ++ " exporter"
, ftrWarning = Default
, ftrChildren = DBusBus xmonadBus:deps
@ -133,7 +133,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO
callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m =
Feature
{ ftrAction = void $ callMethod $ methodCall p i m
{ ftrMaybeAction = void $ callMethod $ methodCall p i m
, ftrName = unwords [n, controlName]
, ftrWarning = Default
, ftrChildren = [xDbusDep p i $ Method_ m]

View File

@ -95,7 +95,7 @@ bodyGetCurrentState _ = Nothing
exportScreensaver :: Client -> FeatureIO
exportScreensaver client = Feature
{ ftrAction = cmd
{ ftrMaybeAction = cmd
, ftrName = "screensaver interface"
, ftrWarning = Default
, ftrChildren = [Executable ssExecutable, DBusBus xmonadBus]
@ -122,7 +122,7 @@ exportScreensaver client = Feature
callToggle :: FeatureIO
callToggle = Feature
{ ftrAction = cmd
{ ftrMaybeAction = cmd
, ftrName = "screensaver toggle"
, ftrWarning = Default
, ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle]

View File

@ -2,17 +2,17 @@
-- | Functions for handling dependencies
module XMonad.Internal.Dependency
( MaybeExe
, UnitType(..)
, Dependency(..)
, Bus(..)
, Endpoint(..)
, DBusMember(..)
, Warning(..)
( MaybeAction
, MaybeX
, FeatureX
, FeatureIO
, Feature(..)
, Warning(..)
, Dependency(..)
, UnitType(..)
, Bus(..)
, Endpoint(..)
, DBusMember(..)
, ioFeature
, evalFeature
, systemUnit
@ -20,14 +20,12 @@ module XMonad.Internal.Dependency
, pathR
, pathW
, pathRW
, featureRun
, featureSpawnCmd
, featureSpawn
, featureDefault
, featureExeArgs
, featureExe
, warnMissing
, whenInstalled
, ifInstalled
, fmtCmd
, spawnCmd
, whenSatisfied
, ifSatisfied
, executeFeature
, executeFeature_
, applyFeature
@ -54,51 +52,71 @@ import XMonad.Internal.Process
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
-- | Gracefully handling missing binaries
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
data Bus = Bus Bool BusName deriving (Eq, Show)
data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show)
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest (IO (Maybe String))
| DBusEndpoint Bus Endpoint
| DBusBus Bus
| Systemd UnitType String
data Warning = Silent | Default
-- | Features
--
-- A 'feature' is an 'action' (usually an IO ()) that requires one or more
-- 'dependencies'. Features also have a useful name and an error logging
-- protocol.
--
-- NOTE: there is no way to make a feature depend on another feature. This is
-- very complicated to implement and would only be applicable to a few instances
-- (notable the dbus interfaces). In order to implement a dependency tree, use
-- 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
{ ftrAction :: a
, ftrName :: String
, ftrWarning :: Warning
, ftrChildren :: [Dependency]
{ ftrMaybeAction :: a
, ftrName :: String
, ftrWarning :: Warning
, ftrChildren :: [Dependency]
}
| ConstFeature a
| BlankFeature
-- TODO this is silly as is, and could be made more useful by representing
-- loglevels
data Warning = Silent | Default
type FeatureX = Feature (X ())
type FeatureIO = Feature (IO ())
ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a)
ioFeature f@Feature { ftrAction = a } = f { ftrAction = liftIO a }
ioFeature (ConstFeature f) = ConstFeature $ liftIO f
ioFeature BlankFeature = BlankFeature
ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a }
ioFeature (ConstFeature f) = ConstFeature $ liftIO f
ioFeature BlankFeature = BlankFeature
evalFeature :: Feature a -> IO (MaybeExe a)
featureDefault :: String -> [Dependency] -> a -> Feature a
featureDefault n ds x = Feature
{ ftrMaybeAction = x
, ftrName = n
, ftrWarning = Default
, ftrChildren = ds
}
featureExe :: MonadIO m => String -> String -> Feature (m ())
featureExe n cmd = featureExeArgs n cmd []
featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureExeArgs n cmd args =
featureDefault n [Executable cmd] $ spawnCmd cmd args
--------------------------------------------------------------------------------
-- | Feature evaluation
--
-- Evaluate a feature by testing if its dependencies are satisfied, and return
-- either the action of the feature or 0 or more error messages that signify
-- what dependencies are missing and why.
type MaybeAction a = Either [String] a
type MaybeX = MaybeAction (X ())
evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Right x
evalFeature BlankFeature = return $ Left []
evalFeature Feature
{ ftrAction = a
{ ftrMaybeAction = a
, ftrName = n
, ftrWarning = w
, ftrChildren = c
@ -113,6 +131,48 @@ evalFeature Feature
Silent -> []
Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es
applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
applyFeature iof def ftr = do
a <- io $ evalFeature ftr
either (\es -> io $ warnMissing' es >> return def) (iof . io) a
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
applyFeature_ iof = applyFeature iof ()
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
executeFeature = applyFeature id
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
whenSatisfied :: Monad m => MaybeAction (m ()) -> m ()
whenSatisfied = flip ifSatisfied skip
ifSatisfied :: MaybeAction a -> a -> a
ifSatisfied (Right x) _ = x
ifSatisfied _ alt = alt
--------------------------------------------------------------------------------
-- | Dependencies
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest (IO (Maybe String))
| DBusEndpoint Bus Endpoint
| DBusBus Bus
| Systemd UnitType String
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
data Bus = Bus Bool BusName deriving (Eq, Show)
data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show)
pathR :: String -> Dependency
pathR n = AccessiblePath n True False
@ -128,35 +188,29 @@ systemUnit = Systemd SystemUnit
userUnit :: String -> Dependency
userUnit = Systemd UserUnit
-- TODO this is poorly named. This actually represents an action that has
-- one or more dependencies (where "action" is not necessarily executing an exe)
type MaybeExe a = Either [String] a
--------------------------------------------------------------------------------
-- | Dependency evaluation
--
-- Test the existence of dependencies and return either Nothing (which actually
-- means success) or Just <error message>.
type MaybeX = MaybeExe (X ())
evalDependency :: Dependency -> IO (Maybe String)
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
featureRun :: String -> [Dependency] -> a -> Feature a
featureRun n ds x = Feature
{ ftrAction = x
, ftrName = n
, ftrWarning = Default
, ftrChildren = ds
}
featureSpawnCmd :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureSpawnCmd n cmd args = featureRun n [Executable cmd] $ spawnCmd cmd args
featureSpawn :: MonadIO m => String -> String -> Feature (m ())
featureSpawn n cmd = featureSpawnCmd n cmd []
exeInstalled :: String -> IO (Maybe String)
exeInstalled x = do
exeSatisfied :: String -> IO (Maybe String)
exeSatisfied x = do
r <- findExecutable x
return $ case r of
(Just _) -> Nothing
_ -> Just $ "executable '" ++ x ++ "' not found"
unitInstalled :: UnitType -> String -> IO (Maybe String)
unitInstalled u x = do
unitSatisfied :: UnitType -> String -> IO (Maybe String)
unitSatisfied u x = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Nothing
@ -166,8 +220,8 @@ unitInstalled u x = do
unitType SystemUnit = "system"
unitType UserUnit = "user"
pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible p testread testwrite = do
pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathSatisfied p testread testwrite = do
res <- getPermissionsSafe p
let msg = permMsg res
return msg
@ -197,8 +251,8 @@ callMethod (Bus usesys bus) path iface mem = do
disconnect client
return $ bimap methodErrorMessage methodReturnBody reply
dbusBusExists :: Bus -> IO (Maybe String)
dbusBusExists (Bus usesystem bus) = do
busSatisfied :: Bus -> IO (Maybe String)
busSatisfied (Bus usesystem bus) = do
ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem
return $ case ret of
Left e -> Just e
@ -214,8 +268,8 @@ dbusBusExists (Bus usesystem bus) = do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = []
dbusEndpointExists :: Bus -> Endpoint -> IO (Maybe String)
dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do
endpointSatisfied :: Bus -> Endpoint -> IO (Maybe String)
endpointSatisfied b@(Bus _ bus) (Endpoint objpath iface mem) = do
ret <- callMethod b objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Just e
@ -245,43 +299,16 @@ dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do
, formatBusName bus
]
evalDependency :: Dependency -> IO (Maybe String)
evalDependency (Executable n) = exeInstalled n
evalDependency (IOTest t) = t
evalDependency (Systemd t n) = unitInstalled t n
evalDependency (AccessiblePath p r w) = pathAccessible p r w
evalDependency (DBusEndpoint b e) = dbusEndpointExists b e
evalDependency (DBusBus b) = dbusBusExists b
--------------------------------------------------------------------------------
-- | Logging functions
whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
whenInstalled = flip ifInstalled skip
ifInstalled :: MaybeExe a -> a -> a
ifInstalled (Right x) _ = x
ifInstalled _ alt = alt
warnMissing :: [MaybeExe a] -> IO ()
warnMissing :: [MaybeAction a] -> IO ()
warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
warnMissing' :: [String] -> IO ()
warnMissing' = mapM_ putStrLn
applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
applyFeature iof def ftr = do
a <- io $ evalFeature ftr
either (\es -> io $ warnMissing' es >> return def) (iof . io) a
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
applyFeature_ iof = applyFeature iof ()
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
executeFeature = applyFeature id
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
fmtMsg :: String -> String -> String -> String
fmtMsg procName level msg = unwords [bracket procName, bracket level, msg]
where
bracket s = "[" ++ s ++ "]"