112 lines
3.0 KiB
Haskell
112 lines
3.0 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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
|
|
|
|
import DBus
|
|
import DBus.Client
|
|
import Data.Internal.DBus
|
|
import Data.Internal.XIO
|
|
import RIO
|
|
import qualified RIO.Map as M
|
|
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"
|
|
|
|
dbusDep :: MemberName -> DBusDependency_ SysClient
|
|
dbusDep m = Endpoint [Package Official "udisks2"] bus path interface $ Signal_ m
|
|
|
|
addedDep :: DBusDependency_ SysClient
|
|
addedDep = dbusDep memAdded
|
|
|
|
removedDep :: DBusDependency_ SysClient
|
|
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
|
|
(M.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 :: MonadUnliftIO m => FilePath -> Bool -> m ()
|
|
playSoundMaybe p b = when b $ io $ playSound p
|
|
|
|
-- 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
|
|
:: ( HasClient (DBusEnv env)
|
|
, HasLogFunc (DBusEnv env SysClient)
|
|
, MonadReader env m
|
|
, MonadUnliftIO m
|
|
)
|
|
=> SysClient
|
|
-> m ()
|
|
listenDevices cl = do
|
|
addMatch' memAdded driveInsertedSound addedHasDrive
|
|
addMatch' memRemoved driveRemovedSound removedHasDrive
|
|
where
|
|
addMatch' m p f = do
|
|
let rule = ruleUdisks {matchMember = Just m}
|
|
void $ withDIO cl $ addMatchCallback rule (playSoundMaybe p . f)
|
|
|
|
runRemovableMon
|
|
:: ( HasClient (DBusEnv env)
|
|
, HasLogFunc (DBusEnv env SysClient)
|
|
, MonadReader env m
|
|
, MonadUnliftIO m
|
|
)
|
|
=> Maybe SysClient
|
|
-> Sometimes (m ())
|
|
runRemovableMon cl =
|
|
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
|
|
where
|
|
deps = toAnd_ addedDep removedDep
|