WIP use intelligent logging messages

This commit is contained in:
Nathan Dwarshuis 2022-07-07 01:05:17 -04:00
parent e8b7c4afc5
commit fcac56b496
6 changed files with 132 additions and 80 deletions

View File

@ -178,6 +178,7 @@ rightPlugins DBusState { dbSesClient = ses, dbSysClient = sys }
type BarFeature = Sometimes CmdSpec type BarFeature = Sometimes CmdSpec
-- TODO what if I don't have a wireless card?
getWireless :: BarFeature getWireless :: BarFeature
getWireless = sometimes1 "wireless status indicator" "sysfs path" getWireless = sometimes1 "wireless status indicator" "sysfs path"
$ IORoot wirelessCmd $ IORoot wirelessCmd
@ -194,7 +195,7 @@ getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" root tree getBattery = iconIO_ "battery level indicator" root tree
where where
root useIcon = IORoot_ (batteryCmd useIcon) root useIcon = IORoot_ (batteryCmd useIcon)
tree = Only_ $ IOTest_ "Test if battery is present" hasBattery tree = Only_ $ IOTest_ "Test if battery is present" $ fmap (Msg Error) <$> hasBattery
getVPN :: Maybe Client -> BarFeature getVPN :: Maybe Client -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd_ vpnDep test getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd_ vpnDep test
@ -413,20 +414,22 @@ readInterface n f = IORead n go
go = io $ do go = io $ do
ns <- filter f <$> listInterfaces ns <- filter f <$> listInterfaces
case ns of case ns of
[] -> return $ Left ["no interfaces found"] [] -> return $ Left [Msg Error "no interfaces found"]
(x:xs) -> do (x:xs) -> do
return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs return $ Right $ PostPass x
$ fmap (Msg Warn . ("ignoring extra interface: " ++)) xs
vpnPresent :: IO (Maybe String) vpnPresent :: IO (Maybe Msg)
vpnPresent = vpnPresent =
go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "") go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
where where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing
else Just "vpn not found" else Just $ Msg Error "vpn not found"
go (Right (ExitFailure c, _, err)) = Just $ "vpn search exited with code " go (Right (ExitFailure c, _, err)) = Just $ Msg Error
$ "vpn search exited with code "
++ show c ++ ": " ++ err ++ show c ++ ": " ++ err
go (Left e) = Just $ show e go (Left e) = Just $ Msg Error $ show e
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | text font -- | text font

View File

@ -74,6 +74,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported Commands -- | Exported Commands
-- TODO test that veracrypt and friends are installed
runDevMenu :: SometimesX runDevMenu :: SometimesX
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
where where
@ -85,11 +86,12 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
++ "--" : themeArgs "#999933" ++ "--" : themeArgs "#999933"
++ myDmenuMatchingArgs ++ myDmenuMatchingArgs
-- TODO test that bluetooth interface exists
runBTMenu :: SometimesX runBTMenu :: SometimesX
runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
myDmenuBluetooth $ "-c":themeArgs "#0044bb" myDmenuBluetooth $ "-c":themeArgs "#0044bb"
-- TODO test that expressVPN is actually running (/var/lib/expressvpn/expressvpnd.socket)
runVPNMenu :: SometimesX runVPNMenu :: SometimesX
runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN" runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN"
(Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
@ -104,7 +106,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runWinMenu :: SometimesX runWinMenu :: SometimesX
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
-- TODO test that networkManager is actually running -- TODO test that networkManager is actually running (systemd service)
runNetMenu :: SometimesX runNetMenu :: SometimesX
runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager" runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager"
True myDmenuNetworks $ themeArgs "#ff3333" True myDmenuNetworks $ themeArgs "#ff3333"
@ -125,11 +127,11 @@ runBwMenu = sometimesIO_ "password manager" "rofi bitwarden"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Clipboard -- | Clipboard
-- TODO test that greenclip daemon is actually running (get process id?)
runClipMenu :: SometimesX runClipMenu :: SometimesX
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
where where
act = spawnCmd myDmenuCmd args act = spawnCmd myDmenuCmd args
-- TODO test that greenclip daemon is actually running
tree = toAnd_ (sysExe myDmenuCmd) $ sysExe myClipboardManager tree = toAnd_ (sysExe myDmenuCmd) $ sysExe myClipboardManager
args = [ "-modi", "\"clipboard:greenclip print\"" args = [ "-modi", "\"clipboard:greenclip print\""
, "-show", "clipboard" , "-show", "clipboard"

View File

@ -90,6 +90,7 @@ myNotificationCtrl = "dunstctl"
volumeChangeSound :: FilePath volumeChangeSound :: FilePath
volumeChangeSound = "smb_fireball.wav" volumeChangeSound = "smb_fireball.wav"
-- TODO make this dynamic (like in xmobar)
ethernetIface :: String ethernetIface :: String
ethernetIface = "enp7s0f1" ethernetIface = "enp7s0f1"
@ -99,6 +100,7 @@ ethernetIface = "enp7s0f1"
runTerm :: SometimesX runTerm :: SometimesX
runTerm = sometimesExe "terminal" "urxvt" True myTerm runTerm = sometimesExe "terminal" "urxvt" True myTerm
-- TODO test that tmux is actually running (/tmp/tmux-<UID>/default)
runTMux :: SometimesX runTMux :: SometimesX
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
where where
@ -119,6 +121,7 @@ runCalc = sometimesIO_ "calculator" "R" deps act
runBrowser :: SometimesX runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" "brave" False myBrowser runBrowser = sometimesExe "web browser" "brave" False myBrowser
-- TODO test that emacs is actually running (/run/user/1000/emacs/server)
runEditor :: SometimesX runEditor :: SometimesX
runEditor = sometimesExeArgs "text editor" "emacs" True myEditor runEditor = sometimesExeArgs "text editor" "emacs" True myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
@ -175,7 +178,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Notification control -- | Notification control
-- TODO test that dunst is actually running -- TODO test that dunst is actually running (org.freedesktop.Notifications/org.dunstproject.cmd0)
runNotificationCmd :: String -> FilePath -> SometimesX runNotificationCmd :: String -> FilePath -> SometimesX
runNotificationCmd n arg = sometimesIO_ (n ++ " control") "dunstctl" tree cmd runNotificationCmd n arg = sometimesIO_ (n ++ " control") "dunstctl" tree cmd
where where
@ -201,12 +204,14 @@ runNotificationContext =
-- | System commands -- | System commands
-- this is required for some vpn's to work properly with network-manager -- this is required for some vpn's to work properly with network-manager
-- TODO test that network manager is up
runNetAppDaemon :: Sometimes (IO ProcessHandle) runNetAppDaemon :: Sometimes (IO ProcessHandle)
runNetAppDaemon = sometimesIO_ "network applet" "NM-applet" tree cmd runNetAppDaemon = sometimesIO_ "network applet" "NM-applet" tree cmd
where where
tree = Only_ $ localExe "nm-applet" tree = Only_ $ localExe "nm-applet"
cmd = snd <$> spawnPipe "nm-applet" cmd = snd <$> spawnPipe "nm-applet"
-- TODO test that bluetooth dbus interface is up
runToggleBluetooth :: SometimesX runToggleBluetooth :: SometimesX
runToggleBluetooth = runToggleBluetooth =
sometimesIO_ "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth) sometimesIO_ "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
@ -280,7 +285,7 @@ getCaptureDir = do
where where
fallback = (</> ".local/share") <$> getHomeDirectory fallback = (</> ".local/share") <$> getHomeDirectory
-- TODO test that flameshot is actually running -- TODO test that flameshot is actually running (Bus org.flameshot.Flameshot)
runFlameshot :: String -> String -> SometimesX runFlameshot :: String -> String -> SometimesX
runFlameshot n mode = sometimesIO_ n myCapture runFlameshot n mode = sometimesIO_ n myCapture
(Only_ $ sysExe myCapture) $ spawnCmd myCapture [mode] (Only_ $ sysExe myCapture) $ spawnCmd myCapture [mode]

View File

@ -135,6 +135,7 @@ runOptimusPrompt' fb = do
#!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"] #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad" #!&& "killall xmonad"
-- TODO test that the socket is open (/tmp/optimus-manager)
runOptimusPrompt :: SometimesX runOptimusPrompt :: SometimesX
runOptimusPrompt = Sometimes "graphics switcher" [s] runOptimusPrompt = Sometimes "graphics switcher" [s]
where where

View File

@ -12,17 +12,18 @@ import Text.XML.Light
import System.Directory import System.Directory
import XMonad.Internal.Dependency
import XMonad.Internal.Shell import XMonad.Internal.Shell
vmExists :: String -> IO (Maybe String) vmExists :: String -> IO (Maybe Msg)
vmExists vm = do vmExists vm = do
d <- vmDirectory d <- vmDirectory
either (return . Just) findVMDir d either (return . Just . Msg Error) findVMDir d
where where
findVMDir vd = do findVMDir vd = do
vs <- listDirectory vd vs <- listDirectory vd
return $ if vm `elem` vs then Nothing return $ if vm `elem` vs then Nothing
else Just $ "could not find " ++ singleQuote vm else Just $ Msg Error $ "could not find " ++ singleQuote vm
vmDirectory :: IO (Either String String) vmDirectory :: IO (Either String String)
vmDirectory = do vmDirectory = do

View File

@ -25,6 +25,7 @@ module XMonad.Internal.Dependency
, Subfeature(..) , Subfeature(..)
, SubfeatureRoot , SubfeatureRoot
, LogLevel(..) , LogLevel(..)
, Msg(..)
-- dependency tree types -- dependency tree types
, Root(..) , Root(..)
@ -153,17 +154,22 @@ evalFeature (Left s) = evalSometimes s
evalSometimes :: Sometimes a -> FIO (Maybe a) evalSometimes :: Sometimes a -> FIO (Maybe a)
evalSometimes x = either goFail goPass =<< evalSometimesMsg x evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where where
goPass (PostPass a ws) = putErrors ws >> return (Just a) goPass (a, ws) = putErrors ws >> return (Just a)
goFail es = putErrors es >> return Nothing goFail es = putErrors es >> return Nothing
putErrors = io . mapM_ putStrLn putErrors = io . mapM_ printMsg
-- | Return the action of an Always -- | Return the action of an Always
evalAlways :: Always a -> FIO a evalAlways :: Always a -> FIO a
evalAlways a = do evalAlways a = do
(PostPass x ws) <- evalAlwaysMsg a (x, ws) <- evalAlwaysMsg a
io $ mapM_ putStrLn ws io $ mapM_ printMsg ws
return x return x
printMsg :: FMsg -> IO ()
printMsg (FMsg fn n (Msg ll m)) = do
p <- getProgName
putStrLn $ unwords [bracket p, bracket $ show ll, bracket fn, bracket n, m]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature status -- | Feature status
@ -306,7 +312,7 @@ instance Hashable DBusDependency_ where
-- | A dependency that only requires IO to evaluate (no payload) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ = IOSystem_ SystemDependency data IODependency_ = IOSystem_ SystemDependency
| IOTest_ String (IO (Maybe String)) | IOTest_ String (IO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a) | forall a. IOSometimes_ (Sometimes a)
instance Eq IODependency_ where instance Eq IODependency_ where
@ -352,6 +358,12 @@ instance Hashable DBusMember where
-- The main reason I need this is so I have a "result" I can convert to JSON -- The main reason I need this is so I have a "result" I can convert to JSON
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO) -- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
-- | A message with criteria for when to show it
data Msg = Msg LogLevel String
-- | A message annotated with subfeature and feature name
data FMsg = FMsg String String Msg
-- | Tested Always feature -- | Tested Always feature
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a) data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
| Fallback a [SubfeatureFail] | Fallback a [SubfeatureFail]
@ -369,13 +381,13 @@ type SubfeaturePass a = Subfeature (PostPass a)
type SubfeatureFail = Subfeature PostFail type SubfeatureFail = Subfeature PostFail
-- | An action that passed -- | An action that passed
data PostPass a = PostPass a [String] deriving (Functor) data PostPass a = PostPass a [Msg] deriving (Functor)
addMsgs :: PostPass a -> [String] -> PostPass a addMsgs :: PostPass a -> [Msg] -> PostPass a
addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms' addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
-- | An action that failed -- | An action that failed
data PostFail = PostFail [String] | PostMissing String data PostFail = PostFail [Msg] | PostMissing Msg
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Evaluation cache -- | Evaluation cache
@ -438,19 +450,33 @@ memoizeFont f d = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Testing pipeline -- | Testing pipeline
evalSometimesMsg :: Sometimes a -> FIO (Result a) evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n xs) = do evalSometimesMsg (Sometimes n xs) = do
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
case s of let fs' = failedMsgs n fs
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgsIO False n fs return $ case s of
_ -> Left <$> failedMsgsIO True n fs (Just p) -> Right $ second (++ fs') $ passActMsg n p
_ -> Left fs'
evalAlwaysMsg :: Always a -> FIO (PostPass a) evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
evalAlwaysMsg (Always n x) = do evalAlwaysMsg (Always n x) = do
r <- testAlways x r <- testAlways x
case r of return $ case r of
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgsIO False n fs (Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p
(Fallback act fs) -> PostPass act <$> failedMsgsIO False n fs (Fallback act fs) -> (act, failedMsgs n fs)
passActMsg :: String -> SubfeaturePass a -> (a, [FMsg])
passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn n) ws)
failedMsgs :: String -> [SubfeatureFail] -> [FMsg]
failedMsgs n = concatMap (failedMsg n)
failedMsg :: String -> SubfeatureFail -> [FMsg]
failedMsg fn Subfeature { sfData = d, sfName = n } = case d of
(PostFail es) -> f es
(PostMissing e) -> f [e]
where
f = fmap (FMsg fn n)
testAlways :: Always_ a -> FIO (PostAlways a) testAlways :: Always_ a -> FIO (PostAlways a)
testAlways = go [] testAlways = go []
@ -496,7 +522,8 @@ testRoot r = do
(IORoot_ a t) -> go_ a testIODependency_ t (IORoot_ a t) -> go_ a testIODependency_ t
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDependency_ cl) testIODependency t (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDependency_ cl) testIODependency t
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t
_ -> return $ Left $ PostMissing "client not available" _ -> return $ Left $ PostMissing
$ Msg Error "client not available"
where where
-- rank N polymorphism is apparently undecidable...gross -- rank N polymorphism is apparently undecidable...gross
go a f_ (f :: forall q. d q -> FIO (Result q)) t = go a f_ (f :: forall q. d q -> FIO (Result q)) t =
@ -506,13 +533,13 @@ testRoot r = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Payloaded dependency testing -- | Payloaded dependency testing
type Result p = Either [String] (PostPass p) type Result p = Either [Msg] (PostPass p)
testTree :: forall d d_ p. (d_ -> FIO Result_) -> (forall q. d q -> FIO (Result q)) testTree :: forall d d_ p. (d_ -> FIO Result_) -> (forall q. d q -> FIO (Result q))
-> Tree d d_ p -> FIO (Either [String] (PostPass p)) -> Tree d d_ p -> FIO (Either [Msg] (PostPass p))
testTree test_ test = go testTree test_ test = go
where where
go :: forall q. Tree d d_ q -> FIO (Either [String] (PostPass q)) go :: forall q. Tree d d_ q -> FIO (Either [Msg] (PostPass q))
go (And12 f a b) = do go (And12 f a b) = do
ra <- go a ra <- go a
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@ -536,15 +563,22 @@ testIODependency (IOConst c) = return $ Right $ PostPass c []
-- succeed, which kinda makes this pointless. The only reason I would want this -- succeed, which kinda makes this pointless. The only reason I would want this
-- is if I want to have a built-in logic to "choose" a payload to use in -- is if I want to have a built-in logic to "choose" a payload to use in
-- building a higher-level feature -- building a higher-level feature
testIODependency (IOAlways a f) = Right . fmap f <$> evalAlwaysMsg a testIODependency (IOAlways a f) = Right . uncurry PostPass
testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x -- TODO this is wetter than Taco Bell shit
. bimap f (fmap stripMsg) <$> evalAlwaysMsg a
testIODependency (IOSometimes x f) =
bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
<$> evalSometimesMsg x
stripMsg :: FMsg -> Msg
stripMsg (FMsg _ _ m) = m
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Standalone dependency testing -- | Standalone dependency testing
type Result_ = Either [String] [String] type Result_ = Either [Msg] [Msg]
testTree_ :: (d -> FIO Result_) -> Tree_ d -> FIO (Either [String] [String]) testTree_ :: (d -> FIO Result_) -> Tree_ d -> FIO Result_
testTree_ test = go testTree_ test = go
where where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@ -558,16 +592,17 @@ testIODependency_ = memoizeIO_ testIODependency'_
testIODependency'_ :: IODependency_ -> FIO Result_ testIODependency'_ :: IODependency_ -> FIO Result_
testIODependency'_ (IOSystem_ s) = io $ readResult_ <$> testSysDependency s testIODependency'_ (IOSystem_ s) = io $ readResult_ <$> testSysDependency s
testIODependency'_ (IOTest_ _ t) = io $ readResult_ <$> t testIODependency'_ (IOTest_ _ t) = io $ readResult_ <$> t
testIODependency'_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x testIODependency'_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
<$> evalSometimesMsg x
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | System Dependency Testing -- | System Dependency Testing
testSysDependency :: SystemDependency -> IO (Maybe String) testSysDependency :: SystemDependency -> IO (Maybe Msg)
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing) testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
<$> findExecutable bin <$> findExecutable bin
where where
msg = unwords [e, "executable", singleQuote bin, "not found"] msg = Msg Error $ unwords [e, "executable", singleQuote bin, "not found"]
e = if sys then "system" else "local" e = if sys then "system" else "local"
testSysDependency (Systemd t n) = shellTest cmd msg testSysDependency (Systemd t n) = shellTest cmd msg
where where
@ -577,21 +612,22 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
where where
testPerm False _ _ = Nothing testPerm False _ _ = Nothing
testPerm True f res = Just $ f res testPerm True f res = Just $ f res
permMsg NotFoundError = Just "file not found" mkErr = Just . Msg Error
permMsg PermError = Just "could not get permissions" permMsg NotFoundError = mkErr "file not found"
permMsg PermError = mkErr "could not get permissions"
permMsg (PermResult res) = permMsg (PermResult res) =
case (testPerm r readable res, testPerm w writable res) of case (testPerm r readable res, testPerm w writable res) of
(Just False, Just False) -> Just "file not readable or writable" (Just False, Just False) -> mkErr "file not readable or writable"
(Just False, _) -> Just "file not readable" (Just False, _) -> mkErr "file not readable"
(_, Just False) -> Just "file not writable" (_, Just False) -> mkErr "file not writable"
_ -> Nothing _ -> Nothing
shellTest :: String -> String -> IO (Maybe String) shellTest :: String -> String -> IO (Maybe Msg)
shellTest cmd msg = do shellTest cmd msg = do
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) "" (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of return $ case rc of
ExitSuccess -> Nothing ExitSuccess -> Nothing
_ -> Just msg _ -> Just $ Msg Error msg
unitType :: UnitType -> String unitType :: UnitType -> String
unitType SystemUnit = "system" unitType SystemUnit = "system"
@ -638,15 +674,12 @@ testFont :: String -> FIO (Result FontBuilder)
testFont = memoizeFont testFont' testFont = memoizeFont testFont'
testFont' :: String -> IO (Result FontBuilder) testFont' :: String -> IO (Result FontBuilder)
testFont' fam = do testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
return $ case rc of
ExitSuccess -> Right $ PostPass (buildFont $ Just fam) []
_ -> Left [msg]
where where
msg = unwords ["font family", qFam, "not found"] msg = unwords ["font family", qFam, "not found"]
cmd = fmtCmd "fc-list" ["-q", qFam] cmd = fmtCmd "fc-list" ["-q", qFam]
qFam = singleQuote fam qFam = singleQuote fam
pass = Right $ PostPass (buildFont $ Just fam) []
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus Dependency Testing -- | DBus Dependency Testing
@ -664,10 +697,12 @@ testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency'_ client (Bus bus) = io $ do testDBusDependency'_ client (Bus bus) = io $ do
ret <- callMethod client queryBus queryPath queryIface queryMem ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Left [e] Left e -> Left [Msg Error e]
Right b -> let ns = bodyGetNames b in Right b -> let ns = bodyGetNames b in
if bus' `elem` ns then Right [] if bus' `elem` ns then Right []
else Left [unwords ["name", singleQuote bus', "not found on dbus"]] else Left [
Msg Error $ unwords ["name", singleQuote bus', "not found on dbus"]
]
where where
bus' = formatBusName bus bus' = formatBusName bus
queryBus = busName_ "org.freedesktop.DBus" queryBus = busName_ "org.freedesktop.DBus"
@ -680,14 +715,14 @@ testDBusDependency'_ client (Bus bus) = io $ do
testDBusDependency'_ client (Endpoint busname objpath iface mem) = io $ do testDBusDependency'_ client (Endpoint busname objpath iface mem) = io $ do
ret <- callMethod client busname objpath introspectInterface introspectMethod ret <- callMethod client busname objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Left [e] Left e -> Left [Msg Error e]
Right body -> procBody body Right body -> procBody body
where where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
=<< listToMaybe body in =<< listToMaybe body in
case res of case res of
Just True -> Right [] Just True -> Right []
_ -> Left [fmtMsg' mem] _ -> Left [Msg Error $ fmtMsg' mem]
findMem = fmap (matchMem mem) findMem = fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface) . find (\i -> I.interfaceName i == iface)
. I.objectInterfaces . I.objectInterfaces
@ -794,12 +829,12 @@ voidResult :: Result p -> Result_
voidResult (Left es) = Left es voidResult (Left es) = Left es
voidResult (Right (PostPass _ ws)) = Right ws voidResult (Right (PostPass _ ws)) = Right ws
voidRead :: Result p -> Maybe String voidRead :: Result p -> Maybe Msg
voidRead (Left []) = Just "unspecified error" voidRead (Left []) = Just $ Msg Error "unspecified error"
voidRead (Left (e:_)) = Just e voidRead (Left (e:_)) = Just e
voidRead (Right _) = Nothing voidRead (Right _) = Nothing
readResult_ :: Maybe String -> Result_ readResult_ :: Maybe Msg -> Result_
readResult_ (Just w) = Left [w] readResult_ (Just w) = Left [w]
readResult_ _ = Right [] readResult_ _ = Right []
@ -976,11 +1011,16 @@ dataDBusDependency d =
memberData (Signal_ n) = ("signal", formatMemberName n) memberData (Signal_ n) = ("signal", formatMemberName n)
memberData (Property_ n) = ("property", n) memberData (Property_ n) = ("property", n)
fromResult :: Result a -> (Bool, [JSONQuotable]) fromMsg :: Msg -> JSONUnquotable
fromResult = second (fmap Q) . either (False,) (\(PostPass _ ws) -> (True, ws)) fromMsg (Msg e s) = jsonObject [ ("level", JSON_Q $ Q $ show e)
, ("msg", JSON_Q $ Q s)
]
fromResult_ :: Result_ -> (Bool, [JSONQuotable]) fromResult :: Result a -> (Bool, [JSONUnquotable])
fromResult_ = second (fmap Q) . either (False,) (True,) fromResult = second (fmap fromMsg) . either (False,) (\(PostPass _ ws) -> (True, ws))
fromResult_ :: Result_ -> (Bool, [JSONUnquotable])
fromResult_ = second (fmap fromMsg) . either (False,) (True,)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | JSON formatting -- | JSON formatting
@ -1032,7 +1072,7 @@ jsonRoot isIO tree = jsonObject
jsonLeafUntested :: JSONQuotable -> [(String, JSONMixed)] -> JSONUnquotable jsonLeafUntested :: JSONQuotable -> [(String, JSONMixed)] -> JSONUnquotable
jsonLeafUntested = jsonLeaf Nothing jsonLeafUntested = jsonLeaf Nothing
jsonLeaf :: Maybe (Bool, [JSONQuotable]) -> JSONQuotable -> [(String, JSONMixed)] jsonLeaf :: Maybe (Bool, [JSONUnquotable]) -> JSONQuotable -> [(String, JSONMixed)]
-> JSONUnquotable -> JSONUnquotable
jsonLeaf status deptype depdata = jsonObject jsonLeaf status deptype depdata = jsonObject
[ ("type", JSON_Q deptype) [ ("type", JSON_Q deptype)
@ -1040,10 +1080,10 @@ jsonLeaf status deptype depdata = jsonObject
, ("data", JSON_UQ $ jsonObject depdata) , ("data", JSON_UQ $ jsonObject depdata)
] ]
jsonStatus :: Bool -> [JSONQuotable] -> JSONUnquotable jsonStatus :: Bool -> [JSONUnquotable] -> JSONUnquotable
jsonStatus present messages = jsonObject jsonStatus present messages = jsonObject
[ ("present", JSON_UQ $ jsonBool present) [ ("present", JSON_UQ $ jsonBool present)
, ("messages", JSON_UQ $ jsonArray $ fmap JSON_Q messages) , ("messages", JSON_UQ $ jsonArray $ fmap JSON_UQ messages)
] ]
jsonAnd :: JSONUnquotable -> JSONUnquotable -> JSONUnquotable jsonAnd :: JSONUnquotable -> JSONUnquotable -> JSONUnquotable
@ -1086,19 +1126,19 @@ curly s = "{" ++ s ++ "}"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Other random formatting -- | Other random formatting
failedMsgsIO :: Bool -> String -> [SubfeatureFail] -> FIO [String] -- failedMsgsIO :: Bool -> String -> [SubfeatureFail] -> FIO [Msg]
failedMsgsIO err fn = io . failedMsgs err fn -- failedMsgsIO err fn = io . failedMsgs err fn
failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String] -- failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [Msg]
failedMsgs err fn = fmap concat . mapM (failedMsg err fn) -- failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
failedMsg :: Bool -> String -> SubfeatureFail -> IO [String] -- failedMsg :: Bool -> String -> SubfeatureFail -> IO [Msg]
failedMsg err fn Subfeature { sfData = d, sfName = n } = do -- failedMsg err fn Subfeature { sfData = d, sfName = n } = do
mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es -- mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
fmtMsg :: Bool -> String -> String -> String -> IO String -- fmtMsg :: Bool -> String -> String -> Msg -> IO Msg
fmtMsg err fn n msg = do -- fmtMsg err fn n msg = do
let e = if err then "ERROR" else "WARNING" -- let e = if err then "ERROR" else "WARNING"
p <- getProgName -- p <- getProgName
return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg] -- return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]