From fa869377b70fa0f36733b9b87ae1b6c2f51c251d Mon Sep 17 00:00:00 2001 From: jao Date: Wed, 21 Nov 2018 21:43:54 +0000 Subject: Plugins.Monitors.Alsa moved to Xmobar --- src/Plugins/Monitors/Alsa.hs | 147 ------------------------------------ src/Xmobar/Plugins/Monitors/Alsa.hs | 147 ++++++++++++++++++++++++++++++++++++ 2 files changed, 147 insertions(+), 147 deletions(-) delete mode 100644 src/Plugins/Monitors/Alsa.hs create mode 100644 src/Xmobar/Plugins/Monitors/Alsa.hs diff --git a/src/Plugins/Monitors/Alsa.hs b/src/Plugins/Monitors/Alsa.hs deleted file mode 100644 index 729042c..0000000 --- a/src/Plugins/Monitors/Alsa.hs +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - , withMonitorWaiter - , parseOptsIncludingMonitorArgs - , AlsaOpts(aoAlsaCtlPath) - ) where - -import Control.Concurrent -import Control.Concurrent.Async -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 - - 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 - - withMonitorWaiter mixerName (aoAlsaCtlPath opts) $ \wait_ -> - runMB args volumeConfig run wait_ cb - -withMonitorWaiter :: String -> Maybe FilePath -> (IO () -> IO a) -> IO a -withMonitorWaiter mixerName alsaCtlPath cont = do - mvar <- newMVar () - - path <- determineAlsaCtlPath - - bracket (async $ readerThread mvar path) cancel $ \a -> do - - -- Throw on this thread if there's an exception - -- on the reader thread. - link a - - cont $ takeMVar mvar - - where - - readerThread mvar path = - let createProc = (proc "stdbuf" ["-oL", path, "monitor", mixerName]) - {std_out = CreatePipe} - in - withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do - hSetBuffering alsaOut LineBuffering - - forever $ do - 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 () - - 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 -trimTrailingNewline x = - case reverse x of - '\n' : '\r' : y -> reverse y - '\n' : y -> reverse y - _ -> x diff --git a/src/Xmobar/Plugins/Monitors/Alsa.hs b/src/Xmobar/Plugins/Monitors/Alsa.hs new file mode 100644 index 0000000..c231303 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Alsa.hs @@ -0,0 +1,147 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.Alsa + ( startAlsaPlugin + , withMonitorWaiter + , parseOptsIncludingMonitorArgs + , AlsaOpts(aoAlsaCtlPath) + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Xmobar.Plugins.Monitors.Common +import Xmobar.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 + + 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 + + withMonitorWaiter mixerName (aoAlsaCtlPath opts) $ \wait_ -> + runMB args volumeConfig run wait_ cb + +withMonitorWaiter :: String -> Maybe FilePath -> (IO () -> IO a) -> IO a +withMonitorWaiter mixerName alsaCtlPath cont = do + mvar <- newMVar () + + path <- determineAlsaCtlPath + + bracket (async $ readerThread mvar path) cancel $ \a -> do + + -- Throw on this thread if there's an exception + -- on the reader thread. + link a + + cont $ takeMVar mvar + + where + + readerThread mvar path = + let createProc = (proc "stdbuf" ["-oL", path, "monitor", mixerName]) + {std_out = CreatePipe} + in + withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do + hSetBuffering alsaOut LineBuffering + + forever $ do + 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 () + + 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 +trimTrailingNewline x = + case reverse x of + '\n' : '\r' : y -> reverse y + '\n' : y -> reverse y + _ -> x -- cgit v1.2.3