ENH use rio for logging deps stage
This commit is contained in:
parent
ec42f34905
commit
7e8cc295f6
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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
|
||||
logOpts <- logOptionsHandle stderr False
|
||||
withLogFunc logOpts $ \f -> do
|
||||
p <- getParams
|
||||
runRIO p x
|
||||
let s = DepStage f p
|
||||
runRIO s x
|
||||
|
||||
-- | Execute an Always immediately
|
||||
executeAlways :: Always (IO a) -> FIO a
|
||||
|
|
@ -172,25 +174,27 @@ 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
|
||||
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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue