path: root/trivmix/Trivmix.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}

import Foreign.C.Types (CFloat(..))
import qualified Sound.JACK as Jack
import qualified Sound.JACK.Audio as Audio

import Options.Applicative hiding (str)

import Data.Maybe

import System.Directory
import System.FilePath
import System.Posix.Files
import System.Posix.IO
import System.Posix.Types
import System.Environment
import System.Process

import System.Systemd.Daemon (notifyReady, notifyWatchdog)

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.Chan

import qualified Control.Monad.Trans.Class as Trans
import qualified Control.Monad.Exception.Synchronous as Sync

import Control.Exception
import System.IO.Error
import System.IO
import System.Exit
import System.Console.Concurrent

import System.FileLock
import System.INotify

import Data.Monoid
import Data.Char
import Data.Function

import Control.Monad

import Text.Heredoc (str)

import Refined
  
import Data.Scientific
import Trivmix.Types

data Options = Options
               { input :: String
               , output :: String
               , client :: String
               , initialLevel :: Level
               , initialBalance :: Balance
               , fps, interval, watchdogInterval :: Scientific
               , run :: [FilePath]
               , balanceFiles :: [FilePath]
               , levelFiles :: [FilePath]
               }

optionParser :: Parser Options
optionParser = Options
               <$> strOption ( long "input"
                               <> metavar "STRING"
                               <> value "in"
                               <> showDefault
                               <> help "Name of the input port"
                             )
               <*> strOption ( long "output"
                                <> metavar "STRING"
                                <> value "out"
                                <> showDefault
                                <> help "Name of the output port"
                              )
               <*> strOption ( long "client"
                               <> metavar "STRING"
                               <> help "Client name to use in jack (the part before the colon in port names)"
                             )
               <*> option auto ( long "level"
                               <> metavar "LEVEL"
                               <> help "Initial value for level"
                               <> value def
                               <> showDefault
                               )
               <*> option auto ( long "initial-balance"
                              <> metavar "BALANCE"
                              <> help "Initial value for balance"
                              <> value def
                              <> showDefault
                               )
               <*> option auto ( long "fps"
                              <> metavar "NUMBER"
                              <> help "Update level ‘NUMBER’ times per second"
                              <> value 200
                              <> showDefault
                               )
               <*> option auto ( long "interval"
                              <> metavar "NUMBER"
                              <> help "Smooth level transitions over ‘NUMBER’ seconds"
                              <> value 0.2
                              <> showDefault
                               )
               <*> option auto ( long "watchdog"
                              <> metavar "NUMBER"
                              <> help "Signal watchdog every ’NUMBER’ seconds"
                              <> value 1
                              <> showDefault
                               )
               <*> many ( strOption ( long "run"
                                   <> metavar "FILE"
                                   <> help [str|Execute a file once setup of jacks is done (use this to autoconnect)
                                               |The executable gets passed the input port (including client name) as its first argument and the output as its second.
                                               |]
                                    )
                        )
               <*> many ( strOption  ( long "balance"
                                    <> metavar "FILE"
                                    <> help [str|Files that contain factors in the interval [0,1] to multiply with each other and the current level.
                                                |For deterministic behaviour use flock(2).
                                                |The format used in these files is a float using ‘.’ as a decimal point.
                                                |]
                                     )
                        )
               <*> many (strArgument ( metavar "FILE..."
                                       <> help [str|Files that contain levels to assume and synchronize
                                                   |For deterministic behaviour use flock(2).
                                                   |The format used in these files is either a signed float, using ‘.’ as a decimal point or a signed float postfixed with ‘dB’.
                                                   |Caveat: ‘-InfinitydB’ exists and works as expected (i.e.: it is equal to ‘0.0’)
                                                   |]
                                     )
                        )

watchedAttrs :: [EventVariety]
watchedAttrs = [ Modify
               , Move
               , MoveIn
               , MoveOut
               , MoveSelf
               , Create
               , Delete
               , DeleteSelf
               ]

defFileMode :: FileMode
defFileMode = foldl unionFileModes nullFileMode [ ownerReadMode
                                                , ownerWriteMode
                                                , groupReadMode
                                                , groupWriteMode
                                                , otherReadMode
                                                ]

defDirectoryMode :: FileMode
defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes
                                                     , groupReadMode
                                                     , groupExecuteMode
                                                     , otherReadMode
                                                     , otherExecuteMode
                                                     ]
main :: IO ()
main = withConcurrentOutput $ execParser opts >>= trivmix
  where
    opts = info (helper <*> optionParser)
           ( fullDesc
             <> progDesc "Setup a JACK mixing input/output pair controlled by files"
             <> header "Trivmix - A trivial mixer"
           )

trivmix :: Options -> IO ()
trivmix Options{..} = do
  level <- newMVar initialLevel
  balance <- newMVar initialBalance
  level' <- newMVar 0
  let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles
                              ++ map (\f -> onStateFile f (show initialBalance ++ "\n")) balanceFiles
  withFiles $ withINotify $ \inotify -> do
    handleFiles inotify level levelFiles
    handleFiles inotify balance balanceFiles
    Jack.handleExceptions $
      Jack.withClientDefault client $ \client' ->
      Jack.withPort client' input $ \input' ->
      Jack.withPort client' output $ \output' ->
      Audio.withProcessMono client' input' (mix level') output' $
        Jack.withActivation client' . Trans.lift $ do
          forM_ run $ \script ->
            (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> errorConcurrent $ script ++ " failed: " ++ show (code :: ExitCode) ++ "\n")
          forkIO . forever $ do -- Smooth out discontinuity
            let
              frames = interval * fps
              delay = round $ recip fps * 1e6
              linInt x a b = a * (1 - x) + b * x
              linInt' x a b = either error id $ asScientific (linInt x) a b
              mulBalance (bToScientific -> b) x = either error id $ asScientific (*) (Lin . either error id $ refine b) x
            newLevel <- mulBalance <$> readMVar balance <*> readMVar level
            currentLevel <- (\(CFloat f) -> Lin . either error id . refine $ realToFrac f) <$> readMVar level'
            case compare currentLevel newLevel of
              EQ -> threadDelay . round $ interval * 1e6
              _  -> do
                mapM_ (\x -> (swapMVar level' $! toRealFloat . unrefine . toLin $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0)
                errorConcurrent $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’.\n"
          notifyReady
          forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog

mix :: MVar CFloat -> CFloat -> IO CFloat
mix level input = (input *) <$> readMVar level

handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> [FilePath] -> IO ()
handleFiles inotify level files = do
  initLevel <- readMVar level
  levelChanges <- newChan
  let 
    handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file)
  mapM_ handleFile files
  forkIO $ forever $ do -- Broadcast level changes and update all files
    levelState <- readChan levelChanges
    swapMVar level levelState
    mapM_ (\f -> writeLevel f levelState) files
    return ()
  return ()

onStateFile :: FilePath -> String -> IO a -> IO a
onStateFile file initial action = do
  let directory = takeDirectory file
      directories = iterate takeDirectory directory
  createDirs <- takeWhileM (\d -> not <$> doesDirectoryExist d) directories
  exists <- doesFileExist file
  setFileCreationMask nullFileMode
  let acquireFile = case exists of
        True -> return ()
        False -> do
          errorConcurrent $ "Creating ‘" ++ file ++ "’ (file)\n"
          createFile file defFileMode >>= closeFd >> writeFile file initial
      releaseFile = case exists of
        True -> return ()
        False -> do
          errorConcurrent $ "Removing ‘" ++ file ++ "’ (file)\n"
          removeFile file
      acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do
          errorConcurrent $ "Creating ‘" ++ directory ++ "’ (dir)\n"
          createDirectory directory
          setFileMode directory defDirectoryMode
      releaseDir = (flip mapM) createDirs $ \directory -> do
          errorConcurrent $ "Removing ‘" ++ directory ++ "’ (dir)\n"
          removeDirectory directory
      acquire = acquireDir >> acquireFile
      release = releaseFile >> releaseDir
  bracket_ acquire release action

takeWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a]
takeWhileM _ [] = return []
takeWhileM pred (x:xs) = do
  take <- pred x
  case take of
    True -> do
      rest <- takeWhileM pred xs
      return $ x:rest
    False -> do
      return []

readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> IO ()
readLevel levelChan current file = catch action handler
  where
    action = do
      level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace
      oldLevel <- readMVar current
      when (oldLevel /= level) $ do
        writeChan levelChan level
        errorConcurrent $ "Detected new level ‘" ++ show level ++ "’.\n"
    handler e = if isUserError e
                then do
                  errorConcurrent $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting.\n"
                  readMVar current >>= writeLevel file
                else throw e
    stripSpace = reverse . stripSpace' . reverse . stripSpace'
    stripSpace' [] = []
    stripSpace' l@(x:xs) = if isSpace x
                          then stripSpace' xs
                          else l

writeLevel :: Show l => FilePath -> l -> IO ()
writeLevel file level = withFileLock file Exclusive $ const $ do
  errorConcurrent $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’.\n"
  writeFile file (show level ++ "\n")