rofi-extras/app/rofi-bt.hs

178 lines
5.5 KiB
Haskell

--------------------------------------------------------------------------------
-- rofi-bt - a prompt to dicsonnect/connect devices
--
module Main (main) where
import DBus
import DBus.Client
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text.IO as TI
import RIO
import qualified RIO.List as L
import qualified RIO.Text as T
import Rofi.Command
import System.Environment
main :: IO ()
main = getArgs >>= runPrompt
data RofiBTConf = RofiBTConf [T.Text] ObjectPath
instance HasRofiConf RofiBTConf where
defArgs (RofiBTConf as _) = as
type BTAction = RofiAction RofiBTConf
runPrompt :: [String] -> IO ()
runPrompt args = do
c <- getClient
maybe (TI.putStrLn "could not get DBus client") run c
where
run client = do
paths <- M.keys <$> getObjectTree client
maybe (TI.putStrLn "could not get DBus adapter") (actions client paths) $
getAdapter paths
actions client paths adapter = do
ras <- getRofiActions client paths
runRofi (RofiBTConf (fmap T.pack args) adapter) $
emptyMenu
{ groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Select Device"
}
getRofiActions :: Client -> [ObjectPath] -> IO [BTAction]
getRofiActions client os = do
devs <- getDevices client os
catMaybes <$> mapM (deviceToRofiAction client) devs
deviceToRofiAction :: Client -> ObjectPath -> IO (Maybe BTAction)
deviceToRofiAction client dev = do
c <- getDeviceConnected client dev
n <- getDeviceName client dev
return $ case (c, n) of
(Just c', Just n') ->
Just
( formatDeviceEntry c' n'
, powerAdapterMaybe client >> io (mkAction c')
)
_ -> Nothing
where
mkAction True = callDeviceDisconnect client dev
mkAction False = callDeviceConnect client dev
powerAdapterMaybe :: Client -> RIO RofiBTConf ()
powerAdapterMaybe client = do
(RofiBTConf _ adapter) <- ask
let mc = btMethodCall adapter i m
let powerOnMaybe = flip unless $ void $ setProperty client mc value
powered <- io $ getBTProperty client adapter i m
io $ maybe (TI.putStrLn "could not get adapter powered status") powerOnMaybe powered
where
i = interfaceName_ "org.bluez.Adapter1"
m = memberName_ "Powered"
-- apparently this needs to be double-variant'd to match the signature of
-- the 'Set' method
value = toVariant $ toVariant True
formatDeviceEntry :: Bool -> T.Text -> T.Text
formatDeviceEntry connected name = T.unwords [prefix connected, name]
where
prefix True = "#"
prefix False = " "
getAdapter :: [ObjectPath] -> Maybe ObjectPath
getAdapter = L.find pathIsAdaptor
getDevices :: Client -> [ObjectPath] -> IO [ObjectPath]
getDevices client = filterM (getDevicePaired client) . filter pathIsDevice
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
getObjectTree :: Client -> IO ObjectTree
getObjectTree client =
fromMaybe M.empty . eitherMaybe from <$> callBTMethod client o i m
where
o = objectPath_ "/"
i = interfaceName_ "org.freedesktop.DBus.ObjectManager"
m = memberName_ "GetManagedObjects"
from = fromVariant <=< listToMaybe . methodReturnBody
getDeviceConnected :: Client -> ObjectPath -> IO (Maybe Bool)
getDeviceConnected = getDevProperty "Connected"
getDeviceName :: Client -> ObjectPath -> IO (Maybe T.Text)
getDeviceName = getDevProperty "Name"
getDevicePaired :: Client -> ObjectPath -> IO Bool
getDevicePaired c = fmap (fromMaybe False) . getDevProperty "Paired" c
callDeviceConnect :: Client -> ObjectPath -> IO ()
callDeviceConnect = callDevMethod "Connect"
callDeviceDisconnect :: Client -> ObjectPath -> IO ()
callDeviceDisconnect = callDevMethod "Disconnect"
pathIsAdaptor :: ObjectPath -> Bool
pathIsAdaptor o = case splitPath o of
[a, b, c] -> pathIsAdaptorPrefix a b c
_ -> False
pathIsDevice :: ObjectPath -> Bool
pathIsDevice o = case splitPath o of
[a, b, c, _] -> pathIsAdaptorPrefix a b c
_ -> False
pathIsAdaptorPrefix :: T.Text -> T.Text -> T.Text -> Bool
pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `T.isPrefixOf` c
splitPath :: ObjectPath -> [T.Text]
splitPath = T.split (== '/') . T.dropWhile (== '/') . T.pack . formatObjectPath
getClient :: IO (Maybe Client)
getClient = either warn (return . Just) =<< try connectSystem
where
warn e = TI.putStrLn (T.pack $ clientErrorMessage e) >> return Nothing
callDevMethod :: T.Text -> Client -> ObjectPath -> IO ()
callDevMethod mem client dev =
void $ callBTMethod client dev btDevInterface $ memberName_ $ T.unpack mem
getDevProperty :: IsVariant a => T.Text -> Client -> ObjectPath -> IO (Maybe a)
getDevProperty mem client dev =
getBTProperty client dev btDevInterface $ memberName_ $ T.unpack mem
callBTMethod
:: Client
-> ObjectPath
-> InterfaceName
-> MemberName
-> IO (Either MethodError MethodReturn)
callBTMethod client o i m = call client (btMethodCall o i m)
-- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-- <$> call client (btMethodCall o i m)
getBTProperty
:: IsVariant a
=> Client
-> ObjectPath
-> InterfaceName
-> MemberName
-> IO (Maybe a)
getBTProperty client o i m =
eitherMaybe fromVariant <$> getProperty client (btMethodCall o i m)
btMethodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall
btMethodCall o i m = (methodCall o i m) {methodCallDestination = Just btBus}
eitherMaybe :: (b -> Maybe c) -> Either a b -> Maybe c
eitherMaybe = either (const Nothing)
btBus :: BusName
btBus = busName_ "org.bluez"
btDevInterface :: InterfaceName
btDevInterface = interfaceName_ "org.bluez.Device1"