From d8a88531b053135f73229f162d1fea39ad66386e Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Tue, 21 Jun 2022 00:56:42 -0400 Subject: [PATCH] WIP transition all dependencies to new framework --- lib/XMonad/Internal/Command/DMenu.hs | 81 +- lib/XMonad/Internal/Command/Desktop.hs | 96 +-- lib/XMonad/Internal/Command/Power.hs | 8 +- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 4 +- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 8 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 26 +- .../DBus/Brightness/IntelBacklight.hs | 8 +- lib/XMonad/Internal/DBus/Control.hs | 4 +- lib/XMonad/Internal/DBus/Removable.hs | 16 +- lib/XMonad/Internal/DBus/Screensaver.hs | 18 +- lib/XMonad/Internal/Dependency.hs | 757 +++++++++--------- lib/XMonad/Internal/DependencyX.hs | 395 --------- lib/XMonad/Internal/Dependency_.hs | 591 ++++++++++++++ 13 files changed, 1109 insertions(+), 903 deletions(-) delete mode 100644 lib/XMonad/Internal/DependencyX.hs create mode 100644 lib/XMonad/Internal/Dependency_.hs diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index cb4a238..87cc2ce 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -56,8 +56,8 @@ myDmenuNetworks = "networkmanager_dmenu" -------------------------------------------------------------------------------- -- | Other internal functions -spawnDmenuCmd :: String -> [String] -> FeatureX -spawnDmenuCmd n = featureExeArgs n myDmenuCmd +spawnDmenuCmd :: String -> [String] -> SometimesX +spawnDmenuCmd n = sometimesExeArgs n True myDmenuCmd themeArgs :: String -> [String] themeArgs hexColor = @@ -71,66 +71,83 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity -------------------------------------------------------------------------------- -- | Exported Commands -runDevMenu :: FeatureX -runDevMenu = featureDefault "device manager" (Only $ exe myDmenuDevices) $ do +runDevMenu :: SometimesX +runDevMenu = sometimesIO "device manager" (Only $ Executable False myDmenuDevices) $ do c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" spawnCmd myDmenuDevices $ ["-c", c] ++ "--" : themeArgs "#999933" ++ myDmenuMatchingArgs -runBTMenu :: FeatureX -runBTMenu = featureExeArgs "bluetooth selector" myDmenuBluetooth +runBTMenu :: SometimesX +runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth $ "-c":themeArgs "#0044bb" -runBwMenu :: FeatureX -runBwMenu = featureDefault "password manager" (Only $ exe myDmenuPasswords) $ +runBwMenu :: SometimesX +runBwMenu = sometimesIO "password manager" (Only $ Executable False myDmenuPasswords) $ spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs -runVPNMenu :: FeatureX -runVPNMenu = featureDefault "VPN selector" (Only $ exe myDmenuVPN) $ +runVPNMenu :: SometimesX +runVPNMenu = sometimesIO "VPN selector" (Only $ Executable False myDmenuVPN) $ 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" } +-- 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" } -runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX +-- TODO not sure what to do with this yet +runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction +runShowKeys _ = NamedAction (skip :: (X ())) + -- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x + +runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX runDMenuShowKeys kbs = - featureDefault "keyboard shortcut menu" (Only $ exe myDmenuCmd) $ io $ do - (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } - forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' + Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys) + +runNotifyShowKeys :: X () +runNotifyShowKeys = spawnNotify + $ defNoteError { body = Just $ Text "could not display keymap" } + +runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree +runDMenuShowKeys' kbs = Subfeature + { sfName = "keyboard shortcut menu" + , sfTree = IOTree (Standalone act) deps + , sfLevel = Warn + } where + deps = Only $ Executable True myDmenuCmd + act = io $ do + (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } + forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs -runCmdMenu :: FeatureX +runCmdMenu :: SometimesX runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] -runAppMenu :: FeatureX +runAppMenu :: SometimesX runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] -runClipMenu :: FeatureX -runClipMenu = - featureDefault "clipboard manager" (And (Only $ exe myDmenuCmd) (Only $ exe "greenclip")) - $ spawnCmd myDmenuCmd args +runClipMenu :: SometimesX +runClipMenu = sometimesIO "clipboard manager" deps act where + act = spawnCmd myDmenuCmd args + deps = toAnd (Executable True myDmenuCmd) (Executable True "greenclip") args = [ "-modi", "\"clipboard:greenclip print\"" , "-show", "clipboard" , "-run-command", "'{cmd}'" ] ++ themeArgs "#00c44e" -runWinMenu :: FeatureX +runWinMenu :: SometimesX runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] -runNetMenu :: FeatureX +runNetMenu :: SometimesX runNetMenu = - featureExeArgs "network control menu" myDmenuNetworks $ themeArgs "#ff3333" + sometimesExeArgs "network control menu" True myDmenuNetworks $ themeArgs "#ff3333" -runAutorandrMenu :: FeatureX +runAutorandrMenu :: SometimesX runAutorandrMenu = - featureExeArgs "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066" + sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066" diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 9ec901a..77a891f 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -91,51 +91,53 @@ ethernetIface = "enp7s0f1" -------------------------------------------------------------------------------- -- | Some nice apps -runTerm :: FeatureX -runTerm = featureExe "terminal" myTerm +runTerm :: SometimesX +runTerm = sometimesExe "terminal" True myTerm -runTMux :: FeatureX -runTMux = featureDefault "terminal multiplexer" deps cmd +runTMux :: SometimesX +runTMux = sometimesIO "terminal multiplexer" deps act where - deps = listToAnds (exe myTerm) $ fmap exe ["tmux", "bash"] - cmd = spawn + deps = listToAnds (Executable True myTerm) $ fmap (Executable True) ["tmux", "bash"] + act = spawn $ "tmux has-session" #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] #!|| fmtNotifyCmd defNoteError { body = Just $ Text msg } c = "exec tmux attach-session -d" msg = "could not connect to tmux session" -runCalc :: FeatureX -runCalc = featureDefault "calculator" (And (Only $ exe myTerm) (Only $ exe "R")) - $ spawnCmd myTerm ["-e", "R"] +runCalc :: SometimesX +runCalc = sometimesIO "calculator" deps act + where + deps = toAnd (Executable True myTerm) (Executable True "R") + act = spawnCmd myTerm ["-e", "R"] -runBrowser :: FeatureX -runBrowser = featureExe "web browser" myBrowser +runBrowser :: SometimesX +runBrowser = sometimesExe "web browser" False myBrowser -runEditor :: FeatureX -runEditor = featureExeArgs "text editor" myEditor +runEditor :: SometimesX +runEditor = sometimesExeArgs "text editor" True myEditor ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] -runFileManager :: FeatureX -runFileManager = featureExe "file browser" "pcmanfm" +runFileManager :: SometimesX +runFileManager = sometimesExe "file browser" True "pcmanfm" -------------------------------------------------------------------------------- -- | Multimedia Commands -runMultimediaIfInstalled :: String -> String -> FeatureX +runMultimediaIfInstalled :: String -> String -> SometimesX 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" -runPrevTrack :: FeatureX +runPrevTrack :: SometimesX runPrevTrack = runMultimediaIfInstalled "previous track" "previous" -runNextTrack :: FeatureX +runNextTrack :: SometimesX runNextTrack = runMultimediaIfInstalled "next track" "next" -runStopPlay :: FeatureX +runStopPlay :: SometimesX runStopPlay = runMultimediaIfInstalled "stop playback" "stop" -------------------------------------------------------------------------------- @@ -151,48 +153,48 @@ playSound file = do -- paplay seems to have less latency than aplay spawnCmd "paplay" [p] -featureSound :: String -> FilePath -> X () -> X () -> FeatureX +featureSound :: String -> FilePath -> X () -> X () -> SometimesX featureSound n file pre post = - featureDefault ("volume " ++ n ++ " control") (Only $ exe "paplay") + sometimesIO ("volume " ++ n ++ " control") (Only $ Executable True "paplay") $ pre >> playSound file >> post -runVolumeDown :: FeatureX +runVolumeDown :: SometimesX runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2) -runVolumeUp :: FeatureX +runVolumeUp :: SometimesX runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2) -runVolumeMute :: FeatureX +runVolumeMute :: SometimesX runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return () -------------------------------------------------------------------------------- -- | Notification control -runNotificationCmd :: String -> String -> FeatureX +runNotificationCmd :: String -> FilePath -> SometimesX runNotificationCmd n cmd = - featureExeArgs (n ++ " control") myNotificationCtrl [cmd] + sometimesExeArgs (n ++ " control") True myNotificationCtrl [cmd] -runNotificationClose :: FeatureX +runNotificationClose :: SometimesX runNotificationClose = runNotificationCmd "close notification" "close" -runNotificationCloseAll :: FeatureX +runNotificationCloseAll :: SometimesX runNotificationCloseAll = runNotificationCmd "close all notifications" "close-all" -runNotificationHistory :: FeatureX +runNotificationHistory :: SometimesX runNotificationHistory = runNotificationCmd "see notification history" "history-pop" -runNotificationContext :: FeatureX +runNotificationContext :: SometimesX runNotificationContext = runNotificationCmd "open notification context" "context" -------------------------------------------------------------------------------- -- | System commands -runToggleBluetooth :: FeatureX +runToggleBluetooth :: SometimesX runToggleBluetooth = - featureDefault "bluetooth toggle" (Only $ exe myBluetooth) + sometimesIO "bluetooth toggle" (Only $ Executable True myBluetooth) $ spawn $ myBluetooth ++ " show | grep -q \"Powered: no\"" #!&& "a=on" @@ -200,8 +202,8 @@ runToggleBluetooth = #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } -runToggleEthernet :: FeatureX -runToggleEthernet = featureDefault "ethernet toggle" (Only $ exe "nmcli") +runToggleEthernet :: SometimesX +runToggleEthernet = sometimesIO "ethernet toggle" (Only $ Executable True "nmcli") $ spawn $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected" #!&& "a=connect" @@ -209,15 +211,15 @@ runToggleEthernet = featureDefault "ethernet toggle" (Only $ exe "nmcli") #!>> fmtCmd "nmcli" ["device", "$a", ethernetIface] #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } -runStartISyncTimer :: FeatureX -runStartISyncTimer = featureDefault "isync timer" (Only $ userUnit "mbsync.timer") +runStartISyncTimer :: SometimesX +runStartISyncTimer = sometimesIO "isync timer" (Only $ Systemd UserUnit "mbsync.timer") $ spawn $ "systemctl --user start mbsync.timer" #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" } #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" } -runStartISyncService :: FeatureX -runStartISyncService = featureDefault "isync" (Only $ userUnit "mbsync.service") +runStartISyncService :: SometimesX +runStartISyncService = sometimesIO "isync" (Only $ Systemd UserUnit "mbsync.service") $ spawn $ "systemctl --user start mbsync.service" #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" } @@ -261,25 +263,25 @@ getCaptureDir = do where fallback = ( ".local/share") <$> getHomeDirectory -runFlameshot :: String -> String -> FeatureX -runFlameshot n mode = featureDefault n (Only $ exe myCapture) +runFlameshot :: String -> String -> SometimesX +runFlameshot n mode = sometimesIO n (Only $ Executable True myCapture) $ spawnCmd myCapture [mode] -- TODO this will steal focus from the current window (and puts it -- in the root window?) ...need to fix -runAreaCapture :: FeatureX +runAreaCapture :: SometimesX runAreaCapture = runFlameshot "screen area capture" "gui" -- myWindowCap = "screencap -w" --external script -runDesktopCapture :: FeatureX +runDesktopCapture :: SometimesX runDesktopCapture = runFlameshot "fullscreen capture" "full" -runScreenCapture :: FeatureX +runScreenCapture :: SometimesX runScreenCapture = runFlameshot "screen capture" "screen" -runCaptureBrowser :: FeatureX +runCaptureBrowser :: SometimesX runCaptureBrowser = - featureDefault "screen capture browser" (Only $ exe myImageBrowser) $ do + sometimesIO "screen capture browser" (Only $ Executable True myImageBrowser) $ do dir <- io getCaptureDir spawnCmd myImageBrowser [dir] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index ca3f604..054ceca 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -45,8 +45,8 @@ myOptimusManager = "optimus-manager" -------------------------------------------------------------------------------- -- | Core commands -runScreenLock :: Feature (X ()) -runScreenLock = featureExe "screen locker" myScreenlock +runScreenLock :: SometimesX +runScreenLock = sometimesExe "screen locker" True myScreenlock runPowerOff :: X () runPowerOff = spawn "systemctl poweroff" @@ -100,8 +100,8 @@ runOptimusPrompt' = do #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"] #!&& "killall xmonad" -runOptimusPrompt :: FeatureX -runOptimusPrompt = featureDefault "graphics switcher" (Only $ exe myOptimusManager) +runOptimusPrompt :: SometimesX +runOptimusPrompt = sometimesIO "graphics switcher" (Only $ Executable True myOptimusManager) runOptimusPrompt' -------------------------------------------------------------------------------- diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index 0f7b5e9..d55a4c0 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -94,8 +94,8 @@ acpiPath = "/var/run/acpid.socket" -- | Spawn a new thread that will listen for ACPI events on the acpid socket -- and send ClientMessage events when it receives them -runPowermon :: FeatureIO -runPowermon = featureDefault "ACPI event monitor" (Only $ pathR acpiPath) listenACPI +runPowermon :: SometimesIO +runPowermon = sometimesIO "ACPI event monitor" (Only $ pathR acpiPath) listenACPI -- | Handle ClientMessage event containing and ACPI event (to be used in -- Xmonad's event hook) diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index e6dd69c..8167f5e 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -107,16 +107,16 @@ clevoKeyboardConfig = BrightnessConfig -------------------------------------------------------------------------------- -- | Exported haskell API -stateFileDep :: FullDep Dependency +stateFileDep :: IODependency a p stateFileDep = pathRW stateFile -brightnessFileDep :: FullDep Dependency +brightnessFileDep :: IODependency a p brightnessFileDep = pathR brightnessFile -clevoKeyboardSignalDep :: DBusDep +clevoKeyboardSignalDep :: DBusDependency RawBrightness p clevoKeyboardSignalDep = signalDep clevoKeyboardConfig -exportClevoKeyboard :: Maybe Client -> FeatureIO +exportClevoKeyboard :: Maybe Client -> SometimesIO exportClevoKeyboard = brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 838ccd7..de7df7f 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -45,10 +45,10 @@ data BrightnessConfig a b = BrightnessConfig } data BrightnessControls = BrightnessControls - { bctlMax :: FeatureIO - , bctlMin :: FeatureIO - , bctlInc :: FeatureIO - , bctlDec :: FeatureIO + { bctlMax :: SometimesIO + , bctlMin :: SometimesIO + , bctlInc :: SometimesIO + , bctlDec :: SometimesIO } brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls @@ -67,7 +67,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = either (const Nothing) bodyGetBrightness <$> callMethod client xmonadBusName p i memGet -signalDep :: BrightnessConfig a b -> DBusDep +signalDep :: BrightnessConfig a b -> DBusDependency a p signalDep BrightnessConfig { bcPath = p, bcInterface = i } = Endpoint xmonadBusName p i $ Signal_ memCur @@ -85,14 +85,12 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = -------------------------------------------------------------------------------- -- | Internal DBus Crap -brightnessExporter :: RealFrac b => [FullDep Dependency] -> BrightnessConfig a b - -> Maybe Client -> FeatureIO -brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature - (n ++ " exporter") Default - $ DBusTree (Single (exportBrightnessControls' bc)) client ds +brightnessExporter :: RealFrac b => [IODependency (IO ()) (Maybe x)] + -> BrightnessConfig a b -> Maybe Client -> SometimesIO +brightnessExporter deps bc@BrightnessConfig { bcName = n } client = + sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc) where - ds = listToAnds (fullDep $ Bus xmonadBusName) - $ fmap (fmap DBusGenDep) deps + ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO () exportBrightnessControls' bc client = do @@ -130,11 +128,11 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = sig = signal p i memCur callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName - -> FeatureIO + -> SometimesIO callBacklight client BrightnessConfig { bcPath = p , bcInterface = i , 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 [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 04eb4a6..62771d0 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -89,16 +89,16 @@ intelBacklightConfig = BrightnessConfig -------------------------------------------------------------------------------- -- | Exported haskell API -curFileDep :: FullDep Dependency +curFileDep :: IODependency a p curFileDep = pathRW curFile -maxFileDep :: FullDep Dependency +maxFileDep :: IODependency a p maxFileDep = pathR maxFile -intelBacklightSignalDep :: DBusDep +intelBacklightSignalDep :: DBusDependency RawBrightness p intelBacklightSignalDep = signalDep intelBacklightConfig -exportIntelBacklight :: Maybe Client -> FeatureIO +exportIntelBacklight :: Maybe Client -> SometimesIO exportIntelBacklight = brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 5637ec0..0b7070a 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -30,7 +30,7 @@ startXMonadService :: IO (Maybe Client) startXMonadService = do client <- getDBusClient False forM_ client requestXMonadName - mapM_ (\f -> executeFeature_ $ f client) dbusExporters + mapM_ (\f -> executeSometimes_ $ f client) dbusExporters return client stopXMonadService :: Client -> IO () @@ -51,5 +51,5 @@ requestXMonadName client = do where xn = "'" ++ formatBusName xmonadBusName ++ "'" -dbusExporters :: [Maybe Client -> FeatureIO] +dbusExporters :: [Maybe Client -> SometimesIO] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index 1bbe54b..6413c9f 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded" memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" -dbusDep :: MemberName -> FullDep DBusDep -dbusDep m = fullDep $ Endpoint bus path interface $ Signal_ m +dbusDep :: MemberName -> DBusDependency a p +dbusDep m = Endpoint bus path interface $ Signal_ m -addedDep :: FullDep DBusDep +addedDep :: DBusDependency a p addedDep = dbusDep memAdded -removedDep :: FullDep DBusDep +removedDep :: DBusDependency a p removedDep = dbusDep memRemoved driveInsertedSound :: FilePath @@ -81,6 +81,8 @@ listenDevices client = do addMatch' m p f = void $ addMatch client ruleUdisks { matchMember = Just m } $ playSoundMaybe p . f . signalBody -runRemovableMon :: Maybe Client -> FeatureIO -runRemovableMon client = feature "removeable device monitor" Default - $ DBusTree (Single listenDevices) client $ And (Only addedDep) (Only removedDep) +runRemovableMon :: Maybe Client -> SometimesIO +runRemovableMon cl = + sometimesDBus cl "removeable device monitor" deps listenDevices + where + deps = toAnd addedDep removedDep diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 307211c..e8fbb48 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -94,9 +94,9 @@ bodyGetCurrentState _ = Nothing -------------------------------------------------------------------------------- -- | Exported haskell API -exportScreensaver :: Maybe Client -> FeatureIO -exportScreensaver client = feature "screensaver interface" Default - $ DBusTree (Single cmd) client (And (Only bus) (Only ssx)) +exportScreensaver :: Maybe Client -> SometimesIO +exportScreensaver client = + sometimesDBus client "screensaver interface" (toAnd bus ssx) cmd where cmd cl = export cl ssPath defaultInterface { interfaceName = interface @@ -116,12 +116,12 @@ exportScreensaver client = feature "screensaver interface" Default } ] } - bus = fullDep $ Bus xmonadBusName - ssx = fullDep $ DBusGenDep $ Executable ssExecutable + bus = Bus xmonadBusName + ssx = DBusIO $ Executable True ssExecutable -callToggle :: Maybe Client -> FeatureIO -callToggle = - featureEndpoint "screensaver toggle" xmonadBusName ssPath interface memToggle +callToggle :: Maybe Client -> SometimesIO +callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath + interface memToggle callQuery :: Client -> IO (Maybe SSState) callQuery client = do @@ -132,5 +132,5 @@ matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO () matchSignal cb = fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState -ssSignalDep :: DBusDep +ssSignalDep :: DBusDependency a p ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index dd6f1cb..dd1b075 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -1,55 +1,56 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} -------------------------------------------------------------------------------- -- | Functions for handling dependencies module XMonad.Internal.Dependency - ( MaybeAction - , AnyFeature(..) - , DepChoice(..) - , MaybeX - , FullDep(..) - , DepTree(..) + ( AlwaysX + , AlwaysIO + , Always(..) + , SometimesX + , SometimesIO + , Sometimes + , executeSometimes_ + , executeSometimes + , executeAlways_ + , executeAlways + , evalAlways + , evalSometimes + + , Subfeature(..) + , LogLevel(..) + , Action(..) - , DBusDep(..) - , FeatureX - , FeatureIO - , Feature(..) - , Feature_(..) - , Warning(..) - , Dependency(..) - , UnitType(..) + + -- feature construction + , sometimes1 + , sometimesIO + , sometimesDBus + , sometimesExe + , sometimesExeArgs + , sometimesEndpoint + + -- Dependency tree + , ActionTree(..) + , Tree(..) + , IODependency(..) + , DBusDependency(..) , DBusMember(..) - , feature - , ioFeature - , evalFeature - , systemUnit - , userUnit - , pathR - , pathW - , pathRW - , featureDefault - , featureExeArgs - , featureExe - , featureEndpoint - , whenSatisfied - , ifSatisfied - , executeFeature - , executeFeature_ - , executeFeatureWith - , executeFeatureWith_ - , depName - , fullDep - , exe + , UnitType(..) , listToAnds + , toAnd + , pathR + , pathRW + , pathW ) 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 @@ -70,370 +71,384 @@ 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 AlwaysAny = AX AlwaysX | AIO AlwaysIO -data Feature_ a = Feature_ - { ftrDepTree :: DepTree a - , ftrName :: String - , ftrWarning :: Warning +type AlwaysX = Always (X ()) + +type AlwaysIO = Always (IO ()) + +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) - | NoFeature - | ConstFeature a +type FailedFeature a p = Either (Subfeature a Tree, String) + (Subfeature a ResultTree, [String]) --- TODO this is silly as is, and could be made more useful by representing --- loglevels -data Warning = Silent | Default +data Finished a p = Finished + { finData :: Subfeature a ResultTree + , finAction :: a + , finWarnings :: [String] + } -type FeatureX = Feature (X ()) +data FeatureResult a p = Untestable (Subfeature a Tree) String | + FailedFtr (Subfeature a ResultTree) [String] | + SuccessfulFtr (Finished a p) -type FeatureIO = Feature (IO ()) +type ActionTreeMaybe a p = Either (ActionTree a Tree, String) + (ActionTree a ResultTree, Maybe a, [String]) -data AnyFeature = FX FeatureX | FIO FeatureIO +sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a +sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }] -feature :: String -> Warning -> DepTree a -> Feature a -feature n w t = Feature f NoFeature - where - f = Feature_ - { ftrDepTree = t - , ftrName = n - , ftrWarning = w - } +always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a +always1_ l n t x = + Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x) -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 +sometimes1 :: String -> ActionTree a Tree -> Sometimes a +sometimes1 = sometimes1_ Error -featureDefault :: String -> DepChoice (FullDep Dependency) -> a -> Feature a -featureDefault n ds x = feature n Default $ GenTree (Single x) ds +sometimesIO :: String -> Tree (IODependency a p) p -> a -> Sometimes a +sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t -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 +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 --- --- 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. +-- | Feature Data -data DepChoice a = And (DepChoice a) (DepChoice a) - | Or (DepChoice a) (DepChoice a) - | Only a +data Subfeature a t = Subfeature + { sfTree :: ActionTree a t + , sfName :: String + , sfLevel :: LogLevel + } -listToAnds :: a -> [a] -> DepChoice a -listToAnds i = foldr (And . Only) (Only i) +data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord) -data DepTree a = GenTree (Action a) (DepChoice (FullDep Dependency)) - | 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 +data Msg = Msg LogLevel String String -------------------------------------------------------------------------------- --- | 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). +-- | Action Tree -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 - fmap f (Single a) = Single (f a) - fmap f (Double a b) = Double (f . a) b +data Action a p = Standalone a | Consumer (p -> a) -------------------------------------------------------------------------------- --- | 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. +-- | Dependency Tree -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) -evalFeature (ConstFeature x) = return $ Just x -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 +toAnd :: d -> d -> Tree d (Maybe x) +toAnd a b = And (const . const Nothing) (Only a) (Only b) -------------------------------------------------------------------------------- --- | 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 -fullDep = FullDep (Right True) +data ResultTree d p = + 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 | IOTest String (IO (Maybe String)) + | IORead String (IO (Either String (Maybe p))) | Systemd UnitType String - | DepFeature AnyFeature + | NestedAlways (Always a) (a -> p) + | NestedSometimes (Sometimes a) (a -> p) data UnitType = SystemUnit | UserUnit deriving (Eq, Show) -exe :: String -> FullDep Dependency -exe = fullDep . Executable +sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ()) +sometimesExe n sys path = sometimesExeArgs n sys path [] -pathR :: String -> FullDep Dependency -pathR n = fullDep $ AccessiblePath n True False +sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ()) +sometimesExeArgs n sys path args = + sometimesIO n (Only (Executable sys path)) $ spawnCmd path args -pathW :: String -> FullDep Dependency -pathW n = fullDep $ AccessiblePath n False True +pathR :: String -> IODependency a p +pathR n = AccessiblePath n True False -pathRW :: String -> FullDep Dependency -pathRW n = fullDep $ AccessiblePath n True True +pathW :: String -> IODependency a p +pathW n = AccessiblePath n False True -systemUnit :: String -> FullDep Dependency -systemUnit = fullDep . Systemd SystemUnit - -userUnit :: String -> FullDep Dependency -userUnit = fullDep . Systemd UserUnit +pathRW :: String -> IODependency a p +pathRW n = AccessiblePath n True True -------------------------------------------------------------------------------- --- | Dependencies (DBus) +-- | 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) -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 . - -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_ "org.freedesktop.DBus.Introspectable" introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" -dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String) -dbusDepSatisfied client (Bus bus) = do +sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName + -> 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 return $ case ret of - Left e -> Just e + Left e -> smryFail e Right b -> let ns = bodyGetNames b in - if bus' `elem` ns then Nothing - else Just $ unwords ["name", singleQuote bus', "not found on dbus"] + 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" @@ -443,17 +458,17 @@ dbusDepSatisfied client (Bus bus) = do bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames _ = [] -dbusDepSatisfied client (Endpoint busname objpath iface mem) = do +testDBusDependency client (Endpoint busname objpath iface mem) = do ret <- callMethod client busname objpath introspectInterface introspectMethod return $ case ret of - Left e -> Just e + 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 -> Nothing - _ -> Just $ fmtMsg' mem + Just True -> Right (Nothing, []) + _ -> smryFail $ fmtMsg' mem findMem = fmap (matchMem mem) . find (\i -> I.interfaceName i == iface) . I.objectInterfaces @@ -473,43 +488,19 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do , formatBusName busname ] -dbusDepSatisfied _ (DBusGenDep d) = evalDependency d +testDBusDependency _ (DBusIO d) = testIODependency d -------------------------------------------------------------------------------- --- | Printing dependencies +-- | Printing --- instance ToJSON (DepTree a) where --- toJSON (GenTree _) = undefined +printMsgs :: LogLevel -> [Msg] -> IO () +printMsgs lvl ms = do + pn <- getProgName + mapM_ (printMsg pn lvl) ms --- 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 - --- 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 +printMsg :: String -> LogLevel -> Msg -> IO () +printMsg pname lvl (Msg ml mn msg) + | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg] + | otherwise = skip where - tp SystemUnit = "sys" - tp UserUnit = "user" -depName (AccessiblePath p _ _) = "path: " ++ p -depName (DepFeature _) = "feature: blablabla" - + bracket s = "[" ++ s ++ "]" diff --git a/lib/XMonad/Internal/DependencyX.hs b/lib/XMonad/Internal/DependencyX.hs deleted file mode 100644 index 9cfc419..0000000 --- a/lib/XMonad/Internal/DependencyX.hs +++ /dev/null @@ -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 diff --git a/lib/XMonad/Internal/Dependency_.hs b/lib/XMonad/Internal/Dependency_.hs new file mode 100644 index 0000000..11a945e --- /dev/null +++ b/lib/XMonad/Internal/Dependency_.hs @@ -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 . + +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" +