summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/Plugins/Monitors/Alsa.hs
blob: 8d02931f8863642d91aedabb0ae48c0eaed27079 (plain)
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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
-----------------------------------------------------------------------------
-- |
-- Module      :  Plugins.Monitors.Alsa
-- Copyright   :  (c) 2018, 2024 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.
--
-----------------------------------------------------------------------------

{-# 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 = 3 -- 'Num NominalDiffTime' assumes seconds

data AlsaOpts = AlsaOpts
    { aoVolumeOpts :: Volume.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) }

-- | Drop generic Monitor args first, then apply 'parseOptsWith' in order to
-- parse everything.
parseOptsIncludingMonitorArgs :: [String] -> IO AlsaOpts
parseOptsIncludingMonitorArgs args =
    case getOpt Permute [] args of
        (_, args', _) -> parseOptsWith options defaultOpts 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 $ parseOptsWith options defaultOpts args2
        Volume.runVolumeWith (aoVolumeOpts opts2) mixerName controlName

  withMonitorWaiter mixerName (aoAlsaCtlPath opts) cb $ \wait_ ->
    runMB args Volume.volumeConfig run wait_ cb

withMonitorWaiter :: String -> Maybe FilePath -> (String -> IO ()) -> (IO () -> IO a) -> IO a
withMonitorWaiter mixerName alsaCtlPathOverride outputCallback cont = do
  mvar <- newMVar ()

  effectivePath <- determineAlsaCtlPath

  bracket (async $ alsaReaderThread mixerName effectivePath outputCallback mvar) cancel $ \a -> do

    -- Throw on this thread if there's an exception
    -- on the reader thread.
    link a

    cont $ takeMVar mvar

  where
    defaultPath = "/usr/sbin/alsactl"

    determineAlsaCtlPath =
      case alsaCtlPathOverride 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"


alsaReaderThread :: String -> String -> (String -> IO a) -> MVar () -> IO b
alsaReaderThread mixerName alsaCtlPath outputCallback mvar =
  let createProc = (proc "stdbuf" ["-oL", alsaCtlPath, "monitor", mixerName])
                      {std_out = CreatePipe}

      runAlsaOnce =
        withCreateProcess createProc $ \_ out _ _ -> do
          let alsaOut = fromJust out
          hSetBuffering alsaOut LineBuffering

          tryPutMVar mvar () -- Refresh immediately after restarting alsactl

          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 ()
  in do
    limiter <- createRateLimiter alsaCtlRestartRateLimit

    forever $ do
      limiter

      catchJust
        (guard . isEOFError)
        runAlsaOnce
        pure

      outputCallback "Restarting 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

-- |
-- Returns an IO action that completes at most once per @interval@.
-- The returned cation is not safe for concurrent use.
createRateLimiter :: NominalDiffTime -> IO (IO ())
createRateLimiter interval = do
  prevTimeRef <- newIORef Nothing

  let
    limiter = do
      prevTime0 <- readIORef prevTimeRef
      curTime <- getCurrentTime

      case prevTime0 of
        Just prevTime | diff <- interval - (curTime `diffUTCTime` prevTime),
                        diff > 0
                        -> do
                            threadDelayNDT diff
                            writeIORef prevTimeRef . Just =<< getCurrentTime

        _ -> writeIORef prevTimeRef (Just curTime)

  pure limiter

threadDelayNDT :: NominalDiffTime -> IO ()
threadDelayNDT ndt =
  threadDelay (round (realToFrac ndt * 1e6 :: Double))