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 01/10] 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 From 9af6508cdf6dab021d5a731fc02af3a1b313df71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= <44544735+xsebek@users.noreply.github.com> Date: Sun, 11 Aug 2024 18:54:40 +0200 Subject: [PATCH 02/10] Add simple REPL shell script (#1427) * add script to work as a minimal REPL, that can be run from different window or machine --- scripts/remote-repl.sh | 55 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100755 scripts/remote-repl.sh diff --git a/scripts/remote-repl.sh b/scripts/remote-repl.sh new file mode 100755 index 000000000..785f24678 --- /dev/null +++ b/scripts/remote-repl.sh @@ -0,0 +1,55 @@ +#!/usr/bin/env bash + +PORT="5357" +HOST="localhost" + +function help { + echo "Swarm remote REPL" + echo + echo "This is a shortcut for sending (TBD: and recieving) to Swarm REPL via cURL:" + echo "curl --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) + EXTENSION="$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 +} + +function repl { + while true; do + read -p "> " expr + curl --header "Content-Type: text/plain;charset=utf-8" --data "$expr" $HOST:$PORT/code/run + done +} + +function main { + parse_args + repl +} + +main \ No newline at end of file From 5491c674f3858dbb88a14b4d0b332865b1efcbdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 11 Aug 2024 18:55:36 +0200 Subject: [PATCH 03/10] Update REPL script --- scripts/remote-repl.sh | 34 +++++++++++++++++++++++++++++----- 1 file changed, 29 insertions(+), 5 deletions(-) diff --git a/scripts/remote-repl.sh b/scripts/remote-repl.sh index 785f24678..0e550633f 100755 --- a/scripts/remote-repl.sh +++ b/scripts/remote-repl.sh @@ -19,7 +19,7 @@ function parse_args { while [[ $# -gt 0 ]]; do case $1 in -p|--port) - EXTENSION="$2" + PORT="$2" shift # past argument shift # past value ;; @@ -40,16 +40,40 @@ function parse_args { 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 - read -p "> " expr - curl --header "Content-Type: text/plain;charset=utf-8" --data "$expr" $HOST:$PORT/code/run + remove_elipsis + read -r -p "> " expr + curl --silent -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 + parse_args "$@" repl } -main \ No newline at end of file +main "$@" \ No newline at end of file From b5c13d6b3707dd362919b3975f56a0cb9b5a96cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 11 Aug 2024 18:58:34 +0200 Subject: [PATCH 04/10] Restyle cabal --- swarm.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/swarm.cabal b/swarm.cabal index 484d1d099..3a1dcaced 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -490,8 +490,8 @@ library swarm-web lens, nonempty-containers, palette, - servant-docs, servant >=0.19 && <0.22, + servant-docs, servant-server >=0.19 && <0.22, text, wai >=3.2 && <3.3, From cb47315cdc8fcfdb7a06bcd079a72682b0ef015f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 11 Aug 2024 19:27:14 +0200 Subject: [PATCH 05/10] Use readline --- scripts/remote-repl.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/remote-repl.sh b/scripts/remote-repl.sh index 0e550633f..39fa6ce62 100755 --- a/scripts/remote-repl.sh +++ b/scripts/remote-repl.sh @@ -54,7 +54,7 @@ function remove_elipsis { function repl { while true; do remove_elipsis - read -r -p "> " expr + read -r -e -p "> " expr curl --silent -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 From 7750518853550a0e01f6a9d3c294569930153fe4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Wed, 14 Aug 2024 23:29:11 +0200 Subject: [PATCH 06/10] Update script help example with cURL GET --- scripts/remote-repl.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/remote-repl.sh b/scripts/remote-repl.sh index 39fa6ce62..2f26dc51b 100755 --- a/scripts/remote-repl.sh +++ b/scripts/remote-repl.sh @@ -6,8 +6,8 @@ HOST="localhost" function help { echo "Swarm remote REPL" echo - echo "This is a shortcut for sending (TBD: and recieving) to Swarm REPL via cURL:" - echo "curl --header \"Content-Type: text/plain;charset=utf-8\" --data \"build {}\" $HOST:$PORT/code/run" + 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." From 22e6844a02067994b069f74a9807224eea288102 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Thu, 15 Aug 2024 00:03:01 +0200 Subject: [PATCH 07/10] Add note for streaming --- src/swarm-web/Swarm/Web.hs | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 517ed57ab..3971aeb3b 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -233,6 +233,23 @@ codeRenderHandler contents = do into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ t Left x -> x +{- 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. +-} + codeRunHandler :: BChan AppEvent -> Text -> Handler (S.SourceT IO WebInvocationState) codeRunHandler chan contents = do replyVar <- liftIO newEmptyMVar @@ -240,7 +257,7 @@ codeRunHandler chan contents = do void $ tryTakeMVar replyVar putMVar replyVar r liftIO . writeBChan chan . Web $ RunWebCode contents putReplyForce - -- wait for mvar, yield, repeat until fail or complete + -- 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 From 9eac2e2ab04af1faec4a1d1e5298390cdf919211 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Thu, 15 Aug 2024 00:03:39 +0200 Subject: [PATCH 08/10] Add motivation as well --- src/swarm-web/Swarm/Web.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 3971aeb3b..b209657ad 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -248,6 +248,10 @@ What we need is to: 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) From b218a2efd2f323d24d2d0fd15e4b255daf2014b2 Mon Sep 17 00:00:00 2001 From: "restyled-io[bot]" <32688539+restyled-io[bot]@users.noreply.github.com> Date: Thu, 15 Aug 2024 00:07:51 +0200 Subject: [PATCH 09/10] Restyled by fourmolu (#2118) Co-authored-by: Restyled.io --- src/swarm-web/Swarm/Web.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index b209657ad..8f1494730 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -251,7 +251,7 @@ 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. +while consuming constant memory. -} codeRunHandler :: BChan AppEvent -> Text -> Handler (S.SourceT IO WebInvocationState) From 683aceaf5c14b6d9d89096f5990704be596a1312 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Thu, 15 Aug 2024 00:43:55 +0200 Subject: [PATCH 10/10] No cURL buffering --- scripts/remote-repl.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/remote-repl.sh b/scripts/remote-repl.sh index 2f26dc51b..9d34a341b 100755 --- a/scripts/remote-repl.sh +++ b/scripts/remote-repl.sh @@ -55,7 +55,7 @@ function repl { while true; do remove_elipsis read -r -e -p "> " expr - curl --silent -XGET --header "Content-Type: text/plain;charset=utf-8" --data "$expr" "$HOST:$PORT/code/run" | while read -r line ; do + 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