Added adjmix

1 files changed, 215 insertions, 0 deletions

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)