ENH finish bluetooth xmobar interface

This commit is contained in:
Nathan Dwarshuis 2020-03-21 14:30:27 -04:00
parent ce02bf185f
commit 90140fef5d
3 changed files with 42 additions and 19 deletions

View File

@ -123,7 +123,7 @@ config confDir = defaultConfig
, Run $ Screensaver ("<fn=1>\xf254</fn>", T.fgColor, T.backdropFgColor) , Run $ Screensaver ("<fn=1>\xf254</fn>", T.fgColor, T.backdropFgColor)
, Run $ Bluetooth ("BT", T.fgColor, T.backdropFgColor) , Run $ Bluetooth ("<fn=1>\xf293</fn>", T.fgColor, T.backdropFgColor)
, Run UnsafeStdinReader , Run UnsafeStdinReader
] ]

View File

@ -6,43 +6,65 @@ module Xmobar.Plugins.Bluetooth where
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad
import Data.List (find) import qualified Data.Map.Lazy as M
import Data.Maybe (mapMaybe) import Data.Maybe
import DBus import DBus
import DBus.Client import DBus.Client
import DBus.Internal.Types
import Xmobar import Xmobar
newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show) newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show)
path :: ObjectPath
path = "/org/bluez/hci0"
interface :: InterfaceName
interface = "org.freedesktop.DBus.Properties"
rule :: MatchRule rule :: MatchRule
rule = matchAny rule = matchAny
{ matchPath = Just "/org/bluez/hci0" { matchPath = Just path
, matchInterface = Just "org.freedesktop.DBus.Properties" , matchInterface = Just interface
, matchMember = Just "PropertiesChanged" , matchMember = Just "PropertiesChanged"
} }
callBT :: Client -> IO (Either MethodError MethodReturn)
callBT client =
call client (methodCall path interface "Get")
{ methodCallDestination = Just "org.bluez", methodCallBody = body }
where
body = map toVariant ["org.bluez.Adapter1", "Powered" :: String]
instance Exec Bluetooth where instance Exec Bluetooth where
alias (Bluetooth _) = "bluetooth" alias (Bluetooth _) = "bluetooth"
start (Bluetooth (text, colorOn, colorOff)) cb = do start (Bluetooth (text, colorOn, colorOff)) cb = do
client <- connectSystem client <- connectSystem
_ <- addMatch client rule $ cb . fmtState . stateFromSignal _ <- addMatch client rule $
-- TODO initialize here cb . fmtState . lookupState . getProps . signalBody
-- cb . formatBrightness =<< callGetBrightness reply <- callBT client
-- TODO handle errors?
case reply of
Right ret -> cb
$ fmtState
$ fromVariant
=<< fromVariant
=<< listToMaybe (methodReturnBody ret)
Left _ -> return ()
forever (threadDelay 5000) forever (threadDelay 5000)
where where
-- TODO this is total utter garbage...but it works... -- Assume that the data in the PropertiesChanged signal has the form
stateFromSignal sig = join -- [something, Map, something] where the Map in the middle has the
$ fmap (fromVariant :: (Variant -> Maybe Bool)) -- "Powered" text key that we care about (among other things that change
$ join -- when the bluetooth interface is powered on)
$ fmap (fromVariant :: (Variant -> Maybe Variant)) getProps = \case
$ fmap snd [_, Variant (ValueMap TypeString TypeVariant m), _] -> Just m
$ find (\(k, _) -> (fromVariant k :: Maybe String) == Just "Powered") _ -> Nothing
$ concatMap dictionaryItems lookupState m = fromVariant
$ mapMaybe fromVariant =<< fromValue
$ filter (\v -> variantType v == TypeDictionary TypeString TypeVariant) =<< M.lookup (AtomText "Powered")
$ signalBody sig =<< m
fmtState = \case fmtState = \case
Just s -> wrapColor text $ if s then colorOn else colorOff Just s -> wrapColor text $ if s then colorOn else colorOff
Nothing -> "N/A" Nothing -> "N/A"

View File

@ -25,6 +25,7 @@ library
, fdo-notify , fdo-notify
, dbus >= 1.2.7 , dbus >= 1.2.7
, text >= 1.2.3.1 , text >= 1.2.3.1
, containers >= 0.6.0.1
, xmobar , xmobar
ghc-options: -Wall -Werror -fno-warn-missing-signatures ghc-options: -Wall -Werror -fno-warn-missing-signatures
default-language: Haskell2010 default-language: Haskell2010