web api to parse, render, and run code

src/Swarm/App.hs

@@ -70,9 +70,11 @@ appMain opts = do
         upRel <- getNewerReleaseVersion (repoGitInfo opts)
         writeBChan chan (UpstreamVersion upRel)
 
-      -- Start the web service with a reference to the game state
+      -- Start the web service with a reference to the game state.
+      -- NOTE: This reference should be considered read-only by
+      -- the web service; the game alone shall host the canonical state.
       appStateRef <- newIORef s
-      eport <- Swarm.Web.startWebThread (userWebPort opts) appStateRef
+      eport <- Swarm.Web.startWebThread (userWebPort opts) appStateRef chan
 
       let logP p = logEvent Said ("Web API", -2) ("started on :" <> T.pack (show p))
       let logE e = logEvent (ErrorTrace Error) ("Web API", -2) (T.pack e)
@@ -119,7 +121,8 @@ demoWeb = do
     Left errMsg -> T.putStrLn errMsg
     Right s -> do
       appStateRef <- newIORef s
-      webMain Nothing demoPort appStateRef
+      chan <- newBChan 5
+      webMain Nothing demoPort appStateRef chan
  where
   demoScenario = Just "./data/scenarios/Testing/475-wait-one.yaml"
 

src/Swarm/TUI/Controller.hs

@@ -19,6 +19,7 @@ module Swarm.TUI.Controller (
   updateUI,
 
   -- ** REPL panel
+  runBaseWebCode,
   handleREPLEvent,
   validateREPLForm,
   adjReplHistIndex,
@@ -259,9 +260,12 @@ handleMainEvent ev = do
   let isCreative = s ^. gameState . creativeMode
   let hasDebug = fromMaybe isCreative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug
   case ev of
-    AppEvent Frame
-      | s ^. gameState . paused -> continueWithoutRedraw
-      | otherwise -> runFrameUI
+    AppEvent ae -> case ae of
+      Frame
+        | s ^. gameState . paused -> continueWithoutRedraw
+        | otherwise -> runFrameUI
+      Web (RunWebCode c) -> runBaseWebCode c
+      _ -> continueWithoutRedraw
     -- ctrl-q works everywhere
     ControlChar 'q' ->
       case s ^. gameState . winCondition of
@@ -949,6 +953,51 @@ handleREPLEventPiloting x = case x of
       & replPromptText .~ nt
       & replPromptType .~ CmdPrompt []
 
+runBaseWebCode :: MonadState AppState m => T.Text -> m ()
+runBaseWebCode uinput = do
+  s <- get
+  let topCtx = topContext s
+  unless (s ^. gameState . replWorking) $
+    runBaseCode topCtx uinput
+
+runBaseCode :: MonadState AppState m => RobotContext -> T.Text -> m ()
+runBaseCode topCtx uinput =
+  case processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput of
+    Right mt -> do
+      uiState %= resetREPL "" (CmdPrompt [])
+      uiState . uiREPL . replHistory %= addREPLItem (REPLEntry uinput)
+      runBaseTerm topCtx mt
+    Left err -> do
+      uiState . uiError ?= err
+
+runBaseTerm :: MonadState AppState m => RobotContext -> Maybe ProcessedTerm -> m ()
+runBaseTerm topCtx =
+  modify . maybe id startBaseProgram
+ where
+  -- The player typed something at the REPL and hit Enter; this
+  -- function takes the resulting ProcessedTerm (if the REPL
+  -- input is valid) and sets up the base robot to run it.
+  startBaseProgram t@(ProcessedTerm (Module tm _) reqs reqCtx) =
+    -- Set the REPL status to Working
+    (gameState . replStatus .~ REPLWorking (Typed Nothing (tm ^. sType) reqs))
+      -- The `reqCtx` maps names of variables defined in the
+      -- term (by `def` statements) to their requirements.
+      -- E.g. if we had `def m = move end`, the reqCtx would
+      -- record the fact that `m` needs the `move` capability.
+      -- We simply add the entire `reqCtx` to the robot's
+      -- context, so we can look up requirements if we later
+      -- need to requirements-check an argument to `build` or
+      -- `reprogram` at runtime.  See the discussion at
+      -- https://github.com/swarm-game/swarm/pull/827 for more
+      -- details.
+      . (gameState . baseRobot . robotContext . defReqs <>~ reqCtx)
+      -- Set up the robot's CESK machine to evaluate/execute the
+      -- given term, being sure to initialize the CESK machine
+      -- environment and store from the top-level context.
+      . (gameState . baseRobot . machine .~ initMachine t (topCtx ^. defVals) (topCtx ^. defStore))
+      -- Finally, be sure to activate the base robot.
+      . (gameState %~ execState (activateRobot 0))
+
 -- | Handle a user input event for the REPL.
 handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState ()
 handleREPLEventTyping = \case
@@ -962,39 +1011,9 @@ handleREPLEventTyping = \case
         repl = s ^. uiState . uiREPL
         uinput = repl ^. replPromptText
 
-        -- The player typed something at the REPL and hit Enter; this
-        -- function takes the resulting ProcessedTerm (if the REPL
-        -- input is valid) and sets up the base robot to run it.
-        startBaseProgram t@(ProcessedTerm (Module tm _) reqs reqCtx) =
-          -- Set the REPL status to Working
-          (gameState . replStatus .~ REPLWorking (Typed Nothing (tm ^. sType) reqs))
-            -- The `reqCtx` maps names of variables defined in the
-            -- term (by `def` statements) to their requirements.
-            -- E.g. if we had `def m = move end`, the reqCtx would
-            -- record the fact that `m` needs the `move` capability.
-            -- We simply add the entire `reqCtx` to the robot's
-            -- context, so we can look up requirements if we later
-            -- need to requirements-check an argument to `build` or
-            -- `reprogram` at runtime.  See the discussion at
-            -- https://github.com/swarm-game/swarm/pull/827 for more
-            -- details.
-            . (gameState . baseRobot . robotContext . defReqs <>~ reqCtx)
-            -- Set up the robot's CESK machine to evaluate/execute the
-            -- given term, being sure to initialize the CESK machine
-            -- environment and store from the top-level context.
-            . (gameState . baseRobot . machine .~ initMachine t (topCtx ^. defVals) (topCtx ^. defStore))
-            -- Finally, be sure to activate the base robot.
-            . (gameState %~ execState (activateRobot 0))
-
     if not $ s ^. gameState . replWorking
       then case repl ^. replPromptType of
-        CmdPrompt _ ->
-          case processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput of
-            Right mt -> do
-              uiState %= resetREPL "" (CmdPrompt [])
-              uiState . uiREPL . replHistory %= addREPLItem (REPLEntry uinput)
-              modify $ maybe id startBaseProgram mt
-            Left err -> uiState . uiError ?= err
+        CmdPrompt _ -> runBaseCode topCtx uinput
         SearchPrompt hist ->
           case lastEntry uinput hist of
             Nothing -> uiState %= resetREPL "" (CmdPrompt [])

src/Swarm/TUI/Model.hs

@@ -12,6 +12,7 @@ module Swarm.TUI.Model (
   -- * Custom UI label types
   -- $uilabel
   AppEvent (..),
+  WebCommand (..),
   FocusablePanel (..),
   Name (..),
 
@@ -140,12 +141,15 @@ import Swarm.Version (NewReleaseFailure (NoMainUpstreamRelease))
 -- $uilabel These types are used as parameters to various @brick@
 -- types.
 
+newtype WebCommand = RunWebCode Text
+  deriving (Show)
+
 -- | 'Swarm.TUI.Model.AppEvent' represents a type for custom event types our app can
---   receive.  At the moment, we only have one custom event, but it's
---   very important: a separate thread sends 'Frame' events as fast as
+--   receive. The primary custom event 'Frame' is sent by a separate thread as fast as
 --   it can, telling the TUI to render a new frame.
 data AppEvent
   = Frame
+  | Web WebCommand
   | UpstreamVersion (Either NewReleaseFailure String)
   deriving (Show)
 

src/Swarm/Web.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
@@ -21,6 +22,7 @@
 --   * TODO: #493 export the whole game state
 module Swarm.Web where
 
+import Brick.BChan
 import CMarkGFM qualified as CMark (commonmarkToHtml)
 import Control.Arrow (left)
 import Control.Concurrent (forkIO)
@@ -37,6 +39,7 @@ import Data.Maybe (fromMaybe)
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as L
 import Data.Text.Lazy.Encoding (encodeUtf8)
+import Data.Tree (Tree (Node), drawTree)
 import Network.HTTP.Types (ok200)
 import Network.Wai (responseLBS)
 import Network.Wai qualified
@@ -49,6 +52,10 @@ import Swarm.Game.Scenario.Objective
 import Swarm.Game.Scenario.Objective.Graph
 import Swarm.Game.Scenario.Objective.WinCheck
 import Swarm.Game.State
+import Swarm.Language.Module
+import Swarm.Language.Pipeline
+import Swarm.Language.Pretty (prettyString)
+import Swarm.Language.Syntax
 import Swarm.TUI.Model
 import Swarm.TUI.Model.Goal
 import Swarm.TUI.Model.UI
@@ -60,6 +67,9 @@ newtype RobotID = RobotID Int
 instance FromHttpApiData RobotID where
   parseUrlPiece = fmap RobotID . left T.pack . readEither . T.unpack
 
+instance SD.ToSample T.Text where
+  toSamples _ = SD.noSamples
+
 type SwarmAPI =
   "robots" :> Get '[JSON] [Robot]
     :<|> "robot" :> Capture "id" RobotID :> Get '[JSON] (Maybe Robot)
@@ -68,6 +78,8 @@ type SwarmAPI =
     :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo)
     :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking
     :<|> "goals" :> Get '[JSON] WinCondition
+    :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text
+    :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text
     :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem]
 
 instance ToCapture (Capture "id" RobotID) where
@@ -99,15 +111,22 @@ docsBS =
  where
   intro = SD.DocIntro "Swarm Web API" ["All of the valid endpoints are documented below."]
 
-mkApp :: IORef AppState -> Servant.Server SwarmAPI
-mkApp appStateRef =
+mkApp ::
+  -- | Readonly
+  IORef AppState ->
+  -- | Writable
+  BChan AppEvent ->
+  Servant.Server SwarmAPI
+mkApp appStateRef chan =
   robotsHandler
     :<|> robotHandler
     :<|> prereqsHandler
     :<|> activeGoalsHandler
     :<|> goalsGraphHandler
     :<|> uiGoalHandler
     :<|> goalsHandler
+    :<|> codeRenderHandler
+    :<|> codeRunHandler
     :<|> replHandler
  where
   robotsHandler = do
@@ -137,22 +156,37 @@ mkApp appStateRef =
   goalsHandler = do
     appState <- liftIO (readIORef appStateRef)
     return $ appState ^. gameState . winCondition
+  codeRenderHandler contents = do
+    return $ T.pack $ case processTermEither contents of
+      Right (ProcessedTerm (Module stx@(Syntax' _srcLoc _term _) _) _ _) ->
+        drawTree . fmap prettyString . para Node $ stx
+      Left x -> x
+  codeRunHandler contents = do
+    liftIO . writeBChan chan . Web $ RunWebCode contents
+    return $ T.pack "Sent\n"
   replHandler = do
     appState <- liftIO (readIORef appStateRef)
     let replHistorySeq = appState ^. uiState . uiREPL . replHistory . replSeq
         items = toList replHistorySeq
     pure items
 
-webMain :: Maybe (MVar (Either String ())) -> Warp.Port -> IORef AppState -> IO ()
-webMain baton port appStateRef = catch (Warp.runSettings settings app) handleErr
+webMain ::
+  Maybe (MVar (Either String ())) ->
+  Warp.Port ->
+  -- | Readonly
+  IORef AppState ->
+  -- | Writable
+  BChan AppEvent ->
+  IO ()
+webMain baton port appStateRef chan = catch (Warp.runSettings settings app) handleErr
  where
   settings = Warp.setPort port $ onReady Warp.defaultSettings
   onReady = case baton of
     Just mv -> Warp.setBeforeMainLoop $ putMVar mv (Right ())
     Nothing -> id
 
   server :: Server ToplevelAPI
-  server = mkApp appStateRef :<|> Tagged serveDocs
+  server = mkApp appStateRef chan :<|> Tagged serveDocs
    where
     serveDocs _ resp =
       resp $ responseLBS ok200 [plain] docsBS
@@ -175,13 +209,19 @@ defaultPort = 5357
 --   startup doesn't work.  Otherwise, ignore the failure.  In any
 --   case, return a @Maybe Port@ value representing whether a web
 --   server is actually running, and if so, what port it is on.
-startWebThread :: Maybe Warp.Port -> IORef AppState -> IO (Either String Warp.Port)
+startWebThread ::
+  Maybe Warp.Port ->
+  -- | Read-only reference to the application state.
+  IORef AppState ->
+  -- | Writable channel to send events to the game
+  BChan AppEvent ->
+  IO (Either String Warp.Port)
 -- User explicitly provided port '0': don't run the web server
-startWebThread (Just 0) _ = pure $ Left "The web port has been turned off."
-startWebThread portM appStateRef = do
+startWebThread (Just 0) _ _ = pure $ Left "The web port has been turned off."
+startWebThread portM appStateRef chan = do
   baton <- newEmptyMVar
   let port = fromMaybe defaultPort portM
-  void $ forkIO $ webMain (Just baton) port appStateRef
+  void $ forkIO $ webMain (Just baton) port appStateRef chan
   res <- timeout 500_000 (takeMVar baton)
   case (portM, res) of
     -- User requested explicit port but server didn't start: fail