1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
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
|
