diff --git a/scripts/remote-repl.sh b/scripts/remote-repl.sh new file mode 100755 index 000000000..9d34a341b --- /dev/null +++ b/scripts/remote-repl.sh @@ -0,0 +1,79 @@ +#!/usr/bin/env bash + +PORT="5357" +HOST="localhost" + +function help { + echo "Swarm remote REPL" + echo + echo "This is a shortcut for sending to Swarm REPL via cURL and recieving responses:" + echo "curl -XGET --header \"Content-Type: text/plain;charset=utf-8\" --data \"build {}\" $HOST:$PORT/code/run" + echo + echo "Options:" + echo " -p PORT --port PORT Specify the port, default is $PORT." + echo " -n NAME --hostaname NAME Specify the hostaname, default is $HOST." + echo " -h --help Show this helpful text." +} + +function parse_args { + while [[ $# -gt 0 ]]; do + case $1 in + -p|--port) + PORT="$2" + shift # past argument + shift # past value + ;; + -n|--hostname) + HOST="$2" + shift # past argument + shift # past value + ;; + -h|--help) + help + exit 0 + ;; + *) + echo "Unknown argument $1" + shift # past argument + ;; + esac + done +} + +IN_PROGRESS="" +function print_elipsis { + echo -n "..." + IN_PROGRESS="\r \r" +} + +function remove_elipsis { + echo -ne "$IN_PROGRESS" + IN_PROGRESS="" +} + +function repl { + while true; do + remove_elipsis + read -r -e -p "> " expr + curl -N -s -XGET --header "Content-Type: text/plain;charset=utf-8" --data "$expr" "$HOST:$PORT/code/run" | while read -r line ; do + remove_elipsis + if jq -e 'has("InProgress")' <<< "$line" > /dev/null; then + print_elipsis + elif jq -e 'has("Complete")' <<< "$line" > /dev/null; then + RESULT="$(jq -r '.Complete' <<< "$line")" + [ -n "$RESULT" ] && echo "$RESULT"; + elif jq -e 'has("Rejected")' <<< "$line" > /dev/null; then + jq -C '.Rejected' <<< "$line" + else + echo "$line" + fi + done + done +} + +function main { + parse_args "$@" + repl +} + +main "$@" \ No newline at end of file diff --git a/src/swarm-engine/Swarm/Game/State/Substate.hs b/src/swarm-engine/Swarm/Game/State/Substate.hs index da4100a9b..f271b33fe 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 @@ -302,6 +303,7 @@ robotStepsPerTick :: Lens' TemporalState Int data GameControls = GameControls { _replStatus :: REPLStatus , _replNextValueIndex :: Integer + , _replListener :: Text -> IO () , _inputHandler :: Maybe (Text, Value) , _initiallyRunCode :: Maybe Syntax } @@ -314,6 +316,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)) @@ -407,6 +413,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 b6b4a577b..320fb3335 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,41 @@ codeRenderHandler contents = do into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ t Left x -> x -codeRunHandler :: BChan AppEvent -> Text -> Handler Text +{- Note [How to stream back responses as we get results] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Servant has a builtin simple streaming: +https://docs.servant.dev/en/stable/cookbook/basic-streaming/Streaming.html + +What we need is to: +1. run IO with 'Effect' +2. send the result with 'Yield' +3. if we are done 'Stop' +4. otherwise continue recursively + +With the endpoint type 'StreamGet NewlineFraming JSON', servant will send each +result as a JSON on a separate line. That is not a valid JSON document, but +it's commonly used because it works well with line-oriented tools. + +This gives the user an immediate feedback (did the code parse) and would +be well suited for streaming large collections of data like the logs +while consuming constant memory. +-} + +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 + -- See note [How to stream back responses as we get results] + 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 551a0fc94..7d07dda95 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -492,8 +492,9 @@ library swarm-web lens, nonempty-containers, palette, + servant >=0.19 && <0.22, servant-docs, - servant-server >=0.19 && <0.21, + servant-server >=0.19 && <0.22, text, wai >=3.2 && <3.3, wai-app-static >=3.1.8 && <3.2, @@ -726,6 +727,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