From 4658cc95745dbdffd7bc1be2e61fa463b28b4a16 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Jun 2015 19:40:40 +0200 Subject: Added adjmix --- src/Trivmix.hs | 257 --------------------------------------------------------- 1 file changed, 257 deletions(-) delete mode 100644 src/Trivmix.hs (limited to 'src/Trivmix.hs') diff --git a/src/Trivmix.hs b/src/Trivmix.hs deleted file mode 100644 index 37ecec6..0000000 --- a/src/Trivmix.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# 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.Fixed - -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 - -withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b -withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p') - -withType :: (p a -> f a) -> f a -withType f = f undefined - -withResolution :: (HasResolution a) => (Integer -> f a) -> f a -withResolution f = withType (f . resolution) - -instance Show Level where - show (Lin x) = show x - show (DB x) = (show $ (withPrec x' :: Milli)) ++ "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 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 - 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 <- 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