Fix race condition issues on Windows.

Former-commit-id: 970a6f8c92ba8cab41053cb7a933a45f416e8696

examples/counter.hs

@@ -6,7 +6,7 @@ module Main (main) where
 
 import           Control.Lens
 import           Data.Text (pack, Text)
-import Numeric
+import           Numeric
 
 import           Graphics.SvgTree hiding (Text)
 import           Reanimate.Driver (reanimate)

examples/raster.hs

@@ -15,10 +15,10 @@ import           Reanimate.Raster
 import           Codec.Picture
 
 main :: IO ()
-main = reanimate $ repeatAnimation 6 $ mkAnimation 5 $ do
+main = reanimate $ mkAnimation 5 $ do
     s <- getSignal signalLinear
     emit $ mkGroup
-      [ mkBackground "black"
+      [ mkBackground "grey"
       , rotate (s*360) $ center $ scale 0.5 $ embedImage img ]
   where
     img = generateImage pixelRenderer 255 255

reanimate.cabal

@@ -67,7 +67,7 @@ library
                        diagrams-core, diagrams-lib, diagrams-contrib,
                        svg-builder, matrices, cubicbezier, palette, websockets,
                        hashable, fsnotify, open-browser, random-shuffle, base64-bytestring,
-                       vector, colour, cassava, ansi-wl-pprint, here
+                       vector, colour, cassava, ansi-wl-pprint, here, temporary
 
 Flag server
   Description: Enable rendering server

src/Reanimate/Driver.hs

@@ -3,7 +3,7 @@ module Reanimate.Driver ( reanimate ) where
 
 import           Control.Concurrent           (MVar, forkIO, killThread,
                                                modifyMVar_, newEmptyMVar,
-                                               putMVar, takeMVar)
+                                               putMVar, takeMVar, forkOS)
 import           Control.Exception            (SomeException, finally, handle)
 import           Control.Monad
 import           Control.Monad.Fix            (fix)
@@ -13,8 +13,7 @@ import qualified Data.Text.Read               as T
 import           Data.Version
 import           Network.WebSockets
 import           Paths_reanimate
-import           Reanimate.Misc               (runCmdLazy, runCmd_, withTempDir,
-                                               withTempFile)
+import           Reanimate.Misc               (runCmdLazy, runCmd_)
 import           Reanimate.Monad              (Animation)
 import           Reanimate.Render             (render, renderSnippets,
                                                renderSvgs)
@@ -24,8 +23,8 @@ import           System.Environment           (getArgs, getProgName)
 import           System.Exit
 import           System.FilePath
 import           System.FSNotify
-import           System.IO                    (BufferMode (..), hPutStrLn,
-                                               hSetBuffering, stderr, stdin)
+import           System.IO.Temp
+import           System.IO
 import           Text.ParserCombinators.ReadP
 import qualified Text.PrettyPrint.ANSI.Leijen as Doc
 import           Text.Printf
@@ -45,58 +44,61 @@ reanimate animation = do
     ["check"] -> checkEnvironment
     ["render", target] ->
       render animation target
-    _ -> withTempDir $ \tmpDir -> do
-      url <- getDataFileName "viewer/build/index.html"
-      putStrLn "Opening browser..."
-      bSucc <- openBrowser url
-      if bSucc
-          then putStrLn "Browser opened."
-          else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url
-      runServerWith "127.0.0.1" 9161 opts $ \pending -> do
-        putStrLn "Server pending..."
-        prog <- getProgName
-        lst <- listDirectory "."
-        mbSelf <- findFile ("." : lst) prog
-        blocker <- newEmptyMVar :: IO (MVar ())
-        case mbSelf of
-          Nothing -> do
-            hPutStrLn stderr "Failed to find own source code."
-          Just self -> do
+    _ -> do
+      prog <- getProgName
+      lst <- listDirectory "."
+      mbSelf <- findFile ("." : lst) prog
+      case mbSelf of
+        Nothing -> do
+          hPutStrLn stderr "Failed to find own source code."
+          exitWith (ExitFailure 1)
+        Just self -> do
+          url <- getDataFileName "viewer/build/index.html"
+          putStrLn "Opening browser..."
+          bSucc <- openBrowser url
+          if bSucc
+              then putStrLn "Browser opened."
+              else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url
+          putStrLn "Listening..."
+          runServerWith "127.0.0.1" 9161 opts $ \pending -> do
+            putStrLn "New connection received."
             conn <- acceptRequest pending
             slave <- newEmptyMVar
             let handler = modifyMVar_ slave $ \tid -> do
-                  sendTextData conn (T.pack "Compiling")
-                  putStrLn "Killing and respawning..."
+
+                  putStrLn "Reloading code..."
                   killThread tid
-                  tid <- forkIO $ slaveHandler conn self tmpDir
+                  tid <- forkOS $ slaveHandler conn self
                   return tid
                 killSlave = do
                   tid <- takeMVar slave
                   killThread tid
-            putStrLn "Found self. Listening..."
             stop <- watchFile watch self handler
             putMVar slave =<< forkIO (return ())
             let loop = do
                   fps <- receiveData conn :: IO T.Text
                   handler
                   loop
-            loop `finally` (killSlave >> stop)
+            loop `finally` (stop >> killSlave)
 
-slaveHandler conn self tmpDir = withTempFile ".exe" $ \tmpExecutable -> do
-  ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [self, "-o", tmpExecutable]
-  case ret of
-    Left err ->
-      sendTextData conn $ T.pack $ "Error" ++ unlines (drop 3 (lines err))
-    Right{} -> do
-      getFrame <- runCmdLazy tmpExecutable ["once", "+RTS", "-N", "-M1G", "-RTS"]
-      (frameCount,_) <- expectFrame =<< getFrame
-      -- sendTextData conn (T.pack "Compiled")
-      sendTextData conn (T.pack $ show frameCount)
-      fix $ \loop -> do
-        (frameIdx, frame) <- expectFrame =<< getFrame
-        sendTextData conn (T.pack $ show frameIdx)
-        sendTextData conn frame
-        loop
+slaveHandler conn self =
+  withSystemTempDirectory "reanimate" $ \tmpDir ->
+  withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do
+    hClose handle
+    sendTextData conn (T.pack "Compiling")
+    ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [self, "-o", tmpExecutable]
+    case ret of
+      Left err ->
+        sendTextData conn $ T.pack $ "Error" ++ unlines (drop 3 (lines err))
+      Right{} -> do
+        getFrame <- runCmdLazy tmpExecutable ["once", "+RTS", "-N", "-M1G", "-RTS"]
+        (frameCount,_) <- expectFrame =<< getFrame
+        sendTextData conn (T.pack $ show frameCount)
+        fix $ \loop -> do
+          (frameIdx, frame) <- expectFrame =<< getFrame
+          sendTextData conn (T.pack $ show frameIdx)
+          sendTextData conn frame
+          loop
   where
     expectFrame (Left "") = do
       sendTextData conn (T.pack "Done")
@@ -213,14 +215,13 @@ ffmpegVersion = do
 
 hasTeXPackage :: FilePath -> String -> IO (Either String String)
 hasTeXPackage exec pkg = handle (\(e::SomeException) -> return $ Left "n/a") $
-    withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file -> do
-      let tmp_dir = "."
-          tex_file = "test.tex"
-      writeFile tex_file tex_document
-      appendFile tex_file $ "\\usepackage" ++ pkg ++ "\n"
-      appendFile tex_file "\\begin{document}\n"
-      appendFile tex_file "blah\n"
-      appendFile tex_file tex_epilogue
+    withSystemTempDirectory "reanimate" $ \tmp_dir -> withTempFile tmp_dir "test.tex" $ \tex_file tex_handle -> do
+      hPutStr tex_handle tex_document
+      hPutStr tex_handle $ "\\usepackage" ++ pkg ++ "\n"
+      hPutStr tex_handle "\\begin{document}\n"
+      hPutStr tex_handle "blah\n"
+      hPutStr tex_handle tex_epilogue
+      hClose tex_handle
       ret <- runCmd_ exec ["-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file]
       return $ case ret of
         Right{} -> Right "OK"

src/Reanimate/Misc.hs

@@ -69,7 +69,7 @@ runCmdLazy exec args = do
 withTempDir :: (FilePath -> IO a) -> IO a
 withTempDir action = do
   dir <- getTemporaryDirectory
-  (path, handle) <- openTempFile dir "reanimate-XXXXXX"
+  (path, handle) <- openTempFile dir "reanimate"
   hClose handle
   removeFile path
   createDirectory (dir </> path)
@@ -78,6 +78,6 @@ withTempDir action = do
 withTempFile :: String -> (FilePath -> IO a) -> IO a
 withTempFile ext action = do
   dir <- getTemporaryDirectory
-  (path, handle) <- openTempFile dir ("reanimate-XXXXXX" <.> ext)
+  (path, handle) <- openTempFile dir ("reanimate" <.> ext)
   hClose handle
   action path -- `finally` removeFile path

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-13.14
+resolver: lts-11.14
 
 allow-newer: false