diff --git a/app/rofi-bt.hs b/app/rofi-bt.hs new file mode 100644 index 0000000..8f8f105 --- /dev/null +++ b/app/rofi-bt.hs @@ -0,0 +1,169 @@ +-------------------------------------------------------------------------------- +-- | rofi-bt - a prompt to dicsonnect/connect devices +-- + +module Main (main) where + +import Control.Exception +import Control.Monad +import Control.Monad.Reader + +import Data.List +import Data.List.Split +import qualified Data.Map as M +import Data.Maybe + +import DBus +import DBus.Client + +import Rofi.Command + +main :: IO () +main = runPrompt + +-- dummy type with nothing in it since there is nothing to configure for this +-- (yet) +newtype RofiBTConf = RofiBTConf ObjectPath + +instance RofiConf RofiBTConf where + defArgs (RofiBTConf _) = [] + +type BTAction = RofiAction RofiBTConf + +runPrompt :: IO () +runPrompt = do + c <- getClient + maybe (putStrLn "could not get DBus client") run c + where + run client = do + paths <- M.keys <$> getObjectTree client + maybe (putStrLn "could not get DBus adapter") (actions client paths) + $ getAdapter paths + actions client paths adapter = do + ras <- getRofiActions client paths + runRofiIO (RofiBTConf adapter) $ selectAction $ 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 -> RofiIO 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 (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 -> String -> String +formatDeviceEntry connected name = unwords [prefix connected, name] + where + prefix True = "#" + prefix False = " " + +getAdapter :: [ObjectPath] -> Maybe ObjectPath +getAdapter = find pathIsAdaptor + +getDevices :: Client -> [ObjectPath] -> IO [ObjectPath] +getDevices client = filterM (getDevicePaired client) . filter pathIsDevice + +type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String 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 String) +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 :: String -> String -> String -> Bool +pathIsAdaptorPrefix a b c = a == "org" && b == "bluez" && "hci" `isPrefixOf` c + +splitPath :: ObjectPath -> [String] +splitPath =splitOn "/" . dropWhile (=='/') . formatObjectPath + +getClient :: IO (Maybe Client) +getClient = either warn (return . Just) =<< try connectSystem + where + warn e = putStrLn (clientErrorMessage e) >> return Nothing + +callDevMethod :: String -> Client -> ObjectPath -> IO () +callDevMethod mem client dev = + void $ callBTMethod client dev btDevInterface $ memberName_ mem + +getDevProperty :: IsVariant a => String -> Client -> ObjectPath -> IO (Maybe a) +getDevProperty mem client dev = + getBTProperty client dev btDevInterface $ memberName_ 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" diff --git a/package.yaml b/package.yaml index e555167..b647285 100644 --- a/package.yaml +++ b/package.yaml @@ -60,6 +60,7 @@ executables: - -threaded dependencies: - rofi-extras + rofi-autorandr: main: rofi-autorandr.hs source-dirs: app @@ -69,6 +70,7 @@ executables: - -threaded dependencies: - rofi-extras + rofi-bw: main: rofi-bw.hs source-dirs: app @@ -78,6 +80,17 @@ executables: - -threaded dependencies: - rofi-extras + + rofi-bt: + main: rofi-bt.hs + source-dirs: app + ghc-options: + - -Wall + - -Werror + - -threaded + dependencies: + - rofi-extras + rofi-dev: main: rofi-dev.hs source-dirs: app @@ -87,6 +100,7 @@ executables: - -threaded dependencies: - rofi-extras + current-output: main: current-output.hs source-dirs: app