From d8ea165173a2b7ba514bb3eafac3d21fc1f4d086 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 21 Jun 2015 17:10:13 +0200
Subject: Switched build system structure & locks

---
 src/Trivmix.hs | 32 ++++++++++++++++++++------------
 1 file changed, 20 insertions(+), 12 deletions(-)

(limited to 'src/Trivmix.hs')

diff --git a/src/Trivmix.hs b/src/Trivmix.hs
index 0c1a1a4..79b3804 100644
--- a/src/Trivmix.hs
+++ b/src/Trivmix.hs
@@ -27,6 +27,7 @@ import Control.Exception
 import System.IO.Error
 import System.IO
 
+import System.FileLock
 import System.INotify
 
 import Data.Char
@@ -164,12 +165,13 @@ handleFiles :: INotify -> MVar Level -> [FilePath] -> IO ()
 handleFiles inotify level files = do
   initLevel <- readMVar level
   levelChanges <- (newChan :: IO (Chan Level))
+  stderrLock <- newMVar
   let 
     handleFile file = do
       levelChanges' <- dupChan levelChanges
       forkIO $ forever $ do -- Broadcast level changes and update all files
-        readChan levelChanges' >>= writeLevel file
-      addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file)
+        readChan levelChanges' >>= writeLevel file stderrLock
+      addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock)
   mapM handleFile files
   forkIO $ forever $ do
     readChan levelChanges >>= swapMVar level
@@ -193,7 +195,7 @@ onStateFile file initial action = do
           hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)"
           removeFile file
       acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do
-          hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir"
+          hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)"
           createDirectory directory
           setFileMode directory defDirectoryMode
       releaseDir = (flip mapM) createDirs $ \directory -> do
@@ -214,19 +216,21 @@ takeWhileM pred (x:xs) = do
     False -> do
       return []
 
-readLevel :: Chan Level -> MVar Level -> FilePath -> IO ()
-readLevel levelChan current file = catch action handler
+readLevel :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO ()
+readLevel levelChan current file stderrLock = catch action handler
   where
     action = do
-      level <- readFile file >>= readIO . stripSpace
+      level <- withFileLock file Shared $ readFile file >>= readIO . stripSpace
       oldLevel <- readMVar current
       when (oldLevel /= level) $ do
         writeChan levelChan level
-        hPutStrLn stderr $ "Detected new level: " ++ (show level)
+        withMVarLock stderrLock $ 
+          hPutStrLn stderr $ "Detected new level: " ++ (show level)
     handler e = if isUserError e
                 then do
-                  hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting."
-                  readMVar current >>= writeLevel file
+                  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' [] = []
@@ -234,7 +238,11 @@ readLevel levelChan current file = catch action handler
                           then stripSpace' xs
                           else l
 
-writeLevel :: FilePath -> Level -> IO ()
-writeLevel file level = do
-  hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’"
+writeLevel :: FilePath -> MVar () -> Level -> IO ()
+writeLevel file stderrLock level = withFileLock file Exclusive $ 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