diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,12 @@ +# Revision history for jsaddle-terminal + +## 0.1.0.0 + +* First release. Runs a jsaddle app inside a tmux pane: when a watching + IDE (leksah) answers the handshake, jsaddle's Batch/Results JSON is + tunnelled over the process's own stdin/stdout (OSC 5799 frames out, + RS-prefixed lines in) and the UI renders in an iframe hosted by the IDE. + No sockets are opened, so it also works over ssh-reached tmux servers. +* Builds on POSIX (termios raw mode) and Windows (console API). +* The optional demo (flag `demo`, off by default) uses reflex-dom-core 0.9 + and ghcjs-dom 0.10. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Hamish Mackenzie + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | jsaddle-terminal demo: Breakout. +-- +-- The whole game — state, physics, collisions — runs in Haskell (reflex); +-- only the rendered DOM crosses the tunnel. It is deliberately light on the +-- wire: a 30 fps tick moves the ball (one element's style per frame), the +-- paddle updates only while an arrow is held, and a brick's @div@ is removed +-- (via 'listWithKey') the frame it's hit. Control is the keyboard (← →, or +-- A/D; Space launches / restarts) — arrow keys carry no modifier, so the +-- tunnel's key-forwarding leaves them in the app rather than sending them to +-- leksah's global shortcuts. +module Main (main) where + +import Control.Monad (when) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T + +import Reflex.Dom.Core + +import GHCJS.DOM (currentDocumentUnchecked) +import GHCJS.DOM.EventM (event, onSync) +import qualified GHCJS.DOM.EventM as EventM (preventDefault) +import GHCJS.DOM.GlobalEventHandlers (keyDown, keyUp) +import GHCJS.DOM.KeyboardEvent (getKey) + +import qualified Language.Javascript.JSaddle.Terminal as JT + +main :: IO () +main = JT.run (mainWidget game) + +-- Board / entity geometry (logical px). +boardW, boardH, ballR, paddleW, paddleH, paddleY :: Double +boardW = 560; boardH = 400; ballR = 7 +paddleW = 90; paddleH = 12; paddleY = boardH - 30 + +cols, rows :: Int +cols = 9; rows = 5 + +marginX, marginTop, gap, brickH, brickW, paddleSpeed :: Double +marginX = 12; marginTop = 40; gap = 6; brickH = 20 +brickW = (boardW - 2*marginX - fromIntegral (cols-1) * gap) / fromIntegral cols +paddleSpeed = 13 + +data Phase = Ready | Playing | Over Bool -- Over True = won, False = lost + deriving Eq + +data St = St + { cx, cy, vx, vy :: Double -- ball centre + velocity + , pcx :: Double -- paddle centre x + , bricks :: Map (Int, Int) () + , score, lives :: Int + , phase :: Phase + } + +allBricks :: Map (Int, Int) () +allBricks = M.fromList [ ((r, c), ()) | r <- [0 .. rows-1], c <- [0 .. cols-1] ] + +initSt :: St +initSt = St + { cx = boardW/2, cy = paddleY - ballR, vx = 0, vy = 0 + , pcx = boardW/2, bricks = allBricks, score = 0, lives = 3, phase = Ready } + +data Ev = Tick (Set Text) | Launch + +clampD :: Double -> Double -> Double -> Double +clampD lo hi = max lo . min hi + +brickRect :: (Int, Int) -> (Double, Double, Double, Double) +brickRect (r, c) = + ( marginX + fromIntegral c * (brickW + gap) + , marginTop + fromIntegral r * (brickH + gap) + , brickW, brickH ) + +leftHeld, rightHeld :: Set Text -> Bool +leftHeld h = any (`S.member` h) ["ArrowLeft", "a", "A"] +rightHeld h = any (`S.member` h) ["ArrowRight", "d", "D"] + +step :: Ev -> St -> St +step Launch st = case phase st of + Ready -> st { phase = Playing, vx = 3, vy = -6 + , cx = pcx st, cy = paddleY - ballR } + Over _ -> initSt + Playing -> st +step (Tick held) st = + let dir = (if rightHeld held then 1 else 0) - (if leftHeld held then 1 else 0) + pcx' = clampD (paddleW/2) (boardW - paddleW/2) (pcx st + dir * paddleSpeed) + st' = st { pcx = pcx' } + in case phase st of + Playing -> physics st' + Ready -> st' { cx = pcx', cy = paddleY - ballR } + Over _ -> st' + +physics :: St -> St +physics st = + let r = ballR + oldcy = cy st + cx1 = cx st + vx st + cy1 = cy st + vy st + -- side + top walls + (cx2, vx2) + | cx1 - r < 0 = (r, abs (vx st)) + | cx1 + r > boardW = (boardW - r, negate (abs (vx st))) + | otherwise = (cx1, vx st) + (cy2, vy2) + | cy1 - r < 0 = (r, abs (vy st)) + | otherwise = (cy1, vy st) + -- paddle + pl = pcx st - paddleW/2 + pr = pcx st + paddleW/2 + hitPaddle = vy2 > 0 && cy2 + r >= paddleY && cy2 - r <= paddleY + paddleH + && cx2 >= pl && cx2 <= pr + (cy3, vy3, vx3) + | hitPaddle = let rel = clampD (-1) 1 ((cx2 - pcx st) / (paddleW/2)) + in (paddleY - r, negate (abs vy2), rel * 7) + | otherwise = (cy2, vy2, vx2) + -- first brick the ball now overlaps + hit = listToMaybe + [ (k, rect) | (k, _) <- M.toList (bricks st) + , let rect = brickRect k, overlaps cx2 cy3 r rect ] + (bricks', score', vx4, vy4) = case hit of + Nothing -> (bricks st, score st, vx3, vy3) + Just (k, (_, by, _, bh)) -> + -- vertical hit if the ball was above/below the brick last frame + let vertical = oldcy <= by || oldcy >= by + bh + in ( M.delete k (bricks st), score st + 10 + , if vertical then vx3 else negate vx3 + , if vertical then negate vy3 else vy3 ) + st1 = st { cx = cx2, cy = cy3, vx = vx4, vy = vy4 + , bricks = bricks', score = score' } + in if M.null bricks' then st1 { phase = Over True } + else if cy3 - r > boardH then loseLife st1 + else st1 + +loseLife :: St -> St +loseLife st + | lives st <= 1 = st { lives = 0, phase = Over False } + | otherwise = st { lives = lives st - 1, phase = Ready + , cx = pcx st, cy = paddleY - ballR, vx = 0, vy = 0 } + +-- circle (cx,cy,r) vs axis-aligned rect (x,y,w,h) +overlaps :: Double -> Double -> Double -> (Double, Double, Double, Double) -> Bool +overlaps cx' cy' r (x, y, w, h) = + let nx = clampD x (x+w) cx' + ny = clampD y (y+h) cy' + dx = cx' - nx; dy = cy' - ny + in dx*dx + dy*dy <= r*r + +game :: forall t m. MonadWidget t m => m () +game = mdo + doc <- currentDocumentUnchecked + let gameKeys = ["ArrowLeft","ArrowRight","a","A","d","D"," "] + keyH = do + ke <- event + k <- getKey ke + when (k `elem` gameKeys) EventM.preventDefault -- don't scroll the frame + return (k :: Text) + keydownE <- wrapDomEvent doc (`onSync` keyDown) keyH + keyupE <- wrapDomEvent doc (`onSync` keyUp) keyH + heldD <- foldDyn ($) S.empty $ leftmost + [ S.insert <$> ffilter (`elem` ["ArrowLeft","ArrowRight","a","A","d","D"]) keydownE + , S.delete <$> keyupE ] + tickE <- tickLossyFromPostBuildTime (1/30) + let launchE = leftmost [ () <$ ffilter (== " ") keydownE, () <$ clickE ] + evE = leftmost + [ attachWith (\h _ -> Tick h) (current heldD) tickE + , Launch <$ launchE ] + stD <- foldDyn step initSt evE + + clickE <- elAttr "div" ("style" =: wrapStyle) $ do + elAttr "div" ("style" =: hudStyle) $ dynText (hudText <$> stD) + (boardEl, _) <- elAttr' "div" ("style" =: boardStyle) $ do + _ <- listWithKey (bricks <$> stD) $ \k _ -> + elAttr "div" ("style" =: brickStyle k) blank + elDynAttr "div" (ballAttr <$> stD) blank + elDynAttr "div" (paddleAttr <$> stD) blank + elAttr "div" ("style" =: overlayStyle) $ dynText (overlayText <$> stD) + pure (domEvent Click boardEl) + pure () + +-- Styles / text ------------------------------------------------------------- + +px :: Double -> Text +px d = T.pack (show (round d :: Int)) <> "px" + +wrapStyle, hudStyle, boardStyle, overlayStyle :: Text +wrapStyle = "text-align:center;font-family:-apple-system,BlinkMacSystemFont,\ + \Segoe UI,sans-serif;color:#ddd;padding-top:10px;user-select:none" +hudStyle = "font-size:14px;margin-bottom:8px;letter-spacing:0.3px" +boardStyle = "position:relative;margin:0 auto;overflow:hidden;\ + \background:#0b0b0f;border:2px solid #333;border-radius:4px;" + <> "width:" <> px boardW <> ";height:" <> px boardH +overlayStyle = "position:absolute;inset:0;display:flex;align-items:center;\ + \justify-content:center;font-size:20px;color:#fff;\ + \text-shadow:0 1px 3px #000;pointer-events:none;text-align:center" + +hudText :: St -> Text +hudText st = "Score " <> T.pack (show (score st)) + <> " \8226 Lives " <> T.pack (show (lives st)) + <> " \8226 \8592 \8594 or A/D to move" + +overlayText :: St -> Text +overlayText st = case phase st of + Playing -> "" + Ready -> "Press Space (or click) to launch" + Over True -> "You win! \8212 Space to play again" + Over False -> "Game over \8212 Space to play again" + +brickStyle :: (Int, Int) -> Text +brickStyle k@(r, _) = + let (x, y, w, h) = brickRect k + in "position:absolute;pointer-events:none;border-radius:3px;left:" <> px x + <> ";top:" <> px y <> ";width:" <> px w <> ";height:" <> px h + <> ";background:" <> rowColor r + +rowColor :: Int -> Text +rowColor r = ["#e6432f","#e6822f","#e6d02f","#57c94b","#4aa3ff"] !! (r `mod` 5) + +ballAttr :: St -> Map Text Text +ballAttr st = "style" =: + ( "position:absolute;pointer-events:none;border-radius:50%;background:#f5f5f5;" + <> "left:" <> px (cx st - ballR) <> ";top:" <> px (cy st - ballR) + <> ";width:" <> px (2*ballR) <> ";height:" <> px (2*ballR) ) + +paddleAttr :: St -> Map Text Text +paddleAttr st = "style" =: + ( "position:absolute;pointer-events:none;border-radius:6px;background:#5ab0ff;" + <> "left:" <> px (pcx st - paddleW/2) <> ";top:" <> px paddleY + <> ";width:" <> px paddleW <> ";height:" <> px paddleH ) diff --git a/jsaddle-terminal.cabal b/jsaddle-terminal.cabal new file mode 100644 --- /dev/null +++ b/jsaddle-terminal.cabal @@ -0,0 +1,86 @@ +cabal-version: 3.4 +name: jsaddle-terminal +version: 0.1.0.0 +license: MIT +license-file: LICENSE +author: Hamish Mackenzie +maintainer: Hamish.K.Mackenzie@gmail.com +synopsis: Run jsaddle apps in a tmux pane, tunnelling over stdin/stdout +category: Web, Javascript +description: + A jsaddle transport for executables that run inside a tmux pane. When a + watching IDE (leksah) answers the handshake, jsaddle Batch/Results JSON is + tunnelled over the process's own stdin/stdout — framed as OSC 5799 escape + sequences on stdout (delivered to the IDE via tmux control-mode %output) + and RS-prefixed lines on stdin (injected via tmux send-keys -H) — and the + UI renders in an iframe hosted by the IDE. No sockets are opened on the + app's machine, so it works over ssh-reached tmux servers too. When nobody + answers the handshake there is nothing to tunnel to, so the runner reports + that on stderr and stops (an earlier version fell back to serving the app + over jsaddle-warp; that has been removed). +build-type: Simple +extra-doc-files: ChangeLog.md + +source-repository head + type: git + location: https://github.com/ghcjs/jsaddle + subdir: jsaddle-terminal + +flag demo + description: + Build the jsaddle-terminal-demo executable. Off by default: it needs + reflex-dom-core, whose released versions lag new GHCs (base upper + bounds), which would break solving the whole project on those GHCs. + default: False + manual: True + +library + hs-source-dirs: src + exposed-modules: Language.Javascript.JSaddle.Terminal + Language.Javascript.JSaddle.Terminal.Protocol + Language.Javascript.JSaddle.Terminal.Bootstrap + build-depends: base >=4.16 && <5 + , aeson >=0.11.3.0 && <2.4 + , base64-bytestring >=1.0.0.1 && <1.3 + , bytestring >=0.10.6.0 && <0.13 + , jsaddle >=0.9.4 && <0.10 + , stm >=2.4.4 && <2.6 + ghc-options: -Wall + default-language: Haskell2010 + -- The runner puts its own terminal into raw mode. On POSIX that is termios + -- (unix); on Windows it is the console API (SetConsoleMode with VT flags), + -- from Win32. The IDE-tunnel transport itself opens no sockets, so the + -- runner builds on every platform now (it used to fall back to jsaddle-warp + -- when no IDE answered — dropped, so the aeson<2.3 cap it carried is gone). + if os(windows) + build-depends: Win32 >=2.13.0.0 && <2.15 + else + build-depends: unix >=2.7 && <2.9 + +executable jsaddle-terminal-demo + main-is: Main.hs + hs-source-dirs: demo + build-depends: base + , containers >=0.5.6.2 && <0.9 + , ghcjs-dom >=0.10 && <0.11 + , jsaddle + , jsaddle-terminal + , reflex >=0.9 && <0.10 + , reflex-dom-core >=0.9 && <0.10 + , text >=1.2.1.3 && <1.3 || >=2.0 && <2.2 + ghc-options: -threaded -Wall + default-language: Haskell2010 + if os(windows) || !flag(demo) + buildable: False + +test-suite jsaddle-terminal-test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test + build-depends: base + , bytestring + , jsaddle-terminal + ghc-options: -Wall + default-language: Haskell2010 + if os(windows) + buildable: False diff --git a/src/Language/Javascript/JSaddle/Terminal.hs b/src/Language/Javascript/JSaddle/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/Terminal.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Run a jsaddle app from inside a terminal (e.g. a leksah / tmux pane). +-- +-- 'run' handshakes with a watching IDE (leksah) over the process's OWN +-- stdin/stdout — see "Language.Javascript.JSaddle.Terminal.Protocol" — and, +-- when the IDE answers, tunnels jsaddle 'Batch'/'Results' JSON over that +-- channel; the UI renders in an IDE-hosted iframe. No sockets are opened +-- here, so this works when the pane's machine is only reachable through +-- the IDE's existing ssh+tmux connection, and it works on every platform the +-- IDE runs on (POSIX termios / Windows console raw mode). +-- +-- When nothing answers (not a tty, or the handshake times out) there is +-- nothing to tunnel to, so it just reports that and stops. (An earlier +-- version fell back to serving the app over jsaddle-warp; that has been +-- removed.) +module Language.Javascript.JSaddle.Terminal + ( run + , runWith + , Config(..) + , defaultConfig + ) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar (newMVar, withMVar) +import Control.Concurrent.STM + (atomically, newTChanIO, readTChan, writeTChan, TChan) +import Control.Exception (bracket_, catch, SomeException) +import Control.Monad (forever, when) +import Data.Aeson (encode, decodeStrict') +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as LBS +import Data.IORef (newIORef, readIORef, writeIORef) +import System.Environment (lookupEnv) +import System.IO + (stdin, stdout, stderr, hSetBinaryMode, hSetBuffering, hPutStrLn, + BufferMode(..), hIsTerminalDevice, hFlush) +import System.Timeout (timeout) +#ifdef mingw32_HOST_OS +import Data.Bits ((.&.), (.|.), complement) +import Graphics.Win32.Misc (getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE) +import System.Win32.Console + (getConsoleMode, setConsoleMode, eNABLE_ECHO_INPUT, eNABLE_LINE_INPUT, + eNABLE_PROCESSED_INPUT, eNABLE_VIRTUAL_TERMINAL_INPUT, + eNABLE_VIRTUAL_TERMINAL_PROCESSING) +import System.Win32.Process (getCurrentProcessId) +#else +import System.Posix.IO (stdInput) +import System.Posix.Process (getProcessID) +import System.Posix.Terminal + (getTerminalAttributes, setTerminalAttributes, withoutMode, + withMinInput, withTime, TerminalAttributes, TerminalMode(..), + TerminalState(Immediately)) +#endif + +import Language.Javascript.JSaddle (JSM) +import Language.Javascript.JSaddle.Run (runJavaScript) +import qualified Language.Javascript.JSaddle.Types as JS (Results) + +import Language.Javascript.JSaddle.Terminal.Protocol + +data Config = Config + { helloIntervalUs :: Int -- ^ µs between HELLO retries (default 500ms) + , helloAttempts :: Int -- ^ retries before falling back (default 6 ≈ 3s) + } deriving Show + +defaultConfig :: Config +defaultConfig = Config + { helloIntervalUs = 500000 + , helloAttempts = 6 + } + +-- | 'runWith' 'defaultConfig'. +run :: JSM () -> IO () +run = runWith defaultConfig + +-- | Why the tunnel session ended. +data Outcome = NoIde | Finished + +-- | Debug tracing to a file, enabled by @JSADDLE_TERMINAL_DEBUG=@ +-- (stderr would be swallowed by the tunnel's raw tty). +debugLog :: String -> IO () +debugLog msg = do + mb <- lookupEnv "JSADDLE_TERMINAL_DEBUG" + case mb of + Nothing -> pure () + Just p -> appendFile p (msg <> "\n") `catch` \(_ :: SomeException) -> pure () + +runWith :: Config -> JSM () -> IO () +runWith cfg jsm = do + ttyIn <- hIsTerminalDevice stdin + ttyOut <- hIsTerminalDevice stdout + if not (ttyIn && ttyOut) + then noIde "stdin/stdout is not a terminal" + else do + hSetBinaryMode stdin True + hSetBuffering stdin NoBuffering + hSetBinaryMode stdout True + hSetBuffering stdout NoBuffering + outcome <- withRawMode (tunnel cfg jsm) + case outcome of + NoIde -> noIde "no IDE answered the handshake" + Finished -> pure () + +-- | Nothing is driving the tunnel and there is no fallback server, so report +-- why and stop (the app is meant to be launched from inside leksah). +noIde :: String -> IO () +noIde why = hPutStrLn stderr $ + "jsaddle-terminal: " <> why <> "; nothing to do (run this app from inside leksah)" + +#ifdef mingw32_HOST_OS +-- | Windows console raw mode — the direct analog of the POSIX termios bracket. +-- Input: drop line editing, echo and processed-input (so Ctrl-C arrives as a +-- raw 0x03 rather than a signal, matching the reader), and enable VT input so +-- keys arrive as escape sequences. Output: enable VT processing so the app's +-- ANSI escapes are interpreted. Both modes are restored on exit. +withRawMode :: IO a -> IO a +withRawMode act = do + hIn <- getStdHandle sTD_INPUT_HANDLE + hOut <- getStdHandle sTD_OUTPUT_HANDLE + inSaved <- getConsoleMode hIn + outSaved <- getConsoleMode hOut + let rawIn = (inSaved .&. complement + (eNABLE_LINE_INPUT .|. eNABLE_ECHO_INPUT .|. eNABLE_PROCESSED_INPUT)) + .|. eNABLE_VIRTUAL_TERMINAL_INPUT + rawOut = outSaved .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING + -- One bracket per handle, nested: with both mode changes in a single acquire + -- action, a failure setting the OUTPUT mode would skip the release action + -- altogether and leave the console stuck in raw INPUT mode. + bracket_ (setConsoleMode hIn rawIn) (setConsoleMode hIn inSaved) $ + bracket_ (setConsoleMode hOut rawOut) (setConsoleMode hOut outSaved) act + +-- | A per-run identifier for the HELLO payload (see 'handshake'). +getRunPid :: IO Integer +getRunPid = toInteger <$> getCurrentProcessId +#else +-- | POSIX raw tty: no echo, no canonical mode, no signals, no flow control, +-- and — crucially — no IEXTEN (macOS @stty raw@ leaves it on, and its +-- VDISCARD / VLNEXT would eat 0x0f/0x16 from injected input), no CR mapping, +-- no output processing. Restored on exit. +withRawMode :: IO a -> IO a +withRawMode act = do + saved <- getTerminalAttributes stdInput + bracket_ + (setTerminalAttributes stdInput (rawMode saved) Immediately) + (setTerminalAttributes stdInput saved Immediately) + act + +rawMode :: TerminalAttributes -> TerminalAttributes +rawMode attrs = + withTime (withMinInput cleared 1) 0 + where + cleared = foldl withoutMode attrs + [ EnableEcho, EchoErase, EchoKill, EchoLF + , ProcessInput -- ICANON + , KeyboardInterrupts -- ISIG + , ExtendedFunctions -- IEXTEN + , StartStopOutput -- IXON + , MapCRtoLF -- ICRNL + , ProcessOutput -- OPOST + , InterruptOnBreak, CheckParity, StripHighBit + ] + +-- | A per-run identifier for the HELLO payload (see 'handshake'). +getRunPid :: IO Integer +getRunPid = toInteger <$> getProcessID +#endif + +-- | The tunnel session, inside the 'withRawMode' bracket (termios on POSIX, +-- console mode on Windows). +tunnel :: Config -> JSM () -> IO Outcome +tunnel cfg jsm = do + wlock <- newMVar () + let writeFrame f = withMVar wlock $ \_ -> do + BS.hPut stdout (encodeOsc f) + hFlush stdout + frames <- newTChanIO + -- Reader: the only stdin consumer. A raw 0x03 (Ctrl-C — ISIG is off) is + -- outside any frame (frames are printable+RS+LF), so treat it as a close. + _ <- forkIO $ readerLoop frames + ok <- handshake cfg writeFrame frames + debugLog ("handshake: " <> (if ok then "ACKed" else "timed out")) + if not ok + then pure NoIde + else do + (processResults, processSyncResults, start) + <- runJavaScript + (writeFrame . Frame Batch . LBS.toStrict . encode) + jsm + _ <- forkIO start + let loop = atomically (readTChan frames) >>= \case + Frame Results p -> case decodeStrict' p :: Maybe JS.Results of + Just r -> processResults r >> loop + Nothing -> protoErr "undecodable RESULTS" + Frame Sync p -> case decodeStrict' p :: Maybe JS.Results of + -- processSyncResults blocks on the batch loop; never run it + -- on the dispatch thread. + Just r -> do + _ <- forkIO $ + processSyncResults r + >>= writeFrame . Frame SyncReply . LBS.toStrict . encode + loop + Nothing -> protoErr "undecodable SYNC" + Frame Close _ -> do + debugLog "dispatch: CLOSE" + writeFrame (Frame Bye "{}") + f -> do + debugLog ("dispatch: ignoring " <> show (frameType f)) + loop + protoErr msg = do + debugLog ("protocol error: " <> msg) + hPutStrLn stderr ("jsaddle-terminal: protocol error: " <> msg) + writeFrame (Frame Bye "{}") + loop + pure Finished + +-- | Read stdin, scan RS frames into the channel; Ctrl-C injects Close. +readerLoop :: TChan Frame -> IO () +readerLoop frames = do + st <- newIORef emptyRsScan + forever $ do + chunk <- BS.hGetSome stdin 4096 + when (BS.null chunk) $ threadDelay 50000 -- EOF-ish; don't spin + when (0x03 `BS.elem` chunk) $ do + debugLog "reader: Ctrl-C" + atomically $ writeTChan frames (Frame Close "{}") + s <- readIORef st + let (fs, s') = scanRs s chunk + writeIORef st s' + mapM_ (\f -> do debugLog ("reader: frame " <> show (frameType f)) + atomically (writeTChan frames f)) fs + +-- | Emit HELLO until an ACK (True), a CLOSE (False → fallback is still the +-- sane response) or the retry budget runs out (False). +-- +-- The HELLO payload carries a per-run identifier (the pid): retries of the +-- SAME run are byte-identical, so the IDE can tell a retry still in flight +-- when its ACK lands (ignore/re-ACK) from a genuinely restarted app (tear +-- down the old iframe and rebuild) — without it, a late retry made the IDE +-- rebuild mid-handshake and drop the first batch. +handshake :: Config -> (Frame -> IO ()) -> TChan Frame -> IO Bool +handshake cfg writeFrame frames = do + pid <- getRunPid + let hello = Frame Hello $ + "{\"proto\":1,\"caps\":[\"sync\"],\"run\":" <> BSC.pack (show pid) <> "}" + go 0 = pure False + go n = do + writeFrame hello + r <- timeout (helloIntervalUs cfg) waitAck + case r of + Just b -> pure b + Nothing -> go (n - 1 :: Int) + waitAck = atomically (readTChan frames) >>= \case + Frame Ack _ -> pure True + Frame Close _ -> pure False + _ -> waitAck + go (helloAttempts cfg) diff --git a/src/Language/Javascript/JSaddle/Terminal/Bootstrap.hs b/src/Language/Javascript/JSaddle/Terminal/Bootstrap.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/Terminal/Bootstrap.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | The JS side of the tunnel: a self-contained HTML page the IDE loads +-- into a per-pane iframe. It embeds jsaddle's stock JS runtime +-- ('Language.Javascript.JSaddle.Run.Files') wired to @window.postMessage@: +-- +-- * incoming batches arrive as @{leksahJsaddleBatch: key, batch: json}@ +-- messages from the parent (the IDE page); +-- * async results go back as @{leksahJsaddle: key, type:'results', +-- seq: n, data: json}@ — @seq@ lets the IDE restore order (its jsaddle +-- callbacks run on forked threads); +-- * sync callbacks use a __synchronous__ XHR to the IDE's own local web +-- server (same origin), which answers by round-tripping over the pane's +-- stdin/stdout — the app machine itself needs no reachable socket; +-- * @{type:'ready'}@ is posted once the runtime is installed, and the IDE +-- only then ACKs the exe's HELLO. +module Language.Javascript.JSaddle.Terminal.Bootstrap + ( bootstrapHtml + , bootstrapJs + , syncPath + , framePath + ) where + +import Data.ByteString.Lazy (ByteString) +import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers) + +-- | URL path (on the IDE's own server) answering sync XHRs for a pane key. +syncPath :: ByteString -> ByteString +syncPath key = "/jsaddle-terminal/sync/" <> key + +-- | URL path (on the IDE's own server) serving 'bootstrapHtml' for a key. +framePath :: ByteString -> ByteString +framePath key = "/jsaddle-terminal/frame/" <> key + +-- | The iframe page for pane @key@ (already URL/JS-safe: keys are made of +-- @[A-Za-z0-9._-]@ by the IDE's sanitiser). +bootstrapHtml :: ByteString -> ByteString +bootstrapHtml key = + "\n\ + \\n\ + \\n\ + \\n\ + \jsaddle-terminal\n\ + \\n\ + \\n\ + \\n\ + \\n\ + \\n\ + \\n" + +-- | The runtime script for pane @key@. +bootstrapJs :: ByteString -> ByteString +bootstrapJs key = + ghcjsHelpers <> + "var jstermKey = '" <> key <> "';\n\ + \var jstermSeq = 0;\n\ + \function jstermSend(r){\n\ + \ parent.postMessage({leksahJsaddle: jstermKey, type: 'results',\n\ + \ seq: jstermSeq++, data: JSON.stringify(r)}, '*');\n\ + \}\n\ + \function jstermSendSync(r){\n\ + \ var xhr = new XMLHttpRequest();\n\ + \ xhr.open('POST', '" <> syncPath key <> "', false);\n\ + \ xhr.send(JSON.stringify(r));\n\ + \ if (xhr.status !== 200) { throw new Error('jsaddle-terminal sync failed: ' + xhr.status); }\n\ + \ return JSON.parse(xhr.responseText);\n\ + \}\n\ + \window.runJSaddleBatch = (function() {\n" <> + initState <> + "\n return function(batch) {\n" <> + runBatch (\a -> "jstermSend(" <> a <> ");") + (Just (\a -> "jstermSendSync(" <> a <> ")")) <> + "\n };\n\ + \})();\n\ + \window.addEventListener('message', function(e){\n\ + \ if (e.data && e.data.leksahJsaddleBatch === jstermKey) {\n\ + \ runJSaddleBatch(JSON.parse(e.data.batch));\n\ + \ }\n\ + \});\n\ + \function jstermFocused(){\n\ + \ parent.postMessage({leksahJsaddle: jstermKey, type: 'focus'}, '*');\n\ + \}\n\ + \window.addEventListener('focus', jstermFocused);\n\ + \window.addEventListener('mousedown', jstermFocused, true);\n\ + \\n\ + \// Forward modifier-key chords to the host so its global keymap (build,\n\ + \// find, the ⌃` flipper, ⌘-navigation, …) works while this pane has focus —\n\ + \// keyboard events don't cross the frame boundary on their own. Plain keys\n\ + \// (no modifier) stay in the app; we never preventDefault, so the app's own\n\ + \// ⌘C/⌘V etc. keep working (the host acts only on chords it recognises).\n\ + \function jstermFwdKey(kind, e){\n\ + \ if (e.ctrlKey || e.metaKey || e.altKey ||\n\ + \ e.key === 'Control' || e.key === 'Meta' || e.key === 'Alt') {\n\ + \ parent.postMessage({leksahJsaddle: jstermKey, type: 'key', kind: kind,\n\ + \ keyCode: e.keyCode, key: e.key, code: e.code,\n\ + \ ctrl: e.ctrlKey, shift: e.shiftKey, alt: e.altKey, meta: e.metaKey}, '*');\n\ + \ }\n\ + \}\n\ + \window.addEventListener('keydown', function(e){ jstermFwdKey('keydown', e); }, true);\n\ + \window.addEventListener('keyup', function(e){ jstermFwdKey('keyup', e); }, true);\n\ + \parent.postMessage({leksahJsaddle: jstermKey, type: 'ready'}, '*');\n" diff --git a/src/Language/Javascript/JSaddle/Terminal/Protocol.hs b/src/Language/Javascript/JSaddle/Terminal/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Language/Javascript/JSaddle/Terminal/Protocol.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | The jsaddle-terminal wire protocol: jsaddle 'Batch'/'Results' JSON +-- tunnelled over a tmux pane's own stdin/stdout. +-- +-- Two stream shapes, one 'Frame' type: +-- +-- * __exe → IDE__ (the exe's stdout, seen by the IDE as tmux control-mode +-- @%output@ bytes): OSC frames @ESC ] 5799 ; TYPE ; base64(payload) BEL@. +-- Unknown OSC is invisible on a plain terminal, and tmux forwards it +-- verbatim to control clients, so the frames ride the existing channel — +-- local or over ssh. Bytes outside frames are ordinary pane output. +-- +-- * __IDE → exe__ (injected into the pane's stdin via @send-keys -H@; the +-- exe has its tty in raw mode): @RS TYPE ; base64(payload) LF@ +-- (RS = 0x1e). All frame bytes are printable ASCII plus RS/LF, so no +-- tty processing can mangle them (the exe also clears IEXTEN — the one +-- raw-mode gap on macOS, where VDISCARD/VLNEXT would eat 0x0f/0x16). +-- +-- Both scanners are incremental: frames can straddle input chunks +-- arbitrarily (tmux splits @%output@ at arbitrary byte boundaries). +module Language.Javascript.JSaddle.Terminal.Protocol + ( protoVersion + , FrameType(..) + , Frame(..) + , renderFrameType + , parseFrameType + -- * exe → IDE (OSC framing on the pane's stdout) + , encodeOsc + , OscScan + , emptyOscScan + , scanOsc + -- * IDE → exe (RS framing on the pane's stdin) + , encodeRs + , RsScan + , emptyRsScan + , scanRs + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Base64 as B64 + +-- | Protocol version sent in HELLO/ACK. +protoVersion :: Int +protoVersion = 1 + +-- | Every message either direction. Which types are legal in which +-- direction is a convention, not enforced here: +-- +-- * exe → IDE: 'Hello', 'Batch', 'SyncReply', 'Log', 'Bye' +-- * IDE → exe: 'Ack', 'Results', 'Sync', 'Close' +data FrameType + = Hello -- ^ exe requests a tunnel: @{"proto":1,"caps":["sync"]}@ + | Batch -- ^ a jsaddle @Batch@ (Haskell → JS commands) + | SyncReply -- ^ the @Batch@ answering a pending 'Sync' + | Log -- ^ @{"level":…,"msg":…}@ for the IDE to log + | Bye -- ^ exe is shutting down; IDE restores the terminal + | Ack -- ^ IDE accepted the tunnel (iframe is ready) + | Results -- ^ a jsaddle @Results@ (async, JS → Haskell) + | Sync -- ^ a jsaddle @Results@ requiring a 'SyncReply' @Batch@ + | Close -- ^ IDE is tearing down; exe should exit (or fall back) + deriving (Eq, Show) + +data Frame = Frame + { frameType :: FrameType + , framePayload :: ByteString -- ^ raw (decoded) payload, normally JSON + } deriving (Eq, Show) + +renderFrameType :: FrameType -> ByteString +renderFrameType t = case t of + Hello -> "HELLO" + Batch -> "BATCH" + SyncReply -> "SYNCR" + Log -> "LOG" + Bye -> "BYE" + Ack -> "ACK" + Results -> "RESULTS" + Sync -> "SYNC" + Close -> "CLOSE" + +parseFrameType :: ByteString -> Maybe FrameType +parseFrameType t = case t of + "HELLO" -> Just Hello + "BATCH" -> Just Batch + "SYNCR" -> Just SyncReply + "LOG" -> Just Log + "BYE" -> Just Bye + "ACK" -> Just Ack + "RESULTS" -> Just Results + "SYNC" -> Just Sync + "CLOSE" -> Just Close + _ -> Nothing + +-- | @ESC ] 5799 ;@ — the OSC frame introducer. +oscMarker :: ByteString +oscMarker = "\ESC]5799;" + +oscTerminator :: Char +oscTerminator = '\BEL' + +-- | A frame whose body grows past this without a terminator is flushed +-- through as plain output (protects the scanner from unbounded buffering +-- if a stray marker appears in binary output). +oscMaxFrame :: Int +oscMaxFrame = 8 * 1024 * 1024 + +-- | exe → IDE frame bytes (write to the pane's stdout). +encodeOsc :: Frame -> ByteString +encodeOsc (Frame t p) = + oscMarker <> renderFrameType t <> ";" <> B64.encode p <> BSC.singleton oscTerminator + +-- | Incremental scanner state for the OSC (pane stdout) stream: the bytes +-- held back because they might be the start of an unterminated frame. +newtype OscScan = OscScan ByteString + deriving (Eq, Show) + +emptyOscScan :: OscScan +emptyOscScan = OscScan BS.empty + +-- | Feed a chunk; get (passthrough bytes for the terminal, complete frames, +-- new state). Malformed frames (unknown type / bad base64) are passed +-- through verbatim so nothing is silently swallowed. +scanOsc :: OscScan -> ByteString -> (ByteString, [Frame], OscScan) +scanOsc (OscScan held) chunk = go mempty [] (held <> chunk) + where + go passOut frames buf = + case BS.breakSubstring oscMarker buf of + (before, rest) + | BS.null rest -> + -- No full marker: pass everything except a trailing proper + -- prefix of the marker, which we hold for the next chunk. + let keep = longestMarkerPrefix before + passN = BS.length before - keep + in ( passOut <> BS.take passN before + , reverse frames + , OscScan (BS.drop passN before) ) + | otherwise -> + let body = BS.drop (BS.length oscMarker) rest + in case BSC.elemIndex oscTerminator body of + Nothing + | BS.length body > oscMaxFrame -> + -- Unterminated and huge: give up on it as a frame. + go (passOut <> before <> oscMarker) frames body + | otherwise -> + ( passOut <> before + , reverse frames + , OscScan (oscMarker <> body) ) + Just i -> + let inner = BS.take i body + rest' = BS.drop (i + 1) body + in case decodeInner inner of + Just f -> go (passOut <> before) (f : frames) rest' + Nothing -> + -- Malformed: emit the raw bytes untouched. + go (passOut <> before <> oscMarker + <> BS.take (i + 1) body) + frames rest' + decodeInner inner = + let (t, rest) = BSC.break (== ';') inner + in case (parseFrameType t, BS.uncons rest) of + (Just ft, Just (_, b64)) -> + either (const Nothing) (Just . Frame ft) (B64.decode b64) + _ -> Nothing + -- Length of the longest suffix of @bs@ that is a proper prefix of the + -- marker (bounded by the marker length, so this is O(1)-ish). + longestMarkerPrefix bs = + let m = min (BS.length bs) (BS.length oscMarker - 1) + candidates = [ k | k <- [m, m-1 .. 1] + , BS.drop (BS.length bs - k) bs + == BS.take k oscMarker ] + in case candidates of + (k:_) -> k + [] -> 0 + +-- | @RS@ — the stdin frame introducer. +rsMarker :: Char +rsMarker = '\RS' -- 0x1e + +rsTerminator :: Char +rsTerminator = '\n' + +-- | IDE → exe frame bytes (inject into the pane's stdin). +encodeRs :: Frame -> ByteString +encodeRs (Frame t p) = + BSC.singleton rsMarker <> renderFrameType t <> ";" <> B64.encode p + <> BSC.singleton rsTerminator + +-- | Incremental scanner state for the RS (exe stdin) stream. Bytes outside +-- frames are dropped (stray typing into the pane). +newtype RsScan = RsScan ByteString + deriving (Eq, Show) + +emptyRsScan :: RsScan +emptyRsScan = RsScan BS.empty + +scanRs :: RsScan -> ByteString -> ([Frame], RsScan) +scanRs (RsScan held) chunk = go [] (held <> chunk) + where + go frames buf = + case BSC.elemIndex rsMarker buf of + Nothing -> (reverse frames, RsScan BS.empty) -- drop non-frame bytes + Just i -> + let body = BS.drop (i + 1) buf + in case BSC.elemIndex rsTerminator body of + Nothing -> (reverse frames, RsScan (BS.drop i buf)) + Just j -> + let inner = BS.take j body + rest = BS.drop (j + 1) body + (t, r) = BSC.break (== ';') inner + mf = case (parseFrameType t, BS.uncons r) of + (Just ft, Just (_, b64)) -> + either (const Nothing) (Just . Frame ft) + (B64.decode b64) + _ -> Nothing + in go (maybe frames (: frames) mf) rest diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Protocol scanner tests: frames must survive arbitrary re-chunking and +-- interleaving with arbitrary passthrough bytes (tmux splits %output at +-- arbitrary byte boundaries). Uses a small deterministic LCG so there are +-- no extra test dependencies. +module Main (main) where + +import Control.Monad (forM_, unless) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.List (foldl') +import Data.Word (Word8) +import System.Exit (exitFailure) + +import Language.Javascript.JSaddle.Terminal.Protocol + +-- deterministic pseudo-random stream +lcg :: Int -> [Int] +lcg seed = tail (iterate step seed) + where step x = (x * 1103515245 + 12345) `mod` 2147483648 + +frameOf :: Int -> Frame +frameOf n = Frame ty payload + where + tys = [Hello, Batch, SyncReply, Log, Bye, Ack, Results, Sync, Close] + ty = tys !! (n `mod` length tys) + payload = BS.pack (map fromIntegral (take (n `mod` 200) (lcg n))) + +garbageOf :: Int -> ByteString +garbageOf n = BS.pack (map (fromIntegral :: Int -> Word8) + (take (n `mod` 97) (lcg (n + 7)))) + +-- split a bytestring at pseudo-random boundaries +chunksOfRandom :: Int -> ByteString -> [ByteString] +chunksOfRandom seed = go (lcg seed) + where + go _ bs | BS.null bs = [] + go (r:rs) bs = let n = 1 + (r `mod` 13) + in BS.take n bs : go rs (BS.drop n bs) + go [] _ = error "impossible" + +check :: String -> Bool -> IO () +check name ok = unless ok $ putStrLn ("FAIL: " <> name) >> exitFailure + +main :: IO () +main = do + -- OSC: interleave garbage and frames (stream ends with a frame, so the + -- scanner holds nothing back at the end), re-chunk, expect exact recovery. + forM_ [1 .. 50 :: Int] $ \i -> do + let fs = map frameOf [i * 10 + k | k <- [0 .. 5]] + gs = map garbageOf [i * 20 + k | k <- [0 .. 5]] + stream = mconcat (zipWith (\g f -> g <> encodeOsc f) gs fs) + pieces = chunksOfRandom i stream + step (accP, accF, st) c = + let (p, f, st') = scanOsc st c in (accP <> p, accF <> f, st') + (passOut, frames, _st) = foldl' step (mempty, [], emptyOscScan) pieces + check ("osc frames " <> show i) (frames == fs) + check ("osc passthrough " <> show i) (passOut == mconcat gs) + -- RS: garbage dropped, frames recovered. + forM_ [1 .. 50 :: Int] $ \i -> do + let fs = map frameOf [i * 11 + k | k <- [0 .. 5]] + -- RS-stream garbage must not contain RS itself (a bare RS starts a + -- frame candidate that swallows bytes to the next LF; stray pane + -- input containing RS is not a supported case). + gs = map (BS.filter (/= 0x1e) . garbageOf) + [i * 21 + k | k <- [0 .. 5]] + stream = mconcat (zipWith (\g f -> g <> encodeRs f) gs fs) + pieces = chunksOfRandom (i + 3) stream + step (accF, st) c = let (f, st') = scanRs st c in (accF <> f, st') + (frames, _) = foldl' step ([], emptyRsScan) pieces + check ("rs frames " <> show i) (frames == fs) + putStrLn "All protocol tests passed."