diff --git a/default.nix b/default.nix index 51923b7..794498e 100644 --- a/default.nix +++ b/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 ]; diff --git a/dev/cli-run.sh b/dev/cli-run.sh new file mode 100755 index 0000000..4f1aba5 --- /dev/null +++ b/dev/cli-run.sh @@ -0,0 +1,3 @@ +cd "$(dirname "$0")" + +DBUS_SYSTEM_BUS_ADDRESS=unix:path=/tmp/tuxclocker-dbus-socket ../inst/bin/tuxclocker diff --git a/meson_options.txt b/meson_options.txt index a03fb5e..7df61d0 100644 --- a/meson_options.txt +++ b/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', diff --git a/src/meson.build b/src/meson.build index 0f70b8f..ff4906e 100644 --- a/src/meson.build +++ b/src/meson.build @@ -50,3 +50,7 @@ endif if get_option('gui') subdir('tuxclocker-qt') endif + +if get_option('cli') + subdir('tuxclocker-cli') +endif diff --git a/src/tuxclocker-cli/Main.hs b/src/tuxclocker-cli/Main.hs new file mode 100644 index 0000000..8abad56 --- /dev/null +++ b/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 diff --git a/src/tuxclocker-cli/meson.build b/src/tuxclocker-cli/meson.build new file mode 100644 index 0000000..fea4968 --- /dev/null +++ b/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)) diff --git a/src/tuxclocker-cli/tuxclocker.cabal b/src/tuxclocker-cli/tuxclocker.cabal new file mode 100644 index 0000000..da2b1af --- /dev/null +++ b/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