From 31fa44e9aa4ba4d3db8688d785b766fd5e7cf8f1 Mon Sep 17 00:00:00 2001 From: Daniel Schüssler <933504+DanielSchuessler@users.noreply.github.com> Date: Sun, 26 Aug 2018 17:29:43 +0200 Subject: Turn the --monitor option to `Volume` into a new plugin `Alsa` instead See #360. --- readme.md | 23 ++++-- src/Plugins/Monitors.hs | 6 +- src/Plugins/Monitors/Alsa.hs | 149 +++++++++++++++++++++++++++++++++ src/Plugins/Monitors/Volume.hs | 121 +++------------------------ test/Plugins/Monitors/AlsaSpec.hs | 157 +++++++++++++++++++++++++++++++++++ test/Plugins/Monitors/VolumeSpec.hs | 161 ------------------------------------ xmobar.cabal | 12 ++- 7 files changed, 345 insertions(+), 284 deletions(-) create mode 100644 src/Plugins/Monitors/Alsa.hs create mode 100644 test/Plugins/Monitors/AlsaSpec.hs delete mode 100644 test/Plugins/Monitors/VolumeSpec.hs diff --git a/readme.md b/readme.md index b868091..3dc988a 100644 --- a/readme.md +++ b/readme.md @@ -1063,14 +1063,6 @@ more than one battery. - `--highd` _number_ High threshold for dB. Defaults to -5.0. - `--lowd` _number_ Low threshold for dB. Defaults to -30.0. - `--volume-icon-pattern` _string_ dynamic string for current volume in `volumeipat`. - - `--monitor[=/path/to/alsactl]` - - Use event-based refreshing via `alsactl monitor` instead of polling - (`RefreshRate` will be ignored). - - If no `/path/to/alsactl` is given, `alsactl` will be sought in your `PATH` - first, and failing that, at `/usr/sbin/alsactl` (this is its location on - Debian systems. `alsactl monitor` works as a non-root user despite living - in `/usr/sbin`.). - - `stdbuf` (from coreutils) must be (and most probably already is) in your `PATH`. - Variables that can be used with the `-t`/`--template` argument: `volume`, `volumebar`, `volumevbar`, `volumeipat`, `dB`, `status` - Note that `dB` might only return 0 on your system. This is known @@ -1080,6 +1072,21 @@ more than one battery. system. In addition, to activate this plugin you must pass `--flags="with_alsa"` during compilation. +### `Alsa Mixer Element Args` + +Like [Volume](#volume-mixer-element-args-refreshrate), but with the following differences: +- Uses event-based refreshing via `alsactl monitor` instead of polling, so it will refresh + instantly when there's a volume change, and won't use CPU until a change happens. +- Aliases to `alsa:` followed by the mixer name and element name separated by a colon. Thus, + `Alsa "default" "Master" []` can be used as `%alsa:default:Master%`. +- Additional options (after the `--`): + - `--alsactl=/path/to/alsactl` + - If this option is not specified, `alsactl` will be sought in your `PATH` + first, and failing that, at `/usr/sbin/alsactl` (this is its location on + Debian systems. `alsactl monitor` works as a non-root user despite living + in `/usr/sbin`.). +- `stdbuf` (from coreutils) must be (and most probably already is) in your `PATH`. + ### `MPD Args RefreshRate` - This monitor will only be compiled if you ask for it using the diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs index 2fe7cc2..08fd098 100644 --- a/src/Plugins/Monitors.hs +++ b/src/Plugins/Monitors.hs @@ -50,6 +50,7 @@ import Plugins.Monitors.Common (runMBD) #endif #ifdef ALSA import Plugins.Monitors.Volume +import Plugins.Monitors.Alsa #endif #ifdef MPRIS import Plugins.Monitors.Mpris @@ -90,6 +91,7 @@ data Monitors = Network Interface Args Rate #endif #ifdef ALSA | Volume String String Args Rate + | Alsa String String Args #endif #ifdef MPRIS | Mpris1 String Args Rate @@ -143,6 +145,7 @@ instance Exec Monitors where #endif #ifdef ALSA alias (Volume m c _ _) = m ++ ":" ++ c + alias (Alsa m c _) = "alsa:" ++ m ++ ":" ++ c #endif #ifdef MPRIS alias (Mpris1 _ _ _) = "mpris1" @@ -183,7 +186,8 @@ instance Exec Monitors where start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady #endif #ifdef ALSA - start (Volume m c a r) = startVolume m c a r + start (Volume m c a r) = runM a volumeConfig (runVolume m c) r + start (Alsa m c a) = startAlsaPlugin m c a #endif #ifdef MPRIS start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r diff --git a/src/Plugins/Monitors/Alsa.hs b/src/Plugins/Monitors/Alsa.hs new file mode 100644 index 0000000..ba8e100 --- /dev/null +++ b/src/Plugins/Monitors/Alsa.hs @@ -0,0 +1,149 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Alsa +-- Copyright : (c) 2018 Daniel Schüssler +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- Event-based variant of the Volume plugin. +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Alsa + ( startAlsaPlugin + , getMonitorWaiter + , parseOptsIncludingMonitorArgs + , AlsaOpts(aoAlsaCtlPath) + ) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Plugins.Monitors.Common +import Plugins.Monitors.Volume(volumeConfig, VolumeOpts, runVolumeWith) +import qualified Plugins.Monitors.Volume as Volume; +import System.Console.GetOpt +import System.Directory +import System.Exit +import System.IO +import System.Process + +data AlsaOpts = AlsaOpts + { aoVolumeOpts :: VolumeOpts + , aoAlsaCtlPath :: Maybe FilePath + } + +defaultOpts :: AlsaOpts +defaultOpts = AlsaOpts Volume.defaultOpts Nothing + +alsaCtlOptionName :: String +alsaCtlOptionName = "alsactl" + +options :: [OptDescr (AlsaOpts -> AlsaOpts)] +options = + Option "" [alsaCtlOptionName] (ReqArg (\x o -> + o { aoAlsaCtlPath = Just x }) "") "" + : fmap (fmap modifyVolumeOpts) Volume.options + where + modifyVolumeOpts f o = o { aoVolumeOpts = f (aoVolumeOpts o) } + +parseOpts :: [String] -> IO AlsaOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +parseOptsIncludingMonitorArgs :: [String] -> IO AlsaOpts +parseOptsIncludingMonitorArgs args = + -- Drop generic Monitor args first + case getOpt Permute [] args of + (_, args', _) -> parseOpts args' + +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, + -- GHC could in principle do it already since getOpt is pure, but + -- it would have to inline 'runMBD', 'doArgs' and 'parseOpts' to see + -- it, which probably isn't going to happen with the default + -- optimization settings). + opts2 <- io $ parseOpts args2 + runVolumeWith (aoVolumeOpts opts2) mixerName controlName + + runMB args volumeConfig run waitFunction cb + +getMonitorWaiter :: String -> Maybe FilePath -> IO (IO ()) +getMonitorWaiter mixerName alsaCtlPath = do + mvar <- newMVar Nothing :: IO (MVar (Maybe SomeException)) + + forkFinally (readerThread mvar) (putMVar mvar . either Just (const Nothing)) + + pure $ do + ei <- takeMVar mvar + case ei of + -- Propagate exceptions from reader thread + Just (SomeException ex) -> throwIO ex + Nothing -> pure () + + where + + readerThread mvar = do + path <- determineAlsaCtlPath + withCreateProcess + (proc "stdbuf" ["-oL", path, "monitor", mixerName]) {std_out = CreatePipe} + run + + where + + 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" + + + run _ ~(Just out) _ _ = do + hSetBuffering out LineBuffering + forever $ do + c <- hGetChar out + 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 + +-- This is necessarily very inefficient on 'String's +trimTrailingNewline :: String -> String +trimTrailingNewline x = + case reverse x of + '\n' : '\r' : y -> reverse y + '\n' : y -> reverse y + _ -> x diff --git a/src/Plugins/Monitors/Volume.hs b/src/Plugins/Monitors/Volume.hs index 4974e5b..5702137 100644 --- a/src/Plugins/Monitors/Volume.hs +++ b/src/Plugins/Monitors/Volume.hs @@ -13,29 +13,21 @@ ----------------------------------------------------------------------------- module Plugins.Monitors.Volume - ( startVolume - , runVolume + ( runVolume + , runVolumeWith , volumeConfig - , getMonitorWaiter - , parseOptsIncludingMonitorArgs - , VolumeOpts(refreshMode) - , RefreshMode(..) + , options + , defaultOpts + , VolumeOpts ) where -import Commands (tenthSeconds) import Control.Applicative ((<$>)) -import Control.Concurrent -import Control.Exception -import Control.Monad ( forever, liftM2, liftM3, mplus, void, when, unless ) +import Control.Monad ( liftM2, liftM3, mplus ) import Data.Traversable (sequenceA) import Plugins.Monitors.Common import Sound.ALSA.Mixer import qualified Sound.ALSA.Exception as AE import System.Console.GetOpt -import System.Directory -import System.Exit -import System.IO -import System.Process volumeConfig :: IO MConfig volumeConfig = mkMConfig "Vol: % " @@ -50,13 +42,8 @@ data VolumeOpts = VolumeOpts , highDbThresh :: Float , lowDbThresh :: Float , volumeIconPattern :: Maybe IconPattern - , refreshMode :: RefreshMode } -data RefreshMode = RefreshModePoll - | RefreshModeMonitor (Maybe FilePath) -- alsactl path - deriving(Eq,Show) - defaultOpts :: VolumeOpts defaultOpts = VolumeOpts { onString = "[on] " @@ -66,12 +53,8 @@ defaultOpts = VolumeOpts , highDbThresh = -5.0 , lowDbThresh = -30.0 , volumeIconPattern = Nothing - , refreshMode = RefreshModePoll } -monitorOptionName :: String -monitorOptionName = "monitor" - options :: [OptDescr (VolumeOpts -> VolumeOpts)] options = [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") "" @@ -82,8 +65,6 @@ options = , Option "c" ["offc"] (ReqArg (\x o -> o { offColor = Just x }) "") "" , Option "" ["volume-icon-pattern"] (ReqArg (\x o -> o { volumeIconPattern = Just $ parseIconPattern x }) "") "" - , Option "" [monitorOptionName] (OptArg (\x o -> - o { refreshMode = RefreshModeMonitor x }) "") "" ] parseOpts :: [String] -> IO VolumeOpts @@ -148,6 +129,10 @@ formatDb opts dbi = do runVolume :: String -> String -> [String] -> Monitor String runVolume mixerName controlName argv = do opts <- io $ parseOpts argv + runVolumeWith opts mixerName controlName + +runVolumeWith :: VolumeOpts -> String -> String -> Monitor String +runVolumeWith opts mixerName controlName = do (lo, hi, val, db, sw) <- io readMixer p <- liftMonitor $ liftM3 formatVol lo hi val b <- liftMonitor $ liftM3 formatVolBar lo hi val @@ -209,89 +194,3 @@ runVolume mixerName controlName argv = do getFormatSwitch opts (Just sw) = formatSwitch opts sw unavailable = getConfigValue naString - -parseOptsIncludingMonitorArgs :: [String] -> IO VolumeOpts -parseOptsIncludingMonitorArgs args = - -- Drop generic Monitor args first - case getOpt Permute [] args of - (_, args', _) -> parseOpts args' - -startVolume :: String -> String -> [String] -> Int -> (String -> IO ()) -> IO () -startVolume mixerName controlName args rate cb = do - opts <- parseOptsIncludingMonitorArgs args - - waitFunction <- - case refreshMode opts of - RefreshModePoll -> pure $ tenthSeconds rate - RefreshModeMonitor alsaCtlPath -> getMonitorWaiter mixerName alsaCtlPath - - runMB args volumeConfig (runVolume mixerName controlName) waitFunction cb - - -getMonitorWaiter :: String -> Maybe FilePath -> IO (IO ()) -getMonitorWaiter mixerName alsaCtlPath = do - mvar <- newMVar Nothing :: IO (MVar (Maybe SomeException)) - - forkFinally (readerThread mvar) (putMVar mvar . either Just (const Nothing)) - - pure $ do - ei <- takeMVar mvar - case ei of - -- Propagate exceptions from reader thread - Just (SomeException ex) -> throwIO ex - Nothing -> pure () - - where - - readerThread mvar = do - path <- determineAlsaCtlPath - withCreateProcess - (proc "stdbuf" ["-oL", path, "monitor", mixerName]) {std_out = CreatePipe} - run - - where - - 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 --" ++ - monitorOptionName ++ "=/path/to/alsactl" - - - run _ ~(Just out) _ _ = do - hSetBuffering out LineBuffering - forever $ do - c <- hGetChar out - 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 - --- This is necessarily very inefficient on 'String's -trimTrailingNewline :: String -> String -trimTrailingNewline x = - case reverse x of - '\n' : '\r' : y -> reverse y - '\n' : y -> reverse y - _ -> x diff --git a/test/Plugins/Monitors/AlsaSpec.hs b/test/Plugins/Monitors/AlsaSpec.hs new file mode 100644 index 0000000..a813c1d --- /dev/null +++ b/test/Plugins/Monitors/AlsaSpec.hs @@ -0,0 +1,157 @@ +{-# OPTIONS_GHC -Wall #-} +module Plugins.Monitors.AlsaSpec + ( main + , spec + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import Plugins.Monitors.Alsa +import System.FilePath +import System.IO +import System.IO.Temp +import System.Posix.Files +import System.Process +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Alsa.getWaitMonitor" $ + it "produces the expected timeline (using a fake alsactl)" + runFakeAlsactlTest + + describe "Alsa.parseOptsIncludingMonitorArgs" $ do + it "works with empty args" $ do + opts <- parseOptsIncludingMonitorArgs [] + aoAlsaCtlPath opts `shouldBe` Nothing + + it "parses --alsactl=foo" $ do + opts <- parseOptsIncludingMonitorArgs ["--", "--alsactl=foo"] + aoAlsaCtlPath opts `shouldBe` Just "foo" + + +runFakeAlsactlTest :: Expectation +runFakeAlsactlTest = + withSystemTempDirectory "xmobar-test" $ \tmpDir -> do + + let fifoPath = tmpDir "fifo" + fakeAlsactlPath = tmpDir "fake-alsactl" + + writeFile fakeAlsactlPath $ + unlines + [ "#!/bin/bash" + , "[[ $1 == monitor ]] || exit 99" + , "exec cat \"$2\"" + ] + + setFileMode fakeAlsactlPath ownerModes + + withFifoWriteHandle fifoPath $ \fifo -> do + + timeline <- newMVar [] :: IO (MVar [TimelineEntry]) + runVolumeCompleted <- newEmptyMVar :: IO (MVar Bool) -- True -> quit + waiterTaskIsRunning <- newEmptyMVar :: IO (MVar ()) + waiterTaskIsWaiting <- newEmptyMVar :: IO (MVar ()) + + waitFunc <- getMonitorWaiter fifoPath (Just fakeAlsactlPath) + + let addToTimeline e = modifyMVar_ timeline (pure . (e :)) + + 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" + + simulateRunVolumeCompleted = putNow runVolumeCompleted False + + quitWaiter = putNow runVolumeCompleted True + + waiterTaskMain = do + addToTimeline RunVolume + putNow waiterTaskIsRunning () + q <- takeMVar runVolumeCompleted + unless q $ do + addToTimeline Waiting + putNow waiterTaskIsWaiting () + waitFunc + + waiterTaskMain + + delay_ms = threadDelay . (* 1000) + + 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 + simulateRunVolumeCompleted + takeMVar waiterTaskIsWaiting + + emitEvent + takeMVar waiterTaskIsRunning + quitWaiter + + wait waiterTask + + 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] + +data TimelineEntry = EventEmitted | Waiting | RunVolume + deriving(Eq) + +instance Show TimelineEntry where + show x = + case x of + EventEmitted -> "E" + Waiting -> "W" + RunVolume -> "R" + + +withFifoWriteHandle :: FilePath -> (Handle -> IO b) -> IO b +withFifoWriteHandle fifoPath body = do + createNamedPipe fifoPath ownerModes + -- Can't seem to get the writing to the FIFO to work internally + withCreateProcess + (proc "bash" ["-c", "cat >> \"$0\"", fifoPath]) {std_in = CreatePipe} + $ \(Just h) _ _ _ -> do + hSetBuffering h LineBuffering + body h \ No newline at end of file diff --git a/test/Plugins/Monitors/VolumeSpec.hs b/test/Plugins/Monitors/VolumeSpec.hs deleted file mode 100644 index d724c21..0000000 --- a/test/Plugins/Monitors/VolumeSpec.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module Plugins.Monitors.VolumeSpec - ( main - , spec - ) where - -import Control.Concurrent -import Control.Concurrent.Async -import Control.Monad -import Plugins.Monitors.Volume -import System.FilePath -import System.IO -import System.IO.Temp -import System.Posix.Files -import System.Process -import Test.Hspec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "Volume.getWaitMonitor" $ - it "produces the expected timeline (using a fake alsactl)" $ - runFakeAlsactlTest - - describe "Volume.parseOptsIncludingMonitorArgs" $ do - it "works with empty args" $ do - opts <- parseOptsIncludingMonitorArgs [] - refreshMode opts `shouldBe` RefreshModePoll - - it "parses --monitor" $ do - opts <- parseOptsIncludingMonitorArgs ["--", "--monitor"] - refreshMode opts `shouldBe` RefreshModeMonitor Nothing - - it "parses --monitor=foo" $ do - opts <- parseOptsIncludingMonitorArgs ["--", "--monitor=foo"] - refreshMode opts `shouldBe` RefreshModeMonitor (Just "foo") - - -runFakeAlsactlTest :: Expectation -runFakeAlsactlTest = - withSystemTempDirectory "xmobar-test" $ \tmpDir -> do - - let fifoPath = tmpDir "fifo" - fakeAlsactlPath = tmpDir "fake-alsactl" - - writeFile fakeAlsactlPath $ - unlines - [ "#!/bin/bash" - , "[[ $1 == monitor ]] || exit 99" - , "exec cat \"$2\"" - ] - - setFileMode fakeAlsactlPath ownerModes - - withFifoWriteHandle fifoPath $ \fifo -> do - - timeline <- newMVar [] :: IO (MVar [TimelineEntry]) - runVolumeCompleted <- newEmptyMVar :: IO (MVar Bool) -- True -> quit - waiterTaskIsRunning <- newEmptyMVar :: IO (MVar ()) - waiterTaskIsWaiting <- newEmptyMVar :: IO (MVar ()) - - waitFunc <- getMonitorWaiter fifoPath (Just fakeAlsactlPath) - - let addToTimeline e = modifyMVar_ timeline (pure . (e :)) - - 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" - - simulateRunVolumeCompleted = putNow runVolumeCompleted False - - quitWaiter = putNow runVolumeCompleted True - - waiterTaskMain = do - addToTimeline RunVolume - putNow waiterTaskIsRunning () - q <- takeMVar runVolumeCompleted - unless q $ do - addToTimeline Waiting - putNow waiterTaskIsWaiting () - waitFunc - - waiterTaskMain - - delay_ms = threadDelay . (* 1000) - - 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 - simulateRunVolumeCompleted - takeMVar waiterTaskIsWaiting - - emitEvent - takeMVar waiterTaskIsRunning - quitWaiter - - wait waiterTask - - 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] - -data TimelineEntry = EventEmitted | Waiting | RunVolume - deriving(Eq) - -instance Show TimelineEntry where - show x = - case x of - EventEmitted -> "E" - Waiting -> "W" - RunVolume -> "R" - - -withFifoWriteHandle :: FilePath -> (Handle -> IO b) -> IO b -withFifoWriteHandle fifoPath body = do - createNamedPipe fifoPath ownerModes - -- Can't seem to get the writing to the FIFO to work internally - withCreateProcess - (proc "bash" ["-c", "cat >> \"$0\"", fifoPath]) {std_in = CreatePipe} - $ \(Just h) _ _ _ -> do - hSetBuffering h LineBuffering - body h \ No newline at end of file diff --git a/xmobar.cabal b/xmobar.cabal index 6306677..1a3684c 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -45,7 +45,8 @@ test-suite XmobarTest Plugins.Monitors.ThermalZone, Plugins.Monitors.Top, Plugins.Monitors.Uptime, Plugins.Monitors.Bright, Plugins.Monitors.CatInt, - Plugins.Monitors.VolumeSpec + Plugins.Monitors.CommonSpec + build-depends: base >= 4.9.1.0 && < 4.13, hspec == 2.*, @@ -69,8 +70,11 @@ test-suite XmobarTest if flag(with_alsa) || flag(all_extensions) build-depends: alsa-mixer > 0.2.0.2 - build-depends: alsa-core == 0.5.* + build-depends: alsa-core == 0.5.*, + process >= 1.4.3.0 other-modules: Plugins.Monitors.Volume + Plugins.Monitors.Alsa + Plugins.Monitors.AlsaSpec cpp-options: -DALSA source-repository head @@ -229,8 +233,10 @@ executable xmobar if flag(with_alsa) || flag(all_extensions) build-depends: alsa-mixer > 0.2.0.2 - build-depends: alsa-core == 0.5.* + build-depends: alsa-core == 0.5.*, + process >= 1.4.3.0 other-modules: Plugins.Monitors.Volume + Plugins.Monitors.Alsa cpp-options: -DALSA if flag(with_datezone) || flag(all_extensions) -- cgit v1.2.3