From 7e8cc295f631cb3a2863a0920d558942d854da35 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 26 Dec 2022 17:56:55 -0500 Subject: [PATCH] ENH use rio for logging deps stage --- bin/xmobar.hs | 10 +- bin/xmonad.hs | 14 +-- lib/Data/Internal/Dependency.hs | 107 +++++++++++-------- lib/XMonad/Internal/Concurrent/VirtualBox.hs | 3 +- 4 files changed, 76 insertions(+), 58 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 5d85010..3cd0e36 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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 diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 24ceb96..d84b8d6 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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]) diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index d785025..2e3f0a8 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -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 diff --git a/lib/XMonad/Internal/Concurrent/VirtualBox.hs b/lib/XMonad/Internal/Concurrent/VirtualBox.hs index 79b6a58..dddfb72 100644 --- a/lib/XMonad/Internal/Concurrent/VirtualBox.hs +++ b/lib/XMonad/Internal/Concurrent/VirtualBox.hs @@ -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