From 917dc3693d2948abc6a4a9169f331cf3abcd6cb1 Mon Sep 17 00:00:00 2001 From: David Himmelstrup Date: Fri, 28 Aug 2020 14:49:55 +0800 Subject: [PATCH] Improve the safety of the playground and limit the resources it may use. (#144) * Improve the safety of the playground and limit the resources it may use. * Don't send new code to server until 0.5s after the last keypress. --- .github/workflows/gh-pages.yml | 4 +- Dockerfile.playground | 8 +- .../Dockerfile.nginx | 0 {reanimate-playground => playground}/LICENSE | 0 .../README.md | 0 {reanimate-playground => playground}/hie.yaml | 0 .../nginx.conf | 0 .../playground.cabal | 0 .../playground.hs | 0 .../snippets/00_Hello World.hs | 0 .../snippets/01_Composition.hs | 0 .../snippets/02_Color Maps.hs | 0 .../snippets/03_Try it live.hs | 0 .../snippets/04_Basic Objects.hs | 0 .../snippets/05_LaTeX.hs | 0 .../snippets/06_Easing Functions.hs | 0 .../snippets/07_Easing Graphs.hs | 0 .../snippets/08_Object Positions.hs | 0 .../snippets/09_Camera.hs | 0 .../src/Main.hs | 193 +++++++++++++----- .../stack.yaml | 0 .../viewer-elm/README.md | 0 .../viewer-elm/dist/bulma.min.css | 0 .../dist/collections-white-48dp.svg | 0 .../viewer-elm/dist/embed.css | 0 .../viewer-elm/dist/embed.js | 0 .../viewer-elm/dist/forward_10-white-48dp.svg | 0 .../dist/help_outline-white-48dp.svg | 0 .../viewer-elm/dist/home-white-48dp.svg | 0 .../viewer-elm/dist/index.html | 0 .../dist/pause_circle_outline-white-48dp.svg | 0 .../dist/play_circle_outline-white-48dp.svg | 0 .../viewer-elm/dist/playground.js | 8 +- .../viewer-elm/dist/replay_10-white-48dp.svg | 0 .../viewer-elm/dist/skip_next-white-48dp.svg | 0 .../dist/skip_previous-white-48dp.svg | 0 .../viewer-elm/dist/snippets.js | 0 .../viewer-elm/dist/style.css | 0 .../viewer-elm/elm.json | 0 .../viewer-elm/package.json | 0 .../viewer-elm/src/Fps.elm | 0 .../viewer-elm/src/Main.elm | 21 +- .../viewer-elm/src/Ports.elm | 0 src/Reanimate/Render.hs | 48 +++-- 44 files changed, 204 insertions(+), 78 deletions(-) rename {reanimate-playground => playground}/Dockerfile.nginx (100%) rename {reanimate-playground => playground}/LICENSE (100%) rename {reanimate-playground => playground}/README.md (100%) rename {reanimate-playground => playground}/hie.yaml (100%) rename {reanimate-playground => playground}/nginx.conf (100%) rename {reanimate-playground => playground}/playground.cabal (100%) rename {reanimate-playground => playground}/playground.hs (100%) rename {reanimate-playground => playground}/snippets/00_Hello World.hs (100%) rename {reanimate-playground => playground}/snippets/01_Composition.hs (100%) rename {reanimate-playground => playground}/snippets/02_Color Maps.hs (100%) rename {reanimate-playground => playground}/snippets/03_Try it live.hs (100%) rename {reanimate-playground => playground}/snippets/04_Basic Objects.hs (100%) rename {reanimate-playground => playground}/snippets/05_LaTeX.hs (100%) rename {reanimate-playground => playground}/snippets/06_Easing Functions.hs (100%) rename {reanimate-playground => playground}/snippets/07_Easing Graphs.hs (100%) rename {reanimate-playground => playground}/snippets/08_Object Positions.hs (100%) rename {reanimate-playground => playground}/snippets/09_Camera.hs (100%) rename {reanimate-playground => playground}/src/Main.hs (64%) rename {reanimate-playground => playground}/stack.yaml (100%) rename {reanimate-playground => playground}/viewer-elm/README.md (100%) rename {reanimate-playground => playground}/viewer-elm/dist/bulma.min.css (100%) rename {reanimate-playground => playground}/viewer-elm/dist/collections-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/embed.css (100%) rename {reanimate-playground => playground}/viewer-elm/dist/embed.js (100%) rename {reanimate-playground => playground}/viewer-elm/dist/forward_10-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/help_outline-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/home-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/index.html (100%) rename {reanimate-playground => playground}/viewer-elm/dist/pause_circle_outline-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/play_circle_outline-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/playground.js (94%) rename {reanimate-playground => playground}/viewer-elm/dist/replay_10-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/skip_next-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/skip_previous-white-48dp.svg (100%) rename {reanimate-playground => playground}/viewer-elm/dist/snippets.js (100%) rename {reanimate-playground => playground}/viewer-elm/dist/style.css (100%) rename {reanimate-playground => playground}/viewer-elm/elm.json (100%) rename {reanimate-playground => playground}/viewer-elm/package.json (100%) rename {reanimate-playground => playground}/viewer-elm/src/Fps.elm (100%) rename {reanimate-playground => playground}/viewer-elm/src/Main.elm (94%) rename {reanimate-playground => playground}/viewer-elm/src/Ports.elm (100%) diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml index 11a8251..53bc4f1 100644 --- a/.github/workflows/gh-pages.yml +++ b/.github/workflows/gh-pages.yml @@ -85,9 +85,9 @@ jobs: run: | CWD=`pwd` stack build - cd reanimate-playground + cd playground stack build - stack exec --cwd ../ playground snippets reanimate-playground/snippets > viewer-elm/dist/snippets.js + stack exec --cwd ../ playground snippets playground/snippets > viewer-elm/dist/snippets.js cd viewer-elm npm install npm run build diff --git a/Dockerfile.playground b/Dockerfile.playground index 2c96454..8671234 100644 --- a/Dockerfile.playground +++ b/Dockerfile.playground @@ -23,8 +23,8 @@ ADD reanimate.cabal stack.yaml ./ RUN stack build --only-dependencies --no-install-ghc --system-ghc --haddock # Install discord-bot dependencies and cache the layer -ADD reanimate-playground/playground.cabal reanimate-playground/stack.yaml ./reanimate-playground/ -RUN cd reanimate-playground && \ +ADD playground/playground.cabal playground/stack.yaml ./playground/ +RUN cd playground && \ stack build --only-dependencies --no-install-ghc --system-ghc # Add source after dependencies have been installed as to not invalidate the caches @@ -38,8 +38,8 @@ ADD Setup.hs ./ RUN stack build --no-install-ghc --system-ghc # Add bot sources and build it -ADD reanimate-playground reanimate-playground -RUN (cd reanimate-playground && \ +ADD playground playground +RUN (cd playground && \ stack install --no-install-ghc --system-ghc) && \ playground test diff --git a/reanimate-playground/Dockerfile.nginx b/playground/Dockerfile.nginx similarity index 100% rename from reanimate-playground/Dockerfile.nginx rename to playground/Dockerfile.nginx diff --git a/reanimate-playground/LICENSE b/playground/LICENSE similarity index 100% rename from reanimate-playground/LICENSE rename to playground/LICENSE diff --git a/reanimate-playground/README.md b/playground/README.md similarity index 100% rename from reanimate-playground/README.md rename to playground/README.md diff --git a/reanimate-playground/hie.yaml b/playground/hie.yaml similarity index 100% rename from reanimate-playground/hie.yaml rename to playground/hie.yaml diff --git a/reanimate-playground/nginx.conf b/playground/nginx.conf similarity index 100% rename from reanimate-playground/nginx.conf rename to playground/nginx.conf diff --git a/reanimate-playground/playground.cabal b/playground/playground.cabal similarity index 100% rename from reanimate-playground/playground.cabal rename to playground/playground.cabal diff --git a/reanimate-playground/playground.hs b/playground/playground.hs similarity index 100% rename from reanimate-playground/playground.hs rename to playground/playground.hs diff --git a/reanimate-playground/snippets/00_Hello World.hs b/playground/snippets/00_Hello World.hs similarity index 100% rename from reanimate-playground/snippets/00_Hello World.hs rename to playground/snippets/00_Hello World.hs diff --git a/reanimate-playground/snippets/01_Composition.hs b/playground/snippets/01_Composition.hs similarity index 100% rename from reanimate-playground/snippets/01_Composition.hs rename to playground/snippets/01_Composition.hs diff --git a/reanimate-playground/snippets/02_Color Maps.hs b/playground/snippets/02_Color Maps.hs similarity index 100% rename from reanimate-playground/snippets/02_Color Maps.hs rename to playground/snippets/02_Color Maps.hs diff --git a/reanimate-playground/snippets/03_Try it live.hs b/playground/snippets/03_Try it live.hs similarity index 100% rename from reanimate-playground/snippets/03_Try it live.hs rename to playground/snippets/03_Try it live.hs diff --git a/reanimate-playground/snippets/04_Basic Objects.hs b/playground/snippets/04_Basic Objects.hs similarity index 100% rename from reanimate-playground/snippets/04_Basic Objects.hs rename to playground/snippets/04_Basic Objects.hs diff --git a/reanimate-playground/snippets/05_LaTeX.hs b/playground/snippets/05_LaTeX.hs similarity index 100% rename from reanimate-playground/snippets/05_LaTeX.hs rename to playground/snippets/05_LaTeX.hs diff --git a/reanimate-playground/snippets/06_Easing Functions.hs b/playground/snippets/06_Easing Functions.hs similarity index 100% rename from reanimate-playground/snippets/06_Easing Functions.hs rename to playground/snippets/06_Easing Functions.hs diff --git a/reanimate-playground/snippets/07_Easing Graphs.hs b/playground/snippets/07_Easing Graphs.hs similarity index 100% rename from reanimate-playground/snippets/07_Easing Graphs.hs rename to playground/snippets/07_Easing Graphs.hs diff --git a/reanimate-playground/snippets/08_Object Positions.hs b/playground/snippets/08_Object Positions.hs similarity index 100% rename from reanimate-playground/snippets/08_Object Positions.hs rename to playground/snippets/08_Object Positions.hs diff --git a/reanimate-playground/snippets/09_Camera.hs b/playground/snippets/09_Camera.hs similarity index 100% rename from reanimate-playground/snippets/09_Camera.hs rename to playground/snippets/09_Camera.hs diff --git a/reanimate-playground/src/Main.hs b/playground/src/Main.hs similarity index 64% rename from reanimate-playground/src/Main.hs rename to playground/src/Main.hs index a8a7e10..7a5bed4 100644 --- a/reanimate-playground/src/Main.hs +++ b/playground/src/Main.hs @@ -1,6 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{- + Mitigated attacks: + * unsafeIO: Blocked by fixed import list. + * TemplateHaskell: Blocked by parsing code. + * Code injection: Blocked by parsing code. + * Exhausting memory: Blocked by RTS flags on ghci. + * Rendering too long: Blocked by both soft and hard timeouts. + * Generating huge error messages: Error messages are truncated. + * Take up disk space: Space limits are checked before each frame is rendered. +-} module Main (main) where import Control.Applicative @@ -56,8 +66,23 @@ playgroundVersion = T.pack $ formatTime defaultTimeLocale "%F" playgroundCommitDate ++ " (" ++ take 5 (giHash gi) ++ ")" -computeLimit :: Int -computeLimit = 15 * 10^(6::Int) -- 15 seconds +-- Seconds of wall time if the render queue is empty. +totalTimeLimitLong :: NominalDiffTime +totalTimeLimitLong = 30 + +-- Seconds of wall time if the render queue is full. +totalTimeLimitShort :: NominalDiffTime +totalTimeLimitShort = 5 + +frameTimeLimit = 5 + +-- Disk space limit in MiB +diskSpaceLimit :: Double +diskSpaceLimit = 50 + +-- Limit animation runtimes to 1 minute. +maxAnimationDuration :: Double +maxAnimationDuration = 60 -- Maximum size of error messages charLimit :: Int @@ -94,6 +119,7 @@ main = do putStrLn $ "const playgroundVersion = " ++ show playgroundVersion ++ ";" [] -> do root <- cacheDir + -- The http server is only used for local development. tid <- forkIO $ run 10162 (staticApp $ defaultWebAppSettings root) serverMain backend `finally` killThread tid _ -> do @@ -151,6 +177,7 @@ requestHandler backend conn = loop =<< newMVar True , renderFrameCount = \i -> sendWebMessage conn (WebFrameCount i) , renderFrameReady = \i path -> sendWebMessage conn (WebFrame i path) , renderError = \msg -> sendWebMessage conn (WebError msg) + , renderWarning = \msg -> sendWebMessage conn (WebWarning msg) , renderWanted = wantThisRequest } loop wantThisRequest @@ -166,6 +193,12 @@ data CacheResult | CacheHitPartial Int IntSet deriving (Show) +ppCacheResult :: CacheResult -> String +ppCacheResult CacheMiss = "CacheMiss" +ppCacheResult (CacheHit frames) = "CacheHit " ++ show frames +ppCacheResult (CacheHitPartial frames partial) = + "CacheHitPartial " ++ show (IntSet.size partial) ++ "/" ++ show frames + checkCache :: String -> IO CacheResult checkCache key = handle (\SomeException{} -> pure CacheMiss) $ do root <- cacheDir @@ -191,13 +224,14 @@ data Render = Render , renderFrameCount :: Int -> IO () , renderFrameReady :: Int -> FilePath -> IO () , renderError :: String -> IO () + , renderWarning :: String -> IO () , renderWanted :: MVar Bool } requestRender :: Backend -> Render -> IO () requestRender backend render = do cache <- checkCache (renderHash render) - logMsg $ "Cache: " ++ show cache + logMsg $ "Cache: " ++ ppCacheResult cache case cache of CacheMiss -> void $ forkIO $ putMVar (backendQueue backend) render CacheHit frames -> do @@ -210,7 +244,7 @@ requestRender backend render = do forM_ (IntSet.toList frameSet) $ \i -> do let path = renderHash render show i <.> "svg" renderFrameReady render i path - void $ forkIO $ putMVar (backendQueue backend) render + void $ forkIO $ putMVar (backendQueue backend) render{ renderFrameCount = \_ -> return () } newGhci :: IO Ghci newGhci = do @@ -225,51 +259,99 @@ newBackend :: IO Backend newBackend = do ghciRef <- newMVar =<< newGhci queue <- newEmptyMVar + root <- cacheDir tid <- forkIO $ forever $ do req <- takeMVar queue - guardWanted req $ withHaskellFile (renderCode req) $ \hs -> do - ghci <- readMVar ghciRef - catch @GhciError (loadAndRender req ghci hs) (\_ -> restartGhci ghciRef req) + let svgFolder = root renderHash req + createDirectoryIfMissing True svgFolder + startTime <- getCurrentTime + ghci <- readMVar ghciRef + let guardTimeout action = do + now <- getCurrentTime + emptyQueue <- isEmptyMVar queue + let timeLimit = if emptyQueue then totalTimeLimitLong else totalTimeLimitShort + if (diffUTCTime now startTime < timeLimit) + then action + else do + renderWarning req "Render timed out" + logMsg "Request timed out" + guardFileSize action = do + size <- getDirectorySize svgFolder + if size < round (diskSpaceLimit*1024*1024) + then action + else do + renderWarning req "Disk space limit hit" + logMsg "Disk space limit hit" + guardWanted action = do + wanted <- readMVar (renderWanted req) + if wanted + then action + else logMsg "Results no longer wanted" + guardGhci cmd action = do + mbValue <- timeout (round (frameTimeLimit * 1e6)) $ + splitGhciOutput ghci cmd + case mbValue of + Nothing -> do + renderWarning req "Frame render timed out." + forkIO $ stopGhci ghci + modifyMVar_ ghciRef (const newGhci) + Just (err, out) + | null err -> action out + | otherwise -> do + logMsg $ "Error:\n" ++ take charLimit (unlines err) + renderError req (take charLimit (unlines err)) + restartGhci = do + renderWarning req "Ghci crashed. Restarting." + logMsg "Ghci crashed. Restarting." + forkIO $ stopGhci ghci + modifyMVar_ ghciRef (const newGhci) + + loadAndRender hs = + guardGhci (":load " ++ hs) $ \_ -> guardWanted $ + guardGhci "Reanimate.duration animation" $ \out -> do + let dur = max 1 (min maxAnimationDuration (read (unlines out))) :: Double + frameCount = round (dur * fromIntegral frameRate) :: Int + durFile = root renderHash req "frames" + writeFile durFile (show frameCount) + renderFrameCount req frameCount + renderFrames dur + renderFrames dur = guardWanted $ guardTimeout $ guardFileSize $ do + let cmd = printf + "Reanimate.renderLimitedFrames \"%s\" 0 False %d \ + \(Reanimate.setDuration %f animation)" + svgFolder frameRate dur + done <- newIORef False + mbErrors <- streamGhci ghci cmd $ \msg -> + case msg of + "Done" -> writeIORef done True + _ -> do + let frameIdx = read msg + path = renderHash req show frameIdx <.> "svg" + renderFrameReady req frameIdx path + isDone <- readIORef done + case mbErrors of + Nothing -> do + renderWarning req "Frame render timed out." + forkIO $ stopGhci ghci + modifyMVar_ ghciRef (const newGhci) + Just [] | isDone -> + logMsg "Render finished." + Just [] -> + renderFrames dur + Just errMsgs -> do + logMsg $ "Error:\n" ++ take charLimit (unlines errMsgs) + renderError req (take charLimit (unlines errMsgs)) + + guardWanted $ withHaskellFile (renderCode req) $ \hs -> do + catch @GhciError + (loadAndRender hs) + (\_ -> restartGhci) return $ Backend ghciRef queue - where - restartGhci ghciRef req = do - renderError req "Ghci crashed. Restarting." - modifyMVar_ ghciRef (const newGhci) - loadAndRender req ghci hs = - guardGhci req ghci (":load " ++ hs) $ \_ -> guardWanted req $ - guardGhci req ghci "Reanimate.duration animation" $ \out -> do - root <- cacheDir - let dur = read (unlines out) :: Double - frameCount = round (dur * fromIntegral frameRate) :: Int - durFile = root renderHash req "frames" - createDirectoryIfMissing True (root renderHash req) - writeFile durFile (show frameCount) - renderFrameCount req frameCount - renderFrames req ghci - renderFrames req ghci = guardWanted req $ do - root <- cacheDir - let svgFolder = root renderHash req - createDirectoryIfMissing True svgFolder - let cmd = printf "Reanimate.renderOneFrame \"%s\" 0 False %d animation" svgFolder frameRate - guardGhci req ghci cmd $ \out -> - case unlines out of - "Done\n" -> return () - _ -> do - let frameIdx = read (unlines out) - path = renderHash req show frameIdx <.> "svg" - renderFrameReady req frameIdx path - renderFrames req ghci - guardGhci req ghci cmd action = do - (err, out) <- splitGhciOutput ghci cmd - if not (null err) - then do - logMsg $ "Error:\n" ++ unlines err - renderError req (unlines err) - else action out - guardWanted req action = do - wanted <- readMVar (renderWanted req) - unless wanted $ logMsg "Results no longer wanted" - when wanted action + +getDirectorySize :: FilePath -> IO Integer +getDirectorySize root = do + files <- getDirectoryContents root + sum <$> mapM getFileSize [ root file | file <- files, takeExtension file == ".svg" ] cacheDir :: IO FilePath cacheDir = do @@ -302,6 +384,11 @@ withHaskellFile m action = withSystemTempFile "playground.hs" $ \target h -> do \import Linear.Vector\n\ \import Text.Printf\n\ \import Codec.Picture.Types\n\ + \-- Used for testing:\n\ + \-- import System.IO.Unsafe\n\ + \-- import Control.Concurrent\n\ + \-- import Control.Exception\n\ + \-- svgDelay d = unsafePerformIO (threadDelay d >> evaluate SVG.None)\n\ \{-# LINE 1 \"playground\" #-}\n" T.appendFile target $ T.pack $ prettyPrint m action target @@ -323,6 +410,18 @@ reqGhcOutput ghci cmd = do error (unlines err) return out +streamGhci :: Ghci -> String -> (String -> IO ()) -> IO (Maybe [String]) +streamGhci ghci cmd cb = do + err <- newIORef [] + ret <- timeout tLimit $ execStream ghci cmd $ \strm msg -> + case strm of + Stdout -> cb msg + Stderr -> modifyIORef err (++[msg]) + errMsgs <- readIORef err + pure (ret >> pure errMsgs) + where + tLimit = round (frameTimeLimit * 1e6) + logMsg :: String -> IO () logMsg msg = do now <- getCurrentTime @@ -357,6 +456,7 @@ parseHaskell txt = data WebMessage = WebStatus String | WebError String + | WebWarning String | WebFrameCount Int | WebFrame Int FilePath @@ -365,6 +465,7 @@ sendWebMessage conn msg = sendTextData conn $ case msg of WebStatus txt -> T.pack "status\n" <> T.pack txt WebError txt -> T.pack "error\n" <> T.pack txt + WebWarning txt -> T.pack "warning\n" <> T.pack txt WebFrameCount n -> T.pack $ "frame_count\n" ++ show n WebFrame n path -> T.pack $ "frame\n" ++ show n ++ "\n" ++ path diff --git a/reanimate-playground/stack.yaml b/playground/stack.yaml similarity index 100% rename from reanimate-playground/stack.yaml rename to playground/stack.yaml diff --git a/reanimate-playground/viewer-elm/README.md b/playground/viewer-elm/README.md similarity index 100% rename from reanimate-playground/viewer-elm/README.md rename to playground/viewer-elm/README.md diff --git a/reanimate-playground/viewer-elm/dist/bulma.min.css b/playground/viewer-elm/dist/bulma.min.css similarity index 100% rename from reanimate-playground/viewer-elm/dist/bulma.min.css rename to playground/viewer-elm/dist/bulma.min.css diff --git a/reanimate-playground/viewer-elm/dist/collections-white-48dp.svg b/playground/viewer-elm/dist/collections-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/collections-white-48dp.svg rename to playground/viewer-elm/dist/collections-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/embed.css b/playground/viewer-elm/dist/embed.css similarity index 100% rename from reanimate-playground/viewer-elm/dist/embed.css rename to playground/viewer-elm/dist/embed.css diff --git a/reanimate-playground/viewer-elm/dist/embed.js b/playground/viewer-elm/dist/embed.js similarity index 100% rename from reanimate-playground/viewer-elm/dist/embed.js rename to playground/viewer-elm/dist/embed.js diff --git a/reanimate-playground/viewer-elm/dist/forward_10-white-48dp.svg b/playground/viewer-elm/dist/forward_10-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/forward_10-white-48dp.svg rename to playground/viewer-elm/dist/forward_10-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/help_outline-white-48dp.svg b/playground/viewer-elm/dist/help_outline-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/help_outline-white-48dp.svg rename to playground/viewer-elm/dist/help_outline-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/home-white-48dp.svg b/playground/viewer-elm/dist/home-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/home-white-48dp.svg rename to playground/viewer-elm/dist/home-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/index.html b/playground/viewer-elm/dist/index.html similarity index 100% rename from reanimate-playground/viewer-elm/dist/index.html rename to playground/viewer-elm/dist/index.html diff --git a/reanimate-playground/viewer-elm/dist/pause_circle_outline-white-48dp.svg b/playground/viewer-elm/dist/pause_circle_outline-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/pause_circle_outline-white-48dp.svg rename to playground/viewer-elm/dist/pause_circle_outline-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/play_circle_outline-white-48dp.svg b/playground/viewer-elm/dist/play_circle_outline-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/play_circle_outline-white-48dp.svg rename to playground/viewer-elm/dist/play_circle_outline-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/playground.js b/playground/viewer-elm/dist/playground.js similarity index 94% rename from reanimate-playground/viewer-elm/dist/playground.js rename to playground/viewer-elm/dist/playground.js index 175f227..4a70acd 100644 --- a/reanimate-playground/viewer-elm/dist/playground.js +++ b/playground/viewer-elm/dist/playground.js @@ -58,6 +58,7 @@ function playgroundInit(elt) { node: elt }); app.ports.sendSocketCommand.subscribe(sendSocketCommand); + var tHandler = setTimeout(function(){},0); return { play: function () { app.ports.receiveControlMsg.send('play'); @@ -78,8 +79,11 @@ function playgroundInit(elt) { app.ports.receiveControlMsg.send('seek-10'); }, newCode: function(code) { - lastScript = code; - app.ports.receiveEditorMsg.send(code); + clearTimeout(tHandler); + tHandler = setTimeout(function() { + lastScript = code; + app.ports.receiveEditorMsg.send(code); + }, 500); } }; } diff --git a/reanimate-playground/viewer-elm/dist/replay_10-white-48dp.svg b/playground/viewer-elm/dist/replay_10-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/replay_10-white-48dp.svg rename to playground/viewer-elm/dist/replay_10-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/skip_next-white-48dp.svg b/playground/viewer-elm/dist/skip_next-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/skip_next-white-48dp.svg rename to playground/viewer-elm/dist/skip_next-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/skip_previous-white-48dp.svg b/playground/viewer-elm/dist/skip_previous-white-48dp.svg similarity index 100% rename from reanimate-playground/viewer-elm/dist/skip_previous-white-48dp.svg rename to playground/viewer-elm/dist/skip_previous-white-48dp.svg diff --git a/reanimate-playground/viewer-elm/dist/snippets.js b/playground/viewer-elm/dist/snippets.js similarity index 100% rename from reanimate-playground/viewer-elm/dist/snippets.js rename to playground/viewer-elm/dist/snippets.js diff --git a/reanimate-playground/viewer-elm/dist/style.css b/playground/viewer-elm/dist/style.css similarity index 100% rename from reanimate-playground/viewer-elm/dist/style.css rename to playground/viewer-elm/dist/style.css diff --git a/reanimate-playground/viewer-elm/elm.json b/playground/viewer-elm/elm.json similarity index 100% rename from reanimate-playground/viewer-elm/elm.json rename to playground/viewer-elm/elm.json diff --git a/reanimate-playground/viewer-elm/package.json b/playground/viewer-elm/package.json similarity index 100% rename from reanimate-playground/viewer-elm/package.json rename to playground/viewer-elm/package.json diff --git a/reanimate-playground/viewer-elm/src/Fps.elm b/playground/viewer-elm/src/Fps.elm similarity index 100% rename from reanimate-playground/viewer-elm/src/Fps.elm rename to playground/viewer-elm/src/Fps.elm diff --git a/reanimate-playground/viewer-elm/src/Main.elm b/playground/viewer-elm/src/Main.elm similarity index 94% rename from reanimate-playground/viewer-elm/src/Main.elm rename to playground/viewer-elm/src/Main.elm index 760f630..d75a359 100644 --- a/reanimate-playground/viewer-elm/src/Main.elm +++ b/playground/viewer-elm/src/Main.elm @@ -131,6 +131,7 @@ type alias Animation = , player : Player , bestFrame : Maybe String , frameDeltas : List Float + , warning : Maybe String } @@ -142,6 +143,7 @@ initAnimation frameCount = , player = Playing 0 , bestFrame = Nothing , frameDeltas = Fps.init + , warning = Nothing } @@ -352,6 +354,12 @@ processMessage data model = "error" :: errorLines -> Problem (CompilationError (String.join "\n" errorLines)) + [ "warning", warning ] -> + case model of + Animating animation -> + Animating { animation | warning = Just warning } + _ -> Problem (CompilationError warning) + [ "frame_count", n ] -> case String.toInt n of Just frameCount -> @@ -396,8 +404,8 @@ view model = Problem problem -> problemView problem - Animating { bestFrame } -> - frameView bestFrame + Animating { bestFrame, warning } -> + frameView bestFrame warning ] ] @@ -415,8 +423,8 @@ framesPerMillisecond = -frameView : Maybe String -> Html Msg -frameView bestFrame = +frameView : Maybe String -> Maybe String -> Html Msg +frameView bestFrame mbWarning = let image = case bestFrame of @@ -425,9 +433,14 @@ frameView bestFrame = Nothing -> Html.text "" + warn = + case mbWarning of + Just txt -> Html.span [ class "warning" ] [Html.text txt] + Nothing -> Html.span [] [] in Html.div [ class "viewer" ] [ image + , warn ] diff --git a/reanimate-playground/viewer-elm/src/Ports.elm b/playground/viewer-elm/src/Ports.elm similarity index 100% rename from reanimate-playground/viewer-elm/src/Ports.elm rename to playground/viewer-elm/src/Ports.elm diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs index fa69322..8e9886f 100644 --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -14,7 +14,7 @@ module Reanimate.Render ( render , renderSvgs , renderSnippets -- :: Animation -> IO () - , renderOneFrame + , renderLimitedFrames , Format(..) , Raster(..) , Width, Height, FPS @@ -82,27 +82,35 @@ renderSvgs folder offset _prettyPrint ani = do hPutStrLn stderr msg exitWith (ExitFailure 1) --- | Select a single frame that doesn't already exist in the output --- folder and render it. If all frames have been rendered, print "Done". -renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO () -renderOneFrame folder offset _prettyPrint rate ani = - worker (frameOrder rate frameCount) +-- | Render as many frames as possible in 2 seconds. Limited to 20 frames. +renderLimitedFrames :: FilePath -> Int -> Bool -> Int -> Animation -> IO () +renderLimitedFrames folder offset _prettyPrint rate ani = do + now <- getCurrentTime + worker (addUTCTime timeLimit now) frameLimit (frameOrder rate frameCount) where - worker [] = putStrLn "Done" - worker (x:xs) = do - let nth = (x+offset) `mod` frameCount - now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth - frame = frameAt (if frameCount <= 1 then 0 else now) ani - svg = renderSvg Nothing Nothing frame - path = folder show nth <.> "svg" - tmpPath = path <.> "tmp" - haveFile <- doesFileExist path - if haveFile - then worker xs + timeLimit = 2 + frameLimit = 20 :: Int + worker _ 0 _ = return () + worker _ _ [] = putStrLn "Done" + worker localTimeLimit l (x:xs) = do + curTime <- getCurrentTime + if curTime > localTimeLimit + then return () else do - writeFile tmpPath svg - renameOrCopyFile tmpPath path - print nth + let nth = (x+offset) `mod` frameCount + now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + frame = frameAt (if frameCount <= 1 then 0 else now) ani + svg = renderSvg Nothing Nothing frame + path = folder show nth <.> "svg" + tmpPath = path <.> "tmp" + haveFile <- doesFileExist path + if haveFile + then worker localTimeLimit l xs + else do + writeFile tmpPath svg + renameOrCopyFile tmpPath path + print nth + worker localTimeLimit (l-1) xs frameCount = round (duration ani * fromIntegral rate) :: Int -- XXX: Merge with 'renderSvgs'