diff options
| -rw-r--r-- | readme.md | 8 | ||||
| -rw-r--r-- | src/Plugins/Monitors.hs | 2 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Volume.hs | 116 | ||||
| -rw-r--r-- | test/Plugins/Monitors/VolumeSpec.hs | 161 | ||||
| -rw-r--r-- | xmobar.cabal | 13 |
5 files changed, 295 insertions, 5 deletions
@@ -1063,6 +1063,14 @@ 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 diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs index 873130e..2fe7cc2 100644 --- a/src/Plugins/Monitors.hs +++ b/src/Plugins/Monitors.hs @@ -183,7 +183,7 @@ instance Exec Monitors where start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady #endif #ifdef ALSA - start (Volume m c a r) = runM a volumeConfig (runVolume m c) r + start (Volume m c a r) = startVolume m c a r #endif #ifdef MPRIS start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r diff --git a/src/Plugins/Monitors/Volume.hs b/src/Plugins/Monitors/Volume.hs index 39697f7..4974e5b 100644 --- a/src/Plugins/Monitors/Volume.hs +++ b/src/Plugins/Monitors/Volume.hs @@ -12,15 +12,30 @@ -- ----------------------------------------------------------------------------- -module Plugins.Monitors.Volume (runVolume, volumeConfig) where +module Plugins.Monitors.Volume + ( startVolume + , runVolume + , volumeConfig + , getMonitorWaiter + , parseOptsIncludingMonitorArgs + , VolumeOpts(refreshMode) + , RefreshMode(..) + ) where +import Commands (tenthSeconds) import Control.Applicative ((<$>)) -import Control.Monad ( liftM2, liftM3, mplus ) +import Control.Concurrent +import Control.Exception +import Control.Monad ( forever, liftM2, liftM3, mplus, void, when, unless ) 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: <volume>% <status>" @@ -35,8 +50,13 @@ 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] " @@ -46,8 +66,12 @@ 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 }) "") "" @@ -58,6 +82,8 @@ 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 @@ -183,3 +209,89 @@ 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/VolumeSpec.hs b/test/Plugins/Monitors/VolumeSpec.hs new file mode 100644 index 0000000..d724c21 --- /dev/null +++ b/test/Plugins/Monitors/VolumeSpec.hs @@ -0,0 +1,161 @@ +{-# 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 cb8f63f..6306677 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -44,7 +44,8 @@ test-suite XmobarTest Plugins.Monitors.Swap, Plugins.Monitors.Thermal, Plugins.Monitors.ThermalZone, Plugins.Monitors.Top, Plugins.Monitors.Uptime, - Plugins.Monitors.Bright, Plugins.Monitors.CatInt + Plugins.Monitors.Bright, Plugins.Monitors.CatInt, + Plugins.Monitors.VolumeSpec build-depends: base >= 4.9.1.0 && < 4.13, hspec == 2.*, @@ -62,7 +63,15 @@ test-suite XmobarTest mtl >= 2.1 && < 2.3, parsec == 3.1.*, parsec-numbers == 0.1.0, - stm >= 2.3 && < 2.6 + stm >= 2.3 && < 2.6, + temporary, + async + + if flag(with_alsa) || flag(all_extensions) + build-depends: alsa-mixer > 0.2.0.2 + build-depends: alsa-core == 0.5.* + other-modules: Plugins.Monitors.Volume + cpp-options: -DALSA source-repository head type: git |