render map preview as dynamic PNG (#2184)

Shows a map thumbnail for an uploaded scenario.

```
./scripts/demo/server-native.sh
```
![Screenshot from 2024-10-18 15-45-46](https://github.com/user-attachments/assets/f980bc40-5e10-4973-aaa4-9ace1864f915)

app/scene/Main.hs

@@ -6,7 +6,7 @@ module Main where
 
 import Options.Applicative
 import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))
-import Swarm.Game.World.Render (FailureMode (..), OuputFormat (..), RenderOpts (..), doRenderCmd)
+import Swarm.Game.World.Render (FailureMode (..), OuputFormat (..), RenderComputationContext (..), RenderOpts (..), doRenderCmd)
 
 data CLI
   = RenderMap FilePath RenderOpts
@@ -20,12 +20,16 @@ cliParser =
       <$> option auto (metavar "WIDTH" <> short 'w' <> long "width" <> help "width of source grid")
       <*> option auto (metavar "HEIGHT" <> short 'h' <> long "height" <> help "height of source grid")
 
+  renderComputationOpts =
+    RenderComputationContext
+      <$> seed
+      <*> optional sizeOpts
+
   subOpts =
     RenderOpts
-      <$> seed
+      <$> renderComputationOpts
       <*> flag ConsoleText PngImage (long "png" <> help "Render to PNG")
       <*> option str (long "dest" <> short 'd' <> value "output.png" <> help "Output filepath")
-      <*> optional sizeOpts
       <*> flag Terminate RenderBlankImage (long "fail-blank" <> short 'b' <> help "Render blank image upon failure")
 
   seed :: Parser (Maybe Int)

src/swarm-scenario/Swarm/Game/World/Render.hs

@@ -5,10 +5,13 @@
 module Swarm.Game.World.Render (
   FailureMode (..),
   RenderOpts (..),
+  RenderComputationContext (..),
   OuputFormat (..),
   ColorableCell,
   getDisplayGrid,
   doRenderCmd,
+  getRenderableGrid,
+  renderImage,
 ) where
 
 import Codec.Picture
@@ -17,6 +20,8 @@ import Control.Carrier.Throw.Either (runThrow)
 import Control.Effect.Lift (Lift, sendIO)
 import Control.Effect.Throw
 import Control.Lens (view, (^.))
+import Control.Monad.Logger
+import Control.Monad.Trans (MonadIO)
 import Data.Aeson
 import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
@@ -43,12 +48,11 @@ import Swarm.Game.State.Landscape
 import Swarm.Game.Universe
 import Swarm.Game.World.Coords
 import Swarm.Game.World.Gen (Seed)
-import Swarm.Pretty (prettyString)
-import Swarm.Util (surfaceEmpty)
+import Swarm.Pretty (prettyText)
+import Swarm.Util (failT, surfaceEmpty)
 import Swarm.Util.Content
 import Swarm.Util.Erasable (erasableToMaybe)
 import Swarm.Util.Yaml
-import System.IO (hPutStrLn, stderr)
 
 newtype OneBitColor = OneBitColor Bool
   deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
@@ -83,13 +87,17 @@ data FailureMode
   = Terminate
   | RenderBlankImage
 
+data RenderComputationContext = RenderComputationContext
+  { _renderSeed :: Maybe Seed
+  , gridSize :: Maybe AreaDimensions
+  }
+
 -- | Command-line options for configuring the app.
 data RenderOpts = RenderOpts
-  { renderSeed :: Maybe Seed
+  { renderComputation :: RenderComputationContext
   -- ^ Explicit seed chosen by the user.
   , outputFormat :: OuputFormat
   , outputFilepath :: FilePath
-  , gridSize :: Maybe AreaDimensions
   , failureMode :: FailureMode
   }
 
@@ -142,13 +150,21 @@ getDisplayGrid vc sLandscape ls maybeSize =
 
   firstScenarioWorld = NE.head $ view scenarioWorlds sLandscape
 
-getRenderableGrid ::
+getRenderableGridFromPath ::
   (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
   RenderOpts ->
   FilePath ->
-  m (Grid (PCell EntityFacade), M.Map WorldAttr PreservableColor)
-getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize _) fp = do
+  m ThumbnailRenderContext
+getRenderableGridFromPath (RenderOpts ctx _ _ _) fp = do
   (myScenario, _gsi) <- loadStandaloneScenario fp
+  getRenderableGrid ctx myScenario
+
+getRenderableGrid ::
+  Has (Lift IO) sig m =>
+  RenderComputationContext ->
+  Scenario ->
+  m ThumbnailRenderContext
+getRenderableGrid (RenderComputationContext maybeSeed maybeSize) myScenario = do
   let sLandscape = myScenario ^. scenarioLandscape
   theSeed <- sendIO $ arbitrateSeed maybeSeed sLandscape
 
@@ -159,38 +175,57 @@ getRenderableGrid (RenderOpts maybeSeed _ _ maybeSize _) fp = do
         view planar $
           determineStaticViewCenter sLandscape worldTuples
 
-  return (getDisplayGrid vc sLandscape myLandscape maybeSize, sLandscape ^. scenarioCosmetics)
+  return $
+    ThumbnailRenderContext
+      (getDisplayGrid vc sLandscape myLandscape maybeSize)
+      (sLandscape ^. scenarioCosmetics)
 
 doRenderCmd :: RenderOpts -> FilePath -> IO ()
-doRenderCmd opts@(RenderOpts _ asPng _ _ _) mapPath =
+doRenderCmd opts@(RenderOpts _ asPng _ _) mapPath =
   case asPng of
     ConsoleText -> printScenarioMap =<< renderScenarioMap opts mapPath
     PngImage -> renderScenarioPng opts mapPath
 
 renderScenarioMap :: RenderOpts -> FilePath -> IO [String]
 renderScenarioMap opts fp = simpleErrorHandle $ do
-  (grid, _) <- getRenderableGrid opts fp
+  ThumbnailRenderContext grid _ <- getRenderableGridFromPath opts fp
   return $ getRows $ getDisplayChar <$> grid
 
+data ThumbnailRenderContext
+  = ThumbnailRenderContext
+      (Grid (PCell EntityFacade))
+      (M.Map WorldAttr PreservableColor)
+
+renderImage ::
+  ThumbnailRenderContext ->
+  Image PixelRGBA8
+renderImage (ThumbnailRenderContext grid aMap) =
+  makeImage $ getTerrainEntityColor aMap <$> grid
+
+renderImageHandleFailure ::
+  (MonadFail m, MonadIO m) =>
+  RenderOpts ->
+  Either SystemFailure ThumbnailRenderContext ->
+  LoggingT m (Image PixelRGBA8)
+renderImageHandleFailure opts result =
+  case result of
+    Left err -> handleFailure err
+    Right ctx -> return $ renderImage ctx
+ where
+  handleFailure err = case failureMode opts of
+    Terminate -> failT $ pure errorMsg
+    RenderBlankImage -> do
+      logWarnN errorMsg
+      let s = maybe (1, 1) (both fromIntegral . asTuple) $ gridSize $ renderComputation opts
+      return $ uncurry (generateImage $ \_x _y -> PixelRGBA8 0 0 0 255) s
+   where
+    errorMsg = prettyText err
+
 renderScenarioPng :: RenderOpts -> FilePath -> IO ()
 renderScenarioPng opts fp = do
-  result <- runThrow $ getRenderableGrid opts fp
-  img <- case result of
-    Left (err :: SystemFailure) -> case failureMode opts of
-      Terminate -> fail errorMsg
-      RenderBlankImage -> do
-        hPutStrLn stderr errorMsg
-        let s = maybe (1, 1) (both fromIntegral . asTuple) $ gridSize opts
-        return $ uncurry (generateImage $ \_x _y -> PixelRGBA8 0 0 0 255) s
-     where
-      errorMsg :: String
-      errorMsg = prettyString err
-    Right (grid, aMap) ->
-      return $
-        makeImage $
-          getTerrainEntityColor aMap <$> grid
+  result <- runThrow $ getRenderableGridFromPath opts fp
+  img <- runStderrLoggingT $ renderImageHandleFailure opts result
   writePng (outputFilepath opts) img
 
 printScenarioMap :: [String] -> IO ()
-printScenarioMap =
-  sendIO . mapM_ putStrLn
+printScenarioMap = sendIO . mapM_ putStrLn

src/swarm-tournament/Swarm/Web/Tournament.hs

@@ -19,6 +19,7 @@ module Swarm.Web.Tournament (
   app,
 ) where
 
+import Codec.Picture
 import Commonmark qualified as Mark (commonmark, renderHtml)
 import Control.Lens hiding (Context)
 import Control.Monad.IO.Class (liftIO)
@@ -51,10 +52,12 @@ import Network.Wai.Parse (
   setMaxRequestNumFiles,
  )
 import Servant
+import Servant.JuicyPixels (PNG)
 import Servant.Multipart
 import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)
 import Swarm.Game.Scenario (ScenarioMetadata, scenarioMetadata)
 import Swarm.Game.State (Sha1 (..))
+import Swarm.Game.World.Render
 import Swarm.Web.Auth
 import Swarm.Web.Tournament.Database.Query
 import Swarm.Web.Tournament.Type
@@ -90,6 +93,7 @@ type TournamentAPI =
     :<|> "api" :> "private" :> "upload" :> "solution" :> Header "Referer" TL.Text :> AuthProtect "cookie-auth" :> MultipartForm Mem (MultipartData Mem) :> Verb 'POST 303 '[JSON] (Headers '[Header "Location" TL.Text] SolutionFileCharacterization)
     :<|> "scenario" :> Capture "sha1" Sha1 :> "metadata" :> Get '[JSON] ScenarioMetadata
     :<|> "scenario" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text
+    :<|> "scenario" :> Capture "sha1" Sha1 :> "thumbnail" :> Get '[PNG] DynamicImage
     :<|> "solution" :> Capture "sha1" Sha1 :> "fetch" :> Get '[PlainText] TL.Text
     :<|> "list" :> "games" :> Get '[JSON] [TournamentGame]
     :<|> "list" :> "game" :> Capture "sha1" Sha1 :> Get '[JSON] GameWithSolutions
@@ -104,6 +108,7 @@ mkApp appData =
     :<|> uploadSolution appData
     :<|> getScenarioMetadata appData
     :<|> downloadRedactedScenario appData
+    :<|> renderThumbnail appData
     :<|> downloadSolution appData
     :<|> listScenarios
     :<|> listSolutions
@@ -260,6 +265,18 @@ downloadRedactedScenario (AppData _ _ persistenceLayer _) scenarioSha1 = do
     withExceptT DecodingFailure . except . decodeUtf8' . LBS.fromStrict $
       encodeWith defaultEncodeOptions redactedDict
 
+renderThumbnail :: AppData -> Sha1 -> Handler DynamicImage
+renderThumbnail (AppData _ _ persistenceLayer _) scenarioSha1 = do
+  Handler . withExceptT toServantError $ do
+    doc <-
+      ExceptT $
+        maybeToEither (DatabaseRetrievalFailure scenarioSha1)
+          <$> (getContent . scenarioStorage) persistenceLayer scenarioSha1
+
+    s <- withExceptT RetrievedInstantiationFailure $ initScenarioObjectWithEnv doc
+    g <- getRenderableGrid (RenderComputationContext Nothing Nothing) s
+    return $ ImageRGBA8 $ renderImage g
+
 listScenarios :: Handler [TournamentGame]
 listScenarios =
   Handler . liftIO . withConnection databaseFilename $ runReaderT listGames

swarm.cabal

@@ -251,6 +251,9 @@ common minimorph
 common MissingH
   build-depends: MissingH >=1.4 && <2
 
+common monad-logger
+  build-depends: monad-logger >=0.3.0 && <0.4.0
+
 common mtl
   build-depends: mtl >=2.2.2 && <2.4
 
@@ -296,6 +299,9 @@ common servant-docs
 common servant-multipart
   build-depends: servant-multipart >=0.11 && <1.0
 
+common servant-JuicyPixels
+  build-depends: servant-JuicyPixels >=0.3.1 && <0.3.2
+
 common servant-server
   build-depends: servant-server >=0.19 && <0.22
 
@@ -569,6 +575,8 @@ library swarm-scenario
     lens,
     linear,
     megaparsec,
+    monad-logger,
+    mtl,
     murmur3,
     palette,
     parser-combinators,
@@ -804,6 +812,8 @@ library swarm-tournament
     http-types,
     lens,
     mtl,
+    JuicyPixels,
+    servant-JuicyPixels,
     servant-docs,
     servant-multipart,
     servant-server,

tournament/web/list-solutions.html

@@ -27,19 +27,25 @@
         const queryString = window.location.search;
         const urlParams = new URLSearchParams(queryString);
         const scenarioHash = urlParams.get('scenario')
-        document.getElementById('scenario-field').value=scenarioHash;
+        document.getElementById('scenario-field').value = scenarioHash;
 
         const tableElement = document.querySelector("table");
         doFetch(tableElement, scenarioHash);
+
+        const mapPreviewImage = document.getElementById('map-preview-image');
+        mapPreviewImage.src = "scenario/" + scenarioHash + "/thumbnail";
       }
     </script>
   </head>
   <body>
     <div id="login-info-container"></div>
     [<a href="/list-games.html">Back to scenarios</a>]
     <h1 id="main-header">Scenario info</h1>
-
-    <h2>Solution submissions</h2>
+
+    <img id="map-preview-image" style="float: left; margin-right: 2em; image-rendering: pixelated" width="150"/>
+
+    <h2 style="clear: left">Solution submissions</h2>
+
     <table id="my-table">
         <thead>
           <tr data-sort-method="none">

tournament/web/script/list-solutions.js

@@ -32,6 +32,7 @@ function mkDefinitionEntryElements(title, element) {
 function renderGameInfoBox(entry) {
 
     const dl = document.createElement("dl");
+    dl.style.float = "left";
     const pairs = [
         mkDefinitionEntryElements("Title:", regularSpan(entry.scenarioTitle)),
         mkDefinitionEntryElements("File:", mkLink(entry.originalFilename, "scenario/" + entry.scenarioHash + "/fetch")),
@@ -55,9 +56,9 @@ function doFetch(myTable, gameSha1) {
             response.json().then(data => {
                 const infoBox = renderGameInfoBox(data.theGame);
 
-                const mainHeaderElement = document.getElementById('main-header');
+                const previewImageElement = document.getElementById('map-preview-image');
 
-                mainHeaderElement.parentNode.insertBefore(infoBox, mainHeaderElement.nextSibling);
+                previewImageElement.parentNode.insertBefore(infoBox, previewImageElement.nextSibling);
 
                 const tableElement = document.getElementById('my-table');
                 const myTableBody = myTable.querySelector("tbody");