path: root/trivmix/Trivmix.hs

{-# LANGUAGE RecordWildCards #-}

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

import Options.Applicative

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 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.FileLock
import System.INotify

import Data.Char
import Data.Function

import Control.Monad
  
import Trivmix.Types

data Options = Options
               { input :: String
               , output :: String
               , client :: String
               , run :: Maybe String
               , 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)"
                             )
               <*> optional ( strOption ( long "run"
                                          <> metavar "FILE"
                                          <> help "Execute a file once setup of jacks is done (use this to autoconnect)\nThe executable gets passed the input port (including client name) as its first argument and the output as its second."
                                        )
                            )
               <*> some (strArgument ( metavar "FILE..."
                                       <> help "Files that contain levels to assume and synchronize\nFor deterministic behaviour use flock(2).\nThe format used in these files is either a signed float, using ‘.’ as a decimal point or a signed float postfixed with ‘dB’.\nCaveat: ‘-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
               ]

initialLevel :: Level
initialLevel = def

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 = 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
  level' <- newMVar initialLevel
  forkIO $ forever $ do -- Smooth out discontinuity
    let
      fps = 200
      interval = 0.2
      frames = interval * fps
      delay = round $ recip fps * 10e6
      linInt x a b = a * (1 - x) + b * x
    newLevel <- readMVar level
    currentLevel <- readMVar level'
    mapM_ (\x -> swapMVar level' (asFloat (linInt x) currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float])
  let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles
  withFiles $ withINotify $ \inotify -> do
    handleFiles inotify level levelFiles
    Jack.handleExceptions $
      Jack.withClientDefault client $ \client' ->
      Jack.withPort client' input $ \input' ->
      Jack.withPort client' output $ \output' -> do
        Trans.lift $ do
          case run of
            Nothing -> return ()
            Just run' -> do
              (_, _, _, ph) <- createProcess $ (proc run' [client ++ ":" ++ input, client ++ ":" ++ output]) { delegate_ctlc = True }
              return ()
        Audio.withProcessMono client' input' (mix level') output' $
          Jack.withActivation client' . forever . Trans.lift $ threadDelay 1000000

mix :: MVar Level -> CFloat -> IO CFloat
mix level input = do
  level' <- readMVar level
  return $ (CFloat $ toFloat level') * input

handleFiles :: INotify -> MVar Level -> [FilePath] -> IO ()
handleFiles inotify level files = do
  initLevel <- readMVar level
  levelChanges <- (newChan :: IO (Chan Level))
  stderrLock <- newEmptyMVar
  let 
    handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock)
  mapM_ handleFile files
  forkIO $ forever $ do -- Broadcast level changes and update all files
    levelState <- readChan levelChanges
    swapMVar level levelState
    mapM_ (\f -> writeLevel f stderrLock 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
          hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)"
          createFile file defFileMode >>= closeFd >> writeFile file initial
      releaseFile = case exists of
        True -> return ()
        False -> do
          hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)"
          removeFile file
      acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do
          hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)"
          createDirectory directory
          setFileMode directory defDirectoryMode
      releaseDir = (flip mapM) createDirs $ \directory -> do
          hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)"
          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 :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO ()
readLevel levelChan current file stderrLock = 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
        withMVarLock stderrLock $ 
          hPutStrLn stderr $ "Detected new level: " ++ (show level)
    handler e = if isUserError e
                then do
                  withMVarLock stderrLock $ 
                    hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting."
                  readMVar current >>= writeLevel file stderrLock
                else throw e
    stripSpace = reverse . stripSpace' . reverse . stripSpace'
    stripSpace' [] = []
    stripSpace' l@(x:xs) = if isSpace x
                          then stripSpace' xs
                          else l

writeLevel :: FilePath -> MVar () -> Level -> IO ()
writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do
  withMVarLock stderrLock $ 
    hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’"
  writeFile file (show level ++ "\n")

withMVarLock :: MVar () -> IO a -> IO a
withMVarLock lock = bracket_ (putMVar lock ()) (takeMVar lock)