Systemd.hs

{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Information.Systemd
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module provides information about systemd failed units using the
-- org.freedesktop.systemd1 DBus interface. It monitors both the system bus
-- (for system units) and the session bus (for user units).
-----------------------------------------------------------------------------
module System.Taffybar.Information.Systemd
  ( SystemdState(..)
  , SystemdInfo(..)
  , getSystemdInfo
  , getSystemdInfoFromClients
  , getSystemdInfoChan
  , getSystemdInfoState
  , systemdUnknownInfo
  ) where

import           Control.Concurrent
import           Control.Concurrent.STM.TChan
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.STM (atomically)
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Reader
import           DBus
import           DBus.Client
import qualified DBus.TH as DBus
import           Data.Maybe (fromMaybe)
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Word (Word32)
import           System.Log.Logger
import           System.Taffybar.Context

-- | The state of a systemd instance (system or user).
data SystemdState
  = SystemdRunning        -- ^ All units are running properly
  | SystemdDegraded       -- ^ Some units have failed
  | SystemdStarting       -- ^ System is starting up
  | SystemdStopping       -- ^ System is shutting down
  | SystemdMaintenance    -- ^ System is in maintenance mode
  | SystemdInitializing   -- ^ System is initializing
  | SystemdOther Text     -- ^ Unknown state
  | SystemdUnavailable    -- ^ systemd is not available on this bus
  deriving (Eq, Show)

-- | Information about systemd failed units.
data SystemdInfo = SystemdInfo
  { systemState :: SystemdState        -- ^ State of system systemd
  , userState :: SystemdState          -- ^ State of user systemd
  , systemFailedCount :: Int           -- ^ Number of failed system units
  , userFailedCount :: Int             -- ^ Number of failed user units
  , totalFailedCount :: Int            -- ^ Total failed units (system + user)
  } deriving (Eq, Show)

-- | Default info when systemd is unknown/unavailable.
systemdUnknownInfo :: SystemdInfo
systemdUnknownInfo = SystemdInfo
  { systemState = SystemdUnavailable
  , userState = SystemdUnavailable
  , systemFailedCount = 0
  , userFailedCount = 0
  , totalFailedCount = 0
  }

systemdLogPath :: String
systemdLogPath = "System.Taffybar.Information.Systemd"

-- | DBus constants for systemd.
systemdBusName :: BusName
systemdBusName = "org.freedesktop.systemd1"

systemdObjectPath :: ObjectPath
systemdObjectPath = "/org/freedesktop/systemd1"

systemdManagerInterface :: InterfaceName
systemdManagerInterface = "org.freedesktop.systemd1.Manager"

-- | Parse a SystemdState from a DBus string.
parseSystemdState :: Text -> SystemdState
parseSystemdState txt =
  case T.toLower txt of
    "running"      -> SystemdRunning
    "degraded"     -> SystemdDegraded
    "starting"     -> SystemdStarting
    "stopping"     -> SystemdStopping
    "maintenance"  -> SystemdMaintenance
    "initializing" -> SystemdInitializing
    _              -> SystemdOther txt

-- | Newtype wrapper for the channel/var pair stored in Context.
newtype SystemdInfoChanVar = SystemdInfoChanVar (TChan SystemdInfo, MVar SystemdInfo)

-- | Get the current systemd info state.
getSystemdInfoState :: TaffyIO SystemdInfo
getSystemdInfoState = do
  SystemdInfoChanVar (_, theVar) <- getSystemdInfoChanVar
  lift $ readMVar theVar

-- | Get the broadcast channel for systemd info updates.
getSystemdInfoChan :: TaffyIO (TChan SystemdInfo)
getSystemdInfoChan = do
  SystemdInfoChanVar (chan, _) <- getSystemdInfoChanVar
  return chan

-- | Get or create the channel/var pair for systemd monitoring.
getSystemdInfoChanVar :: TaffyIO SystemdInfoChanVar
getSystemdInfoChanVar =
  getStateDefault $ SystemdInfoChanVar <$> monitorSystemdInfo

-- | The debounce delay in microseconds (1 second, like Waybar).
debounceDelayMicros :: Int
debounceDelayMicros = 1_000_000

-- | Start monitoring systemd on both system and session buses.
monitorSystemdInfo :: TaffyIO (TChan SystemdInfo, MVar SystemdInfo)
monitorSystemdInfo = do
  infoVar <- lift $ newMVar systemdUnknownInfo
  chan <- liftIO newBroadcastTChanIO
  debounceVar <- liftIO $ newMVar False

  taffyFork $ do
    ctx <- ask
    systemClient <- asks systemDBusClient
    sessionClient <- asks sessionDBusClient

    let doUpdate = updateSystemdInfo chan infoVar systemClient sessionClient
        debouncedUpdate = do
          pending <- liftIO $ swapMVar debounceVar True
          unless pending $ do
            liftIO $ threadDelay debounceDelayMicros
            liftIO $ void $ swapMVar debounceVar False
            doUpdate

        signalCallback _ _ _ _ = runReaderT debouncedUpdate ctx

    -- Register for PropertiesChanged on system bus
    _ <- lift $ DBus.registerForPropertiesChanged
      systemClient
      matchAny { matchInterface = Just systemdManagerInterface
               , matchPath = Just systemdObjectPath
               }
      signalCallback

    -- Register for PropertiesChanged on session bus
    _ <- lift $ DBus.registerForPropertiesChanged
      sessionClient
      matchAny { matchInterface = Just systemdManagerInterface
               , matchPath = Just systemdObjectPath
               }
      signalCallback

    -- Initial update
    doUpdate

  return (chan, infoVar)

-- | Update the systemd info by querying both buses.
updateSystemdInfo
  :: TChan SystemdInfo
  -> MVar SystemdInfo
  -> Client
  -> Client
  -> TaffyIO ()
updateSystemdInfo chan var systemClient sessionClient = do
  info <- liftIO $ getSystemdInfoFromClients systemClient sessionClient
  liftIO $ do
    _ <- swapMVar var info
    atomically $ writeTChan chan info

-- | Get systemd info using the clients from Context.
getSystemdInfo :: TaffyIO SystemdInfo
getSystemdInfo = do
  systemClient <- asks systemDBusClient
  sessionClient <- asks sessionDBusClient
  liftIO $ getSystemdInfoFromClients systemClient sessionClient

-- | Get systemd info from the provided DBus clients.
getSystemdInfoFromClients :: Client -> Client -> IO SystemdInfo
getSystemdInfoFromClients systemClient sessionClient = do
  (sysState, sysFailed) <- getSystemdStateAndFailed systemClient "system"
  (usrState, usrFailed) <- getSystemdStateAndFailed sessionClient "user"
  return SystemdInfo
    { systemState = sysState
    , userState = usrState
    , systemFailedCount = sysFailed
    , userFailedCount = usrFailed
    , totalFailedCount = sysFailed + usrFailed
    }

-- | Query a single systemd instance for its state and failed count.
getSystemdStateAndFailed :: Client -> String -> IO (SystemdState, Int)
getSystemdStateAndFailed client busType = do
  stateResult <- getSystemdProperty client "SystemState"
  case stateResult of
    Left err -> do
      logM systemdLogPath DEBUG $
        "Failed to get " ++ busType ++ " systemd state: " ++ show err
      return (SystemdUnavailable, 0)
    Right stateVariant -> do
      let state = maybe (SystemdOther "unknown")
                        parseSystemdState
                        (fromVariant stateVariant :: Maybe Text)
      -- Only query failed count if degraded
      if state == SystemdDegraded
        then do
          failedResult <- getSystemdProperty client "NFailedUnits"
          case failedResult of
            Left err -> do
              logM systemdLogPath WARNING $
                "Failed to get " ++ busType ++ " failed units count: " ++ show err
              return (state, 0)
            Right failedVariant -> do
              let failed = fromMaybe 0 (fromVariant failedVariant :: Maybe Word32)
              return (state, fromIntegral failed)
        else return (state, 0)

-- | Get a property from the systemd1.Manager interface.
getSystemdProperty :: Client -> MemberName -> IO (Either MethodError Variant)
getSystemdProperty client propName = do
  reply <- call client $ (methodCall systemdObjectPath
                           "org.freedesktop.DBus.Properties"
                           "Get")
    { methodCallDestination = Just systemdBusName
    , methodCallBody = [toVariant systemdManagerInterface, toVariant propName]
    }
  case reply of
    Left err -> return $ Left err
    Right ret ->
      case methodReturnBody ret of
        [v] -> case fromVariant v of
          Just inner -> return $ Right inner
          Nothing -> return $ Left $ methodError
            (methodReturnSerial ret)
            (errorName_ "org.taffybar.Systemd.TypeMismatch")
        _ -> return $ Left $ methodError
          (methodReturnSerial ret)
          (errorName_ "org.taffybar.Systemd.InvalidResponse")