diff --git a/src/QBar/Qubes/AdminAPI.hs b/src/QBar/Qubes/AdminAPI.hs index 5ede69c1d648575b5be713ed7354ea233d11132f..ed54d3b66f9913137f00e191b4ef3b3aad2395af 100644 --- a/src/QBar/Qubes/AdminAPI.hs +++ b/src/QBar/Qubes/AdminAPI.hs @@ -7,8 +7,10 @@ import Data.Binary.Put import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Maybe (fromMaybe) import Network.HostName import Pipes +import qualified Pipes.Prelude as P import qualified Pipes.Safe as P import System.IO (Handle, hSetBinaryMode) import System.Process.Typed @@ -113,8 +115,74 @@ qubesAdminEvents serviceName = qubesAdminCallP serviceName >-> onlyEvents Exception {} -> fail $ "service has returned an exception: " ++ show reply Event {} -> yield reply -qubesVMStats :: Producer QubesAdminReturn (P.SafeT IO) () -qubesVMStats = qubesAdminEvents "admin.vm.Stats" +qubesVMStatsRaw :: Producer QubesAdminReturn (P.SafeT IO) () +qubesVMStatsRaw = qubesAdminEvents "admin.vm.Stats" + +data QubesVMStats = QubesVMStats { statsVMName :: BL.ByteString, memoryKB :: Int, cpuTime :: Int, cpuUsageRaw :: Int, cpuUsage :: Int } + deriving (Eq, Ord, Show, Read) + +qubesVMStats :: Producer QubesVMStats (P.SafeT IO) () +qubesVMStats = qubesVMStatsRaw >-> P.mapFoldable parse where + parse :: QubesAdminReturn -> Maybe QubesVMStats + parse Event {evSubject, evEvent, evProperties} + | evEvent == "connection-established" = Nothing + | evEvent == "vm-stats" = Just $ addProperties evProperties $ QubesVMStats evSubject absent absent absent absent + | otherwise = Nothing -- shouldn't happen -> report error? + parse _ = Nothing -- shouldn't happen -> report error? + + absent = (-1) + readBL = read . BLC.unpack + + addProperties :: [(BL.ByteString, BL.ByteString)] -> QubesVMStats -> QubesVMStats + addProperties (("memory_kb", x) : xs) st = addProperties xs $ st { memoryKB = readBL x } + addProperties (("cpu_time", x) : xs) st = addProperties xs $ st { cpuTime = readBL x } + addProperties (("cpu_usage_raw", x) : xs) st = addProperties xs $ st { cpuUsageRaw = readBL x } + addProperties (("cpu_usage", x) : xs) st = addProperties xs $ st { cpuUsage = readBL x } + addProperties (_ : xs) st = addProperties xs st + addProperties [] st = st + +data QubesEvent + = OtherEvent QubesAdminReturn + | DomainPreStart { domainName :: BL.ByteString, startGuid :: Maybe Bool } + | DomainStart { domainName :: BL.ByteString, startGuid :: Maybe Bool } + | DomainUnpaused { domainName :: BL.ByteString } + | DomainStopped { domainName :: BL.ByteString } + | DomainShutdown { domainName :: BL.ByteString } + | DomainUpdatesAvailable { domainName :: BL.ByteString, updatesAvailable :: Bool, updatesAvailableOld :: Bool } + | DomainStartFailed { domainName :: BL.ByteString, reason :: BL.ByteString } + deriving (Eq, Ord, Show, Read) + +qubesEventsRaw :: Producer QubesAdminReturn (P.SafeT IO) () +qubesEventsRaw = qubesAdminEvents "admin.Events" + +qubesEvents :: Producer QubesEvent (P.SafeT IO) () +qubesEvents = qubesEventsRaw >-> P.mapFoldable parse where + parse :: QubesAdminReturn -> Maybe QubesEvent + parse Event {evEvent="connection-established"} = Nothing + parse ev@(Event {evSubject, evEvent, evProperties}) = + Just $ case evEvent of + "domain-pre-start" -> DomainPreStart evSubject (boolProp "start_guid") + "domain-start" -> DomainStart evSubject (boolProp "start_guid") + "domain-unpaused" -> DomainUnpaused evSubject + "domain-stopped" -> DomainStopped evSubject + "domain-shutdown" -> DomainShutdown evSubject + "domain-feature-set:updates-available" -> + DomainUpdatesAvailable evSubject (boolPropViaInt "value") (boolPropViaInt "oldvalue") + "domain-start-failed" -> + DomainStartFailed evSubject (fromMaybe "" $ getProp "reason") + _ -> OtherEvent ev + where + getProp :: BL.ByteString -> Maybe BL.ByteString + getProp name = lookup name evProperties + readProp :: Read a => BL.ByteString -> Maybe a + readProp name = read . BLC.unpack <$> getProp name + intProp :: BL.ByteString -> Maybe Int + intProp = readProp + boolProp :: BL.ByteString -> Maybe Bool + boolProp = readProp + boolPropViaInt :: BL.ByteString -> Bool + boolPropViaInt = fromMaybe False . fmap (/=0) . intProp + parse _ = Nothing -- shouldn't happen -> report error? printEvents :: Show a => Producer a (P.SafeT IO) () -> IO () printEvents prod = P.runSafeT $ runEffect $ prod >-> (forever $ await >>= liftIO . print)