ENH actually make dependency framework functional
This commit is contained in:
parent
5326b49ce2
commit
ec957c1dbf
|
@ -11,8 +11,6 @@ module Main (main) where
|
||||||
-- * Theme integration with xmonad (shared module imported below)
|
-- * Theme integration with xmonad (shared module imported below)
|
||||||
-- * A custom Locks plugin from my own forked repo
|
-- * A custom Locks plugin from my own forked repo
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
|
|
||||||
import Data.Either
|
import Data.Either
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
@ -255,16 +253,15 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
|
||||||
sysfsNet :: FilePath
|
sysfsNet :: FilePath
|
||||||
sysfsNet = "/sys/class/net"
|
sysfsNet = "/sys/class/net"
|
||||||
|
|
||||||
readInterface :: (String -> Bool) -> IO (Either String String)
|
readInterface :: String -> (String -> Bool) -> IODependency String
|
||||||
readInterface f = do
|
readInterface n f = IORead n go
|
||||||
|
where
|
||||||
|
go = do
|
||||||
ns <- filter f <$> listInterfaces
|
ns <- filter f <$> listInterfaces
|
||||||
case ns of
|
case ns of
|
||||||
[] -> return $ Left "no interfaces found"
|
[] -> return $ Left ["no interfaces found"]
|
||||||
(x:xs) -> do
|
(x:xs) -> do
|
||||||
unless (null xs) $
|
return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs
|
||||||
-- TODO store this somehow intead of printing
|
|
||||||
putStrLn $ "WARNING: extra interfaces found, using " ++ x
|
|
||||||
return $ Right x
|
|
||||||
|
|
||||||
vpnPresent :: IO (Maybe String)
|
vpnPresent :: IO (Maybe String)
|
||||||
vpnPresent = do
|
vpnPresent = do
|
||||||
|
@ -292,53 +289,48 @@ rightPlugins sysClient sesClient = mapM evalFeature
|
||||||
]
|
]
|
||||||
|
|
||||||
getWireless :: BarFeature
|
getWireless :: BarFeature
|
||||||
getWireless = sometimes1 "wireless status indicator"
|
getWireless = sometimes1 "wireless status indicator" $ IORoot wirelessCmd
|
||||||
$ IOTree (Consumer wirelessCmd)
|
$ Only $ readInterface "get wifi interface" isWireless
|
||||||
$ Only $ IORead "get wifi interface" $ fmap Just <$> readInterface isWireless
|
|
||||||
|
|
||||||
getEthernet :: Maybe Client -> BarFeature
|
getEthernet :: Maybe Client -> BarFeature
|
||||||
getEthernet client = sometimes1 "ethernet status indicator" $
|
getEthernet client = sometimes1 "ethernet status indicator" $
|
||||||
DBusTree (Consumer act) client deps
|
DBusRoot (const . ethernetCmd) tree client
|
||||||
where
|
where
|
||||||
act i = const $ ethernetCmd i
|
tree = And1 id (Only readEth) (Only_ devDep)
|
||||||
deps = And (\_ s -> s) (Only devDep) (Only readEth)
|
readEth = readInterface "read ethernet interface" isEthernet
|
||||||
readEth = DBusIO $ IORead "read ethernet interface"
|
|
||||||
$ fmap Just <$> readInterface isEthernet
|
|
||||||
|
|
||||||
getBattery :: BarFeature
|
getBattery :: BarFeature
|
||||||
getBattery = sometimesIO "battery level indicator"
|
getBattery = sometimesIO "battery level indicator"
|
||||||
(Only $ IOTest "Test if battery is present" hasBattery)
|
(Only_ $ sysTest "Test if battery is present" hasBattery)
|
||||||
batteryCmd
|
batteryCmd
|
||||||
|
|
||||||
getVPN :: Maybe Client -> BarFeature
|
getVPN :: Maybe Client -> BarFeature
|
||||||
getVPN client = sometimesDBus client "VPN status indicator"
|
getVPN client = sometimesDBus client "VPN status indicator"
|
||||||
(toAnd vpnDep test) (const vpnCmd)
|
(toAnd vpnDep test) (const vpnCmd)
|
||||||
where
|
where
|
||||||
test = DBusIO $ IOTest "Use nmcli to test if VPN is present" vpnPresent
|
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
|
||||||
|
|
||||||
getBt :: Maybe Client -> BarFeature
|
getBt :: Maybe Client -> BarFeature
|
||||||
getBt client = sometimesDBus client "bluetooth status indicator"
|
getBt client = sometimesDBus client "bluetooth status indicator"
|
||||||
(Only btDep)
|
(Only_ btDep)
|
||||||
(const btCmd)
|
(const btCmd)
|
||||||
|
|
||||||
getAlsa :: BarFeature
|
getAlsa :: BarFeature
|
||||||
getAlsa = sometimesIO "volume level indicator"
|
getAlsa = sometimesIO "volume level indicator" (Only_ $ sysExe "alsact") alsaCmd
|
||||||
(Only $ Executable True "alsact")
|
|
||||||
alsaCmd
|
|
||||||
|
|
||||||
getBl :: Maybe Client -> BarFeature
|
getBl :: Maybe Client -> BarFeature
|
||||||
getBl client = sometimesDBus client "Intel backlight indicator"
|
getBl client = sometimesDBus client "Intel backlight indicator"
|
||||||
(Only intelBacklightSignalDep)
|
(Only_ intelBacklightSignalDep)
|
||||||
(const blCmd)
|
(const blCmd)
|
||||||
|
|
||||||
getCk :: Maybe Client -> BarFeature
|
getCk :: Maybe Client -> BarFeature
|
||||||
getCk client = sometimesDBus client "Clevo keyboard indicator"
|
getCk client = sometimesDBus client "Clevo keyboard indicator"
|
||||||
(Only clevoKeyboardSignalDep)
|
(Only_ clevoKeyboardSignalDep)
|
||||||
(const ckCmd)
|
(const ckCmd)
|
||||||
|
|
||||||
getSs :: Maybe Client -> BarFeature
|
getSs :: Maybe Client -> BarFeature
|
||||||
getSs client = sometimesDBus client "screensaver indicator"
|
getSs client = sometimesDBus client "screensaver indicator"
|
||||||
(Only ssSignalDep) $ const ssCmd
|
(Only_ ssSignalDep) $ const ssCmd
|
||||||
|
|
||||||
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
|
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
|
||||||
getAllCommands right = do
|
getAllCommands right = do
|
||||||
|
@ -430,4 +422,3 @@ fmtSpecs = intercalate sep . fmap go
|
||||||
fmtRegions :: BarRegions -> String
|
fmtRegions :: BarRegions -> String
|
||||||
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } =
|
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } =
|
||||||
fmtSpecs l ++ [lSep] ++ fmtSpecs c ++ [rSep] ++ fmtSpecs r
|
fmtSpecs l ++ [lSep] ++ fmtSpecs c ++ [rSep] ++ fmtSpecs r
|
||||||
|
|
||||||
|
|
|
@ -72,7 +72,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
||||||
-- | Exported Commands
|
-- | Exported Commands
|
||||||
|
|
||||||
runDevMenu :: SometimesX
|
runDevMenu :: SometimesX
|
||||||
runDevMenu = sometimesIO "device manager" (Only $ Executable False myDmenuDevices) $ do
|
runDevMenu = sometimesIO "device manager" (Only_ $ localExe myDmenuDevices) $ do
|
||||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
||||||
spawnCmd myDmenuDevices
|
spawnCmd myDmenuDevices
|
||||||
$ ["-c", c]
|
$ ["-c", c]
|
||||||
|
@ -84,11 +84,11 @@ runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth
|
||||||
$ "-c":themeArgs "#0044bb"
|
$ "-c":themeArgs "#0044bb"
|
||||||
|
|
||||||
runBwMenu :: SometimesX
|
runBwMenu :: SometimesX
|
||||||
runBwMenu = sometimesIO "password manager" (Only $ Executable False myDmenuPasswords) $
|
runBwMenu = sometimesIO "password manager" (Only_ $ localExe myDmenuPasswords) $
|
||||||
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||||
|
|
||||||
runVPNMenu :: SometimesX
|
runVPNMenu :: SometimesX
|
||||||
runVPNMenu = sometimesIO "VPN selector" (Only $ Executable False myDmenuVPN) $
|
runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $
|
||||||
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||||
|
|
||||||
-- runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
|
-- runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
|
||||||
|
@ -135,7 +135,7 @@ runClipMenu :: SometimesX
|
||||||
runClipMenu = sometimesIO "clipboard manager" deps act
|
runClipMenu = sometimesIO "clipboard manager" deps act
|
||||||
where
|
where
|
||||||
act = spawnCmd myDmenuCmd args
|
act = spawnCmd myDmenuCmd args
|
||||||
deps = toAnd (Executable True myDmenuCmd) (Executable True "greenclip")
|
deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")
|
||||||
args = [ "-modi", "\"clipboard:greenclip print\""
|
args = [ "-modi", "\"clipboard:greenclip print\""
|
||||||
, "-show", "clipboard"
|
, "-show", "clipboard"
|
||||||
, "-run-command", "'{cmd}'"
|
, "-run-command", "'{cmd}'"
|
||||||
|
|
|
@ -97,7 +97,7 @@ runTerm = sometimesExe "terminal" True myTerm
|
||||||
runTMux :: SometimesX
|
runTMux :: SometimesX
|
||||||
runTMux = sometimesIO "terminal multiplexer" deps act
|
runTMux = sometimesIO "terminal multiplexer" deps act
|
||||||
where
|
where
|
||||||
deps = listToAnds (Executable True myTerm) $ fmap (Executable True) ["tmux", "bash"]
|
deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
|
||||||
act = spawn
|
act = spawn
|
||||||
$ "tmux has-session"
|
$ "tmux has-session"
|
||||||
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
||||||
|
@ -108,7 +108,7 @@ runTMux = sometimesIO "terminal multiplexer" deps act
|
||||||
runCalc :: SometimesX
|
runCalc :: SometimesX
|
||||||
runCalc = sometimesIO "calculator" deps act
|
runCalc = sometimesIO "calculator" deps act
|
||||||
where
|
where
|
||||||
deps = toAnd (Executable True myTerm) (Executable True "R")
|
deps = toAnd (sysExe myTerm) (sysExe "R")
|
||||||
act = spawnCmd myTerm ["-e", "R"]
|
act = spawnCmd myTerm ["-e", "R"]
|
||||||
|
|
||||||
runBrowser :: SometimesX
|
runBrowser :: SometimesX
|
||||||
|
@ -155,7 +155,7 @@ playSound file = do
|
||||||
|
|
||||||
featureSound :: String -> FilePath -> X () -> X () -> SometimesX
|
featureSound :: String -> FilePath -> X () -> X () -> SometimesX
|
||||||
featureSound n file pre post =
|
featureSound n file pre post =
|
||||||
sometimesIO ("volume " ++ n ++ " control") (Only $ Executable True "paplay")
|
sometimesIO ("volume " ++ n ++ " control") (Only_ $ sysExe "paplay")
|
||||||
$ pre >> playSound file >> post
|
$ pre >> playSound file >> post
|
||||||
|
|
||||||
runVolumeDown :: SometimesX
|
runVolumeDown :: SometimesX
|
||||||
|
@ -194,7 +194,7 @@ runNotificationContext =
|
||||||
|
|
||||||
runToggleBluetooth :: SometimesX
|
runToggleBluetooth :: SometimesX
|
||||||
runToggleBluetooth =
|
runToggleBluetooth =
|
||||||
sometimesIO "bluetooth toggle" (Only $ Executable True myBluetooth)
|
sometimesIO "bluetooth toggle" (Only_ $ sysExe myBluetooth)
|
||||||
$ spawn
|
$ spawn
|
||||||
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
||||||
#!&& "a=on"
|
#!&& "a=on"
|
||||||
|
@ -203,7 +203,7 @@ runToggleBluetooth =
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
||||||
|
|
||||||
runToggleEthernet :: SometimesX
|
runToggleEthernet :: SometimesX
|
||||||
runToggleEthernet = sometimesIO "ethernet toggle" (Only $ Executable True "nmcli")
|
runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "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"
|
||||||
|
@ -212,14 +212,14 @@ runToggleEthernet = sometimesIO "ethernet toggle" (Only $ Executable True "nmcli
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
||||||
|
|
||||||
runStartISyncTimer :: SometimesX
|
runStartISyncTimer :: SometimesX
|
||||||
runStartISyncTimer = sometimesIO "isync timer" (Only $ Systemd UserUnit "mbsync.timer")
|
runStartISyncTimer = sometimesIO "isync timer" (Only_ $ sysdUser "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 :: SometimesX
|
runStartISyncService :: SometimesX
|
||||||
runStartISyncService = sometimesIO "isync" (Only $ Systemd UserUnit "mbsync.service")
|
runStartISyncService = sometimesIO "isync" (Only_ $ sysdUser "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" }
|
||||||
|
@ -264,7 +264,7 @@ getCaptureDir = do
|
||||||
fallback = (</> ".local/share") <$> getHomeDirectory
|
fallback = (</> ".local/share") <$> getHomeDirectory
|
||||||
|
|
||||||
runFlameshot :: String -> String -> SometimesX
|
runFlameshot :: String -> String -> SometimesX
|
||||||
runFlameshot n mode = sometimesIO n (Only $ Executable True myCapture)
|
runFlameshot n mode = sometimesIO n (Only_ $ sysExe 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
|
||||||
|
@ -282,6 +282,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
|
||||||
|
|
||||||
runCaptureBrowser :: SometimesX
|
runCaptureBrowser :: SometimesX
|
||||||
runCaptureBrowser =
|
runCaptureBrowser =
|
||||||
sometimesIO "screen capture browser" (Only $ Executable True myImageBrowser) $ do
|
sometimesIO "screen capture browser" (Only_ $ sysExe myImageBrowser) $ do
|
||||||
dir <- io getCaptureDir
|
dir <- io getCaptureDir
|
||||||
spawnCmd myImageBrowser [dir]
|
spawnCmd myImageBrowser [dir]
|
||||||
|
|
|
@ -101,7 +101,7 @@ runOptimusPrompt' = do
|
||||||
#!&& "killall xmonad"
|
#!&& "killall xmonad"
|
||||||
|
|
||||||
runOptimusPrompt :: SometimesX
|
runOptimusPrompt :: SometimesX
|
||||||
runOptimusPrompt = sometimesIO "graphics switcher" (Only $ Executable True myOptimusManager)
|
runOptimusPrompt = sometimesIO "graphics switcher" (Only_ $ localExe myOptimusManager)
|
||||||
runOptimusPrompt'
|
runOptimusPrompt'
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -95,7 +95,7 @@ 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 :: SometimesIO
|
runPowermon :: SometimesIO
|
||||||
runPowermon = sometimesIO "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,13 +107,13 @@ clevoKeyboardConfig = BrightnessConfig
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- | Exported haskell API
|
||||||
|
|
||||||
stateFileDep :: IODependency p
|
stateFileDep :: IODependency_
|
||||||
stateFileDep = pathRW stateFile
|
stateFileDep = pathRW stateFile
|
||||||
|
|
||||||
brightnessFileDep :: IODependency p
|
brightnessFileDep :: IODependency_
|
||||||
brightnessFileDep = pathR brightnessFile
|
brightnessFileDep = pathR brightnessFile
|
||||||
|
|
||||||
clevoKeyboardSignalDep :: DBusDependency RawBrightness
|
clevoKeyboardSignalDep :: DBusDependency_
|
||||||
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
||||||
|
|
||||||
exportClevoKeyboard :: Maybe Client -> SometimesIO
|
exportClevoKeyboard :: Maybe Client -> SometimesIO
|
||||||
|
|
|
@ -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 -> DBusDependency m
|
signalDep :: BrightnessConfig a b -> DBusDependency_
|
||||||
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,8 +85,8 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Internal DBus Crap
|
-- | Internal DBus Crap
|
||||||
|
|
||||||
brightnessExporter :: RealFrac b => [IODependency (Maybe x)]
|
brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b
|
||||||
-> BrightnessConfig a b -> Maybe Client -> SometimesIO
|
-> Maybe Client -> SometimesIO
|
||||||
brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
|
brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
|
||||||
sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
|
sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
|
||||||
where
|
where
|
||||||
|
|
|
@ -89,13 +89,13 @@ intelBacklightConfig = BrightnessConfig
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- | Exported haskell API
|
||||||
|
|
||||||
curFileDep :: IODependency p
|
curFileDep :: IODependency_
|
||||||
curFileDep = pathRW curFile
|
curFileDep = pathRW curFile
|
||||||
|
|
||||||
maxFileDep :: IODependency p
|
maxFileDep :: IODependency_
|
||||||
maxFileDep = pathR maxFile
|
maxFileDep = pathR maxFile
|
||||||
|
|
||||||
intelBacklightSignalDep :: DBusDependency RawBrightness
|
intelBacklightSignalDep :: DBusDependency_
|
||||||
intelBacklightSignalDep = signalDep intelBacklightConfig
|
intelBacklightSignalDep = signalDep intelBacklightConfig
|
||||||
|
|
||||||
exportIntelBacklight :: Maybe Client -> SometimesIO
|
exportIntelBacklight :: Maybe Client -> SometimesIO
|
||||||
|
|
|
@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
|
||||||
memRemoved :: MemberName
|
memRemoved :: MemberName
|
||||||
memRemoved = memberName_ "InterfacesRemoved"
|
memRemoved = memberName_ "InterfacesRemoved"
|
||||||
|
|
||||||
dbusDep :: MemberName -> DBusDependency p
|
dbusDep :: MemberName -> DBusDependency_
|
||||||
dbusDep m = Endpoint bus path interface $ Signal_ m
|
dbusDep m = Endpoint bus path interface $ Signal_ m
|
||||||
|
|
||||||
addedDep :: DBusDependency p
|
addedDep :: DBusDependency_
|
||||||
addedDep = dbusDep memAdded
|
addedDep = dbusDep memAdded
|
||||||
|
|
||||||
removedDep :: DBusDependency p
|
removedDep :: DBusDependency_
|
||||||
removedDep = dbusDep memRemoved
|
removedDep = dbusDep memRemoved
|
||||||
|
|
||||||
driveInsertedSound :: FilePath
|
driveInsertedSound :: FilePath
|
||||||
|
|
|
@ -117,7 +117,7 @@ exportScreensaver client =
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
bus = Bus xmonadBusName
|
bus = Bus xmonadBusName
|
||||||
ssx = DBusIO $ Executable True ssExecutable
|
ssx = DBusIO $ IOSystem_ $ Executable True ssExecutable
|
||||||
|
|
||||||
callToggle :: Maybe Client -> SometimesIO
|
callToggle :: Maybe Client -> SometimesIO
|
||||||
callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath
|
callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath
|
||||||
|
@ -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 :: DBusDependency p
|
ssSignalDep :: DBusDependency_
|
||||||
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState
|
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState
|
||||||
|
|
|
@ -1,30 +1,44 @@
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for handling dependencies
|
-- | Functions for handling dependencies
|
||||||
|
|
||||||
module XMonad.Internal.Dependency
|
module XMonad.Internal.Dependency
|
||||||
( AlwaysX
|
-- feature types
|
||||||
, AlwaysIO
|
( Feature
|
||||||
, Feature
|
|
||||||
, Always(..)
|
, Always(..)
|
||||||
, TestedSometimes(..)
|
, Sometimes
|
||||||
|
, AlwaysX
|
||||||
|
, AlwaysIO
|
||||||
, SometimesX
|
, SometimesX
|
||||||
, SometimesIO
|
, SometimesIO
|
||||||
, Sometimes
|
, PostPass(..)
|
||||||
, ioSometimes
|
, Subfeature(..)
|
||||||
, ioAlways
|
, LogLevel(..)
|
||||||
|
|
||||||
|
-- dependency tree types
|
||||||
|
, Root(..)
|
||||||
|
, Tree(..)
|
||||||
|
, Tree_(..)
|
||||||
|
, IODependency(..)
|
||||||
|
, IODependency_(..)
|
||||||
|
, SystemDependency(..)
|
||||||
|
, DBusDependency_(..)
|
||||||
|
, DBusMember(..)
|
||||||
|
, UnitType(..)
|
||||||
|
, Result
|
||||||
|
|
||||||
|
-- testing
|
||||||
, evalFeature
|
, evalFeature
|
||||||
, executeSometimes
|
, executeSometimes
|
||||||
, executeAlways
|
, executeAlways
|
||||||
, evalAlways
|
, evalAlways
|
||||||
, evalSometimes
|
, evalSometimes
|
||||||
|
|
||||||
, Subfeature(..)
|
-- lifting
|
||||||
, LogLevel(..)
|
, ioSometimes
|
||||||
|
, ioAlways
|
||||||
, Action(..)
|
|
||||||
|
|
||||||
-- feature construction
|
-- feature construction
|
||||||
, sometimes1
|
, sometimes1
|
||||||
|
@ -34,18 +48,17 @@ module XMonad.Internal.Dependency
|
||||||
, sometimesExeArgs
|
, sometimesExeArgs
|
||||||
, sometimesEndpoint
|
, sometimesEndpoint
|
||||||
|
|
||||||
-- Dependency tree
|
-- dependency construction
|
||||||
, ActionTree(..)
|
, sysExe
|
||||||
, Tree(..)
|
, localExe
|
||||||
, IODependency(..)
|
, sysdSystem
|
||||||
, DBusDependency(..)
|
, sysdUser
|
||||||
, DBusMember(..)
|
|
||||||
, UnitType(..)
|
|
||||||
, listToAnds
|
, listToAnds
|
||||||
, toAnd
|
, toAnd
|
||||||
, pathR
|
, pathR
|
||||||
, pathRW
|
, pathRW
|
||||||
, pathW
|
, pathW
|
||||||
|
, sysTest
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
@ -53,7 +66,6 @@ import Control.Monad.Identity
|
||||||
|
|
||||||
-- import Data.Aeson
|
-- import Data.Aeson
|
||||||
import Data.Bifunctor
|
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
|
||||||
|
@ -64,7 +76,7 @@ import DBus.Internal
|
||||||
import qualified DBus.Introspection as I
|
import qualified DBus.Introspection as I
|
||||||
|
|
||||||
import System.Directory (findExecutable, readable, writable)
|
import System.Directory (findExecutable, readable, writable)
|
||||||
-- import System.Environment
|
import System.Environment
|
||||||
import System.Exit
|
import System.Exit
|
||||||
|
|
||||||
import XMonad.Core (X, io)
|
import XMonad.Core (X, io)
|
||||||
|
@ -73,9 +85,52 @@ import XMonad.Internal.Process
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Features
|
-- | Feature Evaluation
|
||||||
|
--
|
||||||
|
-- Here we attempt to build and return the monadic actions encoded by each
|
||||||
|
-- feature.
|
||||||
|
|
||||||
-- data AlwaysAny = AX AlwaysX | AIO AlwaysIO
|
-- | Execute an Always immediately
|
||||||
|
executeAlways :: MonadIO m => Always (m a) -> m a
|
||||||
|
executeAlways = join . evalAlways
|
||||||
|
|
||||||
|
-- | Execute a Sometimes immediately (or do nothing if failure)
|
||||||
|
executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
|
||||||
|
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
|
||||||
|
|
||||||
|
-- | Possibly return the action of an Always/Sometimes
|
||||||
|
evalFeature :: MonadIO m => Feature a -> m (Maybe a)
|
||||||
|
evalFeature (Right a) = Just <$> evalAlways a
|
||||||
|
evalFeature (Left s) = evalSometimes s
|
||||||
|
|
||||||
|
-- | Possibly return the action of a Sometimes
|
||||||
|
evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a)
|
||||||
|
evalSometimes x = io $ either goFail goPass =<< evalSometimesMsg x
|
||||||
|
where
|
||||||
|
goPass (PostPass a ws) = putErrors ws >> return (Just a)
|
||||||
|
goFail es = putErrors es >> return Nothing
|
||||||
|
putErrors = mapM_ putStrLn
|
||||||
|
|
||||||
|
-- | Return the action of an Always
|
||||||
|
evalAlways :: MonadIO m => Always a -> m a
|
||||||
|
evalAlways a = do
|
||||||
|
(PostPass x ws) <- evalAlwaysMsg a
|
||||||
|
io $ mapM_ putStrLn ws
|
||||||
|
return x
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Feature status
|
||||||
|
|
||||||
|
-- | Dump the status of an Always to stdout
|
||||||
|
-- dumpAlways :: MonadIO m => Always a -> m ()
|
||||||
|
-- dumpAlways = undefined
|
||||||
|
|
||||||
|
-- | Dump the status of a Sometimes to stdout
|
||||||
|
-- dumpSometimes :: MonadIO m => Sometimes a -> m ()
|
||||||
|
-- dumpSometimes = undefined
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Wrapper types
|
||||||
|
|
||||||
type AlwaysX = Always (X ())
|
type AlwaysX = Always (X ())
|
||||||
|
|
||||||
|
@ -87,388 +142,273 @@ type SometimesIO = Sometimes (IO ())
|
||||||
|
|
||||||
type Feature a = Either (Sometimes a) (Always a)
|
type Feature a = Either (Sometimes a) (Always a)
|
||||||
|
|
||||||
data Always a = Option (Subfeature a Tree) (Always a) | Always a
|
|
||||||
|
|
||||||
type Sometimes a = [Subfeature a Tree]
|
|
||||||
|
|
||||||
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
|
||||||
ioSometimes = fmap ioSubfeature
|
|
||||||
|
|
||||||
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
|
||||||
ioAlways (Always x) = Always $ io x
|
|
||||||
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
|
||||||
|
|
||||||
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]
|
|
||||||
}
|
|
||||||
|
|
||||||
type FailedFeature a p = Either (Subfeature a Tree, String)
|
|
||||||
(Subfeature a ResultTree, [String])
|
|
||||||
|
|
||||||
data Finished a p = Finished
|
|
||||||
{ finData :: Subfeature a ResultTree
|
|
||||||
, finAction :: a
|
|
||||||
, finWarnings :: [String]
|
|
||||||
}
|
|
||||||
|
|
||||||
data FeatureResult a p = Untestable (Subfeature a Tree) String |
|
|
||||||
FailedFtr (Subfeature a ResultTree) [String] |
|
|
||||||
SuccessfulFtr (Finished a p)
|
|
||||||
|
|
||||||
type ActionTreeMaybe a p = Either (ActionTree a Tree, String)
|
|
||||||
(ActionTree a ResultTree, Maybe a, [String])
|
|
||||||
|
|
||||||
sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a
|
|
||||||
sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }]
|
|
||||||
|
|
||||||
-- always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a
|
|
||||||
-- always1_ l n t x =
|
|
||||||
-- Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x)
|
|
||||||
|
|
||||||
sometimes1 :: String -> ActionTree a Tree -> Sometimes a
|
|
||||||
sometimes1 = sometimes1_ Error
|
|
||||||
|
|
||||||
sometimesIO :: String -> Tree (IODependency p) p -> a -> Sometimes a
|
|
||||||
sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t
|
|
||||||
|
|
||||||
sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency p) p
|
|
||||||
-> (Client -> a) -> Sometimes a
|
|
||||||
sometimesDBus c n t x = sometimes1 n $ DBusTree (Standalone x) c t
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature Data
|
-- | Feature declaration
|
||||||
|
|
||||||
data Subfeature a t = Subfeature
|
-- | Feature that is guaranteed to work
|
||||||
{ sfTree :: ActionTree a t
|
-- This is composed of sub-features that are tested in order, and if all fail
|
||||||
|
-- the fallback is a monadic action (eg a plain haskell function)
|
||||||
|
data Always a = Option (SubfeatureRoot a) (Always a) | Always a
|
||||||
|
|
||||||
|
-- | Feature that might not be present
|
||||||
|
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
||||||
|
-- action
|
||||||
|
type Sometimes a = [SubfeatureRoot a]
|
||||||
|
|
||||||
|
-- | Individually tested sub-feature data for Always/sometimes
|
||||||
|
-- The polymorphism allows representing tested and untested states. Includes
|
||||||
|
-- the 'action' itself to be tested and any auxilary data for describing the
|
||||||
|
-- sub-feature.
|
||||||
|
data Subfeature f = Subfeature
|
||||||
|
{ sfData :: f
|
||||||
, sfName :: String
|
, sfName :: String
|
||||||
, sfLevel :: LogLevel
|
, sfLevel :: LogLevel
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type SubfeatureRoot a = Subfeature (Root a)
|
||||||
|
|
||||||
|
-- | Loglevel at which feature testing should be reported
|
||||||
|
-- This is currently not used for anything important
|
||||||
data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
|
data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
|
||||||
|
|
||||||
ioSubfeature :: MonadIO m => Subfeature (IO a) t -> Subfeature (m a) t
|
-- | An action and its dependencies
|
||||||
ioSubfeature sf = sf { sfTree = ioActionTree $ sfTree sf }
|
-- May be a plain old monad or be DBus-dependent, in which case a client is
|
||||||
|
-- needed
|
||||||
|
data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p)
|
||||||
|
| IORoot_ a (Tree_ IODependency_)
|
||||||
|
| forall p. DBusRoot (p -> Client -> a) (Tree IODependency DBusDependency_ p) (Maybe Client)
|
||||||
|
| DBusRoot_ (Client -> a) (Tree_ DBusDependency_) (Maybe Client)
|
||||||
|
|
||||||
-- data Msg = Msg LogLevel String String
|
-- | The dependency tree with rules to merge results
|
||||||
|
data Tree d d_ p =
|
||||||
|
And12 (p -> p -> p) (Tree d d_ p) (Tree d d_ p)
|
||||||
|
| And1 (p -> p) (Tree d d_ p) (Tree_ d_)
|
||||||
|
| And2 (p -> p) (Tree_ d_) (Tree d d_ p)
|
||||||
|
| Or (p -> p) (p -> p) (Tree d d_ p) (Tree d d_ p)
|
||||||
|
| Only (d p)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
-- | A dependency tree without functions to merge results
|
||||||
-- | Action Tree
|
data Tree_ d =
|
||||||
|
And_ (Tree_ d) (Tree_ d)
|
||||||
|
| Or_ (Tree_ d) (Tree_ d)
|
||||||
|
| Only_ d
|
||||||
|
|
||||||
data ActionTree a t =
|
-- | A dependency that only requires IO to evaluate
|
||||||
forall p. IOTree (Action a p) (t (IODependency p) p)
|
data IODependency p = IORead String (IO (Result p))
|
||||||
| forall p. DBusTree (Action (Client -> a) p) (Maybe Client)
|
| forall a. IOAlways (Always a) (a -> p)
|
||||||
(t (DBusDependency p) p)
|
| forall a. IOSometimes (Sometimes a) (a -> p)
|
||||||
|
|
||||||
data Action a p = Standalone a | Consumer (p -> a)
|
-- | A dependency pertaining to the DBus
|
||||||
|
-- data DBusDependency p =
|
||||||
|
-- -- Bus BusName
|
||||||
|
-- -- | Endpoint BusName ObjectPath InterfaceName DBusMember
|
||||||
|
-- DBusIO (IODependency p)
|
||||||
|
|
||||||
ioActionTree :: MonadIO m => ActionTree (IO a) t -> ActionTree (m a) t
|
-- | A dependency pertaining to the DBus
|
||||||
ioActionTree (IOTree (Standalone a) t) = IOTree (Standalone $ io a) t
|
data DBusDependency_ = Bus BusName
|
||||||
ioActionTree (IOTree (Consumer a) t) = IOTree (Consumer $ io . a) t
|
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
||||||
ioActionTree (DBusTree (Standalone a) cl t) = DBusTree (Standalone $ io . a) cl t
|
| DBusIO IODependency_
|
||||||
ioActionTree (DBusTree (Consumer a) cl t) = DBusTree (Consumer (\p c -> io $ a p c)) cl t
|
|
||||||
|
|
||||||
-- --------------------------------------------------------------------------------
|
-- | A dependency that only requires IO to evaluate (no payload)
|
||||||
-- | Dependency Tree
|
data IODependency_ = IOSystem_ SystemDependency | forall a. IOSometimes_ (Sometimes a)
|
||||||
|
|
||||||
data Tree d p =
|
data SystemDependency = Executable Bool FilePath
|
||||||
And (p -> p -> p) (Tree d p) (Tree d p)
|
|
||||||
| Or (p -> p) (p -> p) (Tree d p) (Tree d p)
|
|
||||||
| Only d
|
|
||||||
|
|
||||||
listToAnds :: d -> [d] -> Tree d (Maybe x)
|
|
||||||
listToAnds i = foldr (And (const . const Nothing) . Only) (Only i)
|
|
||||||
|
|
||||||
toAnd :: d -> d -> Tree d (Maybe x)
|
|
||||||
toAnd a b = And (const . const Nothing) (Only a) (Only b)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | Result Tree
|
|
||||||
|
|
||||||
-- | 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 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
|
||||||
| forall a. NestedAlways (Always a) (a -> p)
|
|
||||||
| forall a. NestedSometimes (Sometimes a) (a -> p)
|
|
||||||
|
|
||||||
|
-- | The type of a systemd service
|
||||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||||
|
|
||||||
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
|
-- | Wrapper type to describe and endpoint
|
||||||
sometimesExe n sys path = sometimesExeArgs n sys path []
|
|
||||||
|
|
||||||
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
|
|
||||||
sometimesExeArgs n sys path args =
|
|
||||||
sometimesIO n (Only (Executable sys path)) $ spawnCmd path args
|
|
||||||
|
|
||||||
pathR :: String -> IODependency p
|
|
||||||
pathR n = AccessiblePath n True False
|
|
||||||
|
|
||||||
pathW :: String -> IODependency p
|
|
||||||
pathW n = AccessiblePath n False True
|
|
||||||
|
|
||||||
pathRW :: String -> IODependency p
|
|
||||||
pathRW n = AccessiblePath n True True
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | DBus Dependency Result
|
|
||||||
|
|
||||||
data DBusDependency p =
|
|
||||||
Bus BusName
|
|
||||||
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
|
||||||
| DBusIO (IODependency p)
|
|
||||||
|
|
||||||
data DBusMember = Method_ MemberName
|
data DBusMember = Method_ MemberName
|
||||||
| Signal_ MemberName
|
| Signal_ MemberName
|
||||||
| Property_ String
|
| Property_ String
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
introspectInterface :: InterfaceName
|
--------------------------------------------------------------------------------
|
||||||
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
-- | Tested dependency tree
|
||||||
|
--
|
||||||
|
-- The main reason I need this is so I have a "result" I can convert to JSON
|
||||||
|
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
|
||||||
|
|
||||||
introspectMethod :: MemberName
|
-- | Tested Always feature
|
||||||
introspectMethod = memberName_ "Introspect"
|
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always a)
|
||||||
|
| Fallback a [SubfeatureFail]
|
||||||
|
|
||||||
sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
|
-- | Tested Sometimes feature
|
||||||
-> MemberName -> Maybe Client -> Sometimes (m ())
|
data PostSometimes a = PostSometimes
|
||||||
sometimesEndpoint name busname path iface mem client =
|
{ psSuccess :: Maybe (SubfeaturePass a)
|
||||||
sometimesDBus client name deps cmd
|
, psFailed :: [SubfeatureFail]
|
||||||
where
|
}
|
||||||
deps = Only $ Endpoint busname path iface $ Method_ mem
|
|
||||||
cmd c = io $ void $ callMethod c busname path iface mem
|
-- | Passing subfeature
|
||||||
|
type SubfeaturePass a = Subfeature (PostPass a)
|
||||||
|
|
||||||
|
-- | Failed subfeature
|
||||||
|
type SubfeatureFail = Subfeature PostFail
|
||||||
|
|
||||||
|
-- | An action that passed
|
||||||
|
data PostPass a = PostPass a [String] deriving (Functor)
|
||||||
|
|
||||||
|
addMsgs :: PostPass a -> [String] -> PostPass a
|
||||||
|
addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
|
||||||
|
|
||||||
|
-- | An action that failed
|
||||||
|
data PostFail = PostFail [String] | PostMissing String
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature evaluation
|
-- | Testing pipeline
|
||||||
--
|
|
||||||
-- Here we attempt to build and return the monadic actions encoded by each
|
|
||||||
-- feature.
|
|
||||||
|
|
||||||
executeAlways :: MonadIO m => Always (m a) -> m a
|
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
|
||||||
executeAlways = join . evalAlways
|
|
||||||
|
|
||||||
executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
|
|
||||||
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
|
|
||||||
|
|
||||||
evalFeature :: MonadIO m => Feature a -> m (Maybe a)
|
|
||||||
evalFeature (Right a) = Just <$> evalAlways a
|
|
||||||
evalFeature (Left s) = evalSometimes s
|
|
||||||
|
|
||||||
-- 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
|
evalSometimesMsg x = io $ do
|
||||||
TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
|
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes x
|
||||||
return $ maybe (Left []) (\Finished { finAction = a } -> Right (a, [])) s
|
case s of
|
||||||
|
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False fs
|
||||||
|
_ -> Left <$> failedMsgs True fs
|
||||||
|
|
||||||
|
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
|
||||||
|
evalAlwaysMsg x = io $ do
|
||||||
|
r <- testAlways x
|
||||||
|
case r of
|
||||||
|
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False fs
|
||||||
|
(Fallback act fs) -> PostPass act <$> failedMsgs False fs
|
||||||
|
|
||||||
-- TODO actually print things
|
testAlways :: Always a -> IO (PostAlways a)
|
||||||
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 m -> IO (TestedAlways m p)
|
|
||||||
testAlways = go []
|
testAlways = go []
|
||||||
where
|
where
|
||||||
go failed (Option fd next) = do
|
go failed (Option fd next) = do
|
||||||
r <- testSubfeature fd
|
r <- testSubfeature fd
|
||||||
case r of
|
case r of
|
||||||
(Untestable fd' err) -> go (Left (fd' ,err):failed) next
|
(Left l) -> go (l:failed) next
|
||||||
(FailedFtr fd' errs) -> go (Right (fd' ,errs):failed) next
|
(Right pass) -> return $ Primary pass failed next
|
||||||
(SuccessfulFtr s) -> return $ Primary s failed next
|
|
||||||
go failed (Always a) = return $ Fallback a failed
|
go failed (Always a) = return $ Fallback a failed
|
||||||
|
|
||||||
testSometimes :: Sometimes m -> IO (TestedSometimes m p)
|
testSometimes :: Sometimes a -> IO (PostSometimes a)
|
||||||
testSometimes = go (TestedSometimes Nothing [] [])
|
testSometimes = go (PostSometimes Nothing [])
|
||||||
where
|
where
|
||||||
go ts [] = return ts
|
go ts [] = return ts
|
||||||
go ts (x:xs) = do
|
go ts (x:xs) = do
|
||||||
r <- testSubfeature x
|
sf <- testSubfeature x
|
||||||
|
case sf of
|
||||||
|
(Left l) -> go (ts { psFailed = l:psFailed ts }) xs
|
||||||
|
(Right pass) -> return $ ts { psSuccess = Just pass }
|
||||||
|
|
||||||
|
testSubfeature :: SubfeatureRoot a -> IO (Either SubfeatureFail (SubfeaturePass a))
|
||||||
|
testSubfeature sf@Subfeature{ sfData = t } = do
|
||||||
|
t' <- testRoot t
|
||||||
|
-- monomorphism restriction :(
|
||||||
|
return $ bimap (\n -> sf { sfData = n }) (\n -> sf { sfData = n }) t'
|
||||||
|
|
||||||
|
testRoot :: Root a -> IO (Either PostFail (PostPass a))
|
||||||
|
testRoot r = do
|
||||||
case r of
|
case r of
|
||||||
(Untestable fd' err) -> go (addFail ts (Left (fd' ,err))) xs
|
(IORoot a t) -> go a testIODependency_ testIODependency t
|
||||||
(FailedFtr fd' errs) -> go (addFail ts (Right (fd' ,errs))) xs
|
(IORoot_ a t) -> go_ a testIODependency_ t
|
||||||
(SuccessfulFtr s) -> return $ ts { tsSuccess = Just s }
|
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDependency_ cl) testIODependency t
|
||||||
addFail ts@(TestedSometimes { tsFailed = f }) new
|
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t
|
||||||
= ts { tsFailed = new:f }
|
_ -> return $ Left $ PostMissing "client not available"
|
||||||
|
|
||||||
testSubfeature :: Subfeature m Tree -> IO (FeatureResult m p)
|
|
||||||
testSubfeature fd@(Subfeature { sfTree = t }) = do
|
|
||||||
atm <- testActionTree t
|
|
||||||
return $ either untestable checkAction atm
|
|
||||||
where
|
where
|
||||||
untestable (t', err) = Untestable (fd { sfTree = t' }) err
|
go a f_ f t = bimap PostFail (fmap a) <$> testTree f_ f t
|
||||||
checkAction (t', Just a, ms) = SuccessfulFtr
|
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
|
||||||
$ Finished { finData = fd { sfTree = t' }
|
|
||||||
, finAction = a
|
|
||||||
, finWarnings = ms
|
|
||||||
}
|
|
||||||
checkAction (t', Nothing, ms) = FailedFtr (fd { sfTree = t' }) ms
|
|
||||||
|
|
||||||
testActionTree :: ActionTree m Tree -> IO (ActionTreeMaybe m p)
|
--------------------------------------------------------------------------------
|
||||||
testActionTree t = do
|
-- | Payloaded dependency testing
|
||||||
case t of
|
|
||||||
(IOTree a d) -> do
|
type Result p = Either [String] (PostPass p)
|
||||||
(t', a', msgs) <- doTest testIOTree d a
|
|
||||||
return $ Right (IOTree a t', a', msgs)
|
testTree :: (d_ -> IO Result_) -> (d p -> IO (Result p)) -> Tree d d_ p
|
||||||
(DBusTree a (Just cl) d) -> do
|
-> IO (Either [String] (PostPass p))
|
||||||
(t', a', msgs) <- doTest (testDBusTree cl) d a
|
testTree test_ test = go
|
||||||
return $ Right (DBusTree a (Just cl) t', fmap (\f -> f cl) a', msgs)
|
-- TODO clean this up
|
||||||
_ -> return $ Left (t, "client not available")
|
|
||||||
where
|
where
|
||||||
doTest testFun d a = do
|
go (And12 f a b) = either (return . Left) (\ra -> (and2nd f ra =<<) <$> go b)
|
||||||
(t', r) <- testFun d
|
=<< go a
|
||||||
-- TODO actually recover the proper error messages
|
go (And1 f a b) = do
|
||||||
let (a', msgs) = maybe (Nothing, []) (\p -> (fmap (apply a) p, [])) r
|
ra <- go a
|
||||||
return (t', a', msgs)
|
case ra of
|
||||||
apply (Standalone a) _ = a
|
(Right (PostPass pa wa)) -> do
|
||||||
apply (Consumer a) p = a p
|
rb <- testTree_ test_ b
|
||||||
|
return $ case rb of
|
||||||
testIOTree :: Tree (IODependency p) p
|
(Left es) -> Left es
|
||||||
-> IO (ResultTree (IODependency p) p, Maybe (Maybe p))
|
(Right wb) -> Right $ PostPass (f pa) $ wa ++ wb
|
||||||
testIOTree = testTree testIODependency
|
l -> return l
|
||||||
|
go (And2 f a b) = do
|
||||||
testDBusTree :: Client -> Tree (DBusDependency p) p
|
ra <- testTree_ test_ a
|
||||||
-> IO (ResultTree (DBusDependency p) p, Maybe (Maybe p))
|
case ra of
|
||||||
testDBusTree client = testTree (testDBusDependency client)
|
(Right wa) -> do
|
||||||
|
rb <- go b
|
||||||
testTree :: Monad m => (d -> m (Summary p)) -> Tree d p
|
return $ case rb of
|
||||||
-> m (ResultTree d p, Maybe (Maybe p))
|
(Left es) -> Left es
|
||||||
testTree test = go
|
(Right (PostPass pb wb)) -> Right $ PostPass (f pb) $ wa ++ wb
|
||||||
where
|
(Left l) -> return $ Left l
|
||||||
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
|
go (Or fa fb a b) = do
|
||||||
(ra, pa) <- go a
|
ra <- go a
|
||||||
let pass p = return (First ra b, Just $ fa <$> p)
|
case ra of
|
||||||
let fail_ = test2nd (Just . fb) ra b
|
(Right (PostPass pa wa)) -> return $ Right $ PostPass (fa pa) wa
|
||||||
maybe fail_ pass pa
|
(Left ea) -> (or2nd fb ea =<<) <$> go b
|
||||||
go (Only a) =
|
go (Only a) = test a
|
||||||
either (\es -> (LeafFail a es, Nothing)) (\(p, ws) -> (LeafSuccess a ws, Just p))
|
and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
|
||||||
<$> test a
|
or2nd f es (PostPass pb wb) = Right $ PostPass (f pb) $ es ++ wb
|
||||||
test2nd f ra b = do
|
|
||||||
(rb, pb) <- go b
|
|
||||||
return (Both ra rb, fmap (f =<<) pb)
|
|
||||||
|
|
||||||
testIODependency :: IODependency p -> IO (Summary p)
|
testIODependency :: IODependency p -> IO (Result p)
|
||||||
testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin
|
testIODependency (IORead _ t) = t
|
||||||
|
testIODependency (IOAlways a f) = Right . fmap f <$> evalAlwaysMsg a
|
||||||
|
testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Standalone dependency testing
|
||||||
|
|
||||||
|
type Result_ = Either [String] [String]
|
||||||
|
|
||||||
|
testTree_ :: (d -> IO Result_) -> Tree_ d -> IO (Either [String] [String])
|
||||||
|
testTree_ test = go
|
||||||
where
|
where
|
||||||
err = Left ["executable '" ++ bin ++ "' not found"]
|
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
|
||||||
|
go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a
|
||||||
|
go (Only_ a) = test a
|
||||||
|
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
|
||||||
|
|
||||||
testIODependency (IOTest _ t) = maybe (Right (Nothing, [])) (Left . (:[])) <$> t
|
testIODependency_ :: IODependency_ -> IO Result_
|
||||||
|
testIODependency_ (IOSystem_ s) = maybe (Right []) (Left . (:[])) <$> testSysDependency s
|
||||||
|
testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
|
||||||
|
|
||||||
testIODependency (IORead _ t) = bimap (:[]) (, []) <$> t
|
testSysDependency :: SystemDependency -> IO (Maybe String)
|
||||||
|
testSysDependency (IOTest _ t) = t
|
||||||
testIODependency (Systemd t n) = do
|
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
||||||
|
<$> findExecutable bin
|
||||||
|
where
|
||||||
|
msg = unwords [e, "executable", quote bin, "not found"]
|
||||||
|
e = if sys then "system" else "local"
|
||||||
|
testSysDependency (Systemd t n) = do
|
||||||
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
||||||
return $ case rc of
|
return $ case rc of
|
||||||
ExitSuccess -> Right (Nothing, [])
|
ExitSuccess -> Nothing
|
||||||
_ -> Left ["systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"]
|
_ -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"
|
||||||
where
|
where
|
||||||
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
||||||
unitType SystemUnit = "system"
|
unitType SystemUnit = "system"
|
||||||
unitType UserUnit = "user"
|
unitType UserUnit = "user"
|
||||||
|
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
||||||
testIODependency (AccessiblePath p r w) = do
|
|
||||||
res <- getPermissionsSafe p
|
|
||||||
let msg = permMsg res
|
|
||||||
return msg
|
|
||||||
where
|
where
|
||||||
testPerm False _ _ = Nothing
|
testPerm False _ _ = Nothing
|
||||||
testPerm True f res = Just $ f res
|
testPerm True f res = Just $ f res
|
||||||
permMsg NotFoundError = smryFail "file not found"
|
permMsg NotFoundError = Just "file not found"
|
||||||
permMsg PermError = smryFail "could not get permissions"
|
permMsg PermError = Just "could not get permissions"
|
||||||
permMsg (PermResult res) =
|
permMsg (PermResult res) =
|
||||||
case (testPerm r readable res, testPerm w writable res) of
|
case (testPerm r readable res, testPerm w writable res) of
|
||||||
(Just False, Just False) -> smryFail "file not readable or writable"
|
(Just False, Just False) -> Just "file not readable or writable"
|
||||||
(Just False, _) -> smryFail "file not readable"
|
(Just False, _) -> Just "file not readable"
|
||||||
(_, Just False) -> smryFail "file not writable"
|
(_, Just False) -> Just "file not writable"
|
||||||
_ -> Right (Nothing, [])
|
_ -> Nothing
|
||||||
|
|
||||||
-- TODO actually collect errors here
|
testDBusDependency_ :: Client -> DBusDependency_ -> IO Result_
|
||||||
testIODependency (NestedAlways a f) = do
|
testDBusDependency_ client (Bus bus) = 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 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 -> smryFail e
|
Left e -> smryFail e
|
||||||
Right b -> let ns = bodyGetNames b in
|
Right b -> let ns = bodyGetNames b in
|
||||||
if bus' `elem` ns then Right (Nothing, [])
|
if bus' `elem` ns then Right []
|
||||||
else smryFail $ 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
|
||||||
|
@ -479,7 +419,7 @@ testDBusDependency client (Bus bus) = do
|
||||||
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
|
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
|
||||||
bodyGetNames _ = []
|
bodyGetNames _ = []
|
||||||
|
|
||||||
testDBusDependency 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 -> smryFail e
|
Left e -> smryFail e
|
||||||
|
@ -488,7 +428,7 @@ testDBusDependency client (Endpoint busname objpath iface mem) = do
|
||||||
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 -> Right (Nothing, [])
|
Just True -> Right []
|
||||||
_ -> smryFail $ 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)
|
||||||
|
@ -509,7 +449,124 @@ testDBusDependency client (Endpoint busname objpath iface mem) = do
|
||||||
, formatBusName busname
|
, formatBusName busname
|
||||||
]
|
]
|
||||||
|
|
||||||
testDBusDependency _ (DBusIO d) = testIODependency d
|
testDBusDependency_ _ (DBusIO i) = testIODependency_ i
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Constructor functions
|
||||||
|
|
||||||
|
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
|
||||||
|
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
||||||
|
|
||||||
|
-- always1_ :: LogLevel -> String -> Root a Tree -> a -> Always a
|
||||||
|
-- always1_ l n t x =
|
||||||
|
-- Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x)
|
||||||
|
|
||||||
|
sometimes1 :: String -> Root a -> Sometimes a
|
||||||
|
sometimes1 = sometimes1_ Error
|
||||||
|
|
||||||
|
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
|
||||||
|
sometimesIO n t x = sometimes1 n $ IORoot_ x t
|
||||||
|
|
||||||
|
sometimesDBus :: Maybe Client -> String -> Tree_ DBusDependency_
|
||||||
|
-> (Client -> a) -> Sometimes a
|
||||||
|
sometimesDBus c n t x = sometimes1 n $ DBusRoot_ x t c
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | IO Lifting functions
|
||||||
|
|
||||||
|
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
||||||
|
ioSometimes = fmap ioSubfeature
|
||||||
|
|
||||||
|
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
||||||
|
ioAlways (Always x) = Always $ io x
|
||||||
|
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
||||||
|
|
||||||
|
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||||
|
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
||||||
|
|
||||||
|
-- data Msg = Msg LogLevel String String
|
||||||
|
|
||||||
|
ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
|
||||||
|
ioRoot (IORoot a t) = IORoot (io . a) t
|
||||||
|
ioRoot (IORoot_ a t) = IORoot_ (io a) t
|
||||||
|
ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
|
||||||
|
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||||
|
|
||||||
|
-- --------------------------------------------------------------------------------
|
||||||
|
-- | Dependency Tree
|
||||||
|
|
||||||
|
listToAnds :: d -> [d] -> Tree_ d
|
||||||
|
listToAnds i = foldr (And_ . Only_) (Only_ i)
|
||||||
|
|
||||||
|
toAnd :: d -> d -> Tree_ d
|
||||||
|
toAnd a b = And_ (Only_ a) (Only_ b)
|
||||||
|
|
||||||
|
smryFail :: String -> Either [String] a
|
||||||
|
smryFail msg = Left [msg]
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | IO Dependency
|
||||||
|
|
||||||
|
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
|
||||||
|
sometimesExe n sys path = sometimesExeArgs n sys path []
|
||||||
|
|
||||||
|
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
|
||||||
|
sometimesExeArgs n sys path args =
|
||||||
|
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
||||||
|
|
||||||
|
exe :: Bool -> String -> IODependency_
|
||||||
|
exe b = IOSystem_ . Executable b
|
||||||
|
|
||||||
|
sysExe :: String -> IODependency_
|
||||||
|
sysExe = exe True
|
||||||
|
|
||||||
|
localExe :: String -> IODependency_
|
||||||
|
localExe = exe False
|
||||||
|
|
||||||
|
pathR :: String -> IODependency_
|
||||||
|
pathR n = IOSystem_ $ AccessiblePath n True False
|
||||||
|
|
||||||
|
pathW :: String -> IODependency_
|
||||||
|
pathW n = IOSystem_ $ AccessiblePath n False True
|
||||||
|
|
||||||
|
pathRW :: String -> IODependency_
|
||||||
|
pathRW n = IOSystem_ $ AccessiblePath n True True
|
||||||
|
|
||||||
|
sysd :: UnitType -> String -> IODependency_
|
||||||
|
sysd u = IOSystem_ . Systemd u
|
||||||
|
|
||||||
|
sysdUser :: String -> IODependency_
|
||||||
|
sysdUser = sysd UserUnit
|
||||||
|
|
||||||
|
sysdSystem :: String -> IODependency_
|
||||||
|
sysdSystem = sysd SystemUnit
|
||||||
|
|
||||||
|
sysTest :: String -> IO (Maybe String) -> IODependency_
|
||||||
|
sysTest n = IOSystem_ . IOTest n
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | DBus Dependency Result
|
||||||
|
|
||||||
|
introspectInterface :: InterfaceName
|
||||||
|
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||||
|
|
||||||
|
introspectMethod :: MemberName
|
||||||
|
introspectMethod = memberName_ "Introspect"
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | 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.
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Printing
|
-- | Printing
|
||||||
|
@ -525,3 +582,22 @@ testDBusDependency _ (DBusIO d) = testIODependency d
|
||||||
-- | otherwise = skip
|
-- | otherwise = skip
|
||||||
-- where
|
-- where
|
||||||
-- bracket s = "[" ++ s ++ "]"
|
-- bracket s = "[" ++ s ++ "]"
|
||||||
|
|
||||||
|
bracket :: String -> String
|
||||||
|
bracket s = "[" ++ s ++ "]"
|
||||||
|
|
||||||
|
quote :: String -> String
|
||||||
|
quote s = "'" ++ s ++ "'"
|
||||||
|
|
||||||
|
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
|
||||||
|
failedMsgs err = fmap concat . mapM (failedMsg err)
|
||||||
|
|
||||||
|
failedMsg :: Bool -> SubfeatureFail -> IO [String]
|
||||||
|
failedMsg err Subfeature { sfData = d, sfName = n } = do
|
||||||
|
mapM (fmtMsg err n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
|
||||||
|
|
||||||
|
fmtMsg :: Bool -> String -> String -> IO String
|
||||||
|
fmtMsg err n msg = do
|
||||||
|
let e = if err then "ERROR" else "WARNING"
|
||||||
|
p <- getProgName
|
||||||
|
return $ unwords [bracket p, bracket e, bracket n, msg]
|
||||||
|
|
|
@ -55,7 +55,7 @@ import Xmobar.Plugins.Common
|
||||||
btAlias :: String
|
btAlias :: String
|
||||||
btAlias = "bluetooth"
|
btAlias = "bluetooth"
|
||||||
|
|
||||||
btDep :: DBusDependency p
|
btDep :: DBusDependency_
|
||||||
btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects
|
btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects
|
||||||
|
|
||||||
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||||
|
|
|
@ -41,7 +41,7 @@ getByIP = memberName_ "GetDeviceByIpIface"
|
||||||
devSignal :: String
|
devSignal :: String
|
||||||
devSignal = "Ip4Connectivity"
|
devSignal = "Ip4Connectivity"
|
||||||
|
|
||||||
devDep :: DBusDependency p
|
devDep :: DBusDependency_
|
||||||
devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
|
devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
|
||||||
|
|
||||||
getDevice :: Client -> String -> IO (Maybe ObjectPath)
|
getDevice :: Client -> String -> IO (Maybe ObjectPath)
|
||||||
|
|
|
@ -118,5 +118,5 @@ vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
||||||
vpnAlias :: String
|
vpnAlias :: String
|
||||||
vpnAlias = "vpn"
|
vpnAlias = "vpn"
|
||||||
|
|
||||||
vpnDep :: DBusDependency p
|
vpnDep :: DBusDependency_
|
||||||
vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects
|
vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects
|
||||||
|
|
Loading…
Reference in New Issue