From b11192d813bdf803011b4ea4cd3efead532d9b4c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 15 May 2018 22:36:52 +0200 Subject: Don't use manual locking --- package.yaml | 3 ++- trivmix.nix | 16 ++++++++-------- trivmix/Trivmix.hs | 54 ++++++++++++++++++++++++------------------------------ 3 files changed, 34 insertions(+), 39 deletions(-) diff --git a/package.yaml b/package.yaml index 8e5eb44..a9e8ddf 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: trivmix -version: 4.0.2 +version: 4.0.3 license: PublicDomain license-file: LICENSE author: Gregor Kleen @@ -40,6 +40,7 @@ executables: - heredoc >=0.2.0.0 && <1 - refined >=0.1.2.1 && <1 - scientific >=0.3.5.3 && <1 + - concurrent-output >=1.10.5 && <2 - trivmix adjmix: ghc-options: -threaded -O2 diff --git a/trivmix.nix b/trivmix.nix index 8aa59cc..690e184 100644 --- a/trivmix.nix +++ b/trivmix.nix @@ -1,11 +1,11 @@ -{ mkDerivation, base, case-insensitive, data-default, directory -, explicit-exception, filelock, filepath, heredoc, hinotify, hpack -, jack, optparse-applicative, process, refined, scientific, stdenv -, systemd, th-lift, transformers, unix +{ mkDerivation, base, case-insensitive, concurrent-output +, data-default, directory, explicit-exception, filelock, filepath +, heredoc, hinotify, hpack, jack, optparse-applicative, process +, refined, scientific, stdenv, systemd, th-lift, transformers, unix }: mkDerivation { pname = "trivmix"; - version = "4.0.2"; + version = "4.0.3"; src = ./.; isLibrary = true; isExecutable = true; @@ -14,9 +14,9 @@ mkDerivation { ]; libraryToolDepends = [ hpack ]; executableHaskellDepends = [ - base directory explicit-exception filelock filepath heredoc - hinotify jack optparse-applicative process refined scientific - systemd transformers unix + base concurrent-output directory explicit-exception filelock + filepath heredoc hinotify jack optparse-applicative process refined + scientific systemd transformers unix ]; preConfigure = "hpack"; license = stdenv.lib.licenses.publicDomain; diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs index b9474f2..db3246a 100644 --- a/trivmix/Trivmix.hs +++ b/trivmix/Trivmix.hs @@ -31,6 +31,7 @@ import Control.Exception import System.IO.Error import System.IO import System.Exit +import System.Console.Concurrent import System.FileLock import System.INotify @@ -159,7 +160,7 @@ defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes , otherExecuteMode ] main :: IO () -main = execParser opts >>= trivmix +main = withConcurrentOutput $ execParser opts >>= trivmix where opts = info (helper <*> optionParser) ( fullDesc @@ -172,7 +173,6 @@ trivmix Options{..} = do level <- newMVar initialLevel balance <- newMVar initialBalance level' <- newMVar 0 - stderrLock <- newEmptyMVar let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles ++ map (\f -> onStateFile f (show initialBalance ++ "\n")) balanceFiles withFiles $ withINotify $ \inotify -> do @@ -185,7 +185,7 @@ trivmix Options{..} = do Audio.withProcessMono client' input' (mix level') output' $ Jack.withActivation client' . Trans.lift $ do forM_ run $ \script -> - (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> hPutStrLn stderr $ script ++ " failed: " ++ show (code :: ExitCode)) + (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> errorConcurrent $ script ++ " failed: " ++ show (code :: ExitCode)) forkIO . forever $ do -- Smooth out discontinuity let frames = interval * fps @@ -199,24 +199,24 @@ trivmix Options{..} = do EQ -> threadDelay . round $ interval * 1e6 _ -> do mapM_ (\x -> (swapMVar level' $! toRealFloat . unrefine . toLin $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0) - withMVarLock stderrLock . hPutStrLn stderr $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’." + errorConcurrent $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’." notifyReady forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog mix :: MVar CFloat -> CFloat -> IO CFloat mix level input = (input *) <$> readMVar level -handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> MVar () -> [FilePath] -> IO () -handleFiles inotify level stderrLock files = do +handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> [FilePath] -> IO () +handleFiles inotify level files = do initLevel <- readMVar level levelChanges <- newChan let - handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock) + handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file) 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 + mapM_ (\f -> writeLevel f levelState) files return () return () @@ -229,20 +229,20 @@ onStateFile file initial action = do setFileCreationMask nullFileMode let acquireFile = case exists of True -> return () - False -> withMVarLock stderrLock $ do - hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)" + False -> do + errorConcurrent $ "Creating ‘" ++ file ++ "’ (file)" createFile file defFileMode >>= closeFd >> writeFile file initial releaseFile = case exists of True -> return () - False -> withMVarLock stderrLock $ do - hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)" + False -> do + errorConcurrent $ "Removing ‘" ++ file ++ "’ (file)" removeFile file - acquireDir = (flip mapM) (reverse createDirs) $ \directory -> withMVarLock stderrLock $ do - hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)" + acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do + errorConcurrent $ "Creating ‘" ++ directory ++ "’ (dir)" createDirectory directory setFileMode directory defDirectoryMode - releaseDir = (flip mapM) createDirs $ \directory -> withMVarLock stderrLock $ do - hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)" + releaseDir = (flip mapM) createDirs $ \directory -> do + errorConcurrent $ "Removing ‘" ++ directory ++ "’ (dir)" removeDirectory directory acquire = acquireDir >> acquireFile release = releaseFile >> releaseDir @@ -259,21 +259,19 @@ takeWhileM pred (x:xs) = do False -> do return [] -readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> MVar () -> IO () -readLevel levelChan current file stderrLock = catch action handler +readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> IO () +readLevel levelChan current file = 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) + errorConcurrent $ "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 + errorConcurrent $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting." + readMVar current >>= writeLevel file else throw e stripSpace = reverse . stripSpace' . reverse . stripSpace' stripSpace' [] = [] @@ -281,11 +279,7 @@ readLevel levelChan current file stderrLock = catch action handler then stripSpace' xs else l -writeLevel :: Show l => FilePath -> MVar () -> l -> IO () -writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do - withMVarLock stderrLock $ - hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’" +writeLevel :: Show l => FilePath -> l -> IO () +writeLevel file level = withFileLock file Exclusive $ const $ do + errorConcurrent $ "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