add initial cli

default.nix

@@ -3,8 +3,9 @@
 , boost
 , cmake
 , cudatoolkit
-, git
 , fetchFromGitHub
+, git
+, haskellPackages
 , libdrm
 , libX11
 , libXext
@@ -40,6 +41,7 @@ mkDerivation rec {
   '';
 
   nativeBuildInputs = [
+    (haskellPackages.ghcWithPackages (p: with p; [ dbus ]))
     git
     pkg-config
   ];

dev/cli-run.sh

@@ -0,0 +1,3 @@
+cd "$(dirname "$0")"
+
+DBUS_SYSTEM_BUS_ADDRESS=unix:path=/tmp/tuxclocker-dbus-socket ../inst/bin/tuxclocker

meson_options.txt

@@ -4,6 +4,8 @@ option('daemon', type: 'boolean', value: 'true', description: 'Build daemon')
 option('plugins', type: 'boolean', value: 'true', description: 'Build plugins')
 option('library', type: 'boolean', value: 'true', description: 'Build library')
 option('gui', type: 'boolean', value: 'true', description: 'Build Qt GUI')
+# Disabled by default to not break builds
+option('cli', type: 'boolean', value: 'false', description: 'Build CLI')
 option('require-python-hwdata', type: 'boolean', value: 'false',
 	description: 'Require python-hwdata for prettier AMD GPU names')
 option('require-amd', type: 'boolean', value: 'false',

src/meson.build

@@ -50,3 +50,7 @@ endif
 if get_option('gui')
 	subdir('tuxclocker-qt')
 endif
+
+if get_option('cli')
+	subdir('tuxclocker-cli')
+endif

src/tuxclocker-cli/Main.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Either
+import Data.Functor
+import Data.Maybe
+import Data.Text (Text)
+import Data.Tree
+import DBus
+import DBus.Client
+import qualified DBus.Introspection as I
+
+tuxClockerCall :: MethodCall -> MethodCall
+tuxClockerCall call = call { methodCallDestination = Just "org.tuxclocker" }
+
+printTree :: Show a => Tree a -> IO ()
+printTree tree = printIndent tree 0 where
+  printIndent :: Show a => Tree a -> Int -> IO ()
+  printIndent (Node rootLabel subForest) level = do
+    print $ (replicate level ' ') <> show rootLabel
+    mapM_ (\tree -> printIndent tree (level + 1)) subForest
+
+getObject :: Client -> ObjectPath -> IO I.Object
+getObject client path = do
+  reply <- call_ client $
+    tuxClockerCall $ methodCall path "org.freedesktop.DBus.Introspectable" "Introspect"
+  let xml = fromVariant (head $ methodReturnBody reply)
+  pure $ fromMaybe
+    (error ("Invalid introspection XML: " ++ show xml))
+    (xml >>= I.parseXML path)
+
+getName :: Client -> ObjectPath -> IO String
+getName client path =
+  let
+    call = tuxClockerCall $ methodCall path "org.tuxclocker.Node" "name"
+  in
+    getProperty client call <&> fromRight (toVariant ("Unnamed" :: String)) <&> variantToString
+
+getDBusTree :: Client -> IO (Tree Variant)
+getDBusTree client = unfoldTreeM (buildNode client) "/" where
+  buildNode :: Client -> ObjectPath -> IO (ObjectPath, [ObjectPath])
+  buildNode client path = do
+    object <- getObject client path
+    let childPaths = I.objectPath <$> I.objectChildren object
+    pure (I.objectPath object, childPaths)
+
+variantToString :: Variant -> String
+variantToString x = fromMaybe "Invalid" $ fromVariant x
+
+getNameTree :: Client -> Tree ObjectPath -> IO (Tree String)
+getNameTree client = mapM (getName client)
+
+
+main = do
+  client <- connectSystem
+  tree <- getDBusTree client
+  nameTree <- getNameTree client tree
+  putStr $ drawTree nameTree

src/tuxclocker-cli/meson.build

@@ -0,0 +1,3 @@
+install_dir = join_paths(get_option('prefix'), get_option('bindir'))
+
+run_command('cabal', 'install', '--installdir=@0@'.format(install_dir))

src/tuxclocker-cli/tuxclocker.cabal

@@ -0,0 +1,10 @@
+name: tuxclocker
+version: 0.0.1
+cabal-version: 2.0
+build-type: Simple
+
+executable tuxclocker
+  build-depends: base >= 4.16,
+                 dbus >= 1.2,
+                 text >= 2.0
+  main-is: Main.hs