Rewrite in haskell

1 files changed, 103 insertions, 0 deletions

diff --git a/src/Trivmix.hs b/src/Trivmix.hs
new file mode 100644
index 0000000..019ee32
--- /dev/null
+++ b/src/Trivmix.hs
@@ -0,0 +1,103 @@
+{-# 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.Environment
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+
+import qualified Control.Monad.Trans.Class as Trans
+
+import Control.Exception
+import System.IO.Error
+
+import System.INotify
+
+data Options = Options
+               { input :: String
+               , output :: String
+               , initialLevel :: Float
+               , stateDir :: FilePath
+               }
+
+optionParser :: Parser Options
+optionParser = Options <$>
+               strOption ( long "input"
+                           <> metavar "JACK"
+                         )
+               <*> strOption ( long "output"
+                               <> metavar "JACK"
+                             )
+               <*> (fromMaybe 0 <$> optional (option auto ( long "level"
+                                                            <> metavar "FLOAT"
+                                                          )
+                                             )
+                   )
+               <*> strOption ( long "dir"
+                               <> metavar "DIRECTORY"
+                             )
+
+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
+  name <- getProgName
+  createDirectoryIfMissing True stateDir
+  level <- newMVar initialLevel
+  let levelFile = stateDir </> "level"
+  onLevelFile levelFile initialLevel $ withINotify $ \n -> do
+    addWatch n [Modify] levelFile (const $ handleLevel level levelFile)
+    Jack.handleExceptions $
+      Jack.withClientDefault name $ \client ->
+      Jack.withPort client input $ \input' ->
+      Jack.withPort client output $ \output' ->
+      Audio.withProcessMono client input' (mix level) output' $
+      Jack.withActivation client $ Trans.lift $ do
+        Jack.waitForBreak
+  
+mix :: MVar Float -> CFloat -> IO CFloat
+mix level input = do
+  level' <- readMVar level
+  return $ (CFloat level') * input
+
+onLevelFile :: FilePath -> Float -> IO a -> IO a
+onLevelFile file initial action = do
+  exists <- doesFileExist file
+  let acquire = case exists of
+        True -> return ()
+        False -> createFile file mode >>= closeFd
+      mode = foldl unionFileModes nullFileMode [ ownerReadMode
+                                               , ownerWriteMode
+                                               , groupReadMode
+                                               , groupWriteMode
+                                               ]
+      release = case exists of
+        True -> return ()
+        False -> removeFile file
+  bracket_ acquire release action
+
+handleLevel :: MVar Float -> FilePath -> IO ()
+handleLevel level file = catch action handler
+  where
+    action = readFile file >>= readIO >>= swapMVar level >>= const (return ())
+    handler e = if isUserError e
+                then readMVar level >>= \l -> writeFile file (show l)
+                else throw e