Reply to Web API run with result

* send InProgress or Rejected
* once REPLDone send Complete
* closes #1426

src/swarm-engine/Swarm/Game/State/Substate.hs

@@ -54,6 +54,7 @@ module Swarm.Game.State.Substate (
   initiallyRunCode,
   replStatus,
   replNextValueIndex,
+  replListener,
   inputHandler,
 
   -- *** Discovery
@@ -301,6 +302,7 @@ robotStepsPerTick :: Lens' TemporalState Int
 data GameControls = GameControls
   { _replStatus :: REPLStatus
   , _replNextValueIndex :: Integer
+  , _replListener :: Text -> IO ()
   , _inputHandler :: Maybe (Text, Value)
   , _initiallyRunCode :: Maybe Syntax
   }
@@ -313,6 +315,10 @@ replStatus :: Lens' GameControls REPLStatus
 -- | The index of the next @it{index}@ value
 replNextValueIndex :: Lens' GameControls Integer
 
+-- | The action to be run after transitioning to REPLDone.
+--   This is used to tell Web API the result of run command.
+replListener :: Lens' GameControls (Text -> IO ())
+
 -- | The currently installed input handler and hint text.
 inputHandler :: Lens' GameControls (Maybe (Text, Value))
 
@@ -406,6 +412,7 @@ initGameControls =
   GameControls
     { _replStatus = REPLDone Nothing
     , _replNextValueIndex = 0
+    , _replListener = const $ pure ()
     , _inputHandler = Nothing
     , _initiallyRunCode = Nothing
     }

src/swarm-tui/Swarm/TUI/Controller.hs

@@ -120,47 +120,55 @@ import Swarm.Version (NewReleaseFailure (..))
 
 -- | The top-level event handler for the TUI.
 handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
-handleEvent = \case
-  -- the query for upstream version could finish at any time, so we have to handle it here
-  AppEvent (UpstreamVersion ev) -> do
-    let logReleaseEvent l sev e = runtimeState . eventLog %= logEvent l sev "Release" (T.pack $ show e)
-    case ev of
-      Left e ->
-        let sev = case e of
-              FailedReleaseQuery {} -> Error
-              OnDevelopmentBranch {} -> Info
-              _ -> Warning
-         in logReleaseEvent SystemLog sev e
-      Right _ -> pure ()
-    runtimeState . upstreamRelease .= ev
-  e -> do
-    -- Handle popup display at the very top level, so it is
-    -- unaffected by any other state, e.g. even when starting or
-    -- quitting a game, moving around the menu, the popup
-    -- display will continue as normal.
-    upd <- case e of
-      AppEvent Frame -> Brick.zoom (uiState . uiPopups) progressPopups
-      _ -> pure False
-
-    s <- get
-    if s ^. uiState . uiPlaying
-      then handleMainEvent upd e
-      else do
-        e & case s ^. uiState . uiMenu of
-          -- If we reach the NoMenu case when uiPlaying is False, just
-          -- quit the app.  We should actually never reach this code (the
-          -- quitGame function would have already halted the app).
-          NoMenu -> const halt
-          MainMenu l -> handleMainMenuEvent l
-          NewGameMenu l ->
-            if s ^. uiState . uiLaunchConfig . controls . fileBrowser . fbIsDisplayed
-              then handleFBEvent
-              else case s ^. uiState . uiLaunchConfig . controls . isDisplayedFor of
-                Nothing -> handleNewGameMenuEvent l
-                Just siPair -> handleLaunchOptionsEvent siPair
-          MessagesMenu -> handleMainMessagesEvent
-          AchievementsMenu l -> handleMainAchievementsEvent l
-          AboutMenu -> pressAnyKey (MainMenu (mainMenu About))
+handleEvent e = do
+  playing <- use $ uiState . uiPlaying
+  case e of
+    -- the query for upstream version could finish at any time, so we have to handle it here
+    AppEvent (UpstreamVersion ev) -> handleUpstreamVersionResponse ev
+    AppEvent (Web (RunWebCode {..})) | not playing -> liftIO . webReply $ Rejected NoActiveGame
+    _ -> do
+      -- Handle popup display at the very top level, so it is
+      -- unaffected by any other state, e.g. even when starting or
+      -- quitting a game, moving around the menu, the popup
+      -- display will continue as normal.
+      upd <- case e of
+        AppEvent Frame -> Brick.zoom (uiState . uiPopups) progressPopups
+        _ -> pure False
+      if playing
+        then handleMainEvent upd e
+        else handleMenuEvent e
+
+handleUpstreamVersionResponse :: Either NewReleaseFailure String -> EventM Name AppState ()
+handleUpstreamVersionResponse ev = do
+  let logReleaseEvent l sev e = runtimeState . eventLog %= logEvent l sev "Release" (T.pack $ show e)
+  case ev of
+    Left e ->
+      let sev = case e of
+            FailedReleaseQuery {} -> Error
+            OnDevelopmentBranch {} -> Info
+            _ -> Warning
+       in logReleaseEvent SystemLog sev e
+    Right _ -> pure ()
+  runtimeState . upstreamRelease .= ev
+
+handleMenuEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
+handleMenuEvent e =
+  use (uiState . uiMenu) >>= \case
+    -- If we reach the NoMenu case when uiPlaying is False, just
+    -- quit the app.  We should actually never reach this code (the
+    -- quitGame function would have already halted the app).
+    NoMenu -> halt
+    MainMenu l -> handleMainMenuEvent l e
+    NewGameMenu l -> do
+      launchControls <- use $ uiState . uiLaunchConfig . controls
+      if launchControls ^. fileBrowser . fbIsDisplayed
+        then handleFBEvent e
+        else case launchControls ^. isDisplayedFor of
+          Nothing -> handleNewGameMenuEvent l e
+          Just siPair -> handleLaunchOptionsEvent siPair e
+    MessagesMenu -> handleMainMessagesEvent e
+    AchievementsMenu l -> handleMainAchievementsEvent l e
+    AboutMenu -> pressAnyKey (MainMenu (mainMenu About)) e
 
 -- | The event handler for the main menu.
 --
@@ -294,7 +302,7 @@ handleMainEvent forceRedraw ev = do
         if s ^. gameState . temporal . paused
           then updateAndRedrawUI forceRedraw
           else runFrameUI forceRedraw
-      Web (RunWebCode c) -> runBaseWebCode c
+      Web (RunWebCode e r) -> runBaseWebCode e r
       UpstreamVersion _ -> error "version event should be handled by top-level handler"
     VtyEvent (V.EvResize _ _) -> invalidateCache
     EscapeKey | Just m <- s ^. uiState . uiGameplay . uiModal -> closeModal m
@@ -541,13 +549,19 @@ handleREPLEventPiloting x = case x of
       & replPromptText .~ nt
       & replPromptType .~ CmdPrompt []
 
-runBaseWebCode :: (MonadState AppState m) => T.Text -> m ()
-runBaseWebCode uinput = do
+runBaseWebCode :: (MonadState AppState m, MonadIO m) => T.Text -> (WebInvocationState -> IO ()) -> m ()
+runBaseWebCode uinput ureply = do
   s <- get
-  unless (s ^. gameState . gameControls . replWorking) $
-    runBaseCode uinput
-
-runBaseCode :: (MonadState AppState m) => T.Text -> m ()
+  if s ^. gameState . gameControls . replWorking
+    then liftIO . ureply $ Rejected AlreadyRunning
+    else do
+      gameState . gameControls . replListener .= (ureply . Complete . T.unpack)
+      runBaseCode uinput
+        >>= liftIO . ureply . \case
+          Left err -> Rejected . ParseError $ T.unpack err
+          Right () -> InProgress
+
+runBaseCode :: (MonadState AppState m) => T.Text -> m (Either Text ())
 runBaseCode uinput = do
   addREPLHistItem (mkREPLSubmission uinput)
   resetREPL "" (CmdPrompt [])
@@ -556,8 +570,10 @@ runBaseCode uinput = do
     Right mt -> do
       uiState . uiGameplay . uiREPL . replHistory . replHasExecutedManualInput .= True
       runBaseTerm mt
+      return (Right ())
     Left err -> do
       addREPLHistItem (mkREPLError err)
+      return (Left err)
 
 -- | Handle a user input event for the REPL.
 --
@@ -579,7 +595,7 @@ handleREPLEventTyping = \case
         if not $ s ^. gameState . gameControls . replWorking
           then case theRepl ^. replPromptType of
             CmdPrompt _ -> do
-              runBaseCode uinput
+              void $ runBaseCode uinput
               invalidateCacheEntry REPLHistoryCache
             SearchPrompt hist ->
               case lastEntry uinput hist of

src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs

@@ -17,6 +17,7 @@ import Brick.Widgets.List qualified as BL
 import Control.Applicative (liftA2, pure)
 import Control.Lens as Lens
 import Control.Monad (unless, when)
+import Control.Monad.IO.Class (liftIO)
 import Data.Foldable (toList)
 import Data.List.Extra (enumerate)
 import Data.Maybe (isNothing)
@@ -99,6 +100,8 @@ updateUI = do
     REPLWorking pty (Just v)
       -- It did, and the result was the unit value or an exception.  Just reset replStatus.
       | v `elem` [VUnit, VExc] -> do
+          listener <- use $ gameState . gameControls . replListener
+          liftIO $ listener ""
           gameState . gameControls . replStatus .= REPLDone (Just (pty, v))
           pure True
 
@@ -112,6 +115,8 @@ updateUI = do
               itName = fromString $ "it" ++ show itIx
               out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)]
           addREPLHistItem (mkREPLOutput out)
+          listener <- use $ gameState . gameControls . replListener
+          liftIO $ listener out
           invalidateCacheEntry REPLHistoryCache
           vScrollToEnd replScroll
           gameState . gameControls . replStatus .= REPLDone (Just (finalType, v))

src/swarm-tui/Swarm/TUI/Model.hs

@@ -12,10 +12,14 @@ module Swarm.TUI.Model (
   -- * Custom UI label types
   -- $uilabel
   AppEvent (..),
-  WebCommand (..),
   FocusablePanel (..),
   Name (..),
 
+  -- ** Web command
+  WebCommand (..),
+  WebInvocationState (..),
+  RejectionReason (..),
+
   -- * Menus and dialogs
   ModalType (..),
   ScenarioOutcome (..),
@@ -105,6 +109,7 @@ import Swarm.TUI.Model.Event (SwarmEvent)
 import Swarm.TUI.Model.Menu
 import Swarm.TUI.Model.Name
 import Swarm.TUI.Model.UI
+import Swarm.TUI.Model.WebCommand (RejectionReason (..), WebCommand (..), WebInvocationState (..))
 import Swarm.Util.Lens (makeLensesNoSigs)
 import Swarm.Version (NewReleaseFailure)
 import Text.Fuzzy qualified as Fuzzy
@@ -116,17 +121,13 @@ import Text.Fuzzy qualified as Fuzzy
 -- $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. 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)
 
 infoScroll :: ViewportScroll Name
 infoScroll = viewportScroll InfoViewport

src/swarm-tui/Swarm/TUI/Model/WebCommand.hs

@@ -0,0 +1,39 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- The type of commands sent from Web API handlers to the Controller,
+-- and the type of replies.
+module Swarm.TUI.Model.WebCommand (
+  WebCommand (..),
+  WebInvocationState (..),
+  RejectionReason (..),
+) where
+
+import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Swarm.Util.JSON (optionsMinimize)
+
+data WebCommand = RunWebCode {webEntry :: Text, webReply :: WebInvocationState -> IO ()}
+
+data RejectionReason = NoActiveGame | AlreadyRunning | ParseError String
+  deriving (Eq, Ord, Show, Generic)
+
+data WebInvocationState = Rejected RejectionReason | InProgress | Complete String
+  deriving (Eq, Ord, Show, Generic)
+
+-- --------------------------
+-- ToJSON/FromJSON Instances
+-- --------------------------
+
+instance ToJSON RejectionReason where
+  toJSON = genericToJSON optionsMinimize
+
+instance FromJSON RejectionReason where
+  parseJSON = genericParseJSON optionsMinimize
+
+instance ToJSON WebInvocationState where
+  toJSON = genericToJSON optionsMinimize
+
+instance FromJSON WebInvocationState where
+  parseJSON = genericParseJSON optionsMinimize

src/swarm-web/Swarm/Web.hs

@@ -62,6 +62,7 @@ import Servant
 import Servant.Docs (ToCapture)
 import Servant.Docs qualified as SD
 import Servant.Docs.Internal qualified as SD (renderCurlBasePath)
+import Servant.Types.SourceT qualified as S
 import Swarm.Game.Entity (EntityName, entityName)
 import Swarm.Game.Robot
 import Swarm.Game.Scenario.Objective
@@ -105,7 +106,7 @@ type SwarmAPI =
     :<|> "recognize" :> "log" :> Get '[JSON] [SearchLog EntityName]
     :<|> "recognize" :> "found" :> Get '[JSON] [StructureLocation]
     :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text
-    :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text
+    :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> StreamGet NewlineFraming JSON (SourceIO WebInvocationState)
     :<|> "paths" :> "log" :> Get '[JSON] (RingBuffer CacheLogEntry)
     :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem]
     :<|> "map" :> Capture "size" AreaDimensions :> Get '[JSON] GridResponse
@@ -232,10 +233,20 @@ codeRenderHandler contents = do
       into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ t
     Left x -> x
 
-codeRunHandler :: BChan AppEvent -> Text -> Handler Text
+codeRunHandler :: BChan AppEvent -> Text -> Handler (S.SourceT IO WebInvocationState)
 codeRunHandler chan contents = do
-  liftIO . writeBChan chan . Web $ RunWebCode contents
-  return $ T.pack "Sent\n"
+  replyVar <- liftIO newEmptyMVar
+  let putReplyForce r = do
+        void $ tryTakeMVar replyVar
+        putMVar replyVar r
+  liftIO . writeBChan chan . Web $ RunWebCode contents putReplyForce
+  -- wait for mvar, yield, repeat until fail or complete
+  let waitForReply = S.Effect $ do
+        reply <- takeMVar replyVar
+        return . S.Yield reply $ case reply of
+          InProgress -> waitForReply
+          _ -> S.Stop
+  return $ S.fromStepT waitForReply
 
 pathsLogHandler :: IO AppState -> Handler (RingBuffer CacheLogEntry)
 pathsLogHandler appStateRef = do

swarm.cabal

@@ -491,7 +491,8 @@ library swarm-web
     nonempty-containers,
     palette,
     servant-docs,
-    servant-server >=0.19 && <0.21,
+    servant >=0.19 && <0.22,
+    servant-server >=0.19 && <0.22,
     text,
     wai >=3.2 && <3.3,
     wai-app-static >=3.1.8 && <3.2,
@@ -724,6 +725,7 @@ library swarm-tui
     Swarm.TUI.Model.StateUpdate
     Swarm.TUI.Model.Structure
     Swarm.TUI.Model.UI
+    Swarm.TUI.Model.WebCommand
     Swarm.TUI.Panel
     Swarm.TUI.View
     Swarm.TUI.View.Achievement