From c3b7a5dc527819e73b0ecfb86b615da1432f6735 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 11 Aug 2024 18:45:01 +0200 Subject: [PATCH] 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 | 7 ++ src/swarm-tui/Swarm/TUI/Controller.hs | 114 ++++++++++-------- .../Swarm/TUI/Controller/UpdateUI.hs | 5 + src/swarm-tui/Swarm/TUI/Model.hs | 11 +- src/swarm-tui/Swarm/TUI/Model/WebCommand.hs | 39 ++++++ src/swarm-web/Swarm/Web.hs | 19 ++- swarm.cabal | 4 +- 7 files changed, 140 insertions(+), 59 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Model/WebCommand.hs diff --git a/src/swarm-engine/Swarm/Game/State/Substate.hs b/src/swarm-engine/Swarm/Game/State/Substate.hs index 6374cb43d..300f6c4ad 100644 --- a/src/swarm-engine/Swarm/Game/State/Substate.hs +++ b/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 } diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 167e4e59d..d037259e8 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/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 diff --git a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs index 7839c88d7..4c24d73d9 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs +++ b/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)) diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 0ac7dce16..9b10ed2e6 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/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,9 +121,6 @@ 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. @@ -126,7 +128,6 @@ data AppEvent = Frame | Web WebCommand | UpstreamVersion (Either NewReleaseFailure String) - deriving (Show) infoScroll :: ViewportScroll Name infoScroll = viewportScroll InfoViewport diff --git a/src/swarm-tui/Swarm/TUI/Model/WebCommand.hs b/src/swarm-tui/Swarm/TUI/Model/WebCommand.hs new file mode 100644 index 000000000..d46ee62fe --- /dev/null +++ b/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 diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index c350d2807..517ed57ab 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/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 diff --git a/swarm.cabal b/swarm.cabal index 8163eef35..484d1d099 100644 --- a/swarm.cabal +++ b/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