WIP use intelligent logging messages
This commit is contained in:
parent
e8b7c4afc5
commit
fcac56b496
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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]
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue