Add event-based refreshing for Volume plugin (--monitor option)

This uses alsactl monitor for push/event-based updating instead of
polling.

5 files changed, 295 insertions, 5 deletions

diff --git a/readme.md b/readme.md
index 601f4c1..b868091 100644
--- a/readme.md
+++ b/readme.md
@@ -1063,6 +1063,14 @@ more than one battery.
     - `--highd` _number_ High threshold for dB. Defaults to -5.0.
     - `--lowd` _number_ Low threshold for dB. Defaults to -30.0.
     - `--volume-icon-pattern` _string_ dynamic string for current volume in `volumeipat`.
+    - `--monitor[=/path/to/alsactl]`
+        - Use event-based refreshing via `alsactl monitor` instead of polling
+          (`RefreshRate` will be ignored).
+        - If no `/path/to/alsactl` is given, `alsactl` will be sought in your `PATH`
+          first, and failing that, at `/usr/sbin/alsactl` (this is its location on
+          Debian systems. `alsactl monitor` works as a non-root user despite living
+          in `/usr/sbin`.).
+        - `stdbuf` (from coreutils) must be (and most probably already is) in your `PATH`.
 - Variables that can be used with the `-t`/`--template` argument:
             `volume`, `volumebar`, `volumevbar`, `volumeipat`, `dB`, `status`
 - Note that `dB` might only return 0 on your system. This is known
diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs
index 873130e..2fe7cc2 100644
--- a/src/Plugins/Monitors.hs
+++ b/src/Plugins/Monitors.hs
@@ -183,7 +183,7 @@ instance Exec Monitors where
     start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady
 #endif
 #ifdef ALSA
-    start (Volume m c a r) = runM a volumeConfig (runVolume m c) r
+    start (Volume m c a r) = startVolume m c a r
 #endif
 #ifdef MPRIS
     start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r
diff --git a/src/Plugins/Monitors/Volume.hs b/src/Plugins/Monitors/Volume.hs
index 39697f7..4974e5b 100644
--- a/src/Plugins/Monitors/Volume.hs
+++ b/src/Plugins/Monitors/Volume.hs
@@ -12,15 +12,30 @@
 --
 -----------------------------------------------------------------------------
 
-module Plugins.Monitors.Volume (runVolume, volumeConfig) where
+module Plugins.Monitors.Volume
+  ( startVolume
+  , runVolume
+  , volumeConfig
+  , getMonitorWaiter
+  , parseOptsIncludingMonitorArgs
+  , VolumeOpts(refreshMode)
+  , RefreshMode(..)
+  ) where
 
+import Commands (tenthSeconds)
 import Control.Applicative ((<$>))
-import Control.Monad ( liftM2, liftM3, mplus )
+import Control.Concurrent
+import Control.Exception
+import Control.Monad ( forever, liftM2, liftM3, mplus, void, when, unless )
 import Data.Traversable (sequenceA)
 import Plugins.Monitors.Common
 import Sound.ALSA.Mixer
 import qualified Sound.ALSA.Exception as AE
 import System.Console.GetOpt
+import System.Directory
+import System.Exit
+import System.IO
+import System.Process
 
 volumeConfig :: IO MConfig
 volumeConfig = mkMConfig "Vol: <volume>% <status>"
@@ -35,8 +50,13 @@ data VolumeOpts = VolumeOpts
     , highDbThresh :: Float
     , lowDbThresh :: Float
     , volumeIconPattern :: Maybe IconPattern
+    , refreshMode :: RefreshMode
     }
 
+data RefreshMode = RefreshModePoll
+                 | RefreshModeMonitor (Maybe FilePath) -- alsactl path
+                 deriving(Eq,Show)
+
 defaultOpts :: VolumeOpts
 defaultOpts = VolumeOpts
     { onString = "[on] "
@@ -46,8 +66,12 @@ defaultOpts = VolumeOpts
     , highDbThresh = -5.0
     , lowDbThresh = -30.0
     , volumeIconPattern = Nothing
+    , refreshMode = RefreshModePoll
     }
 
+monitorOptionName :: String
+monitorOptionName = "monitor"
+
 options :: [OptDescr (VolumeOpts -> VolumeOpts)]
 options =
     [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") ""
@@ -58,6 +82,8 @@ options =
     , Option "c" ["offc"] (ReqArg (\x o -> o { offColor = Just x }) "") ""
     , Option "" ["volume-icon-pattern"] (ReqArg (\x o ->
        o { volumeIconPattern = Just $ parseIconPattern x }) "") ""
+    , Option "" [monitorOptionName] (OptArg (\x o ->
+       o { refreshMode = RefreshModeMonitor x }) "") ""
     ]
 
 parseOpts :: [String] -> IO VolumeOpts
@@ -183,3 +209,89 @@ runVolume mixerName controlName argv = do
     getFormatSwitch opts (Just sw) = formatSwitch opts sw
 
     unavailable = getConfigValue naString
+
+parseOptsIncludingMonitorArgs :: [String] -> IO VolumeOpts
+parseOptsIncludingMonitorArgs args =
+    -- Drop generic Monitor args first
+    case getOpt Permute [] args of
+      (_, args', _) -> parseOpts args'
+
+startVolume :: String -> String -> [String] -> Int -> (String -> IO ()) -> IO ()
+startVolume mixerName controlName args rate cb = do
+  opts <- parseOptsIncludingMonitorArgs args
+
+  waitFunction <-
+    case refreshMode opts of
+      RefreshModePoll -> pure $ tenthSeconds rate
+      RefreshModeMonitor alsaCtlPath -> getMonitorWaiter mixerName alsaCtlPath
+
+  runMB args volumeConfig (runVolume mixerName controlName) waitFunction cb
+
+
+getMonitorWaiter :: String -> Maybe FilePath -> IO (IO ())
+getMonitorWaiter mixerName alsaCtlPath = do
+  mvar <- newMVar Nothing :: IO (MVar (Maybe SomeException))
+
+  forkFinally (readerThread mvar) (putMVar mvar . either Just (const Nothing))
+
+  pure $ do
+    ei <- takeMVar mvar
+    case ei of
+      -- Propagate exceptions from reader thread
+      Just (SomeException ex) -> throwIO ex
+      Nothing -> pure ()
+
+  where
+
+    readerThread mvar = do
+          path <- determineAlsaCtlPath
+          withCreateProcess
+            (proc "stdbuf" ["-oL", path, "monitor", mixerName]) {std_out = CreatePipe}
+            run
+
+      where
+
+        defaultPath = "/usr/sbin/alsactl"
+
+        determineAlsaCtlPath =
+          case alsaCtlPath of
+            Just path -> do
+              found <- doesFileExist path
+              if found
+                then pure path
+                else throwIO . ErrorCall $
+                     "Specified alsactl file " ++ path ++ " does not exist"
+
+            Nothing -> do
+              (ec, path, err) <- readProcessWithExitCode "which" ["alsactl"] ""
+              unless (null err) $ hPutStrLn stderr err
+              case ec of
+                ExitSuccess -> pure $ trimTrailingNewline path
+                ExitFailure _ -> do
+                  found <- doesFileExist defaultPath
+                  if found
+                    then pure defaultPath
+                    else throwIO . ErrorCall $
+                         "alsactl not found in PATH or at " ++
+                         show defaultPath ++
+                         "; please specify with --" ++
+                         monitorOptionName ++ "=/path/to/alsactl"
+
+
+        run _ ~(Just out) _ _ = do
+          hSetBuffering out LineBuffering
+          forever $ do
+            c <- hGetChar out
+            when (c == '\n') $
+              -- This uses 'tryPutMVar' because 'putMVar' would make 'runVolume' run
+              -- once for each event. But we want it to run only once after a burst
+              -- of events.
+              void $ tryPutMVar mvar Nothing
+
+-- This is necessarily very inefficient on 'String's
+trimTrailingNewline :: String -> String
+trimTrailingNewline x =
+  case reverse x of
+    '\n' : '\r' : y -> reverse y
+    '\n' : y -> reverse y
+    _ -> x
diff --git a/test/Plugins/Monitors/VolumeSpec.hs b/test/Plugins/Monitors/VolumeSpec.hs
new file mode 100644
index 0000000..d724c21
--- /dev/null
+++ b/test/Plugins/Monitors/VolumeSpec.hs
@@ -0,0 +1,161 @@
+{-# OPTIONS_GHC -Wall #-}
+module Plugins.Monitors.VolumeSpec
+  ( main
+  , spec
+  ) where
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Monad
+import Plugins.Monitors.Volume
+import System.FilePath
+import System.IO
+import System.IO.Temp
+import System.Posix.Files
+import System.Process
+import Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+  describe "Volume.getWaitMonitor" $
+    it "produces the expected timeline (using a fake alsactl)" $
+      runFakeAlsactlTest
+
+  describe "Volume.parseOptsIncludingMonitorArgs" $ do
+    it "works with empty args" $ do
+      opts <- parseOptsIncludingMonitorArgs []
+      refreshMode opts `shouldBe` RefreshModePoll
+
+    it "parses --monitor" $ do
+      opts <- parseOptsIncludingMonitorArgs ["--", "--monitor"]
+      refreshMode opts `shouldBe` RefreshModeMonitor Nothing
+
+    it "parses --monitor=foo" $ do
+      opts <- parseOptsIncludingMonitorArgs ["--", "--monitor=foo"]
+      refreshMode opts `shouldBe` RefreshModeMonitor (Just "foo")
+
+
+runFakeAlsactlTest :: Expectation
+runFakeAlsactlTest =
+      withSystemTempDirectory "xmobar-test" $ \tmpDir -> do
+
+        let fifoPath = tmpDir </> "fifo"
+            fakeAlsactlPath = tmpDir </> "fake-alsactl"
+
+        writeFile fakeAlsactlPath $
+          unlines
+            [ "#!/bin/bash"
+            , "[[ $1 == monitor ]] || exit 99"
+            , "exec cat \"$2\""
+            ]
+
+        setFileMode fakeAlsactlPath ownerModes
+
+        withFifoWriteHandle fifoPath $ \fifo -> do
+
+            timeline <- newMVar [] :: IO (MVar [TimelineEntry])
+            runVolumeCompleted <- newEmptyMVar :: IO (MVar Bool) -- True -> quit
+            waiterTaskIsRunning <- newEmptyMVar :: IO (MVar ())
+            waiterTaskIsWaiting <- newEmptyMVar :: IO (MVar ())
+
+            waitFunc <- getMonitorWaiter fifoPath (Just fakeAlsactlPath)
+
+            let addToTimeline e =  modifyMVar_ timeline (pure . (e :))
+
+                emitEvent = do
+                  addToTimeline EventEmitted
+                  hPutStrLn fifo "#17 (2,0,0,Master Playback Volume,0) VALUE"
+                  hFlush fifo
+
+                putNow mv val = do
+                  ok <- tryPutMVar mv val
+                  unless ok $ expectationFailure "Expected the MVar to be empty"
+
+                simulateRunVolumeCompleted = putNow runVolumeCompleted False
+
+                quitWaiter = putNow runVolumeCompleted True
+
+                waiterTaskMain = do
+                  addToTimeline RunVolume
+                  putNow waiterTaskIsRunning ()
+                  q <- takeMVar runVolumeCompleted
+                  unless q $ do
+                    addToTimeline Waiting
+                    putNow waiterTaskIsWaiting ()
+                    waitFunc
+
+                    waiterTaskMain
+
+                delay_ms = threadDelay . (* 1000)
+
+            withAsync waiterTaskMain $ \waiterTask -> do
+
+              takeMVar waiterTaskIsRunning
+              simulateRunVolumeCompleted
+              takeMVar waiterTaskIsWaiting
+              takeMVar waiterTaskIsRunning -- Waiter returns instantly once
+              simulateRunVolumeCompleted
+              takeMVar waiterTaskIsWaiting
+
+              emitEvent
+              takeMVar waiterTaskIsRunning
+              simulateRunVolumeCompleted
+              takeMVar waiterTaskIsWaiting
+
+              let iters = 3
+                  burstSize = 5
+
+              replicateM_ iters $ do
+                emitEvent
+                takeMVar waiterTaskIsRunning
+                -- Now more events start to accumulate during runVolume
+                replicateM_ burstSize emitEvent
+                delay_ms 250 -- Give the events time to go through the pipe
+                simulateRunVolumeCompleted
+                -- runVolume completed and should run once more due to
+                -- accumulated events
+                takeMVar waiterTaskIsWaiting
+                takeMVar waiterTaskIsRunning
+                simulateRunVolumeCompleted
+                takeMVar waiterTaskIsWaiting
+
+              emitEvent
+              takeMVar waiterTaskIsRunning
+              quitWaiter
+
+              wait waiterTask
+
+              timelineValue <- reverse <$> readMVar timeline
+
+              timelineValue `shouldBe`
+                [RunVolume, Waiting, RunVolume, Waiting, EventEmitted, RunVolume, Waiting]
+                ++ concat
+                    (replicate iters $
+                      [EventEmitted, RunVolume]
+                      ++ replicate burstSize EventEmitted
+                      ++ [Waiting, RunVolume, Waiting])
+                ++ [EventEmitted, RunVolume]
+
+data TimelineEntry = EventEmitted | Waiting | RunVolume
+              deriving(Eq)
+
+instance Show TimelineEntry where
+  show x =
+    case x of
+      EventEmitted -> "E"
+      Waiting -> "W"
+      RunVolume -> "R"
+
+
+withFifoWriteHandle :: FilePath -> (Handle -> IO b) -> IO b
+withFifoWriteHandle fifoPath body = do
+    createNamedPipe fifoPath ownerModes
+    -- Can't seem to get the writing to the FIFO to work internally
+    withCreateProcess
+      (proc "bash" ["-c", "cat >> \"$0\"", fifoPath]) {std_in = CreatePipe}
+      $ \(Just h) _ _ _ -> do
+        hSetBuffering h LineBuffering
+        body h
\ No newline at end of file
diff --git a/xmobar.cabal b/xmobar.cabal
index cb8f63f..6306677 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -44,7 +44,8 @@ test-suite XmobarTest
         Plugins.Monitors.Swap, Plugins.Monitors.Thermal,
         Plugins.Monitors.ThermalZone, Plugins.Monitors.Top,
         Plugins.Monitors.Uptime,
-        Plugins.Monitors.Bright, Plugins.Monitors.CatInt
+        Plugins.Monitors.Bright, Plugins.Monitors.CatInt,
+        Plugins.Monitors.VolumeSpec
   build-depends:
     base >= 4.9.1.0 && < 4.13,
     hspec == 2.*,
@@ -62,7 +63,15 @@ test-suite XmobarTest
     mtl >= 2.1 && < 2.3,
     parsec == 3.1.*,
     parsec-numbers == 0.1.0,
-    stm >= 2.3 && < 2.6
+    stm >= 2.3 && < 2.6,
+    temporary,
+    async
+
+  if flag(with_alsa) || flag(all_extensions)
+      build-depends: alsa-mixer > 0.2.0.2
+      build-depends: alsa-core == 0.5.*
+      other-modules: Plugins.Monitors.Volume
+      cpp-options: -DALSA
 
 source-repository head
   type:      git