WIP transition all dependencies to new framework
This commit is contained in:
parent
7a1c77b33e
commit
d8a88531b0
|
@ -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 x = addName "Show Keybindings" $ do
|
||||||
|
-- s <- io $ evalFeature $ runDMenuShowKeys x
|
||||||
|
-- ifSatisfied s
|
||||||
|
-- $ spawnNotify
|
||||||
|
-- $ defNoteError { body = Just $ Text "could not display keymap" }
|
||||||
|
|
||||||
|
-- TODO not sure what to do with this yet
|
||||||
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
|
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
|
||||||
runShowKeys x = addName "Show Keybindings" $ do
|
runShowKeys _ = NamedAction (skip :: (X ()))
|
||||||
s <- io $ evalFeature $ runDMenuShowKeys x
|
-- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x
|
||||||
ifSatisfied s
|
|
||||||
$ spawnNotify
|
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX
|
||||||
|
runDMenuShowKeys kbs =
|
||||||
|
Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys)
|
||||||
|
|
||||||
|
runNotifyShowKeys :: X ()
|
||||||
|
runNotifyShowKeys = spawnNotify
|
||||||
$ defNoteError { body = Just $ Text "could not display keymap" }
|
$ defNoteError { body = Just $ Text "could not display keymap" }
|
||||||
|
|
||||||
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
|
runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree
|
||||||
runDMenuShowKeys kbs =
|
runDMenuShowKeys' kbs = Subfeature
|
||||||
featureDefault "keyboard shortcut menu" (Only $ exe myDmenuCmd) $ io $ do
|
{ sfName = "keyboard shortcut menu"
|
||||||
|
, sfTree = IOTree (Standalone act) deps
|
||||||
|
, sfLevel = Warn
|
||||||
|
}
|
||||||
|
where
|
||||||
|
deps = Only $ Executable True myDmenuCmd
|
||||||
|
act = io $ do
|
||||||
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
|
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
|
||||||
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
||||||
where
|
|
||||||
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"
|
||||||
|
|
|
@ -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]
|
||||||
|
|
|
@ -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'
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -1,55 +1,56 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | 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 ())
|
|
||||||
|
|
||||||
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)
|
data FeatureResult a p = Untestable (Subfeature a Tree) String |
|
||||||
ioFeature (ConstFeature a) = ConstFeature $ liftIO a
|
FailedFtr (Subfeature a ResultTree) [String] |
|
||||||
ioFeature NoFeature = NoFeature
|
SuccessfulFtr (Finished a p)
|
||||||
ioFeature (Feature f r)
|
|
||||||
= Feature (f {ftrDepTree = liftIO <$> ftrDepTree f}) $ ioFeature r
|
|
||||||
|
|
||||||
featureDefault :: String -> DepChoice (FullDep Dependency) -> a -> Feature a
|
type ActionTreeMaybe a p = Either (ActionTree a Tree, String)
|
||||||
featureDefault n ds x = feature n Default $ GenTree (Single x) ds
|
(ActionTree a ResultTree, Maybe a, [String])
|
||||||
|
|
||||||
featureExe :: MonadIO m => String -> String -> Feature (m ())
|
sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a
|
||||||
featureExe n cmd = featureExeArgs n cmd []
|
sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }]
|
||||||
|
|
||||||
featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
|
always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a
|
||||||
featureExeArgs n cmd args =
|
always1_ l n t x =
|
||||||
featureDefault n (Only $ FullDep (Right False) $ Executable cmd) $ spawnCmd cmd args
|
Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x)
|
||||||
|
|
||||||
featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
|
sometimes1 :: String -> ActionTree a Tree -> Sometimes a
|
||||||
-> MemberName -> Maybe Client -> FeatureIO
|
sometimes1 = sometimes1_ Error
|
||||||
featureEndpoint name busname path iface mem client = feature name Default
|
|
||||||
$ DBusTree (Single cmd) client deps
|
sometimesIO :: String -> Tree (IODependency a p) p -> a -> Sometimes a
|
||||||
where
|
sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t
|
||||||
cmd c = void $ callMethod c busname path iface mem
|
|
||||||
deps = Only $ FullDep (Right False) $ Endpoint busname path iface $ Method_ mem
|
sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency a p) p
|
||||||
|
-> (Client -> a) -> Sometimes a
|
||||||
|
sometimesDBus c n t x = sometimes1 n $ DBusTree (Standalone x) c t
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | 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"
|
|
||||||
|
|
||||||
|
|
|
@ -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
|
|
|
@ -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"
|
||||||
|
|
Loading…
Reference in New Issue