xmonad-config/lib/XMonad/Internal/DBus/Removable.hs

107 lines
2.9 KiB
Haskell
Raw Normal View History

--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Module for monitoring removable drive events
--
-- Currently, its only purpose is to play Super Mario sounds when a drive is
-- inserted or removed. Why? Because I can.
module XMonad.Internal.DBus.Removable (runRemovableMon) where
2022-12-30 14:58:23 -05:00
import DBus
import DBus.Client
import Data.Internal.DBus
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2022-12-31 19:47:02 -05:00
import RIO
import qualified RIO.Map as M
2022-12-30 14:58:23 -05:00
import XMonad.Core (io)
import XMonad.Internal.Command.Desktop
bus :: BusName
bus = busName_ "org.freedesktop.UDisks2"
path :: ObjectPath
path = objectPath_ "/org/freedesktop/UDisks2"
interface :: InterfaceName
interface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
memAdded :: MemberName
memAdded = memberName_ "InterfacesAdded"
memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved"
2022-07-09 17:08:10 -04:00
dbusDep :: MemberName -> DBusDependency_ SysClient
dbusDep m = Endpoint [Package Official "udisks2"] bus path interface $ Signal_ m
2021-11-20 11:48:05 -05:00
2022-07-09 17:08:10 -04:00
addedDep :: DBusDependency_ SysClient
2021-11-07 20:16:53 -05:00
addedDep = dbusDep memAdded
2022-07-09 17:08:10 -04:00
removedDep :: DBusDependency_ SysClient
2021-11-07 20:16:53 -05:00
removedDep = dbusDep memRemoved
driveInsertedSound :: FilePath
driveInsertedSound = "smb_powerup.wav"
driveRemovedSound :: FilePath
driveRemovedSound = "smb_pipe.wav"
ruleUdisks :: MatchRule
2022-12-30 14:58:23 -05:00
ruleUdisks =
matchAny
{ matchPath = Just path
, matchInterface = Just interface
}
driveFlag :: String
driveFlag = "org.freedesktop.UDisks2.Drive"
addedHasDrive :: [Variant] -> Bool
2022-12-30 14:58:23 -05:00
addedHasDrive [_, a] =
maybe
False
2022-12-31 19:47:02 -05:00
(M.member driveFlag)
2022-12-30 14:58:23 -05:00
(fromVariant a :: Maybe (Map String (Map String Variant)))
addedHasDrive _ = False
removedHasDrive :: [Variant] -> Bool
2022-12-30 14:58:23 -05:00
removedHasDrive [_, a] =
maybe
False
(driveFlag `elem`)
(fromVariant a :: Maybe [String])
removedHasDrive _ = False
2023-01-02 18:21:13 -05:00
playSoundMaybe :: MonadUnliftIO m => FilePath -> Bool -> m ()
2022-03-05 18:18:16 -05:00
playSoundMaybe p b = when b $ io $ playSound p
2020-07-10 18:48:20 -04:00
-- NOTE: the udisks2 service should be already running for this module to work.
-- If it not already, we won't see any signals from the dbus until it is
-- started (it will work after it is started however). It seems safe to simply
-- enable the udisks2 service at boot; however this is not default behavior.
2023-01-03 22:18:55 -05:00
listenDevices
:: ( HasClient (DBusEnv env)
, MonadReader env m
, MonadUnliftIO m
)
=> SysClient
-> m ()
2022-07-09 17:08:10 -04:00
listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive
addMatch' memRemoved driveRemovedSound removedHasDrive
where
2023-01-02 18:21:13 -05:00
addMatch' m p f = do
let rule = ruleUdisks {matchMember = Just m}
2023-01-03 22:18:55 -05:00
void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
runRemovableMon
:: ( HasClient (DBusEnv env)
, MonadReader env m
, MonadUnliftIO m
)
=> Maybe SysClient
-> Sometimes (m ())
runRemovableMon cl =
2023-01-03 22:18:55 -05:00
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
where
deps = toAnd_ addedDep removedDep