{-# LANGUAGE PatternGuards #-}
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 Data.IORef
import Data.Maybe (fromJust)
import Data.Time.Clock
import Xmobar.Plugins.Monitors.Common
import qualified Xmobar.Plugins.Monitors.Volume as Volume;
import System.Console.GetOpt
import System.Directory
import System.Exit
import System.IO
import System.IO.Error
import System.Process
alsaCtlRestartRateLimit :: NominalDiffTime
alsaCtlRestartRateLimit :: NominalDiffTime
alsaCtlRestartRateLimit = NominalDiffTime
3
data AlsaOpts = AlsaOpts
{ AlsaOpts -> VolumeOpts
aoVolumeOpts :: Volume.VolumeOpts
, AlsaOpts -> Maybe FilePath
aoAlsaCtlPath :: Maybe FilePath
}
defaultOpts :: AlsaOpts
defaultOpts :: AlsaOpts
defaultOpts = VolumeOpts -> Maybe FilePath -> AlsaOpts
AlsaOpts VolumeOpts
Volume.defaultOpts Maybe FilePath
forall a. Maybe a
Nothing
alsaCtlOptionName :: String
alsaCtlOptionName :: FilePath
alsaCtlOptionName = FilePath
"alsactl"
options :: [OptDescr (AlsaOpts -> AlsaOpts)]
options :: [OptDescr (AlsaOpts -> AlsaOpts)]
options =
FilePath
-> [FilePath]
-> ArgDescr (AlsaOpts -> AlsaOpts)
-> FilePath
-> OptDescr (AlsaOpts -> AlsaOpts)
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option FilePath
"" [FilePath
alsaCtlOptionName] ((FilePath -> AlsaOpts -> AlsaOpts)
-> FilePath -> ArgDescr (AlsaOpts -> AlsaOpts)
forall a. (FilePath -> a) -> FilePath -> ArgDescr a
ReqArg (\FilePath
x AlsaOpts
o ->
AlsaOpts
o { aoAlsaCtlPath = Just x }) FilePath
"") FilePath
""
OptDescr (AlsaOpts -> AlsaOpts)
-> [OptDescr (AlsaOpts -> AlsaOpts)]
-> [OptDescr (AlsaOpts -> AlsaOpts)]
forall a. a -> [a] -> [a]
: (OptDescr (VolumeOpts -> VolumeOpts)
-> OptDescr (AlsaOpts -> AlsaOpts))
-> [OptDescr (VolumeOpts -> VolumeOpts)]
-> [OptDescr (AlsaOpts -> AlsaOpts)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((VolumeOpts -> VolumeOpts) -> AlsaOpts -> AlsaOpts)
-> OptDescr (VolumeOpts -> VolumeOpts)
-> OptDescr (AlsaOpts -> AlsaOpts)
forall a b. (a -> b) -> OptDescr a -> OptDescr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VolumeOpts -> VolumeOpts) -> AlsaOpts -> AlsaOpts
modifyVolumeOpts) [OptDescr (VolumeOpts -> VolumeOpts)]
Volume.options
where
modifyVolumeOpts :: (VolumeOpts -> VolumeOpts) -> AlsaOpts -> AlsaOpts
modifyVolumeOpts VolumeOpts -> VolumeOpts
f AlsaOpts
o = AlsaOpts
o { aoVolumeOpts = f (aoVolumeOpts o) }
parseOptsIncludingMonitorArgs :: [String] -> IO AlsaOpts
parseOptsIncludingMonitorArgs :: [FilePath] -> IO AlsaOpts
parseOptsIncludingMonitorArgs [FilePath]
args =
case ArgOrder Any
-> [OptDescr Any] -> [FilePath] -> ([Any], [FilePath], [FilePath])
forall a.
ArgOrder a
-> [OptDescr a] -> [FilePath] -> ([a], [FilePath], [FilePath])
getOpt ArgOrder Any
forall a. ArgOrder a
Permute [] [FilePath]
args of
([Any]
_, [FilePath]
args', [FilePath]
_) -> [OptDescr (AlsaOpts -> AlsaOpts)]
-> AlsaOpts -> [FilePath] -> IO AlsaOpts
forall opts.
[OptDescr (opts -> opts)] -> opts -> [FilePath] -> IO opts
parseOptsWith [OptDescr (AlsaOpts -> AlsaOpts)]
options AlsaOpts
defaultOpts [FilePath]
args'
startAlsaPlugin :: String -> String -> [String] -> (String -> IO ()) -> IO ()
startAlsaPlugin :: FilePath -> FilePath -> [FilePath] -> (FilePath -> IO ()) -> IO ()
startAlsaPlugin FilePath
mixerName FilePath
controlName [FilePath]
args FilePath -> IO ()
cb = do
opts <- [FilePath] -> IO AlsaOpts
parseOptsIncludingMonitorArgs [FilePath]
args
let run [FilePath]
args2 = do
opts2 <- IO AlsaOpts -> Monitor AlsaOpts
forall a. IO a -> Monitor a
io (IO AlsaOpts -> Monitor AlsaOpts)
-> IO AlsaOpts -> Monitor AlsaOpts
forall a b. (a -> b) -> a -> b
$ [OptDescr (AlsaOpts -> AlsaOpts)]
-> AlsaOpts -> [FilePath] -> IO AlsaOpts
forall opts.
[OptDescr (opts -> opts)] -> opts -> [FilePath] -> IO opts
parseOptsWith [OptDescr (AlsaOpts -> AlsaOpts)]
options AlsaOpts
defaultOpts [FilePath]
args2
Volume.runVolumeWith (aoVolumeOpts opts2) mixerName controlName
withMonitorWaiter mixerName (aoAlsaCtlPath opts) cb $ \IO ()
wait_ ->
[FilePath]
-> IO MConfig
-> ([FilePath] -> ReaderT MConfig IO FilePath)
-> IO ()
-> (FilePath -> IO ())
-> IO ()
runMB [FilePath]
args IO MConfig
Volume.volumeConfig [FilePath] -> ReaderT MConfig IO FilePath
run IO ()
wait_ FilePath -> IO ()
cb
withMonitorWaiter :: String -> Maybe FilePath -> (String -> IO ()) -> (IO () -> IO a) -> IO a
withMonitorWaiter :: forall a.
FilePath
-> Maybe FilePath -> (FilePath -> IO ()) -> (IO () -> IO a) -> IO a
withMonitorWaiter FilePath
mixerName Maybe FilePath
alsaCtlPathOverride FilePath -> IO ()
outputCallback IO () -> IO a
cont = do
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
effectivePath <- determineAlsaCtlPath
bracket (async $ alsaReaderThread mixerName effectivePath outputCallback mvar) cancel $ \Async Any
a -> do
Async Any -> IO ()
forall a. Async a -> IO ()
link Async Any
a
IO () -> IO a
cont (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar
where
defaultPath :: FilePath
defaultPath = FilePath
"/usr/sbin/alsactl"
determineAlsaCtlPath :: IO FilePath
determineAlsaCtlPath =
case Maybe FilePath
alsaCtlPathOverride of
Just FilePath
path -> do
found <- FilePath -> IO Bool
doesFileExist FilePath
path
if found
then pure path
else throwIO . ErrorCall $
"Specified alsactl file " ++ path ++ " does not exist"
Maybe FilePath
Nothing -> do
(ec, path, err) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"which" [FilePath
"alsactl"] FilePath
""
unless (null err) $ hPutStrLn stderr err
case ec of
ExitCode
ExitSuccess -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
trimTrailingNewline FilePath
path
ExitFailure Int
_ -> do
found <- FilePath -> IO Bool
doesFileExist FilePath
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"
alsaReaderThread :: String -> String -> (String -> IO a) -> MVar () -> IO b
alsaReaderThread :: forall a b.
FilePath -> FilePath -> (FilePath -> IO a) -> MVar () -> IO b
alsaReaderThread FilePath
mixerName FilePath
alsaCtlPath FilePath -> IO a
outputCallback MVar ()
mvar =
let createProc :: CreateProcess
createProc = (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"stdbuf" [FilePath
"-oL", FilePath
alsaCtlPath, FilePath
"monitor", FilePath
mixerName])
{std_out = CreatePipe}
runAlsaOnce :: IO a
runAlsaOnce =
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
createProc ((Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a)
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
out Maybe Handle
_ ProcessHandle
_ -> do
let alsaOut :: Handle
alsaOut = Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
out
Handle -> BufferMode -> IO ()
hSetBuffering Handle
alsaOut BufferMode
LineBuffering
MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
mvar ()
IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ do
c <- Handle -> IO Char
hGetChar Handle
alsaOut
when (c == '\n') $
void $ tryPutMVar mvar ()
in do
limiter <- NominalDiffTime -> IO (IO ())
createRateLimiter NominalDiffTime
alsaCtlRestartRateLimit
forever $ do
limiter
catchJust
(guard . isEOFError)
runAlsaOnce
pure
outputCallback "Restarting alsactl..."
trimTrailingNewline :: String -> String
trimTrailingNewline :: FilePath -> FilePath
trimTrailingNewline FilePath
x =
case FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
x of
Char
'\n' : Char
'\r' : FilePath
y -> FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
y
Char
'\n' : FilePath
y -> FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
y
FilePath
_ -> FilePath
x
createRateLimiter :: NominalDiffTime -> IO (IO ())
createRateLimiter :: NominalDiffTime -> IO (IO ())
createRateLimiter NominalDiffTime
interval = do
prevTimeRef <- Maybe UTCTime -> IO (IORef (Maybe UTCTime))
forall a. a -> IO (IORef a)
newIORef Maybe UTCTime
forall a. Maybe a
Nothing
let
limiter = do
prevTime0 <- IORef (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a. IORef a -> IO a
readIORef IORef (Maybe UTCTime)
prevTimeRef
curTime <- getCurrentTime
case prevTime0 of
Just UTCTime
prevTime | NominalDiffTime
diff <- NominalDiffTime
interval NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- (UTCTime
curTime UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
prevTime),
NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0
-> do
NominalDiffTime -> IO ()
threadDelayNDT NominalDiffTime
diff
IORef (Maybe UTCTime) -> Maybe UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe UTCTime)
prevTimeRef (Maybe UTCTime -> IO ())
-> (UTCTime -> Maybe UTCTime) -> UTCTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> IO ()) -> IO UTCTime -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
Maybe UTCTime
_ -> IORef (Maybe UTCTime) -> Maybe UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe UTCTime)
prevTimeRef (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
curTime)
pure limiter
threadDelayNDT :: NominalDiffTime -> IO ()
threadDelayNDT :: NominalDiffTime -> IO ()
threadDelayNDT NominalDiffTime
ndt =
Int -> IO ()
threadDelay (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
ndt Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e6 :: Double))