path: root/src/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           Data.CaseInsensitive  ( CI )
import qualified Data.CaseInsensitive as CI

data Options = Options
               { input :: String
               , output :: String
               , client :: String
               , run :: Maybe String
               , levelFiles :: [FilePath]
               }

data Level = Lin Float | DB Float

instance Show Level where
  show (Lin x) = show x
  show (DB x) = (show x') ++ "dB"
    where
      x' = 20 * (logBase 10 x)

instance Read Level where
  readsPrec i = map toL . readsPrec i
    where
      toL :: (Float, String) -> (Level, String)
      toL (f, str)
        | ((==) `on` CI.mk) prec unit = (DB $ 10 ** (0.05 * f), rest)
        | otherwise = (Lin f, str)
        where
          prec = take lU str
          rest = drop lU str
          unit = "dB"
          lU = length unit

instance Eq Level where
  (Lin a) == (Lin b) = a == b
  (Lin a) == (DB b) = a == b
  (DB a) == (Lin b) = a == b
  (DB a) == (DB b) = a == b

optionParser :: Parser Options
optionParser = Options <$>
               (fromMaybe "in" <$> optional (strOption ( long "input"
                                                         <> metavar "STRING"
                                                       )
                                            )
               )
               <*> (fromMaybe "out" <$> optional (strOption ( long "output"
                                                              <> metavar "STRING"
                                                            )
                                                 )
                   )
               <*> strOption ( long "client"
                               <> metavar "STRING"
                             )
               <*> optional ( strOption ( long "run"
                                          <> metavar "FILE"
                                        )
                            )
               <*> some (strArgument ( metavar "FILE..."
                                       <> help "Files that contain levels to assume and synchronize"
                                     )
                        )

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

initialLevel :: Level
initialLevel = Lin 0

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

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

trivmix :: Options -> IO ()
trivmix Options{..} = do
  level <- newMVar initialLevel
  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' $ Trans.lift Jack.waitForBreak

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

handleFiles :: INotify -> MVar Level -> [FilePath] -> IO ()
handleFiles inotify level files = do
  initLevel <- readMVar level
  levelChanges <- (newChan :: IO (Chan Level))
  stderrLock <- newMVar
  let 
    handleFile file = do
      levelChanges' <- dupChan levelChanges
      forkIO $ forever $ do -- Broadcast level changes and update all files
        readChan levelChanges' >>= writeLevel file stderrLock
      addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock)
  mapM handleFile files
  forkIO $ forever $ do
    readChan levelChanges >>= swapMVar level
    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
  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 $ 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 $ 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)