From 158d79a9e7c0865c36f6355944339d9cb227eb28 Mon Sep 17 00:00:00 2001 From: David Himmelstrup Date: Thu, 12 Sep 2019 14:54:59 +0800 Subject: [PATCH] Fix race condition issues on Windows. Former-commit-id: 970a6f8c92ba8cab41053cb7a933a45f416e8696 --- examples/counter.hs | 2 +- examples/raster.hs | 4 +- reanimate.cabal | 2 +- src/Reanimate/Driver.hs | 101 ++++++++++++++++++++-------------------- src/Reanimate/Misc.hs | 4 +- stack.yaml | 2 +- 6 files changed, 58 insertions(+), 57 deletions(-) diff --git a/examples/counter.hs b/examples/counter.hs index e37393a..5a4656e 100755 --- a/examples/counter.hs +++ b/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) diff --git a/examples/raster.hs b/examples/raster.hs index abac4df..ad8cadc 100755 --- a/examples/raster.hs +++ b/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 diff --git a/reanimate.cabal b/reanimate.cabal index c5202fb..879f292 100644 --- a/reanimate.cabal +++ b/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 diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs index 7c2079d..d5a1a3e 100644 --- a/src/Reanimate/Driver.hs +++ b/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" diff --git a/src/Reanimate/Misc.hs b/src/Reanimate/Misc.hs index c7ba5db..b384b27 100644 --- a/src/Reanimate/Misc.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index 1ff3562..7356340 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-13.14 +resolver: lts-11.14 allow-newer: false