jsaddle-terminal (empty) → 0.1.0.0
raw patch · 8 files changed
+1007/−0 lines, 8 filesdep +Win32dep +aesondep +base
Dependencies added: Win32, aeson, base, base64-bytestring, bytestring, containers, ghcjs-dom, jsaddle, jsaddle-terminal, reflex, reflex-dom-core, stm, text, unix
Files
- ChangeLog.md +12/−0
- LICENSE +21/−0
- demo/Main.hs +238/−0
- jsaddle-terminal.cabal +86/−0
- src/Language/Javascript/JSaddle/Terminal.hs +260/−0
- src/Language/Javascript/JSaddle/Terminal/Bootstrap.hs +102/−0
- src/Language/Javascript/JSaddle/Terminal/Protocol.hs +216/−0
- test/Test.hs +72/−0
+ ChangeLog.md view
@@ -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.
+ LICENSE view
@@ -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.
+ demo/Main.hs view
@@ -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 )
+ jsaddle-terminal.cabal view
@@ -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
+ src/Language/Javascript/JSaddle/Terminal.hs view
@@ -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=<path>@+-- (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)
+ src/Language/Javascript/JSaddle/Terminal/Bootstrap.hs view
@@ -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 =+ "<!DOCTYPE html>\n\+ \<html>\n\+ \<head>\n\+ \<meta charset=\"utf-8\">\n\+ \<title>jsaddle-terminal</title>\n\+ \<style>html,body{margin:0;padding:0;width:100%;height:100%;\+ \background:rgb(16,16,16);color:#fff;\+ \font-family:-apple-system,BlinkMacSystemFont,sans-serif}</style>\n\+ \</head>\n\+ \<body>\n\+ \<script>\n" <> bootstrapJs key <> "</script>\n\+ \</body>\n\+ \</html>\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"
+ src/Language/Javascript/JSaddle/Terminal/Protocol.hs view
@@ -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
+ test/Test.hs view
@@ -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."