From 46a5ec61ff18e877b98e47be6d66bf990e919ce9 Mon Sep 17 00:00:00 2001
From: Jan Beinke <git@janbeinke.com>
Date: Mon, 2 Mar 2020 05:35:54 +0100
Subject: [PATCH] Add first draft of the new dbus powered network-manager block
---
package.yaml | 2 +
src/QBar/Blocks.hs | 2 +
src/QBar/Blocks/NetworkManager.hs | 177 ++++++++++++++++++++++++++++++
src/QBar/Cli.hs | 1 +
src/QBar/DefaultConfig.hs | 5 +-
stack.yaml | 1 +
6 files changed, 185 insertions(+), 3 deletions(-)
create mode 100644 src/QBar/Blocks/NetworkManager.hs
diff --git a/package.yaml b/package.yaml
index bbe7066..52a0c37 100644
--- a/package.yaml
+++ b/package.yaml
@@ -27,6 +27,8 @@ dependencies:
- bytestring
- colour
- concurrent-extra
+- containers
+- dbus
- directory
- filepath
- lens
diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs
index 8df8ca3..54acadb 100644
--- a/src/QBar/Blocks.hs
+++ b/src/QBar/Blocks.hs
@@ -2,6 +2,7 @@ module QBar.Blocks
( QBar.Blocks.Battery.batteryBlock,
QBar.Blocks.CpuUsage.cpuUsageBlock,
QBar.Blocks.Date.dateBlock,
+ QBar.Blocks.NetworkManager.networkManagerBlock,
QBar.Blocks.Script.scriptBlock,
QBar.Blocks.Script.pollScriptBlock,
)
@@ -10,4 +11,5 @@ where
import qualified QBar.Blocks.Battery
import qualified QBar.Blocks.CpuUsage
import qualified QBar.Blocks.Date
+import qualified QBar.Blocks.NetworkManager
import qualified QBar.Blocks.Script
diff --git a/src/QBar/Blocks/NetworkManager.hs b/src/QBar/Blocks/NetworkManager.hs
new file mode 100644
index 0000000..fd9bc04
--- /dev/null
+++ b/src/QBar/Blocks/NetworkManager.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module QBar.Blocks.NetworkManager where
+
+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
+import qualified DBus
+import qualified DBus.Client as DBus
+import qualified Data.Map as Map
+import qualified Data.Text.Lazy as T
+import Data.Word (Word32, Word8)
+import QBar.BlockHelper
+import QBar.BlockOutput
+import QBar.Blocks.Utils
+import QBar.Core
+
+data ConnectionInfo = WifiConnection Text Int | WwanConnection Text Int | EthernetConnection Text
+ deriving (Show)
+
+fromJust :: MonadError () m => Maybe a -> m a
+fromJust (Just a) = return a
+fromJust Nothing = throwError ()
+
+runExceptT_ :: Monad m => ExceptT () m a -> m (Maybe a)
+runExceptT_ a = either (const Nothing) Just <$> runExceptT a
+
+getDBusProperty :: (MonadError () m, MonadIO m, DBus.IsVariant a) => DBus.Client -> DBus.BusName -> DBus.ObjectPath -> DBus.InterfaceName -> DBus.MemberName -> m a
+getDBusProperty client busName objectPath interfaceName memberName = do
+ result' <- tryMaybe' $ do
+ let methodCall = ((DBus.methodCall objectPath interfaceName memberName) {DBus.methodCallDestination = Just busName})
+ result <- either (const Nothing) Just <$> DBus.getProperty client methodCall
+ return $ DBus.fromVariant =<< result
+ fromJust result'
+
+getConnectionInfo :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m ConnectionInfo
+getConnectionInfo client connectionObjectPath = do
+ connectionType <- getActiveConnectionType client connectionObjectPath
+ connectionName <- getActiveConnectionName client connectionObjectPath
+ case connectionType of
+ "802-11-wireless" -> do
+ devices <- getActiveConnectionDevice client connectionObjectPath
+ device <- fromJust $ listToMaybe devices
+ accessPoint <- getDeviceAccessPoint client device
+ signalStrength <- fromIntegral <$> getAccessPointSignalStrength client accessPoint
+ return $ WifiConnection connectionName signalStrength
+ "gsm" -> do
+ devices <- getActiveConnectionDevice client connectionObjectPath
+ device <- fromJust $ listToMaybe devices
+ udi <- getDeviceUdi client device
+ signalQuality <- getModemSignalQuality client $ DBus.objectPath_ udi
+ return $ WwanConnection connectionName . fromIntegral . fst $ signalQuality
+ "802-3-ethernet" -> return $ EthernetConnection connectionName
+ _ -> throwError ()
+
+networkManagerBlock :: Block
+networkManagerBlock = runSignalBlockConfiguration $ SignalBlockConfiguration {
+ initialize = initialize',
+ finalize = finalize',
+ signalThread = Nothing,
+ signalBlock = networkManagerBlock',
+ interval = Just defaultInterval
+}
+ where
+ initialize' :: (() -> IO ()) -> BarIO DBus.Client
+ initialize' trigger = liftIO $ do
+ client <- DBus.connectSystem
+ let matchRule = DBus.matchAny {
+ DBus.matchPath = Just "/org/freedesktop/NetworkManager",
+ DBus.matchInterface = Just "org.freedesktop.DBus.Properties"
+ }
+ void . DBus.addMatch client matchRule $ dbusSignalHandler trigger
+ return client
+ finalize' :: DBus.Client -> BarIO ()
+ finalize' = liftIO . DBus.disconnect
+ networkManagerBlock' :: DBus.Client -> SignalBlock ()
+ networkManagerBlock' client = (liftBarIO . networkManagerBlock'' client) >=> respondBlockUpdate >=> networkManagerBlock' client
+ networkManagerBlock'' :: DBus.Client -> Signal () -> BarIO BlockOutput
+ networkManagerBlock'' client _ = do
+ primaryConnection <- runExceptT_ $ getPrimaryConnectionPath client
+ primaryConnectionInfo <- case primaryConnection of
+ Just primaryConnection' -> runExceptT_ $ getConnectionInfo client primaryConnection'
+ Nothing -> return Nothing
+ return . mkBlockOutput $ fullText' primaryConnectionInfo
+ fullText' :: Maybe ConnectionInfo -> BlockText
+ fullText' connectionInfo = fullText'' connectionInfo
+ where
+ importanceLevel :: Importance
+ importanceLevel = case connectionInfo of
+ Nothing -> errorImportant
+ (Just (WifiConnection _ strength)) -> toImportance (0, 85 ,100, 100, 100) . (100 -) $ strength
+ (Just (WwanConnection _ strength)) -> toImportance (0, 85 ,100, 100, 100) . (100 -) $ strength
+ (Just (EthernetConnection _)) -> normalImportant
+ fullText'' :: Maybe ConnectionInfo -> BlockText
+ fullText'' Nothing = importantText importanceLevel "âŒ\xFE0E No Connection"
+ fullText'' (Just (WifiConnection name strength)) = importantText importanceLevel $ "📡\xFE0E " <> name <> " " <> formatPercent strength
+ fullText'' (Just (WwanConnection _ signalQuality)) = importantText importanceLevel $ "📶\xFE0E " <> formatPercent signalQuality
+ fullText'' (Just (EthernetConnection _)) = importantText importanceLevel "🔌\xFE0E Ethernet"
+ dbusSignalHandler :: (() -> IO ()) -> DBus.Signal -> IO ()
+ dbusSignalHandler trigger signal = when (primaryConnectionHasChanged signal) $ trigger ()
+ primaryConnectionHasChanged :: DBus.Signal -> Bool
+ primaryConnectionHasChanged = any (maybe False (containsKey "PrimaryConnection") . DBus.fromVariant) . DBus.signalBody
+ containsKey :: String -> Map.Map String DBus.Variant -> Bool
+ containsKey = Map.member
+
+formatPercent :: Int -> Text
+formatPercent a = T.justifyRight 3 ' ' $ (T.pack . show . max 0 . min 100) a <> "%"
+
+getPrimaryConnectionPath :: (MonadError () m, MonadIO m) => DBus.Client -> m DBus.ObjectPath
+getPrimaryConnectionPath client =
+ getDBusProperty
+ client
+ "org.freedesktop.NetworkManager"
+ "/org/freedesktop/NetworkManager"
+ "org.freedesktop.NetworkManager"
+ "PrimaryConnection"
+
+getActiveConnectionType :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m Text
+getActiveConnectionType client objectPath =
+ getDBusProperty
+ client
+ "org.freedesktop.NetworkManager"
+ objectPath
+ "org.freedesktop.NetworkManager.Connection.Active"
+ "Type"
+
+getActiveConnectionName :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m Text
+getActiveConnectionName client objectPath =
+ getDBusProperty
+ client
+ "org.freedesktop.NetworkManager"
+ objectPath
+ "org.freedesktop.NetworkManager.Connection.Active"
+ "Id"
+
+getActiveConnectionDevice :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m [DBus.ObjectPath]
+getActiveConnectionDevice client objectPath =
+ getDBusProperty
+ client
+ "org.freedesktop.NetworkManager"
+ objectPath
+ "org.freedesktop.NetworkManager.Connection.Active"
+ "Devices"
+
+getDeviceAccessPoint :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m DBus.ObjectPath
+getDeviceAccessPoint client objectPath =
+ getDBusProperty
+ client
+ "org.freedesktop.NetworkManager"
+ objectPath
+ "org.freedesktop.NetworkManager.Device.Wireless"
+ "ActiveAccessPoint"
+
+getDeviceUdi :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m String
+getDeviceUdi client objectPath =
+ getDBusProperty
+ client
+ "org.freedesktop.NetworkManager"
+ objectPath
+ "org.freedesktop.NetworkManager.Device"
+ "Udi"
+
+getAccessPointSignalStrength :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m Word8
+getAccessPointSignalStrength client objectPath =
+ getDBusProperty
+ client
+ "org.freedesktop.NetworkManager"
+ objectPath
+ "org.freedesktop.NetworkManager.AccessPoint"
+ "Strength"
+
+getModemSignalQuality :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m (Word32, Bool)
+getModemSignalQuality client objectPath =
+ getDBusProperty
+ client
+ "org.freedesktop.ModemManager1"
+ objectPath
+ "org.freedesktop.ModemManager1.Modem"
+ "SignalQuality"
diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs
index 619eb15..13cee76 100644
--- a/src/QBar/Cli.hs
+++ b/src/QBar/Cli.hs
@@ -87,6 +87,7 @@ blockParser =
command "date" (info (pure $ addBlock dateBlock) (progDesc "Load the date and time block.")) <>
command "cpu" (info (pure $ addBlock $ cpuUsageBlock 1) (progDesc "Load the cpu usage block.")) <>
command "battery" (info (pure $ addBlock $ batteryBlock) (progDesc "Load the battery block.")) <>
+ command "networkmanager" (info (pure $ addBlock networkManagerBlock) (progDesc "Load the network-manager block.")) <>
command "script" (info scriptBlockParser (progDesc "Display the output of an external script as a block."))
)
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index 85b02a4..6fd5c84 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -15,12 +15,11 @@ defaultBarConfig = do
addBlock $ cpuUsageBlock 1
--addBlock ramUsageBlock
--addBlock cpuTemperatureBlock
- --addBlock networkBlock
+ addBlock networkManagerBlock
legacyBarConfig :: BarIO ()
legacyBarConfig = do
let todo = pollScriptBlock $ blockLocation "todo"
- let wifi = (pollScriptBlock $ blockLocation "wifi2") >-> modify (addIcon "📡\xFE0E")
let networkEnvironment = pollScriptBlock $ blockLocation "network-environment"
let ram = (pollScriptBlock $ blockLocation "memory") >-> modify (addIcon "ðŸ\xFE0E") >-> autoPadding
let temperature = (pollScriptBlock $ blockLocation "temperature") >-> autoPadding
@@ -33,7 +32,7 @@ legacyBarConfig = do
addBlock ram
addBlock $ cpuUsageBlock 1
addBlock networkEnvironment
- addBlock wifi
+ addBlock networkManagerBlock
addBlock todo
where
blockLocation :: String -> FilePath
diff --git a/stack.yaml b/stack.yaml
index d2d8b71..fc999b5 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -42,6 +42,7 @@ packages:
# Disable pure nix-shell environment on NixOS, because access to XDG_RUNTIME_DIR is needed for the control socket
nix:
pure: false
+ packages: [ zlib ]
# Override default flag values for local packages and extra-deps
# flags: {}
--
GitLab