├── .gitignore ├── Setup.hs ├── test └── Spec.hs ├── app └── Main.hs ├── package.yaml ├── LICENSE ├── src └── XMonad │ └── DBus.hs ├── xmonad-dbus.cabal ├── README.md └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | stack.yaml.lock 3 | *~ 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import XMonad.DBus 2 | import Control.Concurrent 3 | import Control.Applicative ((<|>)) 4 | import System.Exit 5 | 6 | main :: IO () 7 | main = do 8 | m <- newEmptyMVar 9 | c1 <- connect 10 | c2 <- connect 11 | subscribe c2 (\s -> putMVar m (head $ bodyToString s)) 12 | requestAccess c1 13 | send c1 "Test String!" 14 | threadDelay 1000000 15 | r <- tryTakeMVar m <|> return (Just "") 16 | case r of 17 | Just "Test String!" -> putStrLn "Test passed" 18 | _ -> do 19 | putStrLn "Test didn't passed" 20 | exitWith $ ExitFailure 1 21 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import XMonad.DBus 4 | import Control.Concurrent 5 | import Data.List (intercalate) 6 | import System.IO (hFlush,stdout) 7 | import System.Environment (getArgs) 8 | 9 | import qualified DBus.Client as DC 10 | 11 | printer m = do r <- takeMVar m 12 | mapM_ putStrLn r 13 | hFlush stdout 14 | printer m 15 | 16 | work :: DC.Client -> [String] -> IO () 17 | 18 | work c ("send":xs) = do 19 | requestAccess c 20 | send c $ intercalate " " xs 21 | 22 | work c ("sendToPath":x:xs) = do 23 | requestAccess c 24 | sendToPath c x $ intercalate " " xs 25 | 26 | work c args = do 27 | m <- newEmptyMVar 28 | case args of 29 | (path:_) -> subscribeToPath c path 30 | _ -> subscribe c 31 | $ \s -> putMVar m (bodyToString s) 32 | printer m 33 | 34 | main :: IO () 35 | main = do 36 | c <- connect 37 | args <- getArgs 38 | work c args 39 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: xmonad-dbus 2 | version: 0.1.0.2 3 | github: "troydm/xmonad-dbus" 4 | license: BSD3 5 | author: "Dmitry Geurkov" 6 | maintainer: "d.geurkov@gmail.com" 7 | copyright: "2018-2023 Dmitry Geurkov" 8 | 9 | extra-source-files: 10 | - README.md 11 | 12 | # Metadata used when publishing your package 13 | # synopsis: Short description of your package 14 | # category: Web 15 | 16 | # To avoid duplicated efforts in documentation and dealing with the 17 | # complications of embedding Haddock markup inside cabal files, it is 18 | # common to point users to the README.md file. 19 | description: Please see the README on Github at 20 | 21 | dependencies: 22 | - base >= 4.7 && < 5 23 | - dbus >= 0.10 24 | 25 | library: 26 | source-dirs: src 27 | 28 | executables: 29 | xmonad-dbus: 30 | main: Main.hs 31 | source-dirs: app 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - xmonad-dbus 38 | 39 | tests: 40 | xmonad-dbus-test: 41 | main: Spec.hs 42 | source-dirs: test 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - xmonad-dbus 49 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Dmitry Geurkov (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/XMonad/DBus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module XMonad.DBus (connect,subscribe,subscribeToPath,bodyToString,requestAccess,send,sendToPath) where 3 | 4 | import Data.Maybe (mapMaybe) 5 | import qualified DBus as D 6 | import qualified DBus.Client as DC 7 | 8 | busName = "org.XMonad.DBus" 9 | interface = "org.XMonad.DBus" 10 | pathPrefix = "/org/XMonad" 11 | pathPrefixObjectPath = D.objectPath_ pathPrefix 12 | member = "Update" 13 | 14 | connect :: IO DC.Client 15 | connect = DC.connectSession 16 | 17 | requestAccess c = DC.requestName c busName [DC.nameAllowReplacement, DC.nameReplaceExisting, DC.nameDoNotQueue] 18 | 19 | 20 | matchAnyPath :: DC.MatchRule 21 | matchAnyPath = DC.matchAny { 22 | DC.matchInterface = Just interface, 23 | DC.matchPathNamespace = Just pathPrefixObjectPath, 24 | DC.matchMember = Just member 25 | } 26 | 27 | matchPath :: String -> DC.MatchRule 28 | matchPath name = DC.matchAny { 29 | DC.matchInterface = Just interface, 30 | DC.matchPath = (D.parseObjectPath $ pathPrefix++"/"++name), 31 | DC.matchMember = Just member 32 | } 33 | 34 | subscribe c handler = DC.addMatch c matchAnyPath handler 35 | subscribeToPath c path handler = DC.addMatch c (matchPath path) handler 36 | 37 | bodyToString :: D.Signal -> [String] 38 | bodyToString s = mapMaybe D.fromVariant (D.signalBody s) 39 | 40 | 41 | send :: DC.Client -> String -> IO () 42 | send c s = DC.emit c $ (D.signal pathPrefixObjectPath interface member) { 43 | D.signalBody = [D.toVariant s] 44 | } 45 | 46 | sendToPath :: DC.Client -> String -> String -> IO () 47 | sendToPath c p s = DC.emit c $ (D.signal (D.objectPath_ $ pathPrefix++"/"++p) interface member) { 48 | D.signalBody = [D.toVariant s] 49 | } 50 | -------------------------------------------------------------------------------- /xmonad-dbus.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: e09852654ab4face57c2b914858976e2a3f163d7aafec5df933a60de1b8baa90 8 | 9 | name: xmonad-dbus 10 | version: 0.1.0.2 11 | description: Please see the README on Github at 12 | homepage: https://github.com/troydm/xmonad-dbus#readme 13 | bug-reports: https://github.com/troydm/xmonad-dbus/issues 14 | author: Dmitry Geurkov 15 | maintainer: d.geurkov@gmail.com 16 | copyright: 2018-2023 Dmitry Geurkov 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/troydm/xmonad-dbus 26 | 27 | library 28 | exposed-modules: 29 | XMonad.DBus 30 | other-modules: 31 | Paths_xmonad_dbus 32 | hs-source-dirs: 33 | src 34 | build-depends: 35 | base >=4.7 && <5 36 | , dbus >=0.10 37 | default-language: Haskell2010 38 | 39 | executable xmonad-dbus 40 | main-is: Main.hs 41 | other-modules: 42 | Paths_xmonad_dbus 43 | hs-source-dirs: 44 | app 45 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 46 | build-depends: 47 | base >=4.7 && <5 48 | , dbus >=0.10 49 | , xmonad-dbus 50 | default-language: Haskell2010 51 | 52 | test-suite xmonad-dbus-test 53 | type: exitcode-stdio-1.0 54 | main-is: Spec.hs 55 | other-modules: 56 | Paths_xmonad_dbus 57 | hs-source-dirs: 58 | test 59 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 60 | build-depends: 61 | base >=4.7 && <5 62 | , dbus >=0.10 63 | , xmonad-dbus 64 | default-language: Haskell2010 65 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # xmonad-dbus 2 | xmonad-dbus is DBus monitoring solution inspired by [xmonad-log](https://github.com/xintron/xmonad-log) completely written in Haskell. 3 | It allows you to easily send your status via DBus using XMonad's DynamicLog to any application that can execute custom scripts. 4 | It can be used to easily display XMonad status in [polybar](https://github.com/jaagr/polybar) 5 | 6 | ## Installation 7 | 8 | ### With Stack 9 | 10 | ```bash 11 | stack build 12 | ``` 13 | 14 | ### With AUR 15 | 16 | Use your favourite [AUR helper](https://wiki.archlinux.org/title/AUR_helpers) to install on ArchLinux-based distribution: 17 | 18 | ```bash 19 | pikaur -S xmonad-dbus-git 20 | ``` 21 | 22 | ## Running 23 | 24 | ```bash 25 | # start xmonad-dbus, you can optionally specify a path that would be used when receiveing messages, 26 | # otherwise all xmonad-dbus related messages will be received) 27 | stack exec xmonad-dbus -- [path] 28 | # you can manually send messages from command line too 29 | stack exec xmonad-dbus -- send string 30 | # and if you want to send messages only to particular path you can use sendToPath 31 | stack exec xmonad-dbus -- sendToPath path string 32 | ``` 33 | 34 | ## Configuring XMonad 35 | To send status information from XMonad you need to add xmonad-dbus as dependency either via stack or manually when building your xmonad.hs 36 | 37 | ```haskell 38 | import XMonad 39 | import XMonad.Hooks.DynamicLog 40 | import qualified XMonad.DBus as D 41 | import qualified DBus.Client as DC 42 | 43 | -- Override the PP values as you would like (see XMonad.Hooks.DynamicLog documentation) 44 | myLogHook :: DC.Client -> PP 45 | myLogHook dbus = def { ppOutput = D.send dbus } 46 | 47 | main :: IO () 48 | main = do 49 | -- Connect to DBus 50 | dbus <- D.connect 51 | -- Request access (needed when sending messages) 52 | D.requestAccess dbus 53 | -- start xmonad 54 | xmonad $ def { logHook = dynamicLogWithPP (myLogHook dbus) } 55 | ``` 56 | 57 | ## Configuring polybar 58 | To receive status you need to add custom/script module to your polybar config 59 | Don't forget to add compiled xmonad-dbus executable to your PATH 60 | 61 | [module/xmonad] 62 | type = custom/script 63 | exec = xmonad-dbus 64 | tail = true 65 | interval = 1 66 | 67 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-21.3 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.6" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | --------------------------------------------------------------------------------