ENH use rio for logging deps stage

This commit is contained in:
Nathan Dwarshuis 2022-12-26 17:56:55 -05:00
parent ec42f34905
commit 7e8cc295f6
4 changed files with 76 additions and 58 deletions

View File

@ -20,10 +20,10 @@ import Data.Internal.Dependency
import Data.List
import Data.Maybe
import RIO hiding (hFlush)
import qualified RIO.Text as T
import System.Environment
import System.Exit
import System.IO
import System.IO.Error
@ -218,7 +218,7 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
where
root useIcon = IORoot_ (batteryCmd useIcon)
tree = Only_ $ IOTest_ "Test if battery is present" []
$ fmap (Msg Error) <$> hasBattery
$ fmap (Msg LevelError) <$> hasBattery
getVPN :: Maybe SysClient -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
@ -426,13 +426,13 @@ vpnPresent =
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` T.lines out then Nothing
else Just $ Msg Error "vpn not found"
go (Right (ExitFailure c, _, err)) = Just $ Msg Error
else Just $ Msg LevelError "vpn not found"
go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError
$ T.concat ["vpn search exited with code "
, T.pack $ show c
, ": "
, err]
go (Left e) = Just $ Msg Error $ T.pack $ show e
go (Left e) = Just $ Msg LevelError $ T.pack $ show e
--------------------------------------------------------------------------------
-- | text font

View File

@ -7,7 +7,6 @@
module Main (main) where
import Control.Concurrent
import Control.Monad
import Data.Internal.DBus
@ -166,7 +165,7 @@ evalConf db@DBusState { dbSysClient = cl } = do
, focusedBorderColor = T.unpack XT.selectedBordersColor
}
where
forkIO_ = void . forkIO
forkIO_ = void . async
startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
$ fsDBusExporters fs
startChildDaemons fs = do
@ -185,11 +184,12 @@ printDeps :: FIO ()
printDeps = do
db <- io connectDBus
(i, f, d) <- allFeatures db
let is = concatMap dumpSometimes i
let fs = concatMap dumpFeature f
let ds = concatMap dumpSometimes d
let ps = fmap showFulfillment $ sort $ nub $ is ++ fs ++ ds
io $ mapM_ (putStrLn . T.unpack) ps
io $ mapM_ (putStrLn . T.unpack)
$ fmap showFulfillment
$ sort
$ nub
$ concat
$ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
io $ disconnectDBus db
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])

View File

@ -25,7 +25,6 @@ module Data.Internal.Dependency
, Subfeature(..)
, SubfeatureRoot
, Msg(..)
, LogLevel(..)
-- configuration
, XParams(..)
@ -125,7 +124,7 @@ import GHC.IO.Exception (ioe_description)
import DBus hiding (typeOf)
import qualified DBus.Introspection as I
import RIO hiding (LogLevel, bracket, fromString)
import RIO hiding (bracket, fromString)
import RIO.FilePath
import qualified RIO.Text as T
@ -150,8 +149,11 @@ import XMonad.Internal.Theme
-- Currently there is no easy way to not use this (oh well)
withCache :: FIO a -> IO a
withCache x = do
p <- getParams
runRIO p x
logOpts <- logOptionsHandle stderr False
withLogFunc logOpts $ \f -> do
p <- getParams
let s = DepStage f p
runRIO s x
-- | Execute an Always immediately
executeAlways :: Always (IO a) -> FIO a
@ -172,29 +174,31 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where
goPass (a, ws) = putErrors ws >> return (Just a)
goFail es = putErrors es >> return Nothing
putErrors = mapM_ printMsg
putErrors = mapM_ logMsg
-- | Return the action of an Always
evalAlways :: Always a -> FIO a
evalAlways a = do
(x, ws) <- evalAlwaysMsg a
mapM_ printMsg ws
mapM_ logMsg ws
return x
-- TODO use real logging functions
printMsg :: FMsg -> FIO ()
printMsg (FMsg fn n (Msg ll m)) = do
xl <- asks xpLogLevel
logMsg :: FMsg -> FIO ()
logMsg (FMsg fn n (Msg ll m)) = do
p <- io getProgName
io $ when (ll <= xl) $
putStrLn $ T.unpack $ T.concat $ s (T.pack p)
f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
where
s p = [ bracket p
, bracket $ T.pack $ show ll
, bracket fn
]
++ maybe [] ((:[]) . bracket) n
++ [m]
llFun LevelError = ("ERROR", logError)
llFun LevelInfo = ("INFO", logInfo)
llFun LevelWarn = ("WARN", logWarn)
llFun _ = ("DEBUG", logDebug)
(s, f) = llFun ll
fmt p l = [ bracket p
, bracket l
, bracket fn
]
++ maybe [] ((:[]) . bracket) n
++ [m]
--------------------------------------------------------------------------------
-- | Package status
@ -265,11 +269,6 @@ data Subfeature f = Subfeature
, sfName :: T.Text
}
-- | Loglevel at which feature testing should be reported
-- This is currently not used for anything important
data LogLevel = Silent | Error | Warn | Debug | Info
deriving (Eq, Show, Ord, Generic)
type SubfeatureRoot a = Subfeature (Root a)
-- | An action and its dependencies
@ -383,19 +382,37 @@ data PostFail = PostFail [Msg] | PostMissing Msg
--------------------------------------------------------------------------------
-- | Configuration
type FIO a = RIO XParams a
type FIO a = RIO DepStage a
data DepStage = DepStage
{ dsLogFun :: !LogFunc
, dsParams :: !XParams
}
instance HasLogFunc DepStage where
logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y })
data XParams = XParams
{ xpLogLevel :: LogLevel
, xpFeatures :: XPFeatures
}
instance FromJSON XParams where
parseJSON = withObject "parameters" $ \o -> XParams
<$> o .: fromString "loglevel"
<*> o .: fromString "features"
data JLogLevel = Error | Warn | Debug | Info
deriving (Eq, Show, Ord, Generic)
instance FromJSON LogLevel
instance FromJSON JLogLevel
instance FromJSON XParams where
parseJSON = withObject "parameters" $ \o -> do
ll <- mapLevel <$> o .: fromString "loglevel"
fs <- o .: fromString "features"
return $ XParams ll fs
where
mapLevel Info = LevelInfo
mapLevel Error = LevelError
mapLevel Warn = LevelWarn
mapLevel Debug = LevelDebug
data XPFeatures = XPFeatures
{ xpfOptimus :: Bool
@ -427,7 +444,7 @@ instance FromJSON XPFeatures where
defParams :: XParams
defParams = XParams
{ xpLogLevel = Error
{ xpLogLevel = LevelError
, xpFeatures = defXPFeatures
}
@ -480,7 +497,7 @@ infix .:+
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do
r <- asks (u . xpFeatures)
r <- asks (u . xpFeatures . dsParams)
if not r then return $ Left [dis n] else do
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
let fs' = failedMsgs n fs
@ -488,7 +505,7 @@ evalSometimesMsg (Sometimes n u xs) = do
(Just p) -> Right $ second (++ fs') $ passActMsg n p
_ -> Left fs'
where
dis name = FMsg name Nothing (Msg Debug "feature disabled")
dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
evalAlwaysMsg (Always n x) = do
@ -555,7 +572,7 @@ testRoot r = do
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
_ -> return $ Left $ PostMissing
$ Msg Error "client not available"
$ Msg LevelError "client not available"
where
-- rank N polymorphism is apparently undecidable...gross
go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
@ -640,11 +657,11 @@ testSysDependency :: SystemDependency -> IO (Maybe Msg)
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
<$> findExecutable bin
where
msg = Msg Error $ T.concat [e, "executable", singleQuote $ T.pack bin, "not found"]
msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
e = if sys then "system" else "local"
testSysDependency (Systemd t n) = shellTest cmd msg
where
msg = T.concat ["systemd", unitType t, "unit", singleQuote n, "not found"]
msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
testSysDependency (Process n) = shellTest (fmtCmd "pidof" [n])
$ T.unwords ["Process", singleQuote n, "not found"]
@ -652,7 +669,7 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
where
testPerm False _ _ = Nothing
testPerm True f res = Just $ f res
mkErr = Just . Msg Error
mkErr = Just . Msg LevelError
permMsg NotFoundError = mkErr "file not found"
permMsg PermError = mkErr "could not get permissions"
permMsg (PermResult res) =
@ -667,7 +684,7 @@ shellTest cmd msg = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell $ T.unpack cmd) ""
return $ case rc of
ExitSuccess -> Nothing
_ -> Just $ Msg Error msg
_ -> Just $ Msg LevelError msg
unitType :: UnitType -> T.Text
unitType SystemUnit = "system"
@ -754,10 +771,10 @@ readInterface n f = IORead n [] go
go = io $ do
ns <- filter f <$> listInterfaces
case ns of
[] -> return $ Left [Msg Error "no interfaces found"]
[] -> return $ Left [Msg LevelError "no interfaces found"]
(x:xs) -> do
return $ Right $ PostPass x
$ fmap (Msg Warn . T.append "ignoring extra interface: ") xs
$ fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs
--------------------------------------------------------------------------------
-- | Misc testers
@ -774,7 +791,7 @@ socketExists' getPath = do
Left e -> toErr $ T.pack $ ioe_description e
Right s -> if isSocket s then Nothing else toErr $ T.append (T.pack p) " is not a socket"
where
toErr = Just . Msg Error
toErr = Just . Msg LevelError
--------------------------------------------------------------------------------
-- | DBus Dependency Testing
@ -792,11 +809,11 @@ testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Left [Msg Error e]
Left e -> Left [Msg LevelError e]
Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Right []
else Left [
Msg Error $ T.unwords ["name", singleQuote bus', "not found on dbus"]
Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
]
where
bus' = T.pack $ formatBusName bus
@ -810,14 +827,14 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod cl busname objpath introspectInterface introspectMethod
return $ case ret of
Left e -> Left [Msg Error e]
Left e -> Left [Msg LevelError e]
Right body -> procBody body
where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in
case res of
Just True -> Right []
_ -> Left [Msg Error $ fmtMsg' mem]
_ -> Left [Msg LevelError $ fmtMsg' mem]
findMem = fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface)
. I.objectInterfaces
@ -927,7 +944,7 @@ voidResult (Left es) = Left es
voidResult (Right (PostPass _ ws)) = Right ws
voidRead :: Result p -> Maybe Msg
voidRead (Left []) = Just $ Msg Error "unspecified error"
voidRead (Left []) = Just $ Msg LevelError "unspecified error"
voidRead (Left (e:_)) = Just e
voidRead (Right _) = Nothing

View File

@ -16,6 +16,7 @@ import Data.Internal.Dependency
import Text.XML.Light
import RIO hiding (try)
import RIO.FilePath
import qualified RIO.Text as T
@ -24,7 +25,7 @@ import System.Directory
import XMonad.Internal.Shell
vmExists :: T.Text -> IO (Maybe Msg)
vmExists vm = either (Just . Msg Error) (const Nothing) <$> vmInstanceConfig vm
vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm
vmInstanceConfig :: T.Text -> IO (Either T.Text FilePath)
vmInstanceConfig vmName = do