Alsa plugin: Restart alsactl if it quits (Fixes #376)

2 files changed, 67 insertions, 15 deletions

diff --git a/src/Xmobar/Plugins/Monitors/Alsa.hs b/src/Xmobar/Plugins/Monitors/Alsa.hs
index 21a2786..4efc808 100644
--- a/src/Xmobar/Plugins/Monitors/Alsa.hs
+++ b/src/Xmobar/Plugins/Monitors/Alsa.hs
@@ -12,6 +12,7 @@
 --
 -----------------------------------------------------------------------------
 
+{-# LANGUAGE PatternGuards #-}
 module Xmobar.Plugins.Monitors.Alsa
   ( startAlsaPlugin
   , withMonitorWaiter
@@ -23,14 +24,20 @@ import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Exception
 import Control.Monad
+import Data.IORef
+import Data.Time.Clock
 import Xmobar.Plugins.Monitors.Common
 import qualified Xmobar.Plugins.Monitors.Volume as Volume;
 import System.Console.GetOpt
 import System.Directory
 import System.Exit
 import System.IO
+import System.IO.Error
 import System.Process
 
+alsaCtlRestartRateLimit :: NominalDiffTime
+alsaCtlRestartRateLimit = 3 -- 'Num NominalDiffTime' assumes seconds
+
 data AlsaOpts = AlsaOpts
     { aoVolumeOpts :: Volume.VolumeOpts
     , aoAlsaCtlPath :: Maybe FilePath
@@ -76,11 +83,11 @@ startAlsaPlugin mixerName controlName args cb = do
         opts2 <- io $ parseOpts args2
         Volume.runVolumeWith (aoVolumeOpts opts2) mixerName controlName
 
-  withMonitorWaiter mixerName (aoAlsaCtlPath opts) $ \wait_ ->
+  withMonitorWaiter mixerName (aoAlsaCtlPath opts) cb $ \wait_ ->
     runMB args Volume.volumeConfig run wait_ cb
 
-withMonitorWaiter :: String -> Maybe FilePath -> (IO () -> IO a) -> IO a
-withMonitorWaiter mixerName alsaCtlPath cont = do
+withMonitorWaiter :: String -> Maybe FilePath -> (String -> IO ()) -> (IO () -> IO a) -> IO a
+withMonitorWaiter mixerName alsaCtlPath outputCallback cont = do
   mvar <- newMVar ()
 
   path <- determineAlsaCtlPath
@@ -98,17 +105,33 @@ withMonitorWaiter mixerName alsaCtlPath cont = do
     readerThread mvar path =
       let createProc = (proc "stdbuf" ["-oL", path, "monitor", mixerName])
                           {std_out = CreatePipe}
-      in
-        withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do
-          hSetBuffering alsaOut LineBuffering
-
-          forever $ do
-            c <- hGetChar alsaOut
-            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 ()
+
+          runAlsaOnce =
+            withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do
+              hSetBuffering alsaOut LineBuffering
+
+              tryPutMVar mvar () -- Refresh immediately after restarting alsactl
+
+              forever $ do
+                c <- hGetChar alsaOut
+                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 ()
+      in do
+        limiter <- createRateLimiter alsaCtlRestartRateLimit
+
+        forever $ do
+          limiter
+
+          catchJust
+            (guard . isEOFError)
+            runAlsaOnce
+            pure
+
+          outputCallback "Restarting alsactl..."
+
 
     defaultPath = "/usr/sbin/alsactl"
 
@@ -144,3 +167,30 @@ trimTrailingNewline x =
     '\n' : '\r' : y -> reverse y
     '\n' : y -> reverse y
     _ -> x
+
+-- |
+-- Returns an IO action that completes at most once per @interval@.
+-- The returned cation is not safe for concurrent use.
+createRateLimiter :: NominalDiffTime -> IO (IO ())
+createRateLimiter interval = do
+  prevTimeRef <- newIORef Nothing
+
+  let
+    limiter = do
+      prevTime0 <- readIORef prevTimeRef
+      curTime <- getCurrentTime
+
+      case prevTime0 of
+        Just prevTime | diff <- interval - (curTime `diffUTCTime` prevTime),
+                        diff > 0
+                        -> do
+                            threadDelayNDT diff
+                            writeIORef prevTimeRef . Just =<< getCurrentTime
+
+        _ -> writeIORef prevTimeRef (Just curTime)
+
+  pure limiter
+
+threadDelayNDT :: NominalDiffTime -> IO ()
+threadDelayNDT ndt =
+  threadDelay (round (realToFrac ndt * 1e6 :: Double))
diff --git a/test/Xmobar/Plugins/Monitors/AlsaSpec.hs b/test/Xmobar/Plugins/Monitors/AlsaSpec.hs
index 53c720f..14810dd 100644
--- a/test/Xmobar/Plugins/Monitors/AlsaSpec.hs
+++ b/test/Xmobar/Plugins/Monitors/AlsaSpec.hs
@@ -58,7 +58,9 @@ runFakeAlsactlTest =
             waiterTaskIsRunning <- newEmptyMVar :: IO (MVar ())
             waiterTaskIsWaiting <- newEmptyMVar :: IO (MVar ())
 
-            withMonitorWaiter fifoPath (Just fakeAlsactlPath) $ \waitFunc -> do
+            let outputCallback msg = fail ("Did not expect the output callback to be invoked (message: "++show msg++")")
+
+            withMonitorWaiter fifoPath (Just fakeAlsactlPath) outputCallback $ \waitFunc -> do
 
               let addToTimeline e =  modifyMVar_ timeline (pure . (e :))