ENH finish bluetooth xmobar interface
This commit is contained in:
parent
ce02bf185f
commit
90140fef5d
|
@ -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
|
||||||
]
|
]
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue