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

96 lines
2.8 KiB
Haskell
Raw Normal View History

--------------------------------------------------------------------------------
-- | 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.Concurrent.Removable (runRemovableMon) where
import Control.Concurrent
import Control.Monad
2021-11-07 20:16:53 -05:00
import Data.Map.Lazy (Map, member)
import DBus
import DBus.Client
2021-11-07 20:16:53 -05:00
-- import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.Dependency
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"
2021-11-07 20:16:53 -05:00
dbusDep :: MemberName -> Dependency
dbusDep m = Dependency { depRequired = True, depData = d }
where
d = DBusEndpoint
{ ddDbusBus = bus
, ddDbusSystem = True
, ddDbusObject = path
, ddDbusInterface = interface
, ddDbusMember = Signal_ m
}
addedDep :: Dependency
addedDep = dbusDep memAdded
removedDep :: Dependency
removedDep = dbusDep memRemoved
driveInsertedSound :: FilePath
driveInsertedSound = "smb_powerup.wav"
driveRemovedSound :: FilePath
driveRemovedSound = "smb_pipe.wav"
ruleUdisks :: MatchRule
ruleUdisks = matchAny
{ matchPath = Just path
, matchInterface = Just interface
}
driveFlag :: String
driveFlag = "org.freedesktop.UDisks2.Drive"
addedHasDrive :: [Variant] -> Bool
addedHasDrive [_, a] = maybe False (member driveFlag)
(fromVariant a :: Maybe (Map String (Map String Variant)))
addedHasDrive _ = False
removedHasDrive :: [Variant] -> Bool
removedHasDrive [_, a] = maybe False (driveFlag `elem`)
(fromVariant a :: Maybe [String])
removedHasDrive _ = False
playSoundMaybe :: FilePath -> Bool -> IO ()
2021-06-19 00:17:47 -04:00
playSoundMaybe p b = when b $ 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.
listenDevices :: IO ()
listenDevices = do
client <- connectSystem
_ <- addMatch' client memAdded driveInsertedSound addedHasDrive
_ <- addMatch' client memRemoved driveRemovedSound removedHasDrive
forever (threadDelay 5000000)
where
addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
$ playSoundMaybe p . f . signalBody
2021-11-07 20:16:53 -05:00
runRemovableMon :: IO (MaybeExe (IO ()))
runRemovableMon = runIfInstalled [addedDep, removedDep] listenDevices