diff options
| -rw-r--r-- | src/Plugins/Monitors/Alsa.hs | 100 | ||||
| -rw-r--r-- | test/Plugins/Monitors/AlsaSpec.hs | 116 |
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 |