rofi-extras/app/rofi-bt.hs

188 lines
5.9 KiB
Haskell
Raw Normal View History

2021-11-29 00:44:37 -05:00
--------------------------------------------------------------------------------
2023-02-13 22:19:49 -05:00
-- rofi-bt - a prompt to dicsonnect/connect devices
2021-11-29 00:44:37 -05:00
--
module Main (main) where
2023-02-13 22:19:49 -05:00
import DBus
import DBus.Client
import qualified Data.Map as M
import Data.Maybe
import RIO
import qualified RIO.List as L
import qualified RIO.Text as T
import Rofi.Command
2023-02-22 22:44:44 -05:00
import UnliftIO.Environment
2021-11-29 00:55:33 -05:00
2021-11-29 00:44:37 -05:00
main :: IO ()
2023-02-22 22:44:44 -05:00
main = runSimpleApp $ getArgs >>= runPrompt
2021-11-29 00:44:37 -05:00
2023-02-22 22:44:44 -05:00
data RofiBTConf = RofiBTConf
{ btArgs :: ![T.Text]
, btAdapter :: !ObjectPath
, btEnv :: !SimpleApp
}
2021-11-29 00:44:37 -05:00
2023-02-14 22:28:26 -05:00
instance HasRofiConf RofiBTConf where
2023-02-22 22:44:44 -05:00
defArgs = btArgs
instance HasLogFunc RofiBTConf where
logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL
2021-11-29 00:44:37 -05:00
type BTAction = RofiAction RofiBTConf
2023-02-22 22:44:44 -05:00
runPrompt :: [String] -> RIO SimpleApp ()
2021-11-29 00:55:33 -05:00
runPrompt args = do
2021-11-29 00:44:37 -05:00
c <- getClient
2023-02-22 22:44:44 -05:00
maybe (logError "could not get DBus client") run c
2021-11-29 00:44:37 -05:00
where
run client = do
paths <- M.keys <$> getObjectTree client
2023-02-22 22:44:44 -05:00
case getAdapter paths of
Nothing -> logError "could not get DBus adapter"
Just adapter -> do
ras <- getRofiActions client paths
mapRIO (RofiBTConf (fmap T.pack args) adapter) $
selectAction $
emptyMenu
{ groups = [untitledGroup $ toRofiActions ras]
, prompt = Just "Select Device"
}
getRofiActions :: MonadIO m => Client -> [ObjectPath] -> m [BTAction]
2021-11-29 00:44:37 -05:00
getRofiActions client os = do
devs <- getDevices client os
catMaybes <$> mapM (deviceToRofiAction client) devs
2023-02-22 22:44:44 -05:00
deviceToRofiAction :: MonadIO m => Client -> ObjectPath -> m (Maybe BTAction)
2021-11-29 00:44:37 -05:00
deviceToRofiAction client dev = do
c <- getDeviceConnected client dev
n <- getDeviceName client dev
return $ case (c, n) of
2023-02-13 22:19:49 -05:00
(Just c', Just n') ->
Just
( formatDeviceEntry c' n'
, powerAdapterMaybe client >> io (mkAction c')
)
_ -> Nothing
2021-11-29 00:44:37 -05:00
where
2023-02-13 22:19:49 -05:00
mkAction True = callDeviceDisconnect client dev
2021-11-29 00:44:37 -05:00
mkAction False = callDeviceConnect client dev
2023-02-14 22:28:26 -05:00
powerAdapterMaybe :: Client -> RIO RofiBTConf ()
2021-11-29 00:44:37 -05:00
powerAdapterMaybe client = do
2023-02-22 22:44:44 -05:00
adapter <- asks btAdapter
2021-11-29 00:44:37 -05:00
let mc = btMethodCall adapter i m
2023-02-22 22:44:44 -05:00
let powerOnMaybe = flip unless $ void $ liftIO $ setProperty client mc value
powered <- getBTProperty client adapter i m
maybe (logError "could not get adapter powered status") powerOnMaybe powered
2021-11-29 00:44:37 -05:00
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
2023-02-13 23:31:50 -05:00
formatDeviceEntry :: Bool -> T.Text -> T.Text
formatDeviceEntry connected name = T.unwords [prefix connected, name]
2021-11-29 00:44:37 -05:00
where
2023-02-13 22:19:49 -05:00
prefix True = "#"
2021-11-29 00:44:37 -05:00
prefix False = " "
getAdapter :: [ObjectPath] -> Maybe ObjectPath
2023-02-13 22:19:49 -05:00
getAdapter = L.find pathIsAdaptor
2021-11-29 00:44:37 -05:00
2023-02-22 22:44:44 -05:00
getDevices :: MonadIO m => Client -> [ObjectPath] -> m [ObjectPath]
2021-11-29 00:44:37 -05:00
getDevices client = filterM (getDevicePaired client) . filter pathIsDevice
2023-02-13 23:31:50 -05:00
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
2021-11-29 00:44:37 -05:00
2023-02-22 22:44:44 -05:00
getObjectTree :: MonadIO m => Client -> m ObjectTree
2021-11-29 00:44:37 -05:00
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
2023-02-22 22:44:44 -05:00
getDeviceConnected :: MonadIO m => Client -> ObjectPath -> m (Maybe Bool)
2021-11-29 00:44:37 -05:00
getDeviceConnected = getDevProperty "Connected"
2023-02-22 22:44:44 -05:00
getDeviceName :: MonadIO m => Client -> ObjectPath -> m (Maybe T.Text)
2021-11-29 00:44:37 -05:00
getDeviceName = getDevProperty "Name"
2023-02-22 22:44:44 -05:00
getDevicePaired :: MonadIO m => Client -> ObjectPath -> m Bool
2021-11-29 00:44:37 -05:00
getDevicePaired c = fmap (fromMaybe False) . getDevProperty "Paired" c
2023-02-22 22:44:44 -05:00
callDeviceConnect :: MonadIO m => Client -> ObjectPath -> m ()
2021-11-29 00:44:37 -05:00
callDeviceConnect = callDevMethod "Connect"
2023-02-22 22:44:44 -05:00
callDeviceDisconnect :: MonadIO m => Client -> ObjectPath -> m ()
2021-11-29 00:44:37 -05:00
callDeviceDisconnect = callDevMethod "Disconnect"
pathIsAdaptor :: ObjectPath -> Bool
pathIsAdaptor o = case splitPath o of
[a, b, c] -> pathIsAdaptorPrefix a b c
2023-02-13 22:19:49 -05:00
_ -> False
2021-11-29 00:44:37 -05:00
pathIsDevice :: ObjectPath -> Bool
pathIsDevice o = case splitPath o of
[a, b, c, _] -> pathIsAdaptorPrefix a b c
2023-02-13 22:19:49 -05:00
_ -> False
2021-11-29 00:44:37 -05:00
2023-02-13 23:31:50 -05:00
pathIsAdaptorPrefix :: T.Text -> T.Text -> T.Text -> Bool
pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `T.isPrefixOf` c
2021-11-29 00:44:37 -05:00
2023-02-13 23:31:50 -05:00
splitPath :: ObjectPath -> [T.Text]
splitPath = T.split (== '/') . T.dropWhile (== '/') . T.pack . formatObjectPath
2021-11-29 00:44:37 -05:00
2023-02-22 22:44:44 -05:00
getClient :: (MonadReader c m, HasLogFunc c, MonadUnliftIO m) => m (Maybe Client)
getClient = either warn (return . Just) =<< try (liftIO connectSystem)
2021-11-29 00:44:37 -05:00
where
2023-02-22 22:44:44 -05:00
warn e = do
logWarn $ displayBytesUtf8 $ encodeUtf8 $ (T.pack $ clientErrorMessage e)
return Nothing
2021-11-29 00:44:37 -05:00
2023-02-22 22:44:44 -05:00
callDevMethod :: MonadIO m => T.Text -> Client -> ObjectPath -> m ()
2021-11-29 00:44:37 -05:00
callDevMethod mem client dev =
2023-02-13 23:31:50 -05:00
void $ callBTMethod client dev btDevInterface $ memberName_ $ T.unpack mem
2021-11-29 00:44:37 -05:00
2023-02-22 22:44:44 -05:00
getDevProperty :: (MonadIO m, IsVariant a) => T.Text -> Client -> ObjectPath -> m (Maybe a)
2021-11-29 00:44:37 -05:00
getDevProperty mem client dev =
2023-02-13 23:31:50 -05:00
getBTProperty client dev btDevInterface $ memberName_ $ T.unpack mem
2021-11-29 00:44:37 -05:00
2023-02-13 22:19:49 -05:00
callBTMethod
2023-02-22 22:44:44 -05:00
:: MonadIO m
=> Client
2023-02-13 22:19:49 -05:00
-> ObjectPath
-> InterfaceName
-> MemberName
2023-02-22 22:44:44 -05:00
-> m (Either MethodError MethodReturn)
callBTMethod client o i m = liftIO $ call client (btMethodCall o i m)
2021-11-29 00:44:37 -05:00
2023-02-13 22:19:49 -05:00
-- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-- <$> call client (btMethodCall o i m)
getBTProperty
2023-02-22 22:44:44 -05:00
:: (MonadIO m, IsVariant a)
2023-02-13 22:19:49 -05:00
=> Client
-> ObjectPath
-> InterfaceName
-> MemberName
2023-02-22 22:44:44 -05:00
-> m (Maybe a)
2021-11-29 00:44:37 -05:00
getBTProperty client o i m =
2023-02-22 22:44:44 -05:00
eitherMaybe fromVariant <$> (liftIO $ getProperty client (btMethodCall o i m))
2021-11-29 00:44:37 -05:00
btMethodCall :: ObjectPath -> InterfaceName -> MemberName -> MethodCall
2023-02-13 22:19:49 -05:00
btMethodCall o i m = (methodCall o i m) {methodCallDestination = Just btBus}
2021-11-29 00:44:37 -05:00
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"