ADD awkwardly unify path dependencies into dependency module

This commit is contained in:
Nathan Dwarshuis 2021-11-07 18:41:25 -05:00
parent 76c0eb3386
commit 952e10b1a5
7 changed files with 234 additions and 135 deletions

View File

@ -81,8 +81,9 @@ main = do
, childPIDs = [p]
, childHandles = [h]
}
(ekbs, missing) <- fmap filterExternal $ evalExternal $ externalBindings bc sc ts
mapM_ warnMissing missing
ext <- evalExternal $ externalBindings bc sc ts
let ekbs = filterExternal ext
warnMissing $ externalToMissing ext
-- IDK why this is necessary; nothing prior to this line will print if missing
hFlush stdout
launch
@ -479,18 +480,32 @@ evalExternal = mapM go
evalKeyBinding :: Monad m => KeyBinding (m a) -> m (KeyBinding a)
evalKeyBinding k@KeyBinding { kbAction = a } = (\b -> k { kbAction = b }) <$> a
filterExternal :: [KeyGroup MaybeX] -> ([KeyGroup (X ())], [Dependency])
filterExternal kgs = let kgs' = fmap go kgs in (fst <$> kgs', concatMap snd kgs')
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go
where
go k@KeyGroup { kgBindings = bs } = let bs' = go' <$> bs in
(k { kgBindings = mapMaybe fst bs' }, concatMap snd bs')
go' k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
Installed x ds -> (Just $ k{ kbAction = x }, ds)
Missing ds -> (Just $ k{ kbDesc = flagMissing d, kbAction = skip }, ds)
Ignore -> (Nothing, [])
flagMissing s = "[!!!]" ++ s
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
-- go k@KeyGroup { kgBindings = bs } =
-- ( k { kgBindings = mapMaybe flagKeyBinding bs }
-- , concatMap go' bs
-- )
-- go' KeyBinding{ kbAction = a } = case a of
-- Installed _ opt -> opt
-- -- TODO this will mash together the optional and required deps
-- Missing req opt -> req ++ opt
-- Ignore -> []
externalBindings :: Maybe BrightnessControls
externalToMissing :: [KeyGroup (MaybeExe a)] -> [MaybeExe a]
externalToMissing = concatMap go
where
go KeyGroup { kgBindings = bs } = fmap kbAction bs
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
externalBindings :: BrightnessControls
-> MaybeExe SSControls
-> ThreadState
-> [KeyGroup (IO MaybeX)]
@ -539,10 +554,10 @@ externalBindings bc sc ts =
]
, KeyGroup "System"
[ KeyBinding "M-." "backlight up" $ runMaybe bc bctlInc
, KeyBinding "M-," "backlight down" $ runMaybe bc bctlDec
, KeyBinding "M-M1-," "backlight min" $ runMaybe bc bctlMin
, KeyBinding "M-M1-." "backlight max" $ runMaybe bc bctlMax
[ KeyBinding "M-." "backlight up" $ return $ io <$> bctlInc bc
, KeyBinding "M-," "backlight down" $ return $ io <$> bctlDec bc
, KeyBinding "M-M1-," "backlight min" $ return $ io <$> bctlMin bc
, KeyBinding "M-M1-." "backlight max" $ return $ io <$> bctlMax bc
, KeyBinding "M-<End>" "power menu" $ noCheck runPowerPrompt
, KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" runScreenLock
@ -558,8 +573,8 @@ externalBindings bc sc ts =
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
]
]
where
-- where
-- TODO this is hacky, I shouldn't really need this data structure for
-- something that doesn't depend on executables
runMaybe c f = return $ maybe Ignore (\x -> Installed (io $ f x) []) c
-- runMaybe c f = return $ maybe Ignore (\x -> Installed (io $ f x) []) c

View File

@ -9,7 +9,7 @@ module XMonad.Internal.DBus.Brightness.Common
, matchSignal
) where
import Control.Monad (void)
import Control.Monad (void, when)
import Data.Int (Int32)
@ -17,6 +17,7 @@ import DBus
import DBus.Client
import XMonad.Internal.DBus.Common
import XMonad.Internal.Dependency
--------------------------------------------------------------------------------
-- | External API
@ -38,24 +39,26 @@ data BrightnessConfig a b = BrightnessConfig
}
data BrightnessControls = BrightnessControls
{ bctlMax :: IO ()
, bctlMin :: IO ()
, bctlInc :: IO ()
, bctlDec :: IO ()
{ bctlMax :: MaybeExe (IO ())
, bctlMin :: MaybeExe (IO ())
, bctlInc :: MaybeExe (IO ())
, bctlDec :: MaybeExe (IO ())
}
exportBrightnessControls :: RealFrac b => BrightnessConfig a b -> Client
-> IO BrightnessControls
exportBrightnessControls bc client = do
exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b
-> Client -> IO BrightnessControls
exportBrightnessControls deps bc client = do
(req, opt) <- checkInstalled deps
when (null req) $
exportBrightnessControls' bc client
return $ BrightnessControls
{ bctlMax = callBacklight' memMax
, bctlMin = callBacklight' memMin
, bctlInc = callBacklight' memInc
, bctlDec = callBacklight' memDec
{ bctlMax = callBacklight' req opt memMax
, bctlMin = callBacklight' req opt memMin
, bctlInc = callBacklight' req opt memInc
, bctlDec = callBacklight' req opt memDec
}
where
callBacklight' = callBacklight bc
callBacklight' r o = createInstalled r o . callBacklight bc
callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do

View File

@ -5,11 +5,11 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
( callGetBrightnessIB
, matchSignalIB
, exportIntelBacklight
, hasBacklight
-- , hasBacklight
, blPath
) where
import Data.Either
-- import Data.Either
import Data.Int (Int32)
import DBus
@ -18,6 +18,7 @@ import DBus.Client
import System.FilePath.Posix
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.Dependency
import XMonad.Internal.IO
--------------------------------------------------------------------------------
@ -64,29 +65,29 @@ decBrightness = decPercent steps curFile
-- Right True -> backlight accessible and present
-- Right False -> backlight not present
-- Left x -> backlight present but could not access (x explaining why)
hasBacklight' :: IO (Either String Bool)
hasBacklight' = do
mx <- isReadable maxFile
cx <- isWritable curFile
return $ case (mx, cx) of
(NotFoundError, NotFoundError) -> Right False
(PermResult True, PermResult True) -> Right True
(PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
_ -> Left "Could not determine permissions for backlight files"
-- hasBacklight' :: IO (Either String Bool)
-- hasBacklight' = do
-- mx <- isReadable maxFile
-- cx <- isWritable curFile
-- return $ case (mx, cx) of
-- (NotFoundError, NotFoundError) -> Right False
-- (PermResult True, PermResult True) -> Right True
-- (PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
-- _ -> Left "Could not determine permissions for backlight files"
msg :: Either String Bool -> IO ()
msg (Right True) = return ()
msg (Right False) = putStrLn "No backlight detected. Controls disabled"
msg (Left m) = putStrLn $ "WARNING: " ++ m
-- msg :: Either String Bool -> IO ()
-- msg (Right True) = return ()
-- msg (Right False) = putStrLn "No backlight detected. Controls disabled"
-- msg (Left m) = putStrLn $ "WARNING: " ++ m
hasBacklightMsg :: IO Bool
hasBacklightMsg = do
b <- hasBacklight'
msg b
return $ fromRight False b
-- hasBacklightMsg :: IO Bool
-- hasBacklightMsg = do
-- b <- hasBacklight'
-- msg b
-- return $ fromRight False b
hasBacklight :: IO Bool
hasBacklight = fromRight False <$> hasBacklight'
-- hasBacklight :: IO Bool
-- hasBacklight = fromRight False <$> hasBacklight'
--------------------------------------------------------------------------------
-- | DBus interface
@ -112,12 +113,14 @@ intelBacklightConfig = BrightnessConfig
--------------------------------------------------------------------------------
-- | Exported haskell API
exportIntelBacklight :: Client -> IO (Maybe BrightnessControls)
exportIntelBacklight client = do
b <- hasBacklightMsg
if b
then Just <$> exportBrightnessControls intelBacklightConfig client
else return Nothing
exportIntelBacklight :: Client -> IO BrightnessControls
exportIntelBacklight = exportBrightnessControls deps intelBacklightConfig
where
deps = [pathRW curFile, pathR maxFile]
-- b <- hasBacklightMsg
-- if b
-- then Just <$> exportBrightnessControls intelBacklightConfig client
-- else return Nothing
callGetBrightnessIB :: IO (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig

View File

@ -31,29 +31,37 @@ introspectMethod = memberName_ "Introspect"
data DBusXMonad = DBusXMonad
{ dxClient :: Client
, dxIntelBacklightCtrl :: Maybe BrightnessControls
, dxClevoBacklightCtrl :: Maybe BrightnessControls
, dxIntelBacklightCtrl :: BrightnessControls
-- , dxClevoBacklightCtrl :: MaybeExe BrightnessControls
, dxScreensaverCtrl :: MaybeExe SSControls
}
blankControls :: BrightnessControls
blankControls = BrightnessControls
{ bctlMax = Ignore
, bctlMin = Ignore
, bctlInc = Ignore
, bctlDec = Ignore
}
startXMonadService :: IO DBusXMonad
startXMonadService = do
client <- connectSession
requestResult <- requestName client xmonadBus []
-- TODO if the client is not released on shutdown the owner will be
-- different
(i, c, s) <- if requestResult /= NamePrimaryOwner then do
(i, s) <- if requestResult /= NamePrimaryOwner then do
putStrLn "Another service owns \"org.xmonad\""
return (Nothing, Nothing, Ignore)
return (blankControls, Ignore)
else do
putStrLn "Started xmonad dbus client"
bc <- exportIntelBacklight client
sc <- exportScreensaver client
return (bc, Nothing, sc)
return (bc, sc)
return $ DBusXMonad
{ dxClient = client
, dxIntelBacklightCtrl = i
, dxClevoBacklightCtrl = c
-- , dxClevoBacklightCtrl = c
, dxScreensaverCtrl = s
}

View File

@ -94,9 +94,9 @@ newtype SSControls = SSControls { ssToggle :: IO () }
exportScreensaver :: Client -> IO (MaybeExe SSControls)
exportScreensaver client = do
d <- depInstalled dep
d <- depInstalled $ depData dep
if d then flip Installed [] <$> exportScreensaver' client
else return $ Missing [dep]
else return $ Missing [depData dep] []
where
dep = exe "xset"

View File

@ -5,10 +5,16 @@ module XMonad.Internal.Dependency
( MaybeExe(..)
, UnitType(..)
, Dependency(..)
, DependencyData(..)
, MaybeX
, exe
, systemUnit
, userUnit
, pathR
, pathW
, pathRW
, checkInstalled
, createInstalled
, runIfInstalled
, depInstalled
, warnMissing
@ -29,18 +35,19 @@ module XMonad.Internal.Dependency
, spawnSound
) where
import Control.Monad (filterM)
import Control.Arrow ((***))
import Control.Monad (filterM, join)
import Control.Monad.IO.Class
import Data.List (partition)
import Data.Maybe (isJust)
-- import System.Directory (findExecutable, readable, writable)
import System.Directory (findExecutable)
import System.Directory (findExecutable, readable, writable)
import System.Exit
import System.FilePath
import XMonad.Core (X, getXMonadDir)
-- import XMonad.Internal.IO
import XMonad.Internal.IO
import XMonad.Internal.Process
import XMonad.Internal.Shell
@ -49,61 +56,69 @@ import XMonad.Internal.Shell
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
data DependencyType = Executable
-- | AccessiblePath FilePath Bool Bool
| Systemd UnitType deriving (Eq, Show)
data DependencyData = Executable String
| AccessiblePath FilePath Bool Bool
| Systemd UnitType String
deriving (Eq, Show)
data Dependency = Dependency
{ depRequired :: Bool
, depName :: String
, depType :: DependencyType
, depData :: DependencyData
}
deriving (Eq, Show)
exe :: String -> Dependency
exe n = Dependency
{ depRequired = True
, depName = n
, depType = Executable
, depData = Executable n
}
unit :: UnitType -> String -> Dependency
unit t n = Dependency
{ depRequired = True
, depName = n
, depType = Systemd t
, depData = Systemd t n
}
path :: Bool -> Bool -> String -> Dependency
path r w n = Dependency
{ depRequired = True
, depData = AccessiblePath n r w
}
pathR :: String -> Dependency
pathR = path True False
pathW :: String -> Dependency
pathW = path False True
pathRW :: String -> Dependency
pathRW = path True True
systemUnit :: String -> Dependency
systemUnit = unit SystemUnit
userUnit :: String -> Dependency
userUnit = unit UserUnit
data MaybeExe a = Installed a [Dependency] | Missing [Dependency] | Ignore
-- 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 (Eq, Show)
instance Functor MaybeExe where
fmap f (Installed x ds) = Installed (f x) ds
fmap _ (Missing x) = Missing x
fmap _ (Missing req opt) = Missing req opt
fmap _ Ignore = Ignore
type MaybeX = MaybeExe (X ())
warnMissing :: Dependency -> IO ()
warnMissing Dependency {depRequired = r, depName = n, depType = t } =
putStrLn $ "WARNING: " ++ r' ++ " " ++ fmtType t ++ " not found: " ++ n
where
fmtType Executable = "executable"
-- fmtType (AccessiblePath _ _ _) = undefined
fmtType (Systemd UserUnit) = "systemd user unit"
fmtType (Systemd SystemUnit) = "systemd system unit"
r' = if r then "required" else "optional"
exeInstalled :: String -> IO Bool
exeInstalled x = isJust <$> findExecutable x
unitInstalled :: String -> UnitType -> IO Bool
unitInstalled x u = do
unitInstalled :: UnitType -> String -> IO Bool
unitInstalled u x = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> True
@ -112,38 +127,56 @@ unitInstalled x u = do
cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
-- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
-- pathAccessible p testread testwrite = do
-- res <- getPermissionsSafe p
-- let msg = permMsg res
pathAccessible :: FilePath -> Bool -> Bool -> IO Bool
pathAccessible p testread testwrite = do
res <- getPermissionsSafe p
let msg = permMsg res
return msg
-- return $ fmap (\m -> m ++ ": " ++ p) msg
-- where
-- testPerm False _ _ = Nothing
-- testPerm True f r = Just $ f r
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
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
depInstalled :: Dependency -> IO Bool
depInstalled Dependency { depName = n, depType = t } =
case t of
Executable -> exeInstalled n
-- TODO somehow get this to preserve error messages if something isn't found
depInstalled :: DependencyData -> IO Bool
depInstalled (Executable n) = exeInstalled n
depInstalled (Systemd t n) = unitInstalled t n
depInstalled (AccessiblePath p r w) = pathAccessible p r w
-- (AccessiblePath p r w) -> pathAccessible p r w
Systemd u -> unitInstalled n u
checkInstalled :: [Dependency] -> IO ([DependencyData], [DependencyData])
checkInstalled = fmap go . filterMissing
where
go = join (***) (fmap depData) . partition depRequired
createInstalled :: [DependencyData] -> [DependencyData] -> a -> MaybeExe a
createInstalled req opt x = if null req then Installed x opt else Missing req opt
filterMissing :: [Dependency] -> IO [Dependency]
filterMissing = filterM (fmap not . depInstalled)
filterMissing = filterM (fmap not . depInstalled . depData)
runIfInstalled :: MonadIO m => [Dependency] -> m () -> IO (MaybeExe (m ()))
runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a))
runIfInstalled ds x = do
missing <- filterMissing ds
return $ if not $ any depRequired missing
then Installed x $ filter (not . depRequired) missing
else Missing missing
(req, opt) <- checkInstalled ds
return $ createInstalled req opt x
spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ()))
spawnIfInstalled n = runIfInstalled [exe n] $ spawn n
@ -172,6 +205,42 @@ spawnSound file pre post = runIfInstalled [exe "paplay"]
playSound :: MonadIO m => FilePath -> m ()
playSound file = do
path <- (</> soundDir </> file) <$> getXMonadDir
p <- (</> soundDir </> file) <$> getXMonadDir
-- paplay seems to have less latency than aplay
spawnCmd "paplay" [path]
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 = ([], [])
fmtMissing :: DependencyData -> String
-- TODO this error message is lame
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)
warnMissing :: [MaybeExe a] -> IO ()
warnMissing = mapM_ putStrLn . uncurry fmtMsgs . partitionMissing
-- fmtType (AccessiblePath _ _ _) = undefined
-- splitDeps :: [MaybeExe a] -> ([a], [String])
-- splitDeps xs = undefined
-- splitDeps' :: [m (MaybeExe a)] -> ([m a], [String])
-- splitDeps' xs = undefined

View File

@ -17,9 +17,10 @@ module XMonad.Internal.IO
, writePercentMax
, decPercent
, incPercent
, isReadable
, isWritable
-- , isReadable
-- , isWritable
, PermResult(..)
, getPermissionsSafe
) where
import Data.Char
@ -99,10 +100,10 @@ decPercent = shiftPercent subtract -- silly (-) operator thingy error
data PermResult a = PermResult a | NotFoundError | PermError
deriving (Show, Eq)
instance Functor PermResult where
fmap f (PermResult r) = PermResult $ f r
fmap _ NotFoundError = NotFoundError
fmap _ PermError = PermError
-- instance Functor PermResult where
-- fmap f (PermResult r) = PermResult $ f r
-- fmap _ NotFoundError = NotFoundError
-- fmap _ PermError = PermError
getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
getPermissionsSafe f = do
@ -115,8 +116,8 @@ getPermissionsSafe f = do
-- so the catchall case should never happen
_ -> error "Unknown permission error"
isReadable :: FilePath -> IO (PermResult Bool)
isReadable = fmap (fmap readable) . getPermissionsSafe
-- isReadable :: FilePath -> IO (PermResult Bool)
-- isReadable = fmap (fmap readable) . getPermissionsSafe
isWritable :: FilePath -> IO (PermResult Bool)
isWritable = fmap (fmap writable) . getPermissionsSafe
-- isWritable :: FilePath -> IO (PermResult Bool)
-- isWritable = fmap (fmap writable) . getPermissionsSafe