WIP transition all dependencies to new framework

This commit is contained in:
Nathan Dwarshuis 2022-06-21 00:56:42 -04:00
parent 7a1c77b33e
commit d8a88531b0
13 changed files with 1109 additions and 903 deletions

View File

@ -56,8 +56,8 @@ myDmenuNetworks = "networkmanager_dmenu"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Other internal functions -- | Other internal functions
spawnDmenuCmd :: String -> [String] -> FeatureX spawnDmenuCmd :: String -> [String] -> SometimesX
spawnDmenuCmd n = featureExeArgs n myDmenuCmd spawnDmenuCmd n = sometimesExeArgs n True myDmenuCmd
themeArgs :: String -> [String] themeArgs :: String -> [String]
themeArgs hexColor = themeArgs hexColor =
@ -71,66 +71,83 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported Commands -- | Exported Commands
runDevMenu :: FeatureX runDevMenu :: SometimesX
runDevMenu = featureDefault "device manager" (Only $ exe myDmenuDevices) $ do runDevMenu = sometimesIO "device manager" (Only $ Executable False myDmenuDevices) $ do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices spawnCmd myDmenuDevices
$ ["-c", c] $ ["-c", c]
++ "--" : themeArgs "#999933" ++ "--" : themeArgs "#999933"
++ myDmenuMatchingArgs ++ myDmenuMatchingArgs
runBTMenu :: FeatureX runBTMenu :: SometimesX
runBTMenu = featureExeArgs "bluetooth selector" myDmenuBluetooth runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth
$ "-c":themeArgs "#0044bb" $ "-c":themeArgs "#0044bb"
runBwMenu :: FeatureX runBwMenu :: SometimesX
runBwMenu = featureDefault "password manager" (Only $ exe myDmenuPasswords) $ runBwMenu = sometimesIO "password manager" (Only $ Executable False myDmenuPasswords) $
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
runVPNMenu :: FeatureX runVPNMenu :: SometimesX
runVPNMenu = featureDefault "VPN selector" (Only $ exe myDmenuVPN) $ runVPNMenu = sometimesIO "VPN selector" (Only $ Executable False myDmenuVPN) $
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
-- TODO this is weirdly inverted -- runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction -- runShowKeys x = addName "Show Keybindings" $ do
runShowKeys x = addName "Show Keybindings" $ do -- s <- io $ evalFeature $ runDMenuShowKeys x
s <- io $ evalFeature $ runDMenuShowKeys x -- ifSatisfied s
ifSatisfied s -- $ spawnNotify
$ spawnNotify -- $ defNoteError { body = Just $ Text "could not display keymap" }
$ defNoteError { body = Just $ Text "could not display keymap" }
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX -- TODO not sure what to do with this yet
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
runShowKeys _ = NamedAction (skip :: (X ()))
-- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX
runDMenuShowKeys kbs = runDMenuShowKeys kbs =
featureDefault "keyboard shortcut menu" (Only $ exe myDmenuCmd) $ io $ do Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys)
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' runNotifyShowKeys :: X ()
runNotifyShowKeys = spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" }
runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree
runDMenuShowKeys' kbs = Subfeature
{ sfName = "keyboard shortcut menu"
, sfTree = IOTree (Standalone act) deps
, sfLevel = Warn
}
where where
deps = Only $ Executable True myDmenuCmd
act = io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
runCmdMenu :: FeatureX runCmdMenu :: SometimesX
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
runAppMenu :: FeatureX runAppMenu :: SometimesX
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runClipMenu :: FeatureX runClipMenu :: SometimesX
runClipMenu = runClipMenu = sometimesIO "clipboard manager" deps act
featureDefault "clipboard manager" (And (Only $ exe myDmenuCmd) (Only $ exe "greenclip"))
$ spawnCmd myDmenuCmd args
where where
act = spawnCmd myDmenuCmd args
deps = toAnd (Executable True myDmenuCmd) (Executable True "greenclip")
args = [ "-modi", "\"clipboard:greenclip print\"" args = [ "-modi", "\"clipboard:greenclip print\""
, "-show", "clipboard" , "-show", "clipboard"
, "-run-command", "'{cmd}'" , "-run-command", "'{cmd}'"
] ++ themeArgs "#00c44e" ] ++ themeArgs "#00c44e"
runWinMenu :: FeatureX runWinMenu :: SometimesX
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: FeatureX runNetMenu :: SometimesX
runNetMenu = runNetMenu =
featureExeArgs "network control menu" myDmenuNetworks $ themeArgs "#ff3333" sometimesExeArgs "network control menu" True myDmenuNetworks $ themeArgs "#ff3333"
runAutorandrMenu :: FeatureX runAutorandrMenu :: SometimesX
runAutorandrMenu = runAutorandrMenu =
featureExeArgs "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066" sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066"

View File

@ -91,51 +91,53 @@ ethernetIface = "enp7s0f1"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Some nice apps -- | Some nice apps
runTerm :: FeatureX runTerm :: SometimesX
runTerm = featureExe "terminal" myTerm runTerm = sometimesExe "terminal" True myTerm
runTMux :: FeatureX runTMux :: SometimesX
runTMux = featureDefault "terminal multiplexer" deps cmd runTMux = sometimesIO "terminal multiplexer" deps act
where where
deps = listToAnds (exe myTerm) $ fmap exe ["tmux", "bash"] deps = listToAnds (Executable True myTerm) $ fmap (Executable True) ["tmux", "bash"]
cmd = spawn act = spawn
$ "tmux has-session" $ "tmux has-session"
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
#!|| fmtNotifyCmd defNoteError { body = Just $ Text msg } #!|| fmtNotifyCmd defNoteError { body = Just $ Text msg }
c = "exec tmux attach-session -d" c = "exec tmux attach-session -d"
msg = "could not connect to tmux session" msg = "could not connect to tmux session"
runCalc :: FeatureX runCalc :: SometimesX
runCalc = featureDefault "calculator" (And (Only $ exe myTerm) (Only $ exe "R")) runCalc = sometimesIO "calculator" deps act
$ spawnCmd myTerm ["-e", "R"] where
deps = toAnd (Executable True myTerm) (Executable True "R")
act = spawnCmd myTerm ["-e", "R"]
runBrowser :: FeatureX runBrowser :: SometimesX
runBrowser = featureExe "web browser" myBrowser runBrowser = sometimesExe "web browser" False myBrowser
runEditor :: FeatureX runEditor :: SometimesX
runEditor = featureExeArgs "text editor" myEditor runEditor = sometimesExeArgs "text editor" True myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
runFileManager :: FeatureX runFileManager :: SometimesX
runFileManager = featureExe "file browser" "pcmanfm" runFileManager = sometimesExe "file browser" True "pcmanfm"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Multimedia Commands -- | Multimedia Commands
runMultimediaIfInstalled :: String -> String -> FeatureX runMultimediaIfInstalled :: String -> String -> SometimesX
runMultimediaIfInstalled n cmd = runMultimediaIfInstalled n cmd =
featureExeArgs (n ++ " multimedia control") myMultimediaCtl [cmd] sometimesExeArgs (n ++ " multimedia control") True myMultimediaCtl [cmd]
runTogglePlay :: FeatureX runTogglePlay :: SometimesX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
runPrevTrack :: FeatureX runPrevTrack :: SometimesX
runPrevTrack = runMultimediaIfInstalled "previous track" "previous" runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
runNextTrack :: FeatureX runNextTrack :: SometimesX
runNextTrack = runMultimediaIfInstalled "next track" "next" runNextTrack = runMultimediaIfInstalled "next track" "next"
runStopPlay :: FeatureX runStopPlay :: SometimesX
runStopPlay = runMultimediaIfInstalled "stop playback" "stop" runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -151,48 +153,48 @@ playSound file = do
-- paplay seems to have less latency than aplay -- paplay seems to have less latency than aplay
spawnCmd "paplay" [p] spawnCmd "paplay" [p]
featureSound :: String -> FilePath -> X () -> X () -> FeatureX featureSound :: String -> FilePath -> X () -> X () -> SometimesX
featureSound n file pre post = featureSound n file pre post =
featureDefault ("volume " ++ n ++ " control") (Only $ exe "paplay") sometimesIO ("volume " ++ n ++ " control") (Only $ Executable True "paplay")
$ pre >> playSound file >> post $ pre >> playSound file >> post
runVolumeDown :: FeatureX runVolumeDown :: SometimesX
runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2) runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
runVolumeUp :: FeatureX runVolumeUp :: SometimesX
runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2) runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
runVolumeMute :: FeatureX runVolumeMute :: SometimesX
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return () runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Notification control -- | Notification control
runNotificationCmd :: String -> String -> FeatureX runNotificationCmd :: String -> FilePath -> SometimesX
runNotificationCmd n cmd = runNotificationCmd n cmd =
featureExeArgs (n ++ " control") myNotificationCtrl [cmd] sometimesExeArgs (n ++ " control") True myNotificationCtrl [cmd]
runNotificationClose :: FeatureX runNotificationClose :: SometimesX
runNotificationClose = runNotificationCmd "close notification" "close" runNotificationClose = runNotificationCmd "close notification" "close"
runNotificationCloseAll :: FeatureX runNotificationCloseAll :: SometimesX
runNotificationCloseAll = runNotificationCloseAll =
runNotificationCmd "close all notifications" "close-all" runNotificationCmd "close all notifications" "close-all"
runNotificationHistory :: FeatureX runNotificationHistory :: SometimesX
runNotificationHistory = runNotificationHistory =
runNotificationCmd "see notification history" "history-pop" runNotificationCmd "see notification history" "history-pop"
runNotificationContext :: FeatureX runNotificationContext :: SometimesX
runNotificationContext = runNotificationContext =
runNotificationCmd "open notification context" "context" runNotificationCmd "open notification context" "context"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | System commands -- | System commands
runToggleBluetooth :: FeatureX runToggleBluetooth :: SometimesX
runToggleBluetooth = runToggleBluetooth =
featureDefault "bluetooth toggle" (Only $ exe myBluetooth) sometimesIO "bluetooth toggle" (Only $ Executable True myBluetooth)
$ spawn $ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\"" $ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on" #!&& "a=on"
@ -200,8 +202,8 @@ runToggleBluetooth =
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
runToggleEthernet :: FeatureX runToggleEthernet :: SometimesX
runToggleEthernet = featureDefault "ethernet toggle" (Only $ exe "nmcli") runToggleEthernet = sometimesIO "ethernet toggle" (Only $ Executable True "nmcli")
$ spawn $ spawn
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected" $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
#!&& "a=connect" #!&& "a=connect"
@ -209,15 +211,15 @@ runToggleEthernet = featureDefault "ethernet toggle" (Only $ exe "nmcli")
#!>> fmtCmd "nmcli" ["device", "$a", ethernetIface] #!>> fmtCmd "nmcli" ["device", "$a", ethernetIface]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: FeatureX runStartISyncTimer :: SometimesX
runStartISyncTimer = featureDefault "isync timer" (Only $ userUnit "mbsync.timer") runStartISyncTimer = sometimesIO "isync timer" (Only $ Systemd UserUnit "mbsync.timer")
$ spawn $ spawn
$ "systemctl --user start mbsync.timer" $ "systemctl --user start mbsync.timer"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" }
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" } #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
runStartISyncService :: FeatureX runStartISyncService :: SometimesX
runStartISyncService = featureDefault "isync" (Only $ userUnit "mbsync.service") runStartISyncService = sometimesIO "isync" (Only $ Systemd UserUnit "mbsync.service")
$ spawn $ spawn
$ "systemctl --user start mbsync.service" $ "systemctl --user start mbsync.service"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@ -261,25 +263,25 @@ getCaptureDir = do
where where
fallback = (</> ".local/share") <$> getHomeDirectory fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> String -> FeatureX runFlameshot :: String -> String -> SometimesX
runFlameshot n mode = featureDefault n (Only $ exe myCapture) runFlameshot n mode = sometimesIO n (Only $ Executable True myCapture)
$ spawnCmd myCapture [mode] $ spawnCmd myCapture [mode]
-- TODO this will steal focus from the current window (and puts it -- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix -- in the root window?) ...need to fix
runAreaCapture :: FeatureX runAreaCapture :: SometimesX
runAreaCapture = runFlameshot "screen area capture" "gui" runAreaCapture = runFlameshot "screen area capture" "gui"
-- myWindowCap = "screencap -w" --external script -- myWindowCap = "screencap -w" --external script
runDesktopCapture :: FeatureX runDesktopCapture :: SometimesX
runDesktopCapture = runFlameshot "fullscreen capture" "full" runDesktopCapture = runFlameshot "fullscreen capture" "full"
runScreenCapture :: FeatureX runScreenCapture :: SometimesX
runScreenCapture = runFlameshot "screen capture" "screen" runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: FeatureX runCaptureBrowser :: SometimesX
runCaptureBrowser = runCaptureBrowser =
featureDefault "screen capture browser" (Only $ exe myImageBrowser) $ do sometimesIO "screen capture browser" (Only $ Executable True myImageBrowser) $ do
dir <- io getCaptureDir dir <- io getCaptureDir
spawnCmd myImageBrowser [dir] spawnCmd myImageBrowser [dir]

View File

@ -45,8 +45,8 @@ myOptimusManager = "optimus-manager"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Core commands -- | Core commands
runScreenLock :: Feature (X ()) runScreenLock :: SometimesX
runScreenLock = featureExe "screen locker" myScreenlock runScreenLock = sometimesExe "screen locker" True myScreenlock
runPowerOff :: X () runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff" runPowerOff = spawn "systemctl poweroff"
@ -100,8 +100,8 @@ runOptimusPrompt' = do
#!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"] #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad" #!&& "killall xmonad"
runOptimusPrompt :: FeatureX runOptimusPrompt :: SometimesX
runOptimusPrompt = featureDefault "graphics switcher" (Only $ exe myOptimusManager) runOptimusPrompt = sometimesIO "graphics switcher" (Only $ Executable True myOptimusManager)
runOptimusPrompt' runOptimusPrompt'
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View File

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

View File

@ -107,16 +107,16 @@ clevoKeyboardConfig = BrightnessConfig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
stateFileDep :: FullDep Dependency stateFileDep :: IODependency a p
stateFileDep = pathRW stateFile stateFileDep = pathRW stateFile
brightnessFileDep :: FullDep Dependency brightnessFileDep :: IODependency a p
brightnessFileDep = pathR brightnessFile brightnessFileDep = pathR brightnessFile
clevoKeyboardSignalDep :: DBusDep clevoKeyboardSignalDep :: DBusDependency RawBrightness p
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
exportClevoKeyboard :: Maybe Client -> FeatureIO exportClevoKeyboard :: Maybe Client -> SometimesIO
exportClevoKeyboard = exportClevoKeyboard =
brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig

View File

@ -45,10 +45,10 @@ data BrightnessConfig a b = BrightnessConfig
} }
data BrightnessControls = BrightnessControls data BrightnessControls = BrightnessControls
{ bctlMax :: FeatureIO { bctlMax :: SometimesIO
, bctlMin :: FeatureIO , bctlMin :: SometimesIO
, bctlInc :: FeatureIO , bctlInc :: SometimesIO
, bctlDec :: FeatureIO , bctlDec :: SometimesIO
} }
brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls
@ -67,7 +67,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
either (const Nothing) bodyGetBrightness either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet <$> callMethod client xmonadBusName p i memGet
signalDep :: BrightnessConfig a b -> DBusDep signalDep :: BrightnessConfig a b -> DBusDependency a p
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
Endpoint xmonadBusName p i $ Signal_ memCur Endpoint xmonadBusName p i $ Signal_ memCur
@ -85,14 +85,12 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Internal DBus Crap -- | Internal DBus Crap
brightnessExporter :: RealFrac b => [FullDep Dependency] -> BrightnessConfig a b brightnessExporter :: RealFrac b => [IODependency (IO ()) (Maybe x)]
-> Maybe Client -> FeatureIO -> BrightnessConfig a b -> Maybe Client -> SometimesIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
(n ++ " exporter") Default sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
$ DBusTree (Single (exportBrightnessControls' bc)) client ds
where where
ds = listToAnds (fullDep $ Bus xmonadBusName) ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
$ fmap (fmap DBusGenDep) deps
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO () exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
exportBrightnessControls' bc client = do exportBrightnessControls' bc client = do
@ -130,11 +128,11 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
sig = signal p i memCur sig = signal p i memCur
callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
-> FeatureIO -> SometimesIO
callBacklight client BrightnessConfig { bcPath = p callBacklight client BrightnessConfig { bcPath = p
, bcInterface = i , bcInterface = i
, bcName = n } controlName m = , bcName = n } controlName m =
featureEndpoint (unwords [n, controlName]) xmonadBusName p i m client sometimesEndpoint (unwords [n, controlName]) xmonadBusName p i m client
bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

View File

@ -89,16 +89,16 @@ intelBacklightConfig = BrightnessConfig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
curFileDep :: FullDep Dependency curFileDep :: IODependency a p
curFileDep = pathRW curFile curFileDep = pathRW curFile
maxFileDep :: FullDep Dependency maxFileDep :: IODependency a p
maxFileDep = pathR maxFile maxFileDep = pathR maxFile
intelBacklightSignalDep :: DBusDep intelBacklightSignalDep :: DBusDependency RawBrightness p
intelBacklightSignalDep = signalDep intelBacklightConfig intelBacklightSignalDep = signalDep intelBacklightConfig
exportIntelBacklight :: Maybe Client -> FeatureIO exportIntelBacklight :: Maybe Client -> SometimesIO
exportIntelBacklight = exportIntelBacklight =
brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig

View File

@ -30,7 +30,7 @@ startXMonadService :: IO (Maybe Client)
startXMonadService = do startXMonadService = do
client <- getDBusClient False client <- getDBusClient False
forM_ client requestXMonadName forM_ client requestXMonadName
mapM_ (\f -> executeFeature_ $ f client) dbusExporters mapM_ (\f -> executeSometimes_ $ f client) dbusExporters
return client return client
stopXMonadService :: Client -> IO () stopXMonadService :: Client -> IO ()
@ -51,5 +51,5 @@ requestXMonadName client = do
where where
xn = "'" ++ formatBusName xmonadBusName ++ "'" xn = "'" ++ formatBusName xmonadBusName ++ "'"
dbusExporters :: [Maybe Client -> FeatureIO] dbusExporters :: [Maybe Client -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

View File

@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
memRemoved :: MemberName memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved" memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> FullDep DBusDep dbusDep :: MemberName -> DBusDependency a p
dbusDep m = fullDep $ Endpoint bus path interface $ Signal_ m dbusDep m = Endpoint bus path interface $ Signal_ m
addedDep :: FullDep DBusDep addedDep :: DBusDependency a p
addedDep = dbusDep memAdded addedDep = dbusDep memAdded
removedDep :: FullDep DBusDep removedDep :: DBusDependency a p
removedDep = dbusDep memRemoved removedDep = dbusDep memRemoved
driveInsertedSound :: FilePath driveInsertedSound :: FilePath
@ -81,6 +81,8 @@ listenDevices client = do
addMatch' m p f = void $ addMatch client ruleUdisks { matchMember = Just m } addMatch' m p f = void $ addMatch client ruleUdisks { matchMember = Just m }
$ playSoundMaybe p . f . signalBody $ playSoundMaybe p . f . signalBody
runRemovableMon :: Maybe Client -> FeatureIO runRemovableMon :: Maybe Client -> SometimesIO
runRemovableMon client = feature "removeable device monitor" Default runRemovableMon cl =
$ DBusTree (Single listenDevices) client $ And (Only addedDep) (Only removedDep) sometimesDBus cl "removeable device monitor" deps listenDevices
where
deps = toAnd addedDep removedDep

View File

@ -94,9 +94,9 @@ bodyGetCurrentState _ = Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
exportScreensaver :: Maybe Client -> FeatureIO exportScreensaver :: Maybe Client -> SometimesIO
exportScreensaver client = feature "screensaver interface" Default exportScreensaver client =
$ DBusTree (Single cmd) client (And (Only bus) (Only ssx)) sometimesDBus client "screensaver interface" (toAnd bus ssx) cmd
where where
cmd cl = export cl ssPath defaultInterface cmd cl = export cl ssPath defaultInterface
{ interfaceName = interface { interfaceName = interface
@ -116,12 +116,12 @@ exportScreensaver client = feature "screensaver interface" Default
} }
] ]
} }
bus = fullDep $ Bus xmonadBusName bus = Bus xmonadBusName
ssx = fullDep $ DBusGenDep $ Executable ssExecutable ssx = DBusIO $ Executable True ssExecutable
callToggle :: Maybe Client -> FeatureIO callToggle :: Maybe Client -> SometimesIO
callToggle = callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath
featureEndpoint "screensaver toggle" xmonadBusName ssPath interface memToggle interface memToggle
callQuery :: Client -> IO (Maybe SSState) callQuery :: Client -> IO (Maybe SSState)
callQuery client = do callQuery client = do
@ -132,5 +132,5 @@ matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
matchSignal cb = matchSignal cb =
fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
ssSignalDep :: DBusDep ssSignalDep :: DBusDependency a p
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState

View File

@ -1,55 +1,56 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Functions for handling dependencies -- | Functions for handling dependencies
module XMonad.Internal.Dependency module XMonad.Internal.Dependency
( MaybeAction ( AlwaysX
, AnyFeature(..) , AlwaysIO
, DepChoice(..) , Always(..)
, MaybeX , SometimesX
, FullDep(..) , SometimesIO
, DepTree(..) , Sometimes
, executeSometimes_
, executeSometimes
, executeAlways_
, executeAlways
, evalAlways
, evalSometimes
, Subfeature(..)
, LogLevel(..)
, Action(..) , Action(..)
, DBusDep(..)
, FeatureX -- feature construction
, FeatureIO , sometimes1
, Feature(..) , sometimesIO
, Feature_(..) , sometimesDBus
, Warning(..) , sometimesExe
, Dependency(..) , sometimesExeArgs
, UnitType(..) , sometimesEndpoint
-- Dependency tree
, ActionTree(..)
, Tree(..)
, IODependency(..)
, DBusDependency(..)
, DBusMember(..) , DBusMember(..)
, feature , UnitType(..)
, ioFeature
, evalFeature
, systemUnit
, userUnit
, pathR
, pathW
, pathRW
, featureDefault
, featureExeArgs
, featureExe
, featureEndpoint
, whenSatisfied
, ifSatisfied
, executeFeature
, executeFeature_
, executeFeatureWith
, executeFeatureWith_
, depName
, fullDep
, exe
, listToAnds , listToAnds
, toAnd
, pathR
, pathRW
, pathW
) where ) where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Identity import Control.Monad.Identity
-- import Data.Aeson -- import Data.Aeson
import Data.Bifunctor
import Data.Either
import Data.List (find) import Data.List (find)
import Data.Maybe import Data.Maybe
-- import qualified Data.Text as T -- import qualified Data.Text as T
@ -70,370 +71,384 @@ import XMonad.Internal.Shell
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Features -- | Features
--
-- A 'feature' is composed of a 'dependency tree' which at the root has an
-- 'action' to be performed with a number of 'dependencies' below it.
--
-- 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
-- (notably 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.
-- TODO some things to add to make this more feature-ful (lol) -- data AlwaysAny = AX AlwaysX | AIO AlwaysIO
-- - use AndOr types to encode alternative dependencies into the tree
-- - use an Alt data constructor for Features (which will mean "try A before B"
-- - add an Either String Bool to dependency nodes that encodes testing status
-- (where Right False means untested)
-- - add a lens/functor mapper thingy to walk down the tree and update testing
-- status fields
-- - print to JSON
-- - make sum type to hold all type instances of Feature blabla (eg IO and X)
-- - figure out how to make features a dependency of another feature
data Feature_ a = Feature_ type AlwaysX = Always (X ())
{ ftrDepTree :: DepTree a
, ftrName :: String type AlwaysIO = Always (IO ())
, ftrWarning :: Warning
type SometimesX = Sometimes (X ())
type SometimesIO = Sometimes (IO ())
data Always a = Option (Subfeature a Tree) (Always a) | Always a
type Sometimes a = [Subfeature a Tree]
data TestedAlways a p =
Primary (Finished a p) [FailedFeature a p] (Always a)
| Fallback a [FailedFeature a p]
data TestedSometimes a p = TestedSometimes
{ tsSuccess :: Maybe (Finished a p)
, tsFailed :: [FailedFeature a p]
, tsUntested :: [Subfeature a Tree]
} }
data Feature a = Feature (Feature_ a) (Feature a) type FailedFeature a p = Either (Subfeature a Tree, String)
| NoFeature (Subfeature a ResultTree, [String])
| ConstFeature a
-- TODO this is silly as is, and could be made more useful by representing data Finished a p = Finished
-- loglevels { finData :: Subfeature a ResultTree
data Warning = Silent | Default , finAction :: a
, finWarnings :: [String]
}
type FeatureX = Feature (X ()) data FeatureResult a p = Untestable (Subfeature a Tree) String |
FailedFtr (Subfeature a ResultTree) [String] |
SuccessfulFtr (Finished a p)
type FeatureIO = Feature (IO ()) type ActionTreeMaybe a p = Either (ActionTree a Tree, String)
(ActionTree a ResultTree, Maybe a, [String])
data AnyFeature = FX FeatureX | FIO FeatureIO sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a
sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }]
feature :: String -> Warning -> DepTree a -> Feature a always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a
feature n w t = Feature f NoFeature always1_ l n t x =
where Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x)
f = Feature_
{ ftrDepTree = t
, ftrName = n
, ftrWarning = w
}
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b) sometimes1 :: String -> ActionTree a Tree -> Sometimes a
ioFeature (ConstFeature a) = ConstFeature $ liftIO a sometimes1 = sometimes1_ Error
ioFeature NoFeature = NoFeature
ioFeature (Feature f r)
= Feature (f {ftrDepTree = liftIO <$> ftrDepTree f}) $ ioFeature r
featureDefault :: String -> DepChoice (FullDep Dependency) -> a -> Feature a sometimesIO :: String -> Tree (IODependency a p) p -> a -> Sometimes a
featureDefault n ds x = feature n Default $ GenTree (Single x) ds sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t
featureExe :: MonadIO m => String -> String -> Feature (m ()) sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency a p) p
featureExe n cmd = featureExeArgs n cmd [] -> (Client -> a) -> Sometimes a
sometimesDBus c n t x = sometimes1 n $ DBusTree (Standalone x) c t
featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureExeArgs n cmd args =
featureDefault n (Only $ FullDep (Right False) $ Executable cmd) $ spawnCmd cmd args
featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> Maybe Client -> FeatureIO
featureEndpoint name busname path iface mem client = feature name Default
$ DBusTree (Single cmd) client deps
where
cmd c = void $ callMethod c busname path iface mem
deps = Only $ FullDep (Right False) $ Endpoint busname path iface $ Method_ mem
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependency Trees -- | Feature Data
--
-- Dependency trees have two subtypes: general and DBus. The latter require a
-- DBus client to evaluate (and will automatically fail if this is missing).
-- The former can be evaluated independently.
data DepChoice a = And (DepChoice a) (DepChoice a) data Subfeature a t = Subfeature
| Or (DepChoice a) (DepChoice a) { sfTree :: ActionTree a t
| Only a , sfName :: String
, sfLevel :: LogLevel
}
listToAnds :: a -> [a] -> DepChoice a data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
listToAnds i = foldr (And . Only) (Only i)
data DepTree a = GenTree (Action a) (DepChoice (FullDep Dependency)) data Msg = Msg LogLevel String String
| DBusTree (Action (Client -> a)) (Maybe Client) (DepChoice (FullDep DBusDep))
instance Functor DepTree where
fmap f (GenTree a ds) = GenTree (f <$> a) ds
fmap f (DBusTree a c ds) = DBusTree (fmap (fmap f) a) c ds
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Actions -- | Action Tree
--
-- Actions have two subtypes: single and double. Single actions are just one
-- independent action. Double actions have one dependent pre-step which the
-- main action consumes (and fails if the pre-step fails).
data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b)) data ActionTree a t =
forall p. IOTree (Action a p) (t (IODependency a p) p)
| forall p. DBusTree (Action (Client -> a) p) (Maybe Client) (t (DBusDependency a p) p)
instance Functor Action where data Action a p = Standalone a | Consumer (p -> a)
fmap f (Single a) = Single (f a)
fmap f (Double a b) = Double (f . a) b
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature evaluation -- | Dependency Tree
--
-- 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 = Maybe a data Tree d p =
And (p -> p -> p) (Tree d p) (Tree d p)
| Or (p -> p) (p -> p) (Tree d p) (Tree d p)
| Only d
type MaybeX = MaybeAction (X ()) listToAnds :: d -> [d] -> Tree d (Maybe x)
listToAnds i = foldr (And (const . const Nothing) . Only) (Only i)
evalFeature :: Feature a -> IO (MaybeAction a) toAnd :: d -> d -> Tree d (Maybe x)
evalFeature (ConstFeature x) = return $ Just x toAnd a b = And (const . const Nothing) (Only a) (Only b)
evalFeature NoFeature = return Nothing
-- TODO actually deal with alt
evalFeature (Feature (Feature_{ftrDepTree = a, ftrName = n, ftrWarning = w}) _) = do
procName <- getProgName
res <- evalTree =<< evalTree' a
either (printWarnings procName) (return . Just) res
where
printWarnings procName es = do
case w of
Silent -> skip
Default -> let prefix = n ++ " disabled; "
es' = fmap (fmtMsg procName . (prefix ++)) es in
mapM_ putStrLn es'
return Nothing
fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
bracket s = "[" ++ s ++ "]"
mapMDepChoice :: Monad m => (a -> m a) -> (a -> Bool) -> DepChoice a -> m (DepChoice a)
mapMDepChoice f pass = fmap snd . go
where
go d@(And a b) = do
(ra, a') <- go a
if not ra then return (False, d) else do
(rb, b') <- go b
return $ if rb then (True, And a' b') else (False, d)
go d@(Or a b) = do
(ra, a') <- go a
if ra then return (True, Or a' b) else do
(rb, b') <- go b
return $ if rb then (True, Or a' b') else (False, d)
go d@(Only a) = do
a' <- f a
return $ if pass a' then (True, Only a') else (False, d)
-- foldDepChoice :: (a -> Bool) -> DepChoice a -> Bool
-- foldDepChoice get dc = case dc of
-- And a b -> go a && go b
-- Or a b -> go a || go b
-- Only a -> get a
-- where
-- go = foldDepChoice get
foldDepChoice' :: Bool -> (a -> Maybe b) -> DepChoice a -> [b]
foldDepChoice' justSucceed get = fromMaybe [] . go []
where
go acc (And a b) = Just $ andFun acc a b
go acc (Or a b) = Just $ orFun acc a b
go acc (Only a) = (:acc) <$> get a
(andFun, orFun) = if justSucceed then (and', or') else (or', and')
and' acc a b = case (go acc a, go acc b) of
(Just a', Just b') -> a' ++ b' ++ acc
(Just a', Nothing) -> a' ++ acc
(Nothing, _) -> acc
or' acc a b = fromMaybe [] (go acc a) ++ fromMaybe [] (go acc b) ++ acc
-- foldDepChoice :: DepChoice a -> (a -> Maybe b) -> [b]
-- foldDepChoice dc f = go [] dc
-- where
-- go acc d = case d of
-- And a b -> do
-- acc'@(a':_) <- go acc a
-- if pass a' then go acc' b else return acc
-- Or a b -> do
-- acc'@(a':_) <- go acc a
-- if pass a' then return [a'] else go acc' b
-- Only a -> maybe acc $ f a
-- TODO wet code
evalTree :: DepTree a -> IO (Either [String] a)
evalTree (GenTree a ds) = do
case foldDepChoice' False fullDepMsg ds of
[] -> evalAction a
es -> return $ Left es
evalTree (DBusTree a (Just client) ds) = do
case foldDepChoice' False fullDepMsg ds of
[] -> fmap (\f -> f client) <$> evalAction a
es -> return $ Left es
evalTree (DBusTree _ Nothing _) = return $ Left ["client not available"]
fullDepMsg :: FullDep a -> Maybe String
fullDepMsg (FullDep e _) = either Just (const Nothing) e
evalTree' :: DepTree a -> IO (DepTree a)
evalTree' (GenTree a ds) = GenTree a <$> mapMDepChoice eval pass ds
where
eval (FullDep _ d) = do
r <- evalDependency d
return $ FullDep (maybe (Right True) Left r) d
pass (FullDep (Right True) _) = True
pass _ = True
evalTree' d@(DBusTree _ Nothing _) = return d
evalTree' (DBusTree a (Just client) ds) = DBusTree a (Just client) <$> mapMDepChoice eval pass ds
where
eval (FullDep _ d) = do
r <- eval' d
return $ FullDep (maybe (Right True) Left r) d
eval' (DBusGenDep d) = evalDependency d
eval' x = dbusDepSatisfied client x
pass (FullDep (Right True) _) = True
pass _ = True
evalAction :: Action a -> IO (Either [String] a)
evalAction (Single a) = return $ Right a
evalAction (Double a b) = fmap a <$> b
executeFeatureWith :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
executeFeatureWith iof def ftr = do
a <- io $ evalFeature ftr
maybe (return def) (iof . io) a
executeFeatureWith_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
executeFeatureWith_ iof = executeFeatureWith iof ()
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
executeFeature = executeFeatureWith id
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
whenSatisfied :: Monad m => MaybeAction (m ()) -> m ()
whenSatisfied = flip ifSatisfied skip
ifSatisfied :: MaybeAction a -> a -> a
ifSatisfied (Just x) _ = x
ifSatisfied _ alt = alt
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependencies (General) -- | Result Tree
data FullDep a = FullDep (Either String Bool) a deriving (Functor) -- | how to interpret ResultTree combinations:
-- First (LeafSuccess a) (Tree a) -> Or that succeeded on left
-- First (LeafFail a) (Tree a) -> And that failed on left
-- Both (LeafFail a) (Fail a) -> Or that failed
-- Both (LeafSuccess a) (LeafSuccess a) -> And that succeeded
-- Both (LeafFail a) (LeafSuccess a) -> Or that failed first and succeeded second
-- Both (LeafSuccess a) (LeafFail a) -> And that failed on the right
fullDep :: a -> FullDep a data ResultTree d p =
fullDep = FullDep (Right True) First (ResultTree d p) (Tree d p)
| Both (ResultTree d p) (ResultTree d p)
| LeafSuccess d [String]
| LeafFail d [String]
data Dependency = Executable String type Payload p = (Maybe p, [String])
type Summary p = Either [String] (Payload p)
smryNil :: q -> Summary p
smryNil = const $ Right (Nothing, [])
smryFail :: String -> Either [String] a
smryFail msg = Left [msg]
smryInit :: Summary p
smryInit = Right (Nothing, [])
foldResultTreeMsgs :: ResultTree d p -> ([String], [String])
foldResultTreeMsgs = undefined
--------------------------------------------------------------------------------
-- | Result
type Result p = Either [String] (Maybe p)
resultNil :: p -> Result q
resultNil = const $ Right Nothing
--------------------------------------------------------------------------------
-- | IO Dependency
data IODependency a p = Executable Bool FilePath
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| IOTest String (IO (Maybe String)) | IOTest String (IO (Maybe String))
| IORead String (IO (Either String (Maybe p)))
| Systemd UnitType String | Systemd UnitType String
| DepFeature AnyFeature | NestedAlways (Always a) (a -> p)
| NestedSometimes (Sometimes a) (a -> p)
data UnitType = SystemUnit | UserUnit deriving (Eq, Show) data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
exe :: String -> FullDep Dependency sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
exe = fullDep . Executable sometimesExe n sys path = sometimesExeArgs n sys path []
pathR :: String -> FullDep Dependency sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
pathR n = fullDep $ AccessiblePath n True False sometimesExeArgs n sys path args =
sometimesIO n (Only (Executable sys path)) $ spawnCmd path args
pathW :: String -> FullDep Dependency pathR :: String -> IODependency a p
pathW n = fullDep $ AccessiblePath n False True pathR n = AccessiblePath n True False
pathRW :: String -> FullDep Dependency pathW :: String -> IODependency a p
pathRW n = fullDep $ AccessiblePath n True True pathW n = AccessiblePath n False True
systemUnit :: String -> FullDep Dependency pathRW :: String -> IODependency a p
systemUnit = fullDep . Systemd SystemUnit pathRW n = AccessiblePath n True True
userUnit :: String -> FullDep Dependency
userUnit = fullDep . Systemd UserUnit
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependencies (DBus) -- | DBus Dependency Result
data DBusDependency a p =
Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember
| DBusIO (IODependency a p)
data DBusMember = Method_ MemberName data DBusMember = Method_ MemberName
| Signal_ MemberName | Signal_ MemberName
| Property_ String | Property_ String
deriving (Eq, Show) deriving (Eq, Show)
data DBusDep =
Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember
| DBusGenDep Dependency
--------------------------------------------------------------------------------
-- | Dependency evaluation (General)
--
-- Test the existence of dependencies and return either Nothing (which actually
-- means success) or Just <error message>.
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 (DepFeature _) = undefined
-- TODO add something here to eval a nested feature's dependencies while
-- bypassing the feature itself
exeSatisfied :: String -> IO (Maybe String)
exeSatisfied x = do
r <- findExecutable x
return $ case r of
(Just _) -> Nothing
_ -> Just $ "executable '" ++ x ++ "' not found"
unitSatisfied :: UnitType -> String -> IO (Maybe String)
unitSatisfied u x = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Nothing
_ -> Just $ "systemd " ++ unitType u ++ " unit '" ++ x ++ "' not found"
where
cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
unitType SystemUnit = "system"
unitType UserUnit = "user"
pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathSatisfied p testread testwrite = do
res <- getPermissionsSafe p
let msg = permMsg res
return msg
where
testPerm False _ _ = Nothing
testPerm True f r = Just $ f r
permMsg NotFoundError = Just "file not found"
permMsg PermError = Just "could not get permissions"
permMsg (PermResult r) =
case (testPerm testread readable r, testPerm testwrite writable r) of
(Just False, Just False) -> Just "file not readable or writable"
(Just False, _) -> Just "file not readable"
(_, Just False) -> Just "file not writable"
_ -> Nothing
--------------------------------------------------------------------------------
-- | Dependency evaluation (DBus)
introspectInterface :: InterfaceName introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" introspectMethod = memberName_ "Introspect"
dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String) sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
dbusDepSatisfied client (Bus bus) = do -> MemberName -> Maybe Client -> Sometimes (m ())
sometimesEndpoint name busname path iface mem client =
sometimesDBus client name deps cmd
where
deps = Only $ Endpoint busname path iface $ Method_ mem
cmd c = io $ void $ callMethod c busname path iface mem
--------------------------------------------------------------------------------
-- | Feature evaluation
--
-- Here we attempt to build and return the monadic actions encoded by each
-- feature.
executeSometimes_ :: MonadIO m => Sometimes (m a) -> m ()
executeSometimes_ = void . executeSometimes
executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
-- TODO actually print things
evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a)
evalSometimes x = either (const Nothing) (Just . fst) <$> evalSometimesMsg x
-- TODO actually collect error messages here
-- TODO add feature name to errors
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Either [String] (a, [String]))
evalSometimesMsg x = io $ do
TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
return $ maybe (Left []) (\Finished { finAction = a } -> Right (a, [])) s
executeAlways_ :: MonadIO m => Always (m a) -> m ()
executeAlways_ = void . executeAlways
executeAlways :: MonadIO m => Always (m a) -> m a
executeAlways = join . evalAlways
-- TODO actually print things
evalAlways :: MonadIO m => Always a -> m a
evalAlways a = fst <$> evalAlwaysMsg a
evalAlwaysMsg :: MonadIO m => Always a -> m (a, [String])
evalAlwaysMsg a = io $ do
r <- testAlways a
return $ case r of
(Primary (Finished { finAction = act }) _ _) -> (act, [])
(Fallback act _) -> (act, [])
--------------------------------------------------------------------------------
-- | Dependency Testing
--
-- Here we test all dependencies and keep the tree structure so we can print it
-- for diagnostic purposes. This obviously has overlap with feature evaluation
-- since we need to resolve dependencies to build each feature.
testAlways :: Always a -> IO (TestedAlways a p)
testAlways = go []
where
go failed (Option fd next) = do
r <- testSubfeature fd
case r of
(Untestable fd' err) -> go (Left (fd' ,err):failed) next
(FailedFtr fd' errs) -> go (Right (fd' ,errs):failed) next
(SuccessfulFtr s) -> return $ Primary s failed next
go failed (Always a) = return $ Fallback a failed
testSometimes :: Sometimes a -> IO (TestedSometimes a p)
testSometimes = go (TestedSometimes Nothing [] [])
where
go ts [] = return ts
go ts (x:xs) = do
r <- testSubfeature x
case r of
(Untestable fd' err) -> go (addFail ts (Left (fd' ,err))) xs
(FailedFtr fd' errs) -> go (addFail ts (Right (fd' ,errs))) xs
(SuccessfulFtr s) -> return $ ts { tsSuccess = Just s }
addFail ts@(TestedSometimes { tsFailed = f }) new
= ts { tsFailed = new:f }
testSubfeature :: Subfeature a Tree -> IO (FeatureResult a p)
testSubfeature fd@(Subfeature { sfTree = t }) = do
atm <- testActionTree t
return $ either untestable checkAction atm
where
untestable (t', err) = Untestable (fd { sfTree = t' }) err
checkAction (t', Just a, ms) = SuccessfulFtr
$ Finished { finData = fd { sfTree = t' }
, finAction = a
, finWarnings = ms
}
checkAction (t', Nothing, ms) = FailedFtr (fd { sfTree = t' }) ms
testActionTree :: ActionTree a Tree -> IO (ActionTreeMaybe a p)
testActionTree t = do
case t of
(IOTree a d) -> do
(t', a', msgs) <- doTest testIOTree d a
return $ Right (IOTree a t', a', msgs)
(DBusTree a (Just cl) d) -> do
(t', a', msgs) <- doTest (testDBusTree cl) d a
return $ Right (DBusTree a (Just cl) t', fmap (\f -> f cl) a', msgs)
_ -> return $ Left (t, "client not available")
where
doTest testFun d a = do
(t', r) <- testFun d
-- TODO actually recover the proper error messages
let (a', msgs) = maybe (Nothing, []) (\p -> (fmap (apply a) p, [])) r
return (t', a', msgs)
apply (Standalone a) _ = a
apply (Consumer a) p = a p
testIOTree :: Tree (IODependency a p) p
-> IO (ResultTree (IODependency a p) p, Maybe (Maybe p))
testIOTree = testTree testIODependency
testDBusTree :: Client -> Tree (DBusDependency a p) p
-> IO (ResultTree (DBusDependency a p) p, Maybe (Maybe p))
testDBusTree client = testTree (testDBusDependency client)
testTree :: Monad m => (d -> m (Summary p)) -> Tree d p
-> m (ResultTree d p, Maybe (Maybe p))
testTree test = go
where
go (And f a b) = do
(ra, pa) <- go a
let combine = maybe (const Nothing) (\pa' -> Just . f pa')
let pass p = test2nd (combine p) ra b
let fail_ = return (First ra b, Nothing)
maybe fail_ pass pa
go (Or fa fb a b) = do
(ra, pa) <- go a
let pass p = return (First ra b, Just $ fa <$> p)
let fail_ = test2nd (Just . fb) ra b
maybe fail_ pass pa
go (Only a) =
either (\es -> (LeafFail a es, Nothing)) (\(p, ws) -> (LeafSuccess a ws, Just p))
<$> test a
test2nd f ra b = do
(rb, pb) <- go b
return (Both ra rb, fmap (f =<<) pb)
testIODependency :: IODependency a p -> IO (Summary p)
testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin
where
err = Left ["executable '" ++ bin ++ "' not found"]
testIODependency (IOTest _ t) = maybe (Right (Nothing, [])) (Left . (:[])) <$> t
testIODependency (IORead _ t) = bimap (:[]) (, []) <$> t
testIODependency (Systemd t n) = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Right (Nothing, [])
_ -> Left ["systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"]
where
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
unitType SystemUnit = "system"
unitType UserUnit = "user"
testIODependency (AccessiblePath p r w) = do
res <- getPermissionsSafe p
let msg = permMsg res
return msg
where
testPerm False _ _ = Nothing
testPerm True f res = Just $ f res
permMsg NotFoundError = smryFail "file not found"
permMsg PermError = smryFail "could not get permissions"
permMsg (PermResult res) =
case (testPerm r readable res, testPerm w writable res) of
(Just False, Just False) -> smryFail "file not readable or writable"
(Just False, _) -> smryFail "file not readable"
(_, Just False) -> smryFail "file not writable"
_ -> Right (Nothing, [])
-- TODO actually collect errors here
testIODependency (NestedAlways a f) = do
r <- testAlways a
return $ Right $ case r of
(Primary (Finished { finAction = act }) _ _) -> (Just $ f act, [])
(Fallback act _) -> (Just $ f act, [])
testIODependency (NestedSometimes x f) = do
TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
return $ maybe (Left []) (\Finished { finAction = a } -> Right (Just $ f a, [])) s
testDBusDependency :: Client -> DBusDependency a p -> IO (Summary p)
testDBusDependency client (Bus bus) = do
ret <- callMethod client queryBus queryPath queryIface queryMem ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Just e Left e -> smryFail e
Right b -> let ns = bodyGetNames b in Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Nothing if bus' `elem` ns then Right (Nothing, [])
else Just $ unwords ["name", singleQuote bus', "not found on dbus"] else smryFail $ unwords ["name", singleQuote bus', "not found on dbus"]
where where
bus' = formatBusName bus bus' = formatBusName bus
queryBus = busName_ "org.freedesktop.DBus" queryBus = busName_ "org.freedesktop.DBus"
@ -443,17 +458,17 @@ dbusDepSatisfied client (Bus bus) = do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = [] bodyGetNames _ = []
dbusDepSatisfied client (Endpoint busname objpath iface mem) = do testDBusDependency client (Endpoint busname objpath iface mem) = do
ret <- callMethod client busname objpath introspectInterface introspectMethod ret <- callMethod client busname objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Just e Left e -> smryFail e
Right body -> procBody body Right body -> procBody body
where where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in =<< listToMaybe body in
case res of case res of
Just True -> Nothing Just True -> Right (Nothing, [])
_ -> Just $ fmtMsg' mem _ -> smryFail $ fmtMsg' mem
findMem = fmap (matchMem mem) findMem = fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface) . find (\i -> I.interfaceName i == iface)
. I.objectInterfaces . I.objectInterfaces
@ -473,43 +488,19 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
, formatBusName busname , formatBusName busname
] ]
dbusDepSatisfied _ (DBusGenDep d) = evalDependency d testDBusDependency _ (DBusIO d) = testIODependency d
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Printing dependencies -- | Printing
-- instance ToJSON (DepTree a) where printMsgs :: LogLevel -> [Msg] -> IO ()
-- toJSON (GenTree _) = undefined printMsgs lvl ms = do
pn <- getProgName
mapM_ (printMsg pn lvl) ms
-- instance ToJSON Dependency where printMsg :: String -> LogLevel -> Msg -> IO ()
-- toJSON (Executable n) = depValue "executable" Nothing n printMsg pname lvl (Msg ml mn msg)
-- toJSON (IOTest d _) = depValue "internal" Nothing d | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
-- toJSON (Systemd t n) = depValue "systemd" (Just $ tp t) n | otherwise = skip
-- where
-- tp SystemUnit = "sys"
-- tp UserUnit = "user"
-- toJSON (AccessiblePath p r w) = depValue "path" perms p
-- where
-- perms = case (r, w) of
-- (True, True) -> Just "readwrite"
-- (True, False) -> Just "read"
-- (False, True) -> Just "write"
-- _ -> Nothing
-- depValue :: String -> Maybe String -> String -> Value
-- depValue t s n = object
-- [ "type" .= t
-- , "name" .= n
-- , "subtype" .= maybe Null (String . T.pack) s
-- ]
depName :: Dependency -> String
depName (Executable n) = "executable: " ++ n
depName (IOTest d _) = "internal: " ++ d
depName (Systemd t n) = "systemd (" ++ tp t ++ "): " ++ n
where where
tp SystemUnit = "sys" bracket s = "[" ++ s ++ "]"
tp UserUnit = "user"
depName (AccessiblePath p _ _) = "path: " ++ p
depName (DepFeature _) = "feature: blablabla"

View File

@ -1,395 +0,0 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
--------------------------------------------------------------------------------
-- | Functions for handling dependencies
module XMonad.Internal.DependencyX where
-- import Control.Monad.IO.Class
-- import Control.Monad.Identity
-- import Data.Aeson
import Data.Bifunctor
import Data.Either
import Data.List (find)
import Data.Maybe
-- import qualified Data.Text as T
import DBus
import DBus.Client
import DBus.Internal
import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable)
import System.Environment
import System.Exit
-- import XMonad.Core (X, io)
import XMonad.Core (X)
import XMonad.Internal.IO
import XMonad.Internal.Process
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
-- | Feature
data AnyFeature p = FX (FeatureX p) | FIO (FeatureIO p)
type FeatureX p = Feature (X ()) p
type FeatureIO p = Feature (IO ()) p
data Feature a p = Feature (FeatureData a Tree p) (Feature a p)
| NoFeature
| ConstFeature a
-- TODO this feels icky, and I don't feel like typing it
data TestedFeature a p = TestedFeature (TestedFeature_ a p)
| TestedConst a [FailedFeature a p]
data TestedFeature_ a p = TestedFeature_
{ tfSuccess :: Maybe (SuccessfulFeature a p)
, tfFailed :: [FailedFeature a p]
, tfUntested :: Feature a p
}
type FailedFeature a p = Either (FeatureData a Tree p, String)
(FeatureData a ResultTree p, [String])
data SuccessfulFeature a p = SuccessfulFeature
{ sfData :: FeatureData a ResultTree p
, sfAction :: a
, sfWarnings :: [String]
}
data FeatureResult a p = Untestable (FeatureData a Tree p) String |
FailedFtr (FeatureData a ResultTree p) [String] |
SuccessfulFtr (SuccessfulFeature a p)
type ActionTreeMaybe a p = Either (ActionTree a Tree p, String)
(ActionTree a ResultTree p, Maybe a, [String])
printMsgs :: LogLevel -> [Msg] -> IO ()
printMsgs lvl ms = do
pn <- getProgName
mapM_ (printMsg pn lvl) ms
printMsg :: String -> LogLevel -> Msg -> IO ()
printMsg pname lvl (Msg ml mn msg)
| lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
| otherwise = skip
where
bracket s = "[" ++ s ++ "]"
--------------------------------------------------------------------------------
-- | Feature Data
data FeatureData a t p = FeatureData
{ fdTree :: ActionTree a t p
, fdName :: String
, fdLevel :: LogLevel
}
data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
data Msg = Msg LogLevel String String
--------------------------------------------------------------------------------
-- | Action Tree
data ActionTree a t p =
IOTree (Action a p) (t (IODependency a p) p)
| DBusTree (Action (Client -> a) p) (Maybe Client) (t (DBusDependency a p) p)
data Action a p = Standalone a | Consumer (p -> a)
--------------------------------------------------------------------------------
-- | (Result) Tree
data Tree d p =
And (p -> p -> p) (Tree d p) (Tree d p)
| Or (p -> p) (p -> p) (Tree d p) (Tree d p)
| Only d
-- | how to interpret ResultTree combinations:
-- First (LeafSuccess a) (Tree a) -> Or that succeeded on left
-- First (LeafFail a) (Tree a) -> And that failed on left
-- Both (LeafFail a) (Fail a) -> Or that failed
-- Both (LeafSuccess a) (LeafSuccess a) -> And that succeeded
-- Both (LeafFail a) (LeafSuccess a) -> Or that failed first and succeeded second
-- Both (LeafSuccess a) (LeafFail a) -> And that failed on the right
data ResultTree d p =
First (ResultTree d p) (Tree d p)
| Both (ResultTree d p) (ResultTree d p)
| LeafSuccess d [String]
| LeafFail d [String]
type Payload p = (Maybe p, [String])
type Summary p = Either [String] (Payload p)
smryNil :: q -> Summary p
smryNil = const $ Right (Nothing, [])
smryFail :: String -> Either [String] a
smryFail msg = Left [msg]
smryInit :: Summary p
smryInit = Right (Nothing, [])
foldResultTreeMsgs :: ResultTree d p -> ([String], [String])
foldResultTreeMsgs = undefined
--------------------------------------------------------------------------------
-- | Result
type Result p = Either [String] (Maybe p)
resultNil :: p -> Result q
resultNil = const $ Right Nothing
--------------------------------------------------------------------------------
-- | IO Dependency
data IODependency a p = Executable Bool FilePath
| AccessiblePath FilePath Bool Bool
| IOTest String (IO (Maybe String))
| IORead String (IO (Either String (Maybe p)))
| Systemd UnitType String
| NestedFeature (Feature a p) (a -> p)
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | DBus Dependency Result
data DBusDependency a p =
Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember
| DBusIO (IODependency a p)
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
--------------------------------------------------------------------------------
-- | Feature evaluation
--
-- Here we attempt to build and return the monadic actions encoded by each
-- feature.
evalFeature :: Feature a p -> IO (Maybe a)
evalFeature ftr = do
r <- testFeature ftr
-- TODO print out all the errors/warnings when doing this
case r of
TestedConst c _ -> return $ Just c
TestedFeature t ->
case t of
TestedFeature_ { tfSuccess = Nothing, tfFailed = _ } -> return Nothing
TestedFeature_ { tfSuccess = Just (SuccessfulFeature { sfAction = a })
, tfFailed = _ } -> return $ Just a
--------------------------------------------------------------------------------
-- | Dependency Testing
--
-- Here we test all dependencies and keep the tree structure so we can print it
-- for diagnostic purposes. This obviously has overlap with feature evaluation
-- since we need to resolve dependencies to build each feature.
testFeature :: Feature a p -> IO (TestedFeature a p)
testFeature = go []
where
go failed (Feature fd alt) = do
r <- testFeatureData fd
case r of
(Untestable fd' err) -> tryAlt alt $ Left (fd' ,err):failed
(FailedFtr fd' errs) -> tryAlt alt $ Right (fd' ,errs):failed
(SuccessfulFtr s) -> return $ TestedFeature $ TestedFeature_ (Just s) failed alt
go failed NoFeature = return $ TestedFeature $ TestedFeature_ Nothing failed NoFeature
go failed (ConstFeature c) = return $ TestedConst c failed
tryAlt NoFeature failed = return $ TestedFeature $ TestedFeature_ Nothing failed NoFeature
tryAlt alt failed = go failed alt
testFeatureData :: FeatureData a Tree p -> IO (FeatureResult a p)
testFeatureData fd@(FeatureData { fdTree = t }) = do
atm <- testActionTree t
return $ either untestable checkAction atm
where
untestable (t', err) = Untestable (fd { fdTree = t' }) err
checkAction (t', Just a, ms) = SuccessfulFtr
$ SuccessfulFeature { sfData = fd { fdTree = t' }
, sfAction = a
, sfWarnings = ms
}
checkAction (t', Nothing, ms) = FailedFtr (fd { fdTree = t' }) ms
testActionTree :: ActionTree a Tree p -> IO (ActionTreeMaybe a p)
testActionTree t = do
case t of
(IOTree a d) -> do
(t', a', msgs) <- doTest testIOTree d a
return $ Right (IOTree a t', a', msgs)
(DBusTree a (Just cl) d) -> do
(t', a', msgs) <- doTest (testDBusTree cl) d a
return $ Right (DBusTree a (Just cl) t', fmap (\f -> f cl) a', msgs)
_ -> return $ Left (t, "client not available")
where
doTest testFun d a = do
(t', r) <- testFun d
-- TODO actually recover the proper error messages
let (a', msgs) = maybe (Nothing, []) (\p -> (fmap (apply a) p, [])) r
return (t', a', msgs)
apply (Standalone a) _ = a
apply (Consumer a) p = a p
testIOTree :: Tree (IODependency a p) p
-> IO (ResultTree (IODependency a p) p, Maybe (Maybe p))
testIOTree = testTree testIODependency
testDBusTree :: Client -> Tree (DBusDependency a p) p
-> IO (ResultTree (DBusDependency a p) p, Maybe (Maybe p))
testDBusTree client = testTree (testDBusDependency client)
testTree :: Monad m => (d -> m (Summary p)) -> Tree d p
-> m (ResultTree d p, Maybe (Maybe p))
testTree test = go
where
go (And f a b) = do
(ra, pa) <- go a
let combine = maybe (const Nothing) (\pa' -> Just . f pa')
let pass p = test2nd (combine p) ra b
let fail_ = return (First ra b, Nothing)
maybe fail_ pass pa
go (Or fa fb a b) = do
(ra, pa) <- go a
let pass p = return (First ra b, Just $ fa <$> p)
let fail_ = test2nd (Just . fb) ra b
maybe fail_ pass pa
go (Only a) =
either (\es -> (LeafFail a es, Nothing)) (\(p, ws) -> (LeafSuccess a ws, Just p))
<$> test a
test2nd f ra b = do
(rb, pb) <- go b
return (Both ra rb, fmap (f =<<) pb)
testIODependency :: IODependency a p -> IO (Summary p)
testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin
where
err = Left ["executable '" ++ bin ++ "' not found"]
testIODependency (IOTest _ t) = maybe (Right (Nothing, [])) (Left . (:[])) <$> t
testIODependency (IORead _ t) = bimap (:[]) (, []) <$> t
testIODependency (Systemd t n) = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Right (Nothing, [])
_ -> Left ["systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"]
where
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
unitType SystemUnit = "system"
unitType UserUnit = "user"
testIODependency (AccessiblePath p r w) = do
res <- getPermissionsSafe p
let msg = permMsg res
return msg
where
testPerm False _ _ = Nothing
testPerm True f res = Just $ f res
permMsg NotFoundError = smryFail "file not found"
permMsg PermError = smryFail "could not get permissions"
permMsg (PermResult res) =
case (testPerm r readable res, testPerm w writable res) of
(Just False, Just False) -> smryFail "file not readable or writable"
(Just False, _) -> smryFail "file not readable"
(_, Just False) -> smryFail "file not writable"
_ -> Right (Nothing, [])
testIODependency (NestedFeature ftr trans) = do
r <- testFeature ftr
return $ case r of
-- TODO why would anyone do this?
TestedConst c _ -> Right (Just $ trans c, [])
TestedFeature t ->
case t of
-- TODO actually summarize errors
TestedFeature_ { tfSuccess = Nothing
, tfFailed = _ } -> Left []
TestedFeature_ { tfSuccess = Just (SuccessfulFeature { sfAction = a })
, tfFailed = _ } -> Right (Just $ trans a, [])
-- testIODependency (NestedFeature ftr) = go ftr
-- where
-- go (Feature (FeatureData { fdTree = t }) alt) =
-- -- TODO add feature name to messages
-- case t of
-- (IOTree _ ct) -> summarize <$> testIOTree ct
-- (DBusTree _ (Just cl) ct) -> summarize <$> testDBusTree cl ct
-- (DBusTree _ Nothing _) -> failMaybe alt ["client not found"]
-- where
-- failMaybe NoFeature msg = return $ Left msg
-- failMaybe f _ = go f
-- -- TODO actually thread errors here
-- summarize (_, Just p) = Right (p, [])
-- summarize (_, Nothing) = Left []
-- go _ = return $ Right (Nothing, [])
testDBusDependency :: Client -> DBusDependency a p -> IO (Summary p)
testDBusDependency client (Bus bus) = do
ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> smryFail e
Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Right (Nothing, [])
else smryFail $ unwords ["name", singleQuote bus', "not found on dbus"]
where
bus' = formatBusName bus
queryBus = busName_ "org.freedesktop.DBus"
queryIface = interfaceName_ "org.freedesktop.DBus"
queryPath = objectPath_ "/"
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = []
testDBusDependency client (Endpoint busname objpath iface mem) = do
ret <- callMethod client busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> smryFail e
Right body -> procBody body
where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in
case res of
Just True -> Right (Nothing, [])
_ -> smryFail $ 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 I.propertyName I.interfaceProperties
elemMember n fname fmember = elem n . fmap fname . fmember
fmtMem (Method_ n) = "method " ++ singleQuote (formatMemberName n)
fmtMem (Signal_ n) = "signal " ++ singleQuote (formatMemberName n)
fmtMem (Property_ n) = "property " ++ singleQuote n
fmtMsg' m = unwords
[ "could not find"
, fmtMem m
, "on interface"
, singleQuote $ formatInterfaceName iface
, "on bus"
, formatBusName busname
]
testDBusDependency _ (DBusIO d) = testIODependency d

View File

@ -0,0 +1,591 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Functions for handling dependencies
module XMonad.Internal.Dependency
( MaybeAction
, AnyFeature(..)
, DepChoice(..)
, MaybeX
, FullDep(..)
, DepTree(..)
, Action(..)
, DBusDep(..)
, FeatureX
, FeatureIO
, Feature(..)
, Feature_(..)
, Warning(..)
, Dependency(..)
, UnitType(..)
, DBusMember(..)
, feature
, ioFeature
, evalFeature
, systemUnit
, userUnit
, pathR
, pathW
, pathRW
, featureDefault
, featureExeArgs
, featureExe
, featureEndpoint
, whenSatisfied
, ifSatisfied
, executeFeature
, executeFeature_
, executeFeatureWith
, executeFeatureWith_
, depName
, fullDep
, exe
, listToAnds
) where
import Control.Monad.IO.Class
import Control.Monad.Identity
-- import Data.Aeson
import Data.Bifunctor
import Data.Either
import Data.List (find)
import Data.Maybe
-- import qualified Data.Text as T
import DBus
import DBus.Client
import DBus.Internal
import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable)
import System.Environment
import System.Exit
import XMonad.Core (X, io)
import XMonad.Internal.IO
import XMonad.Internal.Process
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
-- | Features
--
-- A 'feature' is composed of a 'dependency tree' which at the root has an
-- 'action' to be performed with a number of 'dependencies' below it.
--
-- 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
-- (notably 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.
-- TODO some things to add to make this more feature-ful (lol)
-- - use AndOr types to encode alternative dependencies into the tree
-- - use an Alt data constructor for Features (which will mean "try A before B"
-- - add an Either String Bool to dependency nodes that encodes testing status
-- (where Right False means untested)
-- - add a lens/functor mapper thingy to walk down the tree and update testing
-- status fields
-- - print to JSON
-- - make sum type to hold all type instances of Feature blabla (eg IO and X)
-- - figure out how to make features a dependency of another feature
data Feature_ a = Feature_
{ ftrDepTree :: DepTree a
, ftrName :: String
, ftrWarning :: Warning
}
data Feature a = Feature (Feature_ a) (Feature a)
| NoFeature
| ConstFeature a
-- 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 ())
data AnyFeature = FX FeatureX | FIO FeatureIO
feature :: String -> Warning -> DepTree a -> Feature a
feature n w t = Feature f NoFeature
where
f = Feature_
{ ftrDepTree = t
, ftrName = n
, ftrWarning = w
}
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
ioFeature (ConstFeature a) = ConstFeature $ liftIO a
ioFeature NoFeature = NoFeature
ioFeature (Feature f r)
= Feature (f {ftrDepTree = liftIO <$> ftrDepTree f}) $ ioFeature r
featureDefault :: String -> DepChoice (FullDep Dependency) -> a -> Feature a
featureDefault n ds x = feature n Default $ GenTree (Single x) 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 (Only $ FullDep (Right False) $ Executable cmd) $ spawnCmd cmd args
featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> Maybe Client -> FeatureIO
featureEndpoint name busname path iface mem client = feature name Default
$ DBusTree (Single cmd) client deps
where
cmd c = void $ callMethod c busname path iface mem
deps = Only $ FullDep (Right False) $ Endpoint busname path iface $ Method_ mem
--------------------------------------------------------------------------------
-- | Dependency Trees
--
-- Dependency trees have two subtypes: general and DBus. The latter require a
-- DBus client to evaluate (and will automatically fail if this is missing).
-- The former can be evaluated independently.
data DepChoice a = And (DepChoice a) (DepChoice a)
| Or (DepChoice a) (DepChoice a)
| Only a
data DepChoice_ a b = And_ (b -> b -> b) (DepChoice_ a b) (DepChoice_ a b)
| Or_ (DepChoice_ a b) (DepChoice_ a b)
| Only_ a
listToAnds :: a -> [a] -> DepChoice a
listToAnds i = foldr (And . Only) (Only i)
-- listToAnds' :: [a] -> Maybe (DepChoice a)
-- listToAnds' [] = Nothing
-- listToAnds' (x:xs) = Just $ foldr (And . Only) (Only x) xs
data DepTree a = GenTree (Action a) (DepChoice (FullDep Dependency))
| DBusTree (Action (Client -> a)) (Maybe Client) (DepChoice (FullDep DBusDep))
data DepTree_ a b = GenTree_ (Action_ a b) (DepChoice_ (FullDep Dependency) b)
| DBusTree_ (Action_ (Client -> a) b) (Maybe Client) (DepChoice_ (FullDep DBusDep) b)
instance Functor DepTree where
fmap f (GenTree a ds) = GenTree (f <$> a) ds
fmap f (DBusTree a c ds) = DBusTree (fmap (fmap f) a) c ds
--------------------------------------------------------------------------------
-- | Actions
--
-- Actions have two subtypes: single and double. Single actions are just one
-- independent action. Double actions have one dependent pre-step which the
-- main action consumes (and fails if the pre-step fails).
data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b))
data Action_ a b = Standalone a | Consumer (b -> a)
instance Functor Action where
fmap f (Single a) = Single (f a)
fmap f (Double a b) = Double (f . a) b
--------------------------------------------------------------------------------
-- | 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 = Maybe a
type MaybeX = MaybeAction (X ())
evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Just x
evalFeature NoFeature = return Nothing
evalFeature (Feature f alt) = do
procName <- getProgName
res <- evalTree =<< evalTree' a
case res of
Right r -> return $ Just r
Left l -> do
printWarnings procName l
case alt of
NoFeature -> return Nothing
-- TODO make this message better
next -> putStrLn "trying alternative" >> evalFeature next
where
Feature_ {ftrDepTree = a, ftrName = n, ftrWarning = w} = f
printWarnings procName es = do
case w of
Silent -> return ()
Default -> let prefix = n ++ " disabled; "
es' = fmap (fmtMsg procName . (prefix ++)) es in
mapM_ putStrLn es'
fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
bracket s = concat ["[", s, "]"]
mapMDepChoice :: Monad m => (a -> m a) -> (a -> Bool) -> DepChoice a -> m (DepChoice a)
mapMDepChoice f pass = fmap snd . go
where
go d@(And a b) = do
(ra, a') <- go a
if not ra then return (False, d) else do
(rb, b') <- go b
return $ if rb then (True, And a' b') else (False, d)
go d@(Or a b) = do
(ra, a') <- go a
if ra then return (True, Or a' b) else do
(rb, b') <- go b
return $ if rb then (True, Or a' b') else (False, d)
go d@(Only a) = do
a' <- f a
return $ if pass a' then (True, Only a') else (False, d)
-- foldDepChoice :: (a -> Bool) -> DepChoice a -> Bool
-- foldDepChoice get dc = case dc of
-- And a b -> go a && go b
-- Or a b -> go a || go b
-- Only a -> get a
-- where
-- go = foldDepChoice get
foldDepChoice' :: Bool -> (a -> Maybe b) -> DepChoice a -> [b]
foldDepChoice' justSucceed get = fromMaybe [] . go []
where
go acc (And a b) = Just $ andFun acc a b
go acc (Or a b) = Just $ orFun acc a b
go acc (Only a) = (:acc) <$> get a
(andFun, orFun) = if justSucceed then (and', or') else (or', and')
and' acc a b = case (go acc a, go acc b) of
(Just a', Just b') -> a' ++ b' ++ acc
(Just a', Nothing) -> a' ++ acc
(Nothing, _) -> acc
or' acc a b = fromMaybe [] (go acc a) ++ fromMaybe [] (go acc b) ++ acc
foldDepChoiceX :: (a -> Either b c) -> DepChoice_ a c -> Either [b] c
foldDepChoiceX get = go (Left [])
where
go acc (And_ f a b) = case (go acc a, go acc b) of
(Right a', Right b') -> Right $ f a' b'
(Left a', Right _) -> toLeft acc a'
(Right _, Left b') -> toLeft acc b'
(Left a', Left b') -> toLeft acc $ a' ++ b'
go acc (Or_ a b) = case (go acc a, go acc b) of
(Right a', _) -> Right a'
(Left _, Right b') -> Right b'
(Left a', Left b') -> toLeft acc $ a' ++ b'
go acc (Only_ a) = first (:fromLeft [] acc) $ get a
toLeft acc xs = Left $ xs ++ fromLeft [] acc
-- foldDepChoice :: DepChoice a -> (a -> Maybe b) -> [b]
-- foldDepChoice dc f = go [] dc
-- where
-- go acc d = case d of
-- And a b -> do
-- acc'@(a':_) <- go acc a
-- if pass a' then go acc' b else return acc
-- Or a b -> do
-- acc'@(a':_) <- go acc a
-- if pass a' then return [a'] else go acc' b
-- Only a -> maybe acc $ f a
-- TODO wet code
evalTree :: DepTree a -> IO (Either [String] a)
evalTree dt = case dt of
(GenTree a ds) ->
case foldDep ds of
[] -> evalAction a
es -> return $ Left es
(DBusTree a (Just client) ds) ->
case foldDep ds of
[] -> fmap (\f -> f client) <$> evalAction a
es -> return $ Left es
(DBusTree _ Nothing _) -> return $ Left ["client not available"]
where
foldDep = foldDepChoice' False fullDepMsg
fullDepMsg (FullDep e _) = either Just (const Nothing) e
evalTreeX :: DepTree_ a b -> IO (Either [String] a)
evalTreeX dt = case dt of
(GenTree_ a ds) ->
case foldDep ds of
[] -> evalAction a
es -> return $ Left es
(DBusTree_ a (Just client) ds) ->
case foldDep ds of
[] -> fmap (\f -> f client) <$> evalAction a
es -> return $ Left es
(DBusTree_ _ Nothing _) -> return $ Left ["client not available"]
where
foldDep = foldDepChoiceX fullDepMsg
fullDepMsg (FullDep e _) = either Just (const Nothing) e
depResult :: FullDep Dependency -> Either String (Maybe b)
depResult (FullDep l@(Left e) d) = Left e
depResult (FullDep _ d) = Right $ extractDependency d
evalTree' :: DepTree a -> IO (DepTree a)
evalTree' (GenTree a ds) = GenTree a <$> mapMDepChoice eval pass ds
where
eval (FullDep _ d) = do
r <- evalDependency d
return $ FullDep (maybe (Right True) Left r) d
pass (FullDep (Right True) _) = True
pass _ = True
evalTree' d@(DBusTree _ Nothing _) = return d
evalTree' (DBusTree a (Just client) ds) = DBusTree a (Just client) <$> mapMDepChoice eval pass ds
where
eval (FullDep _ d) = do
r <- eval' d
return $ FullDep (maybe (Right True) Left r) d
eval' (DBusGenDep d) = evalDependency d
eval' x = dbusDepSatisfied client x
pass (FullDep (Right True) _) = True
pass _ = True
evalAction :: Action a -> IO (Either [String] a)
evalAction (Single a) = return $ Right a
evalAction (Double a b) = fmap a <$> b
-- evalActionX :: Action_ a b -> IO (Either [String] a)
-- evalActionX (Standalone a) = return $ Right a
-- evalActionX (Consumer f) = fmap a <$> b
executeFeatureWith :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
executeFeatureWith iof def ftr = do
a <- io $ evalFeature ftr
maybe (return def) (iof . io) a
executeFeatureWith_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
executeFeatureWith_ iof = executeFeatureWith iof ()
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
executeFeature = executeFeatureWith id
executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature ()
whenSatisfied :: Monad m => MaybeAction (m ()) -> m ()
whenSatisfied = flip ifSatisfied skip
ifSatisfied :: MaybeAction a -> a -> a
ifSatisfied (Just x) _ = x
ifSatisfied _ alt = alt
--------------------------------------------------------------------------------
-- | Dependencies (General)
data FullDep a = FullDep (Either String Bool) a deriving (Functor)
fullDep :: a -> FullDep a
fullDep = FullDep (Right True)
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest String (IO (Maybe String))
| Systemd UnitType String
| DepFeature AnyFeature
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
exe :: String -> FullDep Dependency
exe = fullDep . Executable
pathR :: String -> FullDep Dependency
pathR n = fullDep $ AccessiblePath n True False
pathW :: String -> FullDep Dependency
pathW n = fullDep $ AccessiblePath n False True
pathRW :: String -> FullDep Dependency
pathRW n = fullDep $ AccessiblePath n True True
systemUnit :: String -> FullDep Dependency
systemUnit = fullDep . Systemd SystemUnit
userUnit :: String -> FullDep Dependency
userUnit = fullDep . Systemd UserUnit
--------------------------------------------------------------------------------
-- | Dependencies (DBus)
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
data DBusDep =
Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember
| DBusGenDep Dependency
--------------------------------------------------------------------------------
-- | Dependency evaluation (General)
--
-- Test the existence of dependencies and return either Nothing (which actually
-- means success) or Just <error message>.
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 (DepFeature _) = undefined
-- TODO add something here to eval a nested feature's dependencies while
-- bypassing the feature itself
extractDependency :: Dependency -> Maybe a
extractDependency (Executable n) = Nothing
extractDependency (IOTest _ t) = Nothing
extractDependency (Systemd t n) = Nothing
extractDependency (AccessiblePath p r w) = Nothing
extractDependency (DepFeature _) = Nothing
exeSatisfied :: String -> IO (Maybe String)
exeSatisfied x = do
r <- findExecutable x
return $ case r of
(Just _) -> Nothing
_ -> Just $ "executable '" ++ x ++ "' not found"
unitSatisfied :: UnitType -> String -> IO (Maybe String)
unitSatisfied u x = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Nothing
_ -> Just $ "systemd " ++ unitType u ++ " unit '" ++ x ++ "' not found"
where
cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
unitType SystemUnit = "system"
unitType UserUnit = "user"
pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathSatisfied p testread testwrite = do
res <- getPermissionsSafe p
let msg = permMsg res
return msg
where
testPerm False _ _ = Nothing
testPerm True f r = Just $ f r
permMsg NotFoundError = Just "file not found"
permMsg PermError = Just "could not get permissions"
permMsg (PermResult r) =
case (testPerm testread readable r, testPerm testwrite writable r) of
(Just False, Just False) -> Just "file not readable or writable"
(Just False, _) -> Just "file not readable"
(_, Just False) -> Just "file not writable"
_ -> Nothing
--------------------------------------------------------------------------------
-- | Dependency evaluation (DBus)
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
dbusDepSatisfied client (Bus bus) = do
ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Just e
Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Nothing
else Just $ unwords ["name", singleQuote bus', "not found on dbus"]
where
bus' = formatBusName bus
queryBus = busName_ "org.freedesktop.DBus"
queryIface = interfaceName_ "org.freedesktop.DBus"
queryPath = objectPath_ "/"
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = []
dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
ret <- callMethod client busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Just e
Right body -> procBody body
where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in
case res of
Just True -> Nothing
_ -> Just $ 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 I.propertyName I.interfaceProperties
elemMember n fname fmember = elem n . fmap fname . fmember
fmtMem (Method_ n) = "method " ++ singleQuote (formatMemberName n)
fmtMem (Signal_ n) = "signal " ++ singleQuote (formatMemberName n)
fmtMem (Property_ n) = "property " ++ singleQuote n
fmtMsg' m = unwords
[ "could not find"
, fmtMem m
, "on interface"
, singleQuote $ formatInterfaceName iface
, "on bus"
, formatBusName busname
]
dbusDepSatisfied _ (DBusGenDep d) = evalDependency d
--------------------------------------------------------------------------------
-- | Printing dependencies
-- instance ToJSON (Feature_ a) where
-- toJSON Feature_ {} = undefined
-- instance ToJSON (Feature_ a) where
-- toJSON Feature_ {} = undefined
-- instance ToJSON (DepTree a) where
-- toJSON (GenTree _ _) = undefined
-- toJSON (DBusTree {}) = undefined
-- instance ToJSON Dependency where
-- toJSON (Executable n) = depValue "executable" Nothing n
-- toJSON (IOTest d _) = depValue "internal" Nothing d
-- toJSON (Systemd t n) = depValue "systemd" (Just $ tp t) n
-- where
-- tp SystemUnit = "sys"
-- tp UserUnit = "user"
-- toJSON (AccessiblePath p r w) = depValue "path" perms p
-- where
-- perms = case (r, w) of
-- (True, True) -> Just "readwrite"
-- (True, False) -> Just "read"
-- (False, True) -> Just "write"
-- _ -> Nothing
-- toJSON (DepFeature _) = undefined
-- depValue :: String -> Maybe String -> String -> Value
-- depValue t s n = object
-- [ "type" .= t
-- , "name" .= n
-- , "subtype" .= maybe Null (String . T.pack) s
-- ]
depName :: Dependency -> String
depName (Executable n) = "executable: " ++ n
depName (IOTest d _) = "internal: " ++ d
depName (Systemd t n) = "systemd (" ++ tp t ++ "): " ++ n
where
tp SystemUnit = "sys"
tp UserUnit = "user"
depName (AccessiblePath p _ _) = "path: " ++ p
depName (DepFeature _) = "feature: blablabla"