Atomically read and write to interface files.main

This sychronizes multiple processes so fiddle files can be effectively
complied in parallel.

1 files changed, 14 insertions, 1 deletions

diff --git a/src/Language/Fiddle/Compiler/ImportResolution.hs b/src/Language/Fiddle/Compiler/ImportResolution.hs
index d4d6a05..5c09523 100644
--- a/src/Language/Fiddle/Compiler/ImportResolution.hs
+++ b/src/Language/Fiddle/Compiler/ImportResolution.hs
@@ -12,6 +12,7 @@ import qualified Codec.Compression.GZip as GZip
 import Control.Arrow (Arrow (second))
 import Control.Monad (filterM, when)
 import Control.Monad.State (put)
+import Control.Monad.Loops (untilM_)
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
 import Control.Monad.Writer.Lazy (MonadTrans (lift), MonadWriter (tell), WriterT (..), execWriterT)
 import Data.Aeson (eitherDecode, encode)
@@ -31,6 +32,7 @@ import Options.Applicative
 import System.Directory
 import System.FilePath
 import Text.Printf (printf)
+import Control.Exception (uninterruptibleMask)
 
 data Flags = Flags
   { importDirectories :: [FilePath],
@@ -265,7 +267,18 @@ getImportResolutionState parseFile compileToChecked flags unit = do
 
     writeInterfaceFile intfile val = do
       createDirectoryIfMissing True (takeDirectory intfile)
-      BL.writeFile intfile $ GZip.compress (encode val)
+
+      -- Write to a temporary file and then rename it to make the write atomic.
+      let tmpIntFile = intfile <> ".tmp"
+      exists <- doesFileExist tmpIntFile
+      if exists
+        then do
+          -- Another process appears to be writing the file now. Wait for it to
+          -- complete.
+          untilM_ (return ()) (doesFileExist intfile)
+        else do
+          BL.writeFile tmpIntFile $ GZip.compress (encode val)
+          renameFile tmpIntFile intfile
 
     interfaceFileValid :: FilePath -> FilePath -> IO Bool
     interfaceFileValid originalPath intfPath = do