Alsa plugin: Cancel reader thread (to terminate alsactl) when plugin main thread exits.

2 files changed, 107 insertions, 109 deletions

diff --git a/src/Plugins/Monitors/Alsa.hs b/src/Plugins/Monitors/Alsa.hs
index ba8e100..729042c 100644
--- a/src/Plugins/Monitors/Alsa.hs
+++ b/src/Plugins/Monitors/Alsa.hs
@@ -14,12 +14,13 @@
 
 module Plugins.Monitors.Alsa
   ( startAlsaPlugin
-  , getMonitorWaiter
+  , withMonitorWaiter
   , parseOptsIncludingMonitorArgs
   , AlsaOpts(aoAlsaCtlPath)
   ) where
 
 import Control.Concurrent
+import Control.Concurrent.Async
 import Control.Exception
 import Control.Monad
 import Plugins.Monitors.Common
@@ -66,8 +67,6 @@ startAlsaPlugin :: String -> String -> [String] -> (String -> IO ()) -> IO ()
 startAlsaPlugin mixerName controlName args cb = do
   opts <- parseOptsIncludingMonitorArgs args
 
-  waitFunction <- getMonitorWaiter mixerName (aoAlsaCtlPath opts)
-
   let run args2 = do
         -- Replicating the reparsing logic used by other plugins for now,
         -- but it seems the option parsing could be floated out (actually,
@@ -78,67 +77,66 @@ startAlsaPlugin mixerName controlName args cb = do
         opts2 <- io $ parseOpts args2
         runVolumeWith (aoVolumeOpts opts2) mixerName controlName
 
-  runMB args volumeConfig run waitFunction cb
+  withMonitorWaiter mixerName (aoAlsaCtlPath opts) $ \wait_ ->
+    runMB args volumeConfig run wait_ cb
 
-getMonitorWaiter :: String -> Maybe FilePath -> IO (IO ())
-getMonitorWaiter mixerName alsaCtlPath = do
-  mvar <- newMVar Nothing :: IO (MVar (Maybe SomeException))
+withMonitorWaiter :: String -> Maybe FilePath -> (IO () -> IO a) -> IO a
+withMonitorWaiter mixerName alsaCtlPath cont = do
+  mvar <- newMVar ()
 
-  forkFinally (readerThread mvar) (putMVar mvar . either Just (const Nothing))
+  path <- determineAlsaCtlPath
 
-  pure $ do
-    ei <- takeMVar mvar
-    case ei of
-      -- Propagate exceptions from reader thread
-      Just (SomeException ex) -> throwIO ex
-      Nothing -> pure ()
+  bracket (async $ readerThread mvar path) cancel $ \a -> do
 
-  where
+    -- Throw on this thread if there's an exception
+    -- on the reader thread.
+    link a
 
-    readerThread mvar = do
-          path <- determineAlsaCtlPath
-          withCreateProcess
-            (proc "stdbuf" ["-oL", path, "monitor", mixerName]) {std_out = CreatePipe}
-            run
+    cont $ takeMVar mvar
 
-      where
+  where
 
-        defaultPath = "/usr/sbin/alsactl"
+    readerThread mvar path =
+      let createProc = (proc "stdbuf" ["-oL", path, "monitor", mixerName])
+                          {std_out = CreatePipe}
+      in
+        withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do
+          hSetBuffering alsaOut LineBuffering
 
-        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 --" ++
-                         alsaCtlOptionName ++ "=/path/to/alsactl"
-
-
-        run _ ~(Just out) _ _ = do
-          hSetBuffering out LineBuffering
           forever $ do
-            c <- hGetChar out
+            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 Nothing
+              void $ tryPutMVar mvar ()
+
+    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 --" ++
+                      alsaCtlOptionName ++ "=/path/to/alsactl"
+
 
 -- This is necessarily very inefficient on 'String's
 trimTrailingNewline :: String -> String
diff --git a/test/Plugins/Monitors/AlsaSpec.hs b/test/Plugins/Monitors/AlsaSpec.hs
index a813c1d..77845e0 100644
--- a/test/Plugins/Monitors/AlsaSpec.hs
+++ b/test/Plugins/Monitors/AlsaSpec.hs
@@ -57,83 +57,83 @@ runFakeAlsactlTest =
             waiterTaskIsRunning <- newEmptyMVar :: IO (MVar ())
             waiterTaskIsWaiting <- newEmptyMVar :: IO (MVar ())
 
-            waitFunc <- getMonitorWaiter fifoPath (Just fakeAlsactlPath)
+            withMonitorWaiter fifoPath (Just fakeAlsactlPath) $ \waitFunc -> do
 
-            let addToTimeline e =  modifyMVar_ timeline (pure . (e :))
+              let addToTimeline e =  modifyMVar_ timeline (pure . (e :))
 
-                emitEvent = do
-                  addToTimeline EventEmitted
-                  hPutStrLn fifo "#17 (2,0,0,Master Playback Volume,0) VALUE"
-                  hFlush fifo
+                  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"
+                  putNow mv val = do
+                    ok <- tryPutMVar mv val
+                    unless ok $ expectationFailure "Expected the MVar to be empty"
 
-                simulateRunVolumeCompleted = putNow runVolumeCompleted False
+                  simulateRunVolumeCompleted = putNow runVolumeCompleted False
 
-                quitWaiter = putNow runVolumeCompleted True
+                  quitWaiter = putNow runVolumeCompleted True
 
-                waiterTaskMain = do
-                  addToTimeline RunVolume
-                  putNow waiterTaskIsRunning ()
-                  q <- takeMVar runVolumeCompleted
-                  unless q $ do
-                    addToTimeline Waiting
-                    putNow waiterTaskIsWaiting ()
-                    waitFunc
+                  waiterTaskMain = do
+                    addToTimeline RunVolume
+                    putNow waiterTaskIsRunning ()
+                    q <- takeMVar runVolumeCompleted
+                    unless q $ do
+                      addToTimeline Waiting
+                      putNow waiterTaskIsWaiting ()
+                      waitFunc
 
-                    waiterTaskMain
+                      waiterTaskMain
 
-                delay_ms = threadDelay . (* 1000)
+                  delay_ms = threadDelay . (* 1000)
 
-            withAsync waiterTaskMain $ \waiterTask -> do
+              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 -- Waiter returns instantly once
+                simulateRunVolumeCompleted
+                takeMVar waiterTaskIsWaiting
+
+                emitEvent
                 takeMVar waiterTaskIsRunning
                 simulateRunVolumeCompleted
                 takeMVar waiterTaskIsWaiting
 
-              emitEvent
-              takeMVar waiterTaskIsRunning
-              quitWaiter
+                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
+                wait waiterTask
 
-              timelineValue <- reverse <$> readMVar timeline
+                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]
+                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)
@@ -154,4 +154,4 @@ withFifoWriteHandle fifoPath body = do
       (proc "bash" ["-c", "cat >> \"$0\"", fifoPath]) {std_in = CreatePipe}
       $ \(Just h) _ _ _ -> do
         hSetBuffering h LineBuffering
-        body h
\ No newline at end of file
+        body h