path: root/src/Plugins/Monitors/Volume.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Plugins.Monitors.Volume
-- Copyright   :  (c) 2011, 2013, 2015 Thomas Tuegel
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A monitor for ALSA soundcards
--
-----------------------------------------------------------------------------

module Plugins.Monitors.Volume
  ( startVolume
  , runVolume
  , volumeConfig
  , getMonitorWaiter
  , parseOptsIncludingMonitorArgs
  , VolumeOpts(refreshMode)
  , RefreshMode(..)
  ) where

import Commands (tenthSeconds)
import Control.Applicative ((<$>))
import Control.Concurrent
import Control.Exception
import Control.Monad ( forever, liftM2, liftM3, mplus, void, when, unless )
import Data.Traversable (sequenceA)
import Plugins.Monitors.Common
import Sound.ALSA.Mixer
import qualified Sound.ALSA.Exception as AE
import System.Console.GetOpt
import System.Directory
import System.Exit
import System.IO
import System.Process

volumeConfig :: IO MConfig
volumeConfig = mkMConfig "Vol: <volume>% <status>"
                         ["volume", "volumebar", "volumevbar", "dB","status", "volumeipat"]


data VolumeOpts = VolumeOpts
    { onString :: String
    , offString :: String
    , onColor :: Maybe String
    , offColor :: Maybe String
    , highDbThresh :: Float
    , lowDbThresh :: Float
    , volumeIconPattern :: Maybe IconPattern
    , refreshMode :: RefreshMode
    }

data RefreshMode = RefreshModePoll
                 | RefreshModeMonitor (Maybe FilePath) -- alsactl path
                 deriving(Eq,Show)

defaultOpts :: VolumeOpts
defaultOpts = VolumeOpts
    { onString = "[on] "
    , offString = "[off]"
    , onColor = Just "green"
    , offColor = Just "red"
    , highDbThresh = -5.0
    , lowDbThresh = -30.0
    , volumeIconPattern = Nothing
    , refreshMode = RefreshModePoll
    }

monitorOptionName :: String
monitorOptionName = "monitor"

options :: [OptDescr (VolumeOpts -> VolumeOpts)]
options =
    [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") ""
    , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") ""
    , Option "" ["lowd"] (ReqArg (\x o -> o { lowDbThresh = read x }) "") ""
    , Option "" ["highd"] (ReqArg (\x o -> o { highDbThresh = read x }) "") ""
    , Option "C" ["onc"] (ReqArg (\x o -> o { onColor = Just x }) "") ""
    , Option "c" ["offc"] (ReqArg (\x o -> o { offColor = Just x }) "") ""
    , Option "" ["volume-icon-pattern"] (ReqArg (\x o ->
       o { volumeIconPattern = Just $ parseIconPattern x }) "") ""
    , Option "" [monitorOptionName] (OptArg (\x o ->
       o { refreshMode = RefreshModeMonitor x }) "") ""
    ]

parseOpts :: [String] -> IO VolumeOpts
parseOpts argv =
    case getOpt Permute options argv of
        (o, _, []) -> return $ foldr id defaultOpts o
        (_, _, errs) -> ioError . userError $ concat errs

percent :: Integer -> Integer -> Integer -> Float
percent v' lo' hi' = (v - lo) / (hi - lo)
  where v = fromIntegral v'
        lo = fromIntegral lo'
        hi = fromIntegral hi'

formatVol :: Integer -> Integer -> Integer -> Monitor String
formatVol lo hi v =
    showPercentWithColors $ percent v lo hi

formatVolBar :: Integer -> Integer -> Integer -> Monitor String
formatVolBar lo hi v =
    showPercentBar (100 * x) x where x = percent v lo hi

formatVolVBar :: Integer -> Integer -> Integer -> Monitor String
formatVolVBar lo hi v =
    showVerticalBar (100 * x) x where x = percent v lo hi

formatVolDStr :: Maybe IconPattern -> Integer -> Integer -> Integer -> Monitor String
formatVolDStr ipat lo hi v =
    showIconPattern ipat $ percent v lo hi

switchHelper :: VolumeOpts
             -> (VolumeOpts -> Maybe String)
             -> (VolumeOpts -> String)
             -> Monitor String
switchHelper opts cHelp strHelp = return $
    colorHelper (cHelp opts)
    ++ strHelp opts
    ++ maybe "" (const "</fc>") (cHelp opts)

formatSwitch :: VolumeOpts -> Bool -> Monitor String
formatSwitch opts True = switchHelper opts onColor onString
formatSwitch opts False = switchHelper opts offColor offString

colorHelper :: Maybe String -> String
colorHelper = maybe "" (\c -> "<fc=" ++ c ++ ">")

formatDb :: VolumeOpts -> Integer -> Monitor String
formatDb opts dbi = do
    h <- getConfigValue highColor
    m <- getConfigValue normalColor
    l <- getConfigValue lowColor
    d <- getConfigValue decDigits
    let db = fromIntegral dbi / 100.0
        digits = showDigits d db
        startColor | db >= highDbThresh opts = colorHelper h
                   | db < lowDbThresh opts = colorHelper l
                   | otherwise = colorHelper m
        stopColor | null startColor = ""
                  | otherwise = "</fc>"
    return $ startColor ++ digits ++ stopColor

runVolume :: String -> String -> [String] -> Monitor String
runVolume mixerName controlName argv = do
    opts <- io $ parseOpts argv
    (lo, hi, val, db, sw) <- io readMixer
    p <- liftMonitor $ liftM3 formatVol lo hi val
    b <- liftMonitor $ liftM3 formatVolBar lo hi val
    v <- liftMonitor $ liftM3 formatVolVBar lo hi val
    d <- getFormatDB opts db
    s <- getFormatSwitch opts sw
    ipat <- liftMonitor $ liftM3 (formatVolDStr $ volumeIconPattern opts) lo hi val
    parseTemplate [p, b, v, d, s, ipat]

  where

    readMixer =
      AE.catch (withMixer mixerName $ \mixer -> do
                   control <- getControlByName mixer controlName
                   (lo, hi) <- liftMaybe $ getRange <$> volumeControl control
                   val <- getVal $ volumeControl control
                   db <- getDB $ volumeControl control
                   sw <- getSw $ switchControl control
                   return (lo, hi, val, db, sw))
                (const $ return (Nothing, Nothing, Nothing, Nothing, Nothing))

    volumeControl :: Maybe Control -> Maybe Volume
    volumeControl c = (playback . volume =<< c)
              `mplus` (capture . volume =<< c)
              `mplus` (common . volume =<< c)

    switchControl :: Maybe Control -> Maybe Switch
    switchControl c = (playback . switch =<< c)
              `mplus` (capture . switch =<< c)
              `mplus` (common . switch =<< c)

    liftMaybe :: Maybe (IO (a,b)) -> IO (Maybe a, Maybe b)
    liftMaybe = fmap (liftM2 (,) (fmap fst) (fmap snd)) . sequenceA

    liftMonitor :: Maybe (Monitor String) -> Monitor String
    liftMonitor Nothing = unavailable
    liftMonitor (Just m) = m

    channel v r = AE.catch (getChannel FrontLeft v) (const $ return $ Just r)

    getDB :: Maybe Volume -> IO (Maybe Integer)
    getDB Nothing = return Nothing
    getDB (Just v) = channel (dB v) 0

    getVal :: Maybe Volume -> IO (Maybe Integer)
    getVal Nothing = return Nothing
    getVal (Just v) = channel (value v) 0

    getSw :: Maybe Switch -> IO (Maybe Bool)
    getSw Nothing = return Nothing
    getSw (Just s) = channel s False

    getFormatDB :: VolumeOpts -> Maybe Integer -> Monitor String
    getFormatDB _ Nothing = unavailable
    getFormatDB opts (Just d) = formatDb opts d

    getFormatSwitch :: VolumeOpts -> Maybe Bool -> Monitor String
    getFormatSwitch _ Nothing = unavailable
    getFormatSwitch opts (Just sw) = formatSwitch opts sw

    unavailable = getConfigValue naString

parseOptsIncludingMonitorArgs :: [String] -> IO VolumeOpts
parseOptsIncludingMonitorArgs args =
    -- Drop generic Monitor args first
    case getOpt Permute [] args of
      (_, args', _) -> parseOpts args'

startVolume :: String -> String -> [String] -> Int -> (String -> IO ()) -> IO ()
startVolume mixerName controlName args rate cb = do
  opts <- parseOptsIncludingMonitorArgs args

  waitFunction <-
    case refreshMode opts of
      RefreshModePoll -> pure $ tenthSeconds rate
      RefreshModeMonitor alsaCtlPath -> getMonitorWaiter mixerName alsaCtlPath

  runMB args volumeConfig (runVolume mixerName controlName) 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 --" ++
                         monitorOptionName ++ "=/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