ENH use either for dependency results

This commit is contained in:
Nathan Dwarshuis 2021-11-19 00:35:54 -05:00
parent 0caefb336f
commit 5a97a09623
7 changed files with 143 additions and 127 deletions

View File

@ -234,7 +234,7 @@ dateCmd = CmdSpec
dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency a
dbusDep usesys bus obj iface mem =
Dependency { depRequired = True, depData = d }
Dependency d
where
d = DBusEndpoint
{ ddDbusBus = bus
@ -271,13 +271,13 @@ readInterface f = do
return $ Just x
_ -> return Nothing
vpnPresent :: IO (Either String Bool)
vpnPresent :: IO (Maybe String)
vpnPresent = do
res <- tryIOError $ readProcessWithExitCode "nmcli" args ""
-- TODO provide some error messages
return $ case res of
(Right (ExitSuccess, out, _)) -> Right $ "vpn" `elem` lines out
_ -> Left "puke"
(Right (ExitSuccess, out, _)) -> if "vpn" `elem` lines out then Nothing else Just "vpn not found"
_ -> Just "puke"
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
@ -296,17 +296,17 @@ rightPlugins =
, nocheck dateCmd
]
where
nocheck = return . flip Installed []
nocheck = return . Right
getWireless :: IO (MaybeExe CmdSpec)
getWireless = do
i <- readInterface isWireless
return $ maybe Ignore (flip Installed [] . wirelessCmd) i
return $ maybe (Left []) (Right . wirelessCmd) i
getEthernet :: IO (MaybeExe CmdSpec)
getEthernet = do
i <- readInterface isEthernet
maybe (return Ignore) (runIfInstalled [dep] . ethernetCmd) i
maybe (return $ Left []) (runIfInstalled [dep] . ethernetCmd) i
where
dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
@ -315,7 +315,7 @@ getBattery = Feature
{ ftrAction = batteryCmd
, ftrSilent = False
, ftrDefault = Nothing
, ftrChildren = [Dependency { depRequired = True, depData = IOTest hasBattery }]
, ftrChildren = [Dependency $ IOTest hasBattery]
}
type BarFeature = Feature CmdSpec (IO ())
@ -329,7 +329,7 @@ getVPN = Feature
}
where
d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
v = Dependency { depRequired = True, depData = IOTest vpnPresent }
v = Dependency $ IOTest vpnPresent
getBt :: BarFeature
getBt = Feature
@ -379,8 +379,8 @@ getAllCommands right = do
, brRight = mapMaybe eval right
}
where
eval (Installed x _) = Just x
eval _ = Nothing
eval (Right x) = Just x
eval _ = Nothing
--------------------------------------------------------------------------------
-- | various formatting things

View File

@ -500,9 +500,9 @@ externalToMissing = concatMap go
flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
Installed x _ -> Just $ k{ kbAction = x }
Missing _ _ -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip }
Ignore -> Nothing
(Right x) -> Just $ k{ kbAction = x }
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip }
-- _ -> Nothing
externalBindings :: BrightnessControls -> SSControls -> ThreadState
-> [KeyGroup (IO MaybeX)]

View File

@ -77,12 +77,12 @@ runQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess
isUsingNvidia :: IO Bool
isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
hasBattery :: IO (Either String Bool)
hasBattery :: IO (Maybe String)
hasBattery = do
ps <- fromRight [] <$> tryIOError (listDirectory syspath)
ts <- mapM readType ps
-- TODO this is obviously stupid
return $ Right $ "Battery\n" `elem` ts
return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
where
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
syspath = "/sys/class/power_supply"

View File

@ -33,7 +33,7 @@ memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> Dependency (IO a)
dbusDep m = Dependency { depRequired = True, depData = d }
dbusDep m = Dependency d
where
d = DBusEndpoint
{ ddDbusBus = bus

View File

@ -46,6 +46,6 @@ initControls client exporter controls = do
let x = exporter client
e <- evalFeature x
case e of
(Installed c _) -> c
_ -> return ()
(Right c) -> c
_ -> return ()
controls x

View File

@ -21,7 +21,7 @@ import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Dependency
-- import XMonad.Internal.Dependency
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -38,14 +38,14 @@ data DBusXMonad = DBusXMonad
blankControls :: BrightnessControls
blankControls = BrightnessControls
{ bctlMax = Ignore
, bctlMin = Ignore
, bctlInc = Ignore
, bctlDec = Ignore
{ bctlMax = Left []
, bctlMin = Left []
, bctlInc = Left []
, bctlDec = Left []
}
blankSSToggle :: SSControls
blankSSToggle = SSControls { ssToggle = Ignore }
blankSSToggle = SSControls { ssToggle = Left [] }
startXMonadService :: IO DBusXMonad
startXMonadService = do

View File

@ -1,10 +1,8 @@
{-# LANGUAGE DeriveTraversable #-}
--------------------------------------------------------------------------------
-- | Functions for handling dependencies
module XMonad.Internal.Dependency
( MaybeExe(..)
( MaybeExe
, UnitType(..)
, Dependency(..)
, DependencyData(..)
@ -18,7 +16,7 @@ module XMonad.Internal.Dependency
, pathR
, pathW
, pathRW
, checkInstalled
-- , checkInstalled
, runIfInstalled
, depInstalled
, warnMissing
@ -39,13 +37,10 @@ module XMonad.Internal.Dependency
, spawnSound
) where
import Control.Arrow ((***))
import Control.Monad (filterM, join)
import Control.Monad.IO.Class
import Data.Either (isRight)
import Data.List (find, partition)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.List (find)
import Data.Maybe (listToMaybe, maybeToList)
import DBus
import DBus.Client
@ -72,7 +67,7 @@ data DBusMember = Method_ MemberName
data DependencyData = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest (IO (Either String Bool))
| IOTest (IO (Maybe String))
| DBusEndpoint
{ ddDbusBus :: BusName
, ddDbusSystem :: Bool
@ -83,11 +78,7 @@ data DependencyData = Executable String
| Systemd UnitType String
data Dependency a = SubFeature (Feature a a)
| Dependency
-- TODO when would this ever be false?
{ depRequired :: Bool
, depData :: DependencyData
}
| Dependency DependencyData
data Feature a b = Feature
{ ftrAction :: a
@ -96,39 +87,51 @@ data Feature a b = Feature
, ftrChildren :: [Dependency b]
} | ConstFeature a
-- data Chain a = Chain
-- { chainAction :: a
-- , chainChildren :: [Feature a a]
-- , chainCompose :: a -> a -> a
-- }
evalFeature :: Feature a b -> IO (MaybeExe a)
evalFeature (ConstFeature x) = return $ Installed x []
evalFeature (ConstFeature x) = return $ Right x
evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
c' <- concat <$> mapM go c
return $ case foldl groupResult ([], []) c' of
([], opt) -> Installed a opt
(req, opt) -> if s then Ignore else Missing req opt
es <- mapM go c
return $ case concat es of
[] -> Right a
es' -> Left (if s then [] else es')
-- return $ case foldl groupResult ([], []) c' of
-- ([], opt) -> Installed a opt
-- (req, opt) -> if s then Ignore else Missing req opt
where
go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs
go (SubFeature (ConstFeature _)) = return []
go Dependency { depRequired = r, depData = d } = do
i <- depInstalled d
return [(r, d) | not i ]
groupResult (x, y) (True, z) = (z:x, y)
groupResult (x, y) (False, z) = (x, z:y)
go (Dependency d) = do
e <- depInstalled d
return $ maybeToList e
-- groupResult (x, y) (True, z) = (z:x, y)
-- groupResult (x, y) (False, z) = (x, z:y)
-- evalChain :: Chain a -> IO (MaybeExe a)
-- evalChain Chain { chainAction = a, chainChildren = cs , chainCompose = f } =
-- flip Installed [] <$> foldM go a cs
-- where
-- go acc child = do
-- c <- evalFeature child
-- -- TODO need a way to get error messages out of this for anything
-- -- that's missing
-- return $ case c of
-- (Installed x _) -> f x acc
-- _ -> acc
exe :: String -> Dependency a
exe n = Dependency
{ depRequired = True
, depData = Executable n
}
exe = Dependency . Executable
unit :: UnitType -> String -> Dependency a
unit t n = Dependency
{ depRequired = True
, depData = Systemd t n
}
unit t = Dependency . Systemd t
path :: Bool -> Bool -> String -> Dependency a
path r w n = Dependency
{ depRequired = True
, depData = AccessiblePath n r w
}
path r w n = Dependency $ AccessiblePath n r w
pathR :: String -> Dependency a
pathR = path True False
@ -147,32 +150,39 @@ userUnit = unit UserUnit
-- TODO this is poorly named. This actually represents an action that has
-- one or more dependencies (where "action" is not necessarily executing an exe)
data MaybeExe a = Installed a [DependencyData]
| Missing [DependencyData] [DependencyData]
| Ignore
deriving (Foldable, Traversable)
-- data MaybeExe a = Installed a [DependencyData]
-- | Missing [DependencyData] [DependencyData]
-- | Ignore
-- deriving (Foldable, Traversable)
-- data MaybeExe a = MaybeExe (Maybe a) [String]
type MaybeExe a = Either [String] a
-- deriving (Foldable, Traversable)
instance Functor MaybeExe where
fmap f (Installed x ds) = Installed (f x) ds
fmap _ (Missing req opt) = Missing req opt
fmap _ Ignore = Ignore
-- instance Functor MaybeExe where
-- fmap f (MaybeExe x m) = MaybeExe (f <$> x) m
type MaybeX = MaybeExe (X ())
exeInstalled :: String -> IO Bool
exeInstalled x = isJust <$> findExecutable x
exeInstalled :: String -> IO (Maybe String)
exeInstalled x = do
r <- findExecutable x
return $ case r of
(Just _) -> Nothing
_ -> Just $ "executable '" ++ x ++ "' not found"
unitInstalled :: UnitType -> String -> IO Bool
unitInstalled :: UnitType -> String -> IO (Maybe String)
unitInstalled u x = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> True
_ -> False
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"
-- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible :: FilePath -> Bool -> Bool -> IO Bool
pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
pathAccessible p testread testwrite = do
res <- getPermissionsSafe p
let msg = permMsg res
@ -181,20 +191,20 @@ pathAccessible p testread testwrite = do
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 NotFoundError = False
permMsg PermError = False
permMsg NotFoundError = Just "file not found"
permMsg PermError = Just "could not get permissions"
-- permMsg NotFoundError = False
-- permMsg PermError = False
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
(Just True, Just True) -> True
(Just True, Nothing) -> True
(Nothing, Just True) -> True
_ -> False
(Just False, Just False) -> Just "file not readable or writable"
(Just False, _) -> Just "file not readable"
(_, Just False) -> Just "file not writable"
_ -> Nothing
-- (Just True, Just True) -> True
-- (Just True, Nothing) -> True
-- (Nothing, Just True) -> True
-- _ -> False
-- (Just False, Just False) -> Just "file not readable or writable"
-- (Just False, _) -> Just "file not readable"
-- (_, Just False) -> Just "file not writable"
@ -207,7 +217,7 @@ introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember
-> IO Bool
-> IO (Maybe String)
dbusInstalled bus usesystem objpath iface mem = do
client <- if usesystem then connectSystem else connectSession
reply <- call_ client (methodCall objpath introspectInterface introspectMethod)
@ -215,7 +225,10 @@ dbusInstalled bus usesystem objpath iface mem = do
let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe (methodReturnBody reply)
disconnect client
return $ fromMaybe False res
return $ case res of
Just _ -> Nothing
_ -> Just "some random dbus interface not found"
-- return $ fromMaybe False res
where
findMem obj = fmap (matchMem mem)
$ find (\i -> I.interfaceName i == iface)
@ -224,10 +237,9 @@ dbusInstalled bus usesystem objpath iface mem = do
matchMem (Signal_ n) = elem n . fmap I.signalName . I.interfaceSignals
matchMem (Property_ n) = elem n . fmap I.propertyName . I.interfaceProperties
-- TODO somehow get this to preserve error messages if something isn't found
depInstalled :: DependencyData -> IO Bool
depInstalled :: DependencyData -> IO (Maybe String)
depInstalled (Executable n) = exeInstalled n
depInstalled (IOTest t) = isRight <$> t
depInstalled (IOTest t) = t
depInstalled (Systemd t n) = unitInstalled t n
depInstalled (AccessiblePath p r w) = pathAccessible p r w
depInstalled DBusEndpoint { ddDbusBus = b
@ -237,13 +249,13 @@ depInstalled DBusEndpoint { ddDbusBus = b
, ddDbusMember = m
} = dbusInstalled b s o i m
checkInstalled :: [Dependency a] -> IO ([DependencyData], [DependencyData])
checkInstalled = fmap go . filterMissing
where
go = join (***) (fmap depData) . partition depRequired
-- checkInstalled :: [Dependency a] -> IO ([DependencyData], [DependencyData])
-- checkInstalled = fmap go . filterMissing
-- where
-- go = join (***) (fmap depData) . partition depRequired
filterMissing :: [Dependency a] -> IO [Dependency a]
filterMissing = filterM (fmap not . depInstalled . depData)
-- filterMissing :: [Dependency a] -> IO [Dependency a]
-- filterMissing = filterM (fmap not . depInstalled . depData)
runIfInstalled :: [Dependency a] -> b -> IO (MaybeExe b)
runIfInstalled ds x = evalFeature $
@ -264,11 +276,11 @@ whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
whenInstalled = flip ifInstalled skip
ifInstalled :: MaybeExe a -> a -> a
ifInstalled (Installed x _) _ = x
ifInstalled _ alt = alt
ifInstalled (Right x) _ = x
ifInstalled _ alt = alt
noCheck :: Monad m => a () -> m (MaybeExe (a ()))
noCheck = return . flip Installed []
noCheck = return . Right
-- not sure what to do with these
@ -285,35 +297,39 @@ playSound file = do
-- paplay seems to have less latency than aplay
spawnCmd "paplay" [p]
partitionMissing :: [MaybeExe a] -> ([DependencyData], [DependencyData])
partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
where
go (Installed _ opt) = ([], opt)
go (Missing req opt) = (req, opt)
go Ignore = ([], [])
-- partitionMissing :: [MaybeExe a] -> ([DependencyData], [DependencyData])
-- partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
-- where
-- go (Installed _ opt) = ([], opt)
-- go (Missing req opt) = (req, opt)
-- go Ignore = ([], [])
fmtMissing :: DependencyData -> String
-- TODO this error message is lame
fmtMissing (IOTest _) = "some random test failed"
fmtMissing DBusEndpoint {} = "some random dbus path is missing"
fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
fmtMissing (AccessiblePath p _ _) = "path '" ++ p ++ "' not ...something"
fmtMissing (Executable n) = "executable '" ++ n ++ "' not found"
fmtMissing (Systemd st n) = "systemd " ++ unitType st ++ " unit '"
++ n ++ "' not found"
where
unitType SystemUnit = "system"
unitType UserUnit = "user"
-- fmtMissing :: DependencyData -> String
-- -- TODO this error message is lame
-- fmtMissing (IOTest _) = "some random test failed"
-- fmtMissing DBusEndpoint {} = "some random dbus path is missing"
-- fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
-- fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
-- fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
-- fmtMissing (AccessiblePath p _ _) = "path '" ++ p ++ "' not ...something"
-- fmtMissing (Executable n) = "executable '" ++ n ++ "' not found"
-- fmtMissing (Systemd st n) = "systemd " ++ unitType st ++ " unit '"
-- ++ n ++ "' not found"
-- where
-- unitType SystemUnit = "system"
-- unitType UserUnit = "user"
fmtMsgs :: [DependencyData] -> [DependencyData] -> [String]
fmtMsgs req opt = ("[WARNING] "++)
<$> (("[REQUIRED DEP] "++) . fmtMissing <$> req)
++ (("[OPTIONAL DEP] "++) . fmtMissing <$> opt)
-- fmtMsgs :: [DependencyData] -> [DependencyData] -> [String]
-- fmtMsgs req opt = ("[WARNING] "++)
-- <$> (("[REQUIRED DEP] "++) . fmtMissing <$> req)
-- ++ (("[OPTIONAL DEP] "++) . fmtMissing <$> opt)
-- warnMsg ::
-- warnMsg xs = mapM_ putStrLn
-- $ [ "[WARNING] " ++ m | (MaybeExe _ (Just m)) <- xs ]
warnMissing :: [MaybeExe a] -> IO ()
warnMissing = mapM_ putStrLn . uncurry fmtMsgs . partitionMissing
warnMissing xs = mapM_ putStrLn $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ]
-- fmtType (AccessiblePath _ _ _) = undefined