rofi-extras/app/rofi-bt.hs

--------------------------------------------------------------------------------
-- 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 RIO
import qualified RIO.List as L
import qualified RIO.Text as T
import Rofi.Command
import UnliftIO.Environment

main :: IO ()
main = runSimpleApp $ getArgs >>= runPrompt

data RofiBTConf = RofiBTConf
  { btArgs :: ![T.Text]
  , btAdapter :: !ObjectPath
  , btEnv :: !SimpleApp
  }

instance HasRofiConf RofiBTConf where
  defArgs = btArgs

instance HasLogFunc RofiBTConf where
  logFuncL = lens btEnv (\x y -> x {btEnv = y}) . logFuncL

type BTAction = RofiAction RofiBTConf

runPrompt :: [String] -> RIO SimpleApp ()
runPrompt args = do
  c <- getClient
  maybe (logError "could not get DBus client") run c
  where
    run client = do
      paths <- M.keys <$> getObjectTree client
      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]
getRofiActions client os = do
  devs <- getDevices client os
  catMaybes <$> mapM (deviceToRofiAction client) devs

deviceToRofiAction :: MonadIO m => Client -> ObjectPath -> m (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
  adapter <- asks btAdapter
  let mc = btMethodCall adapter i m
  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
  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 :: MonadIO m => Client -> [ObjectPath] -> m [ObjectPath]
getDevices client = filterM (getDevicePaired client) . filter pathIsDevice

type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))

getObjectTree :: MonadIO m => Client -> m 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 :: MonadIO m => Client -> ObjectPath -> m (Maybe Bool)
getDeviceConnected = getDevProperty "Connected"

getDeviceName :: MonadIO m => Client -> ObjectPath -> m (Maybe T.Text)
getDeviceName = getDevProperty "Name"

getDevicePaired :: MonadIO m => Client -> ObjectPath -> m Bool
getDevicePaired c = fmap (fromMaybe False) . getDevProperty "Paired" c

callDeviceConnect :: MonadIO m => Client -> ObjectPath -> m ()
callDeviceConnect = callDevMethod "Connect"

callDeviceDisconnect :: MonadIO m => Client -> ObjectPath -> m ()
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 :: (MonadReader c m, HasLogFunc c, MonadUnliftIO m) => m (Maybe Client)
getClient = either warn (return . Just) =<< try (liftIO connectSystem)
  where
    warn e = do
      logWarn $ displayBytesUtf8 $ encodeUtf8 $ (T.pack $ clientErrorMessage e)
      return Nothing

callDevMethod :: MonadIO m => T.Text -> Client -> ObjectPath -> m ()
callDevMethod mem client dev =
  void $ callBTMethod client dev btDevInterface $ memberName_ $ T.unpack mem

getDevProperty :: (MonadIO m, IsVariant a) => T.Text -> Client -> ObjectPath -> m (Maybe a)
getDevProperty mem client dev =
  getBTProperty client dev btDevInterface $ memberName_ $ T.unpack mem

callBTMethod
  :: MonadIO m
  => Client
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> m (Either MethodError MethodReturn)
callBTMethod client o i m = liftIO $ call client (btMethodCall o i m)

-- eitherMaybe (fromVariant <=< listToMaybe . methodReturnBody)
-- <$> call client (btMethodCall o i m)

getBTProperty
  :: (MonadIO m, IsVariant a)
  => Client
  -> ObjectPath
  -> InterfaceName
  -> MemberName
  -> m (Maybe a)
getBTProperty client o i m =
  eitherMaybe fromVariant <$> (liftIO $ 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"