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

{-# 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