ADD module to monitor removable drives and play super mario sounds

bin/xmonad.hs

@@ -44,6 +44,7 @@ import           XMonad.Internal.Command.Power
 import           XMonad.Internal.Concurrent.ACPIEvent
 import           XMonad.Internal.Concurrent.ClientMessage
 import           XMonad.Internal.Concurrent.DynamicWorkspaces
+import           XMonad.Internal.Concurrent.Removable
 import           XMonad.Internal.DBus.Control
 import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
@@ -66,6 +67,7 @@ main = do
   cl <- startXMonadService
   (h, p) <- spawnPipe "xmobar"
   _ <- forkIO runPowermon
+  _ <- forkIO runRemovableMon
   _ <- forkIO $ runWorkspaceMon allDWs
   let ts = ThreadState
         { client = cl

lib/XMonad/Internal/Concurrent/Removable.hs

@@ -0,0 +1,70 @@
+{-# 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.Concurrent.Removable (runRemovableMon) where
+
+import           Control.Concurrent
+import           Control.Monad
+
+import           Data.Map.Lazy         (Map, member)
+import           Data.Maybe            (maybe)
+
+import           DBus
+import           DBus.Client
+
+import           XMonad.Internal.Shell
+
+path :: ObjectPath
+path = "/org/freedesktop/UDisks2"
+
+interface :: InterfaceName
+interface = "org.freedesktop.DBus.ObjectManager"
+
+memAdded :: MemberName
+memAdded = "InterfacesAdded"
+
+memRemoved :: MemberName
+memRemoved = "InterfacesRemoved"
+
+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 ()
+playSoundMaybe p b = when b $ spawnSound p
+
+runRemovableMon :: IO ()
+runRemovableMon = 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

lib/XMonad/Internal/DBus/Control.hs

@@ -13,7 +13,6 @@ import           DBus.Client
 
 import           XMonad.Internal.DBus.IntelBacklight
 import           XMonad.Internal.DBus.Screensaver
--- import           XMonad.Internal.DBus.Workspaces
 
 startXMonadService :: IO Client
 startXMonadService = do
@@ -27,7 +26,6 @@ startXMonadService = do
     putStrLn "Started xmonad dbus client"
     exportIntelBacklight client
     exportScreensaver client
-    -- exportWorkspaces client
   return client
 
 stopXMonadService :: Client -> IO ()

lib/XMonad/Internal/Process.hs

@@ -16,6 +16,7 @@ module XMonad.Internal.Process
 import           Control.Concurrent
 import           Control.Exception
 import           Control.Monad
+import           Control.Monad.IO.Class
 
 import           Data.Maybe
 
@@ -64,10 +65,10 @@ shell' = addGroupSession . shell
 proc' :: FilePath -> [String] -> CreateProcess
 proc' cmd args = addGroupSession $ proc cmd args
 
-spawn :: String -> X ()
+spawn :: MonadIO m => String -> m ()
 spawn = io . void . createProcess' . shell'
 
-spawnAt :: FilePath -> String -> X ()
+spawnAt :: MonadIO m => FilePath -> String -> m ()
 spawnAt fp cmd = io $ void $ createProcess' $ (shell' cmd) { cwd = Just fp }
 
 spawnPipe :: String -> IO (Handle, ProcessHandle)

lib/XMonad/Internal/Shell.hs

@@ -10,15 +10,17 @@ module XMonad.Internal.Shell
   , (#!>>)
   ) where
 
+import           Control.Monad.IO.Class
+
 import           System.FilePath.Posix
 
-import           XMonad.Core             (X, getXMonadDir)
+import           XMonad.Core             (getXMonadDir)
 import           XMonad.Internal.Process
 
 --------------------------------------------------------------------------------
 -- | Opening subshell
 
-spawnCmd :: String -> [String] -> X ()
+spawnCmd :: MonadIO m => String -> [String] -> m ()
 spawnCmd cmd args = spawn $ fmtCmd cmd args
 
 --------------------------------------------------------------------------------
@@ -27,7 +29,7 @@ spawnCmd cmd args = spawn $ fmtCmd cmd args
 soundDir :: FilePath
 soundDir = "sound"
 
-spawnSound :: FilePath -> X ()
+spawnSound :: MonadIO m => FilePath -> m ()
 spawnSound file = do
   path <- (</> soundDir </> file) <$> getXMonadDir
   -- paplay seems to have less latency than aplay

my-xmonad.cabal

@@ -8,6 +8,7 @@ library
     exposed-modules: XMonad.Internal.Concurrent.ClientMessage
                    , XMonad.Internal.Concurrent.ACPIEvent
                    , XMonad.Internal.Concurrent.DynamicWorkspaces
+                   , XMonad.Internal.Concurrent.Removable
                    , XMonad.Internal.Theme
                    , XMonad.Internal.Notify
                    , XMonad.Internal.Shell
@@ -18,7 +19,6 @@ library
                    , XMonad.Internal.DBus.IntelBacklight
                    , XMonad.Internal.DBus.Control
                    , XMonad.Internal.DBus.Screensaver
-                   , XMonad.Internal.DBus.Workspaces
                    , XMonad.Internal.Process
                    , Xmobar.Plugins.Bluetooth
                    , Xmobar.Plugins.Device