diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2018-05-15 22:36:52 +0200 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2018-05-15 22:36:52 +0200 |
commit | b11192d813bdf803011b4ea4cd3efead532d9b4c (patch) | |
tree | 3c8bc29b0d43eb0fd7ef89d1c3b25c865a8cb46a | |
parent | 8a8d1a99243af120b2e4187c2d90855f02f85f31 (diff) | |
download | trivmix-b11192d813bdf803011b4ea4cd3efead532d9b4c.tar trivmix-b11192d813bdf803011b4ea4cd3efead532d9b4c.tar.gz trivmix-b11192d813bdf803011b4ea4cd3efead532d9b4c.tar.bz2 trivmix-b11192d813bdf803011b4ea4cd3efead532d9b4c.tar.xz trivmix-b11192d813bdf803011b4ea4cd3efead532d9b4c.zip |
Don't use manual locking
-rw-r--r-- | package.yaml | 3 | ||||
-rw-r--r-- | trivmix.nix | 16 | ||||
-rw-r--r-- | 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 @@ | |||
1 | name: trivmix | 1 | name: trivmix |
2 | version: 4.0.2 | 2 | version: 4.0.3 |
3 | license: PublicDomain | 3 | license: PublicDomain |
4 | license-file: LICENSE | 4 | license-file: LICENSE |
5 | author: Gregor Kleen <aethoago@141.li> | 5 | author: Gregor Kleen <aethoago@141.li> |
@@ -40,6 +40,7 @@ executables: | |||
40 | - heredoc >=0.2.0.0 && <1 | 40 | - heredoc >=0.2.0.0 && <1 |
41 | - refined >=0.1.2.1 && <1 | 41 | - refined >=0.1.2.1 && <1 |
42 | - scientific >=0.3.5.3 && <1 | 42 | - scientific >=0.3.5.3 && <1 |
43 | - concurrent-output >=1.10.5 && <2 | ||
43 | - trivmix | 44 | - trivmix |
44 | adjmix: | 45 | adjmix: |
45 | ghc-options: -threaded -O2 | 46 | 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 @@ | |||
1 | { mkDerivation, base, case-insensitive, data-default, directory | 1 | { mkDerivation, base, case-insensitive, concurrent-output |
2 | , explicit-exception, filelock, filepath, heredoc, hinotify, hpack | 2 | , data-default, directory, explicit-exception, filelock, filepath |
3 | , jack, optparse-applicative, process, refined, scientific, stdenv | 3 | , heredoc, hinotify, hpack, jack, optparse-applicative, process |
4 | , systemd, th-lift, transformers, unix | 4 | , refined, scientific, stdenv, systemd, th-lift, transformers, unix |
5 | }: | 5 | }: |
6 | mkDerivation { | 6 | mkDerivation { |
7 | pname = "trivmix"; | 7 | pname = "trivmix"; |
8 | version = "4.0.2"; | 8 | version = "4.0.3"; |
9 | src = ./.; | 9 | src = ./.; |
10 | isLibrary = true; | 10 | isLibrary = true; |
11 | isExecutable = true; | 11 | isExecutable = true; |
@@ -14,9 +14,9 @@ mkDerivation { | |||
14 | ]; | 14 | ]; |
15 | libraryToolDepends = [ hpack ]; | 15 | libraryToolDepends = [ hpack ]; |
16 | executableHaskellDepends = [ | 16 | executableHaskellDepends = [ |
17 | base directory explicit-exception filelock filepath heredoc | 17 | base concurrent-output directory explicit-exception filelock |
18 | hinotify jack optparse-applicative process refined scientific | 18 | filepath heredoc hinotify jack optparse-applicative process refined |
19 | systemd transformers unix | 19 | scientific systemd transformers unix |
20 | ]; | 20 | ]; |
21 | preConfigure = "hpack"; | 21 | preConfigure = "hpack"; |
22 | license = stdenv.lib.licenses.publicDomain; | 22 | 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 | |||
31 | import System.IO.Error | 31 | import System.IO.Error |
32 | import System.IO | 32 | import System.IO |
33 | import System.Exit | 33 | import System.Exit |
34 | import System.Console.Concurrent | ||
34 | 35 | ||
35 | import System.FileLock | 36 | import System.FileLock |
36 | import System.INotify | 37 | import System.INotify |
@@ -159,7 +160,7 @@ defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes | |||
159 | , otherExecuteMode | 160 | , otherExecuteMode |
160 | ] | 161 | ] |
161 | main :: IO () | 162 | main :: IO () |
162 | main = execParser opts >>= trivmix | 163 | main = withConcurrentOutput $ execParser opts >>= trivmix |
163 | where | 164 | where |
164 | opts = info (helper <*> optionParser) | 165 | opts = info (helper <*> optionParser) |
165 | ( fullDesc | 166 | ( fullDesc |
@@ -172,7 +173,6 @@ trivmix Options{..} = do | |||
172 | level <- newMVar initialLevel | 173 | level <- newMVar initialLevel |
173 | balance <- newMVar initialBalance | 174 | balance <- newMVar initialBalance |
174 | level' <- newMVar 0 | 175 | level' <- newMVar 0 |
175 | stderrLock <- newEmptyMVar | ||
176 | let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles | 176 | let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles |
177 | ++ map (\f -> onStateFile f (show initialBalance ++ "\n")) balanceFiles | 177 | ++ map (\f -> onStateFile f (show initialBalance ++ "\n")) balanceFiles |
178 | withFiles $ withINotify $ \inotify -> do | 178 | withFiles $ withINotify $ \inotify -> do |
@@ -185,7 +185,7 @@ trivmix Options{..} = do | |||
185 | Audio.withProcessMono client' input' (mix level') output' $ | 185 | Audio.withProcessMono client' input' (mix level') output' $ |
186 | Jack.withActivation client' . Trans.lift $ do | 186 | Jack.withActivation client' . Trans.lift $ do |
187 | forM_ run $ \script -> | 187 | forM_ run $ \script -> |
188 | (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> hPutStrLn stderr $ script ++ " failed: " ++ show (code :: ExitCode)) | 188 | (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> errorConcurrent $ script ++ " failed: " ++ show (code :: ExitCode)) |
189 | forkIO . forever $ do -- Smooth out discontinuity | 189 | forkIO . forever $ do -- Smooth out discontinuity |
190 | let | 190 | let |
191 | frames = interval * fps | 191 | frames = interval * fps |
@@ -199,24 +199,24 @@ trivmix Options{..} = do | |||
199 | EQ -> threadDelay . round $ interval * 1e6 | 199 | EQ -> threadDelay . round $ interval * 1e6 |
200 | _ -> do | 200 | _ -> do |
201 | mapM_ (\x -> (swapMVar level' $! toRealFloat . unrefine . toLin $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0) | 201 | mapM_ (\x -> (swapMVar level' $! toRealFloat . unrefine . toLin $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0) |
202 | withMVarLock stderrLock . hPutStrLn stderr $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’." | 202 | errorConcurrent $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’." |
203 | notifyReady | 203 | notifyReady |
204 | forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog | 204 | forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog |
205 | 205 | ||
206 | mix :: MVar CFloat -> CFloat -> IO CFloat | 206 | mix :: MVar CFloat -> CFloat -> IO CFloat |
207 | mix level input = (input *) <$> readMVar level | 207 | mix level input = (input *) <$> readMVar level |
208 | 208 | ||
209 | handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> MVar () -> [FilePath] -> IO () | 209 | handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> [FilePath] -> IO () |
210 | handleFiles inotify level stderrLock files = do | 210 | handleFiles inotify level files = do |
211 | initLevel <- readMVar level | 211 | initLevel <- readMVar level |
212 | levelChanges <- newChan | 212 | levelChanges <- newChan |
213 | let | 213 | let |
214 | handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock) | 214 | handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file) |
215 | mapM_ handleFile files | 215 | mapM_ handleFile files |
216 | forkIO $ forever $ do -- Broadcast level changes and update all files | 216 | forkIO $ forever $ do -- Broadcast level changes and update all files |
217 | levelState <- readChan levelChanges | 217 | levelState <- readChan levelChanges |
218 | swapMVar level levelState | 218 | swapMVar level levelState |
219 | mapM_ (\f -> writeLevel f stderrLock levelState) files | 219 | mapM_ (\f -> writeLevel f levelState) files |
220 | return () | 220 | return () |
221 | return () | 221 | return () |
222 | 222 | ||
@@ -229,20 +229,20 @@ onStateFile file initial action = do | |||
229 | setFileCreationMask nullFileMode | 229 | setFileCreationMask nullFileMode |
230 | let acquireFile = case exists of | 230 | let acquireFile = case exists of |
231 | True -> return () | 231 | True -> return () |
232 | False -> withMVarLock stderrLock $ do | 232 | False -> do |
233 | hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)" | 233 | errorConcurrent $ "Creating ‘" ++ file ++ "’ (file)" |
234 | createFile file defFileMode >>= closeFd >> writeFile file initial | 234 | createFile file defFileMode >>= closeFd >> writeFile file initial |
235 | releaseFile = case exists of | 235 | releaseFile = case exists of |
236 | True -> return () | 236 | True -> return () |
237 | False -> withMVarLock stderrLock $ do | 237 | False -> do |
238 | hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)" | 238 | errorConcurrent $ "Removing ‘" ++ file ++ "’ (file)" |
239 | removeFile file | 239 | removeFile file |
240 | acquireDir = (flip mapM) (reverse createDirs) $ \directory -> withMVarLock stderrLock $ do | 240 | acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do |
241 | hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)" | 241 | errorConcurrent $ "Creating ‘" ++ directory ++ "’ (dir)" |
242 | createDirectory directory | 242 | createDirectory directory |
243 | setFileMode directory defDirectoryMode | 243 | setFileMode directory defDirectoryMode |
244 | releaseDir = (flip mapM) createDirs $ \directory -> withMVarLock stderrLock $ do | 244 | releaseDir = (flip mapM) createDirs $ \directory -> do |
245 | hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)" | 245 | errorConcurrent $ "Removing ‘" ++ directory ++ "’ (dir)" |
246 | removeDirectory directory | 246 | removeDirectory directory |
247 | acquire = acquireDir >> acquireFile | 247 | acquire = acquireDir >> acquireFile |
248 | release = releaseFile >> releaseDir | 248 | release = releaseFile >> releaseDir |
@@ -259,21 +259,19 @@ takeWhileM pred (x:xs) = do | |||
259 | False -> do | 259 | False -> do |
260 | return [] | 260 | return [] |
261 | 261 | ||
262 | readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> MVar () -> IO () | 262 | readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> IO () |
263 | readLevel levelChan current file stderrLock = catch action handler | 263 | readLevel levelChan current file = catch action handler |
264 | where | 264 | where |
265 | action = do | 265 | action = do |
266 | level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace | 266 | level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace |
267 | oldLevel <- readMVar current | 267 | oldLevel <- readMVar current |
268 | when (oldLevel /= level) $ do | 268 | when (oldLevel /= level) $ do |
269 | writeChan levelChan level | 269 | writeChan levelChan level |
270 | withMVarLock stderrLock $ | 270 | errorConcurrent $ "Detected new level: " ++ show level |
271 | hPutStrLn stderr $ "Detected new level: " ++ (show level) | ||
272 | handler e = if isUserError e | 271 | handler e = if isUserError e |
273 | then do | 272 | then do |
274 | withMVarLock stderrLock $ | 273 | errorConcurrent $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting." |
275 | hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting." | 274 | readMVar current >>= writeLevel file |
276 | readMVar current >>= writeLevel file stderrLock | ||
277 | else throw e | 275 | else throw e |
278 | stripSpace = reverse . stripSpace' . reverse . stripSpace' | 276 | stripSpace = reverse . stripSpace' . reverse . stripSpace' |
279 | stripSpace' [] = [] | 277 | stripSpace' [] = [] |
@@ -281,11 +279,7 @@ readLevel levelChan current file stderrLock = catch action handler | |||
281 | then stripSpace' xs | 279 | then stripSpace' xs |
282 | else l | 280 | else l |
283 | 281 | ||
284 | writeLevel :: Show l => FilePath -> MVar () -> l -> IO () | 282 | writeLevel :: Show l => FilePath -> l -> IO () |
285 | writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do | 283 | writeLevel file level = withFileLock file Exclusive $ const $ do |
286 | withMVarLock stderrLock $ | 284 | errorConcurrent $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’" |
287 | hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’" | ||
288 | writeFile file (show level ++ "\n") | 285 | writeFile file (show level ++ "\n") |
289 | |||
290 | withMVarLock :: MVar () -> IO a -> IO a | ||
291 | withMVarLock lock = bracket_ (putMVar lock ()) (takeMVar lock) | ||