From 4658cc95745dbdffd7bc1be2e61fa463b28b4a16 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Jun 2015 19:40:40 +0200 Subject: Added adjmix --- trivmix/Trivmix.hs | 215 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 215 insertions(+) create mode 100644 trivmix/Trivmix.hs (limited to 'trivmix') diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs new file mode 100644 index 0000000..9f0cf22 --- /dev/null +++ b/trivmix/Trivmix.hs @@ -0,0 +1,215 @@ +{-# 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 <$> + (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 = def + +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 files" + <> 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 + +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 + 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) -- cgit v1.2.3