-----------------------------------------------------------------------------
-- |
-- 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 :: NominalDiffTime
alsaCtlRestartRateLimit = NominalDiffTime
3 -- 'Num NominalDiffTime' assumes seconds

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) }

-- | Drop generic Monitor args first, then apply 'parseOptsWith' in order to
-- parse everything.
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
        -- 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 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

    -- Throw on this thread if there's an exception
    -- on the reader thread.
    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 () -- Refresh immediately after restarting alsactl

          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') $
              -- 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 <- NominalDiffTime -> IO (IO ())
createRateLimiter NominalDiffTime
alsaCtlRestartRateLimit

    forever $ do
      limiter

      catchJust
        (guard . isEOFError)
        runAlsaOnce
        pure

      outputCallback "Restarting alsactl..."



-- This is necessarily very inefficient on 'String's
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

-- |
-- 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 :: 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))