Permalink
Browse files

Alsa plugin: Cancel reader thread (to terminate alsactl) when plugin …

…main thread exits.
  • Loading branch information...
DanielSchuessler committed Aug 31, 2018
1 parent b9a1818 commit e4bcc59790b4c1650a891c6a4c25e528689c44ac
Showing with 107 additions and 109 deletions.
  1. +49 −51 src/Plugins/Monitors/Alsa.hs
  2. +58 −58 test/Plugins/Monitors/AlsaSpec.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
@@ -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
body h

0 comments on commit e4bcc59

Please sign in to comment.