summaryrefslogtreecommitdiffhomepage
path: root/src/Plugins/Monitors
diff options
context:
space:
mode:
Diffstat (limited to 'src/Plugins/Monitors')
-rw-r--r--src/Plugins/Monitors/Alsa.hs149
-rw-r--r--src/Plugins/Monitors/Volume.hs121
2 files changed, 159 insertions, 111 deletions
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 <jao@gnu.org>
+-- 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: <volume>% <status>"
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-20 18:11:09 +0000