summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Plugins/Monitors/Alsa.hs100
1 files changed, 49 insertions, 51 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