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

@@ -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

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
 

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
 

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);
     }
   };
 }

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
         ]
 
 

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'