From 4c25c7191ead7ed6ea4f069514ad341e78d76063 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Tue, 10 Nov 2026 20:00:28 -0800 Subject: [PATCH 1/5] Backends become render programs the packaging supplies --- CHANGELOG.md | 5 ++ README.md | 49 +++++++++-- app/Main.hs | 54 +++++------- lsp-export-server.cabal | 18 +++- package.yaml | 14 ++- src/Render/Backend.hs | 48 ---------- src/Render/Backend/Latex.hs | 154 -------------------------------- src/Render/Backend/Pandoc.hs | 93 -------------------- src/Render/Command.hs | 165 +++++++++++++++++++++++++++++++++++ src/Render/Server.hs | 22 ++--- 10 files changed, 274 insertions(+), 348 deletions(-) delete mode 100644 src/Render/Backend.hs delete mode 100644 src/Render/Backend/Latex.hs delete mode 100644 src/Render/Backend/Pandoc.hs create mode 100644 src/Render/Command.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 98e3096..7351ac2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog +## 0.5.0.0 + +- The server no longer knows any document format. `--render EXE` (and optionally `--settle EXE`) name the programs that render; they run in the document's directory with the task's layout and options in `RENDER_*` variables, write `RENDER_OUTPUT`, and may list what they read in `RENDER_DEPS`. The `latex` and `pandoc` backends and `--backend` are gone; their logic moves to the packaging. +- No settle pass without a `--settle` program. + ## 0.4.1.2 - Release artifacts for aarch64-linux, x86_64-darwin and aarch64-darwin alongside x86_64-linux. diff --git a/README.md b/README.md index 0e75238..41a4dbd 100644 --- a/README.md +++ b/README.md @@ -4,18 +4,53 @@ A language server that renders documents from the buffers a client sends it, and result back as xdelta3 diffs. The codedown runner uses it for live exports: an edit reaches the server as `didChange` and a new render comes back without a trip through the disk. +The server knows nothing about document formats. The packaging names the program that renders: + ``` -lsp-export-server serve --backend latex -o engine=pdflatex # the LSP, on stdio -lsp-export-server render --backend latex input.tex output.pdf # once, from disk +lsp-export-server serve --render latex-render --settle latex-render -o engine=pdflatex # the LSP, on stdio +lsp-export-server render --render latex-render input.tex output.pdf # once, from disk ``` +Each edit gets a quick render with the `--render` program once edits pause for the debounce +period. With a `--settle` program, a settle pass follows once edits stay quiet for longer (a full +latexmk build, say); only the quick pass reports `rendering`, and an output identical to the last +one is not sent. + +## The render program + +It runs in the document's directory, so relative paths resolve from the document's real tree, +with these variables: + +| Variable | | +|---|---| +| `RENDER_PHASE` | `quick` or `settle` | +| `RENDER_DOCUMENT` | the real document's absolute path | +| `RENDER_ENTRY` | the document's current buffer, written to `RENDER_SRC` | +| `RENDER_OVERLAY` | the other open buffers, at their paths relative to the document's directory; a file here is newer than its disk copy | +| `RENDER_OUT` | scratch space kept across renders, for aux files and the like | +| `RENDER_WORK` | the task's work directory holding `src/`, `overlay/` and `out/` | +| `RENDER_JOB`, `RENDER_FORMAT` | the document's base name and the output extension | +| `RENDER_OUTPUT` | where to write the result: `RENDER_OUT/RENDER_JOB.RENDER_FORMAT` | +| `RENDER_DEPS` | optional: write the files read, one path per line, absolute or relative to the directory | +| `RENDER_EPOCH` | a Unix time to use for timestamps in the output (`SOURCE_DATE_EPOCH`), fixed per task so unchanged input gives unchanged bytes | +| `RENDER_OPT_` | each `-o key=value` from the command line and each option in the start request | + +Its stdout and stderr are streamed to the client as the log. A non-zero exit reports an error with +that exit code. Paths listed in `RENDER_DEPS` under `RENDER_SRC` or `RENDER_OVERLAY` are mapped +back to the documents they stand for; the client is told to watch the ones it does not hold open, +and a `rebuild` renders again only when one of them changed. + +## Protocol + Commands (`workspace/executeCommand`): `codedown.render.start`, `codedown.render.stop`, `codedown.render.rebuild`, `codedown.render.setPaused`, `codedown.render.resync`. Notifications: `codedown/render/status`, `codedown/render/output`, `codedown/render/log`. See `src/Render/Protocol.hs`. - -Each edit gets a quick single-pass render, then a latexmk settle pass once edits stay quiet; only -the quick pass reports `rendering`, and an output identical to the last one is not sent. Statuses -carry the pass (`phase`) and what triggered it (`reason`), and `──` marker lines in the log say -when each pass started, why, how long it took and what was sent. +Statuses carry the pass (`phase`) and what triggered it (`reason`), and `──` marker lines in the +log say when each pass started, why, how long it took and what was sent. `cbits/` is xdelta3, Apache-2.0 (see `cbits/LICENSE`). + +## Developing + +`nix develop -c stack build --test`. The tests drive the built executable through lsp-test with +shell scripts as render programs. diff --git a/app/Main.hs b/app/Main.hs index 4e4dd16..7534940 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,13 +3,11 @@ module Main (main) where import qualified Data.ByteString as B import qualified Data.Map as M import Data.Text (Text) -import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Time.Clock.POSIX (getPOSIXTime) import Options.Applicative -import Render.Backend -import Render.Backend.Latex (latexBackend) -import Render.Backend.Pandoc (pandocBackend) +import Render.Command import Render.Protocol (LogStream(..)) import Render.Server (runRenderServer) import System.Directory @@ -20,29 +18,28 @@ import System.IO.Temp import UnliftIO (try) -backends :: [Backend] -backends = [latexBackend, pandocBackend] - data Common = Common { - commonBackend :: String + commonPrograms :: Programs , commonOptions :: [(Text, Text)] } -data Command = +data Invocation = Serve Common | RenderOnce Common FilePath FilePath commonParser :: Parser Common commonParser = Common - <$> strOption (long "backend" <> metavar "NAME" <> help "Which backend renders: latex, pandoc") - <*> many (option (eitherReader keyValue) (long "option" <> short 'o' <> metavar "KEY=VALUE" <> help "A backend option, e.g. engine=xelatex")) + <$> (Programs + <$> strOption (long "render" <> metavar "EXE" <> help "The program that renders: run in the document's directory with the RENDER_* variables; writes RENDER_OUTPUT") + <*> optional (strOption (long "settle" <> metavar "EXE" <> help "The program for the settle pass once edits stay quiet; without one there is no settle pass"))) + <*> many (option (eitherReader keyValue) (long "option" <> short 'o' <> metavar "KEY=VALUE" <> help "An option passed on as RENDER_OPT_KEY")) where keyValue s = case break (== '=') s of (k, '=' : v) | not (null k) -> Right (T.pack k, T.pack v) _ -> Left "expected KEY=VALUE" -commandParser :: Parser Command -commandParser = hsubparser ( +invocationParser :: Parser Invocation +invocationParser = hsubparser ( command "serve" (info (Serve <$> commonParser) (progDesc "Run the language server on stdio")) <> command "render" (info (RenderOnce <$> commonParser <*> strArgument (metavar "INPUT") @@ -53,43 +50,38 @@ commandParser = hsubparser ( main :: IO () main = do hSetBuffering stderr LineBuffering - cmd <- execParser (info (commandParser <**> helper) (fullDesc <> progDesc "Renders documents, live from a language client or once from disk")) - case cmd of - Serve common -> do - backend <- pickBackend common + invocation <- execParser (info (invocationParser <**> helper) (fullDesc <> progDesc "Renders documents, live from a language client or once from disk")) + case invocation of + Serve (Common {..}) -> do tmp <- getCanonicalTemporaryDirectory withTempDirectory tmp "lsp-export-server" $ \workRoot -> - runRenderServer backend workRoot (M.fromList (commonOptions common)) >>= \case + runRenderServer commonPrograms workRoot (M.fromList commonOptions) >>= \case 0 -> return () n -> exitWith (ExitFailure n) - RenderOnce common input output -> do - backend <- pickBackend common + RenderOnce (Common {..}) input output -> do inputPath <- makeAbsolute input text <- T.readFile inputPath tmp <- getCanonicalTemporaryDirectory epoch <- round <$> getPOSIXTime withTempDirectory tmp "lsp-export-server" $ \workDir -> do - result <- try $ backendRender backend RenderRequest { + result <- try $ render commonPrograms RenderRequest { requestEntryPath = inputPath , requestEntryText = text , requestOverlays = [] , requestWorkDir = workDir - , requestOptions = M.insert "format" (T.pack (drop 1 (takeExtension output))) (M.fromList (commonOptions common)) + , requestOptions = M.insert "format" (T.pack (drop 1 (takeExtension output))) (M.fromList commonOptions) , requestSettle = True , requestEpoch = epoch - , requestLog = \stream line -> T.hPutStrLn (if stream == LogStdout then stdout else stderr) line + , requestLog = \stream line -> T.hPutStrLn (handleFor stream) line } case result of Left (RenderFailure code msg) -> do T.hPutStrLn stderr msg - exitWith (ExitFailure (if code == 0 then 1 else code)) + exitWith (ExitFailure (case code of { 0 -> 1; n -> n })) Right (RenderResult {resultBytes}) -> do createDirectoryIfMissing True (takeDirectory output) B.writeFile output resultBytes - -pickBackend :: Common -> IO Backend -pickBackend (Common {commonBackend}) = case [b | b <- backends, backendName b == T.pack commonBackend] of - (b : _) -> return b - [] -> do - hPutStrLn stderr ("unknown backend: " <> commonBackend <> "; known: " <> unwords (map (T.unpack . backendName) backends)) - exitWith (ExitFailure 2) + where + handleFor = \case + LogStdout -> stdout + LogStderr -> stderr diff --git a/lsp-export-server.cabal b/lsp-export-server.cabal index b46e577..e537499 100644 --- a/lsp-export-server.cabal +++ b/lsp-export-server.cabal @@ -5,7 +5,7 @@ cabal-version: 2.2 -- see: https://github.com/sol/hpack name: lsp-export-server -version: 0.4.1.2 +version: 0.5.0.0 synopsis: A language server that renders documents from their in-memory buffers homepage: https://github.com/codedownio/lsp-export-server#readme bug-reports: https://github.com/codedownio/lsp-export-server/issues @@ -37,9 +37,7 @@ source-repository head library exposed-modules: - Render.Backend - Render.Backend.Latex - Render.Backend.Pandoc + Render.Command Render.Process Render.Protocol Render.Server @@ -156,14 +154,26 @@ test-suite lsp-export-server-test TypeApplications DataKinds ghc-options: -Wunused-packages -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N -W + build-tool-depends: + lsp-export-server:lsp-export-server build-depends: aeson , base >=4.7 && <5 + , base64-bytestring , bytestring , containers + , directory + , exceptions + , filepath + , lens , lsp-export-server + , lsp-test + , lsp-types + , monad-logger + , process , sandwich , string-interpolate , text + , time , unliftio default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 02951be..5dae394 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: lsp-export-server -version: 0.4.1.2 +version: 0.5.0.0 synopsis: A language server that renders documents from their in-memory buffers license: BSD-3-Clause github: codedownio/lsp-export-server @@ -87,7 +87,19 @@ tests: - -rtsopts - -with-rtsopts=-N - -W + build-tools: + - lsp-export-server:lsp-export-server dependencies: + - base64-bytestring + - directory + - filepath - lsp-export-server + - lsp-test + - lsp-types + - monad-logger + - process - sandwich - string-interpolate + - lens + - exceptions + - time diff --git a/src/Render/Backend.hs b/src/Render/Backend.hs deleted file mode 100644 index 69d61ba..0000000 --- a/src/Render/Backend.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Render.Backend ( - Backend(..) - , RenderRequest(..) - , RenderResult(..) - , RenderFailure(..) - ) where - -import Data.ByteString (ByteString) -import Data.Map (Map) -import Data.Text (Text) -import Render.Protocol (LogStream, Timing) -import UnliftIO (Exception) - - -data RenderRequest = RenderRequest { - -- | The real document, as an absolute path; the render's working directory is its directory - requestEntryPath :: FilePath - , requestEntryText :: Text - -- | Other open buffers (absolute real paths) that take priority over their disk copies - , requestOverlays :: [(FilePath, Text)] - -- | Private scratch space for this task, kept across renders - , requestWorkDir :: FilePath - , requestOptions :: Map Text Text - -- | A full build (cross-references settled) rather than a quick single pass - , requestSettle :: Bool - -- | Unix time stamped into the output, kept fixed so unchanged input gives unchanged bytes - , requestEpoch :: Integer - , requestLog :: LogStream -> Text -> IO () - } - -data RenderResult = RenderResult { - resultFileName :: Text - , resultBytes :: ByteString - -- | Absolute paths of every file read, excluding the scratch space and the Nix store - , resultDeps :: [FilePath] - , resultTimings :: [Timing] - } - -data RenderFailure = RenderFailure { - failureExitCode :: Int - , failureMessage :: Text - } deriving (Show) -instance Exception RenderFailure - -data Backend = Backend { - backendName :: Text - , backendRender :: RenderRequest -> IO RenderResult - } diff --git a/src/Render/Backend/Latex.hs b/src/Render/Backend/Latex.hs deleted file mode 100644 index 9712215..0000000 --- a/src/Render/Backend/Latex.hs +++ /dev/null @@ -1,154 +0,0 @@ -module Render.Backend.Latex ( - latexBackend - , prepareWorkDir - , compileTex - , depsFromFls - , logStream - ) where - -import Control.Monad (forM_, unless, when) -import qualified Data.ByteString as B -import Data.List (isPrefixOf, nub) -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.String.Interpolate -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Time -import Render.Backend -import Render.Process -import Render.Protocol (LogStream(..), Timing(..)) -import System.Directory -import System.Environment (getEnvironment) -import System.Exit -import System.FilePath -import UnliftIO (throwIO) - - --- TeX resolves relative paths against the working directory, so running in the document's real --- directory makes its imports resolve from the home while the main file and the unsaved overlays --- live in the work directory, found first through TEXINPUTS. -latexBackend :: Backend -latexBackend = Backend { - backendName = "latex" - , backendRender = \req -> do - srcDir <- prepareWorkDir req - compileTex req (srcDir takeFileName (requestEntryPath req)) - } - --- | Lay out the work directory: the entry buffer under @src/@, the other open buffers under --- @overlay/@ at their paths relative to the entry's directory, and an @out/@ for the build. --- Returns the @src/@ directory. -prepareWorkDir :: RenderRequest -> IO FilePath -prepareWorkDir (RenderRequest {..}) = do - let srcDir = requestWorkDir "src" - forM_ [srcDir, requestWorkDir "out"] (createDirectoryIfMissing True) - T.writeFile (srcDir takeFileName requestEntryPath) requestEntryText - - let overlayDir = requestWorkDir "overlay" - doesDirectoryExist overlayDir >>= \case - True -> removeDirectoryRecursive overlayDir - False -> return () - createDirectoryIfMissing True overlayDir - forM_ requestOverlays $ \(path, text) -> do - let rel = makeRelative (takeDirectory requestEntryPath) path - unless (isAbsolute rel || ".." `isPrefixOf` rel) $ do - createDirectoryIfMissing True (takeDirectory (overlayDir rel)) - T.writeFile (overlayDir rel) text - - return srcDir - --- | Compile a @.tex@ file that lives in the work directory's @src/@: one engine pass, or a latexmk --- build when settling. The PDF, the recorded dependencies and the timing come back. -compileTex :: RenderRequest -> FilePath -> IO RenderResult -compileTex (RenderRequest {..}) texFile = do - let job = dropExtension (takeFileName texFile) - let outDir = requestWorkDir "out" - let overlayDir = requestWorkDir "overlay" - let engine = T.unpack (fromMaybe "pdflatex" (M.lookup "engine" requestOptions)) - env <- texEnv overlayDir requestEpoch <$> getEnvironment - let common = ["-interaction=nonstopmode", "-halt-on-error", "-file-line-error", "-recorder", "-jobname=" <> job] - let (exe, args) = case requestSettle of - True -> ("latexmk", [engineFlag engine, "-outdir=" <> outDir] <> common <> [texFile]) - False -> (engine, ["-output-directory=" <> outDir] <> common <> [texFile]) - - requestLog LogStdout (T.pack (unwords (exe : args))) - let entryDir = takeDirectory requestEntryPath - start <- getCurrentTime - code <- runCapturing entryDir env exe args $ \isOut line -> requestLog (logStream isOut) line - end <- getCurrentTime - let ms = realToFrac (diffUTCTime end start) * 1000 :: Double - - case code of - ExitFailure n -> do - logErrors (outDir job <.> "log") requestLog - throwIO (RenderFailure n [i|#{exe} exited with code #{n}|]) - ExitSuccess -> return () - - bytes <- B.readFile (outDir job <.> "pdf") - fls <- doesFileExist (outDir job <.> "fls") >>= \case - True -> T.readFile (outDir job <.> "fls") - False -> return "" - return RenderResult { - resultFileName = T.pack (job <.> "pdf") - , resultBytes = bytes - , resultDeps = depsFromFls entryDir requestEntryPath (requestWorkDir "src") overlayDir requestWorkDir fls - , resultTimings = [Timing (T.pack exe) ms] - } - -logStream :: Bool -> LogStream -logStream = \case - True -> LogStdout - False -> LogStderr - --- The overlay directory comes first on TEXINPUTS so open buffers shadow their disk copies; the --- epoch pins the timestamps the engine writes into the PDF -texEnv :: FilePath -> Integer -> [(String, String)] -> [(String, String)] -texEnv overlayDir epoch baseEnv = overrides <> filter ((`notElem` map fst overrides) . fst) baseEnv - where - overrides = [ - ("TEXINPUTS", overlayDir <> "//:" <> fromMaybe "" (lookup "TEXINPUTS" baseEnv)) - , ("LC_ALL", "C") - , ("SOURCE_DATE_EPOCH", show epoch) - , ("FORCE_SOURCE_DATE", "1") - ] - -engineFlag :: String -> String -engineFlag = \case - "xelatex" -> "-pdfxe" - "lualatex" -> "-pdflua" - _ -> "-pdf" - --- | The files a run read, from the recorder's @INPUT@ lines: absolute, with the work directory's --- copies mapped back to the documents they stand for, and the Nix store left out. -depsFromFls :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> T.Text -> [FilePath] -depsFromFls entryDir entryPath srcDir overlayDir workDir fls = nub (mapMaybe dep (T.lines fls)) - where - dep line = case T.stripPrefix "INPUT " line of - Nothing -> Nothing - Just (T.unpack . T.strip -> p) -> classify (normalise (absolute p)) - - absolute p = case isAbsolute p of - True -> p - False -> entryDir p - - classify abs' - | "/nix/store" `isPrefixOf` abs' = Nothing - | normalise srcDir `isPrefixOf` abs' = Just entryPath - | normalise overlayDir `isPrefixOf` abs' = Just (entryDir makeRelative (normalise overlayDir) abs') - | normalise workDir `isPrefixOf` abs' = Nothing - | otherwise = Just abs' - --- The engine's own account of what went wrong: the @!@ lines and the @file:line:@ errors -logErrors :: FilePath -> (LogStream -> T.Text -> IO ()) -> IO () -logErrors logFile logFn = doesFileExist logFile >>= \case - False -> return () - True -> do - ls <- T.lines <$> T.readFile logFile - let interesting = [l | (l, next) <- zip ls (drop 1 ls <> [""]), isError l || isError next] - when (not (null interesting)) $ logFn LogStderr (T.unlines interesting) - where - isError l = "!" `T.isPrefixOf` l || T.isInfixOf ":error:" l || hasLineError l - hasLineError l = case T.splitOn ":" l of - (_file : lineNo : _ : _) -> T.all (`elem` ['0'..'9']) lineNo && not (T.null lineNo) && ".tex" `T.isInfixOf` l - _ -> False diff --git a/src/Render/Backend/Pandoc.hs b/src/Render/Backend/Pandoc.hs deleted file mode 100644 index dd325b8..0000000 --- a/src/Render/Backend/Pandoc.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Render.Backend.Pandoc ( - pandocBackend - ) where - -import qualified Data.ByteString as B -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.String.Interpolate -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time -import Render.Backend -import Render.Backend.Latex (compileTex, logStream, prepareWorkDir) -import Render.Process -import Render.Protocol (LogStream(..), Timing(..)) -import System.Environment (getEnvironment) -import System.Exit -import System.FilePath -import UnliftIO (throwIO) - - --- Options: @to@ (pandoc writer; @pdf@ means @latex@), @format@ (output extension), @from@ (reader --- for Markdown input), @pandoc_args@ (extra arguments, space-separated), and the LaTeX backend's --- @engine@ for the LaTeX-based writers. -pandocBackend :: Backend -pandocBackend = Backend { - backendName = "pandoc" - , backendRender = render - } - -render :: RenderRequest -> IO RenderResult -render req@(RenderRequest {..}) = do - srcDir <- prepareWorkDir req - let entryFile = takeFileName requestEntryPath - let job = dropExtension entryFile - let writer = writerFor requestOptions - let format = T.unpack (fromMaybe (defaultExtension writer) (M.lookup "format" requestOptions)) - let viaLatex = writer `elem` ["latex", "beamer"] - let output = case viaLatex of - True -> srcDir job <.> "tex" - False -> requestWorkDir "out" job <.> format - let args = readerArgs entryFile requestOptions <> ["-t", T.unpack writer, "--standalone"] <> extraArgs requestOptions <> [srcDir entryFile, "-o", output] - - env <- (("LC_ALL", "C") :) . filter ((/= "LC_ALL") . fst) <$> getEnvironment - requestLog LogStdout (T.pack (unwords ("pandoc" : args))) - start <- getCurrentTime - code <- runCapturing (takeDirectory requestEntryPath) env "pandoc" args $ \isOut line -> requestLog (logStream isOut) line - end <- getCurrentTime - let pandocTiming = Timing "pandoc" (realToFrac (diffUTCTime end start) * 1000) - - case code of - ExitFailure n -> throwIO (RenderFailure n [i|pandoc exited with code #{n}|]) - ExitSuccess -> return () - - case viaLatex of - True -> do - result <- compileTex req output - return result { resultTimings = pandocTiming : resultTimings result } - False -> do - bytes <- B.readFile output - return RenderResult { - resultFileName = T.pack (job <.> format) - , resultBytes = bytes - , resultDeps = [] - , resultTimings = [pandocTiming] - } - -writerFor :: Map Text Text -> Text -writerFor options = case fromMaybe "html" (M.lookup "to" options) of - "pdf" -> "latex" - other -> other - -readerArgs :: FilePath -> Map Text Text -> [String] -readerArgs entryFile options = case takeExtension entryFile of - ".md" -> ["-f", T.unpack (fromMaybe defaultMarkdown (M.lookup "from" options))] - _ -> [] - -extraArgs :: Map Text Text -> [String] -extraArgs = maybe [] (map T.unpack . T.words) . M.lookup "pandoc_args" - -defaultMarkdown :: Text -defaultMarkdown = "markdown+tex_math_dollars+tex_math_single_backslash+raw_html+smart" - -defaultExtension :: Text -> Text -defaultExtension = \case - "latex" -> "pdf" - "beamer" -> "pdf" - "docx" -> "docx" - "epub" -> "epub" - "rst" -> "rst" - "plain" -> "txt" - _ -> "html" diff --git a/src/Render/Command.hs b/src/Render/Command.hs new file mode 100644 index 0000000..2296c07 --- /dev/null +++ b/src/Render/Command.hs @@ -0,0 +1,165 @@ +module Render.Command ( + Programs(..) + , RenderRequest(..) + , RenderResult(..) + , RenderFailure(..) + , render + , prepareWorkDir + , mapDeps + ) where + +import Control.Monad (forM_, unless) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.List (isPrefixOf, nub) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.String.Interpolate +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time +import Render.Process +import Render.Protocol (LogStream(..), Timing(..)) +import System.Directory +import System.Environment (getEnvironment) +import System.Exit +import System.FilePath +import UnliftIO (Exception, throwIO) + + +-- | The programs that render: one for the quick pass after each edit, and optionally one for the +-- settle pass once edits stay quiet. Each runs in the document's directory with the layout and +-- options in @RENDER_*@ variables and must write @RENDER_OUTPUT@. +data Programs = Programs { + programRender :: FilePath + , programSettle :: Maybe FilePath + } + +data RenderRequest = RenderRequest { + -- | The real document, as an absolute path; the render's working directory is its directory + requestEntryPath :: FilePath + , requestEntryText :: Text + -- | Other open buffers (absolute real paths) that take priority over their disk copies + , requestOverlays :: [(FilePath, Text)] + -- | Private scratch space for this task, kept across renders + , requestWorkDir :: FilePath + , requestOptions :: Map Text Text + -- | The settle pass rather than the quick one + , requestSettle :: Bool + -- | Unix time for the output's timestamps, kept fixed so unchanged input gives unchanged bytes + , requestEpoch :: Integer + , requestLog :: LogStream -> Text -> IO () + } + +data RenderResult = RenderResult { + resultFileName :: Text + , resultBytes :: ByteString + -- | Absolute paths of every file read, excluding the scratch space and the Nix store + , resultDeps :: [FilePath] + , resultTimings :: [Timing] + } + +data RenderFailure = RenderFailure { + failureExitCode :: Int + , failureMessage :: Text + } deriving (Show) +instance Exception RenderFailure + +-- | Lay out the work directory, run the pass's program and collect its output and dependencies. +render :: Programs -> RenderRequest -> IO RenderResult +render cmd req@(RenderRequest {..}) = do + prepareWorkDir req + let exe = case requestSettle of + True -> fromMaybe (programRender cmd) (programSettle cmd) + False -> programRender cmd + let job = dropExtension (takeFileName requestEntryPath) + let format = T.unpack (fromMaybe "" (M.lookup "format" requestOptions)) + let output = requestWorkDir "out" job <.> format + let depsFile = requestWorkDir "deps" + doesFileExist depsFile >>= \case + True -> removeFile depsFile + False -> return () + let vars = [ + ("RENDER_PHASE", case requestSettle of { True -> "settle"; False -> "quick" }) + , ("RENDER_DOCUMENT", requestEntryPath) + , ("RENDER_ENTRY", requestWorkDir "src" takeFileName requestEntryPath) + , ("RENDER_JOB", job) + , ("RENDER_FORMAT", format) + , ("RENDER_OUTPUT", output) + , ("RENDER_WORK", requestWorkDir) + , ("RENDER_SRC", requestWorkDir "src") + , ("RENDER_OVERLAY", requestWorkDir "overlay") + , ("RENDER_OUT", requestWorkDir "out") + , ("RENDER_DEPS", depsFile) + , ("RENDER_EPOCH", show requestEpoch) + ] <> [("RENDER_OPT_" <> T.unpack k, T.unpack v) | (k, v) <- M.toList requestOptions] + env <- (vars <>) . filter ((`notElem` map fst vars) . fst) <$> getEnvironment + + let entryDir = takeDirectory requestEntryPath + start <- getCurrentTime + code <- runCapturing entryDir env exe [] $ \isOut line -> requestLog (logStream isOut) line + end <- getCurrentTime + let ms = realToFrac (diffUTCTime end start) * 1000 :: Double + let name = takeFileName exe + + case code of + ExitFailure n -> throwIO (RenderFailure n [i|#{name} exited with code #{n}|]) + ExitSuccess -> return () + bytes <- doesFileExist output >>= \case + True -> B.readFile output + False -> throwIO (RenderFailure 1 [i|#{name} exited with code 0 but wrote no #{output}|]) + deps <- doesFileExist depsFile >>= \case + True -> map T.unpack . filter (not . T.null) . T.lines <$> T.readFile depsFile + False -> return [] + return RenderResult { + resultFileName = T.pack (job <.> format) + , resultBytes = bytes + , resultDeps = mapDeps entryDir requestEntryPath requestWorkDir deps + , resultTimings = [Timing (T.pack name) ms] + } + +logStream :: Bool -> LogStream +logStream = \case + True -> LogStdout + False -> LogStderr + +-- | Lay out the work directory: the entry buffer under @src/@, the other open buffers under +-- @overlay/@ at their paths relative to the entry's directory, and an @out/@ for the output. +prepareWorkDir :: RenderRequest -> IO () +prepareWorkDir (RenderRequest {..}) = do + let srcDir = requestWorkDir "src" + forM_ [srcDir, requestWorkDir "out"] (createDirectoryIfMissing True) + T.writeFile (srcDir takeFileName requestEntryPath) requestEntryText + + let overlayDir = requestWorkDir "overlay" + doesDirectoryExist overlayDir >>= \case + True -> removeDirectoryRecursive overlayDir + False -> return () + createDirectoryIfMissing True overlayDir + forM_ requestOverlays $ \(path, text) -> do + let rel = makeRelative (takeDirectory requestEntryPath) path + unless (isAbsolute rel || ".." `isPrefixOf` rel) $ do + createDirectoryIfMissing True (takeDirectory (overlayDir rel)) + T.writeFile (overlayDir rel) text + +-- | The files a render read, as the program reported them (absolute, or relative to the document's +-- directory): the work directory's copies mapped back to the documents they stand for, its other +-- files and the Nix store left out. +mapDeps :: FilePath -> FilePath -> FilePath -> [FilePath] -> [FilePath] +mapDeps entryDir entryPath workDir = nub . concatMap (classify . normalise . absolute) + where + srcDir = normalise (workDir "src") + overlayDir = normalise (workDir "overlay") + + absolute p = case isAbsolute p of + True -> p + False -> entryDir p + + classify p + | "/nix/store" `isPrefixOf` p = [] + | srcDir `isPrefixOf` p = [entryPath] + | overlayDir `isPrefixOf` p = [entryDir makeRelative overlayDir p] + | normalise workDir `isPrefixOf` p = [] + | otherwise = [p] diff --git a/src/Render/Server.hs b/src/Render/Server.hs index 19d2ccb..af9e229 100644 --- a/src/Render/Server.hs +++ b/src/Render/Server.hs @@ -31,7 +31,7 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.VFS -import Render.Backend +import Render.Command import Render.Protocol import qualified Render.Xdelta as Xdelta import System.Directory @@ -66,7 +66,7 @@ data Task = Task { } data ServerEnv = ServerEnv { - envBackend :: Backend + envCommand :: Programs , envWorkRoot :: FilePath , envDefaultOptions :: Map Text Text , envTasks :: TVar (Map Text Task) @@ -74,9 +74,9 @@ data ServerEnv = ServerEnv { } -- | Serve on stdio until the client exits us. Returns the exit code. -runRenderServer :: Backend -> FilePath -> Map Text Text -> IO Int -runRenderServer backend workRoot defaultOpts = do - env <- ServerEnv backend workRoot defaultOpts <$> newTVarIO mempty <*> newTVarIO Nothing +runRenderServer :: Programs -> FilePath -> Map Text Text -> IO Int +runRenderServer command workRoot defaultOpts = do + env <- ServerEnv command workRoot defaultOpts <$> newTVarIO mempty <*> newTVarIO Nothing runServer ServerDefinition { defaultConfig = () , configSection = "codedown-render" @@ -220,9 +220,11 @@ runWorker env task = forever $ do True -> return () False -> renderOnce env task PhaseQuick >>= \case False -> return () - True -> quietFor settleQuietMs >>= \case - False -> return () - True -> void (renderOnce env task PhaseSettle) + True -> case programSettle (envCommand env) of + Nothing -> return () + Just _ -> quietFor settleQuietMs >>= \case + False -> return () + True -> void (renderOnce env task PhaseSettle) where quietFor ms = race (threadDelay (ms * 1000)) (atomically (readTVar (taskDirty task) >>= check)) >>= \case Left () -> return True @@ -256,7 +258,7 @@ renderOnce env task phase = do sendStatus env task StatusRendering phase reason Nothing Nothing [] sendLog env task LogStdout "" True marker [i|#{label}: #{fromMaybe "no reason recorded" reason}|] - PhaseSettle -> marker [i|#{label} (latexmk) after #{settleQuietMs}ms without edits|] + PhaseSettle -> marker [i|#{label} after #{settleQuietMs}ms without edits|] start <- getCurrentTime let request = RenderRequest { requestEntryPath = taskEntryPath task @@ -268,7 +270,7 @@ renderOnce env task phase = do , requestEpoch = taskEpoch task , requestLog = logFn } - outcome <- race (atomically (readTVar (taskDirty task) >>= check)) (try (backendRender (envBackend env) request)) + outcome <- race (atomically (readTVar (taskDirty task) >>= check)) (try (render (envCommand env) request)) end <- getCurrentTime let ms = realToFrac (diffUTCTime end start) * 1000 :: Double case outcome of From 186fc1aecb45f87a173f8da61b0d7d0bb8609136 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Tue, 10 Nov 2026 20:00:28 -0800 Subject: [PATCH 2/5] Tests: drive the server through lsp-test --- test/Main.hs | 299 ++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 286 insertions(+), 13 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index 81b37d9..1024cb1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,14 +1,38 @@ +{-# LANGUAGE GADTs #-} + module Main (main) where +import Control.Applicative (Alternative) +import Control.Monad (forM_, void) +import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class (liftIO) -import Data.Aeson (Value, decode, encode) +import Control.Lens ((&), (.~)) +import Control.Monad.Logger (MonadLoggerIO) +import Data.Aeson (Value, decode, encode, toJSON) +import qualified Data.Aeson as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as M import Data.String.Interpolate -import Render.Backend.Latex (depsFromFls) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time +import GHC.TypeLits (symbolVal) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Test +import Render.Command (mapDeps) import Render.Protocol import qualified Render.Xdelta as Xdelta +import System.Directory +import System.FilePath +import System.Process (proc) import Test.Sandwich +import UnliftIO (MonadUnliftIO) +import UnliftIO.Concurrent (threadDelay) spec :: TopSpec @@ -35,17 +59,266 @@ spec = do decode [i|{"taskId":"a","uri":"file:///home/x.tex","format":"pdf","options":{"engine":"xelatex"},"debounceMs":50}|] `shouldBe` Just (StartParams "a" "file:///home/x.tex" "pdf" (M.fromList [("engine", "xelatex")]) (Just 50)) - describe "latex deps" $ do - it "maps the recorder's inputs back to the documents they stand for" $ do - let fls = [__i|PWD /home/u/docs - INPUT /nix/store/abc-texlive/article.cls - INPUT /work/src/main.tex - INPUT ./sub/inc.tex - INPUT /work/overlay/sub/other.tex - INPUT /work/out/main.aux - INPUT /home/u/other/img.png|] - depsFromFls "/home/u/docs" "/home/u/docs/main.tex" "/work/src" "/work/overlay" "/work" fls + describe "deps" $ do + it "maps the work directory's copies back to the documents they stand for" $ do + let reported = ["/nix/store/abc-texlive/article.cls", "/work/src/main.tex", "./sub/inc.tex", "/work/overlay/sub/other.tex", "/work/out/main.aux", "/home/u/other/img.png"] + mapDeps "/home/u/docs" "/home/u/docs/main.tex" "/work" reported `shouldBe` ["/home/u/docs/main.tex", "/home/u/docs/sub/inc.tex", "/home/u/docs/sub/other.tex", "/home/u/other/img.png"] + describe "server" $ do + it "renders on start and sends the full output with what it read from disk" $ do + (docDir, script) <- setup + (_, _, out) <- withServer docDir ["--render", script] $ do + void $ start docDir 50 mempty + untilOutput + + outputRenderId out `shouldBe` 1 + outputBaseRenderId out `shouldBe` Nothing + outputDeps out `shouldBe` [docDir "inc.txt"] + fullBytes out `shouldBe` "hello\ninc1\nquick\n" + + it "answers an edit with a diff against the last render, tagged with the document version" $ do + (docDir, script) <- setup + (first, second) <- withServer docDir ["--render", script] $ do + doc <- start docDir 50 mempty + (_, _, first) <- untilOutput + changeDoc doc [whole "bye\n"] + (_, _, second) <- untilOutput + return (first, second) + + outputBaseRenderId second `shouldBe` Just 1 + outputDocumentVersion second `shouldBe` Just 1 + Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) + rebuilt `shouldBe` "bye\ninc1\nquick\n" + + it "coalesces a burst of edits into one render" $ do + (docDir, script) <- setup + (statuses, out) <- withServer docDir ["--render", script] $ do + doc <- start docDir 300 mempty + void untilOutput + forM_ [1 .. 5 :: Int] $ \n -> do + changeDoc doc [whole [i|edit #{n}\n|]] + threadDelay 20_000 + (statuses, _, out) <- untilOutput + return (statuses, out) + + length [s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` 1 + outputDocumentVersion out `shouldBe` Just 5 + + it "runs the settle program once edits stay quiet" $ do + (docDir, script) <- setup + (first, second, settled) <- withServer docDir ["--render", script, "--settle", script] $ do + void $ start docDir 50 mempty + (_, _, first) <- untilOutput + (_, _, second) <- untilOutput + (_, settled) <- untilStatus ((== PhaseSettle) . statusPhase) + return (first, second, settled) + + fullBytes first `shouldBe` "hello\ninc1\nquick\n" + Right bytes <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) + bytes `shouldBe` "hello\ninc1\nsettle\n" + statusStatus settled `shouldBe` StatusReady + + it "has no settle pass without a settle program" $ do + (docDir, script) <- setup + statuses <- withServer docDir ["--render", script] $ do + doc <- start docDir 50 mempty + void untilOutput + threadDelay 2_500_000 + changeDoc doc [whole "bye\n"] + (statuses, _, _) <- untilOutput + return statuses + + [statusPhase s | s <- statuses] `shouldBe` [PhaseQuick, PhaseQuick] + + it "rebuilds only when a dependency changed on disk" $ do + (docDir, script) <- setup + (statuses, first, second) <- withServer docDir ["--render", script] $ do + void $ start docDir 50 mempty + (_, _, first) <- untilOutput + execute commandRebuild [toJSON ("t1" :: Text)] + liftIO $ writeFile (docDir "inc.txt") "inc2\n" + execute commandRebuild [toJSON ("t1" :: Text)] + (statuses, _, second) <- untilOutput + return (statuses, first, second) + + [statusReason s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` [Just "inc.txt changed on disk"] + Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) + rebuilt `shouldBe` "hello\ninc2\nquick\n" + + it "lets an open buffer shadow its disk copy and re-renders on its edits" $ do + (docDir, script) <- setup + (first, second) <- withServer docDir ["--render", script] $ do + inc <- openDoc "inc.txt" "plaintext" + void $ start docDir 50 mempty + (_, _, first) <- untilOutput + changeDoc inc [whole "inc-edited\n"] + (_, _, second) <- untilOutput + return (first, second) + + fullBytes first `shouldBe` "hello\ninc1\nquick\n" + outputDeps first `shouldBe` [] + Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) + rebuilt `shouldBe` "hello\ninc-edited\nquick\n" + + it "passes the task's options and the command line's defaults as RENDER_OPT variables" $ do + (docDir, script) <- setup + (_, _, out) <- withServer docDir ["--render", script, "-o", "flavor=cli", "-o", "size=big"] $ do + void $ start docDir 50 (M.fromList [("flavor", "vanilla")]) + untilOutput + + fullBytes out `shouldBe` "hello\ninc1\nquick\nflavor=vanilla size=big\n" + + it "reports a failing program with its exit code and stderr" $ do + (docDir, _) <- setup + failing <- writeScript docDir "fail.sh" "#!/bin/sh\necho boom >&2\nexit 3\n" + (logs, status) <- withServer docDir ["--render", failing] $ do + void $ start docDir 50 mempty + untilStatus ((== StatusErrored) . statusStatus) + + statusExitCode status `shouldBe` Just 3 + [logText l | l <- logs, logStream l == LogStderr, "boom" `T.isInfixOf` logText l] `shouldBe` ["boom"] + + it "holds renders while paused" $ do + (docDir, script) <- setup + (statuses, out) <- withServer docDir ["--render", script] $ do + doc <- start docDir 50 mempty + void untilOutput + execute commandSetPaused [toJSON ("t1" :: Text), toJSON True] + changeDoc doc [whole "one\n"] + threadDelay 500_000 + changeDoc doc [whole "two\n"] + execute commandSetPaused [toJSON ("t1" :: Text), toJSON False] + (statuses, _, out) <- untilOutput + return (statuses, out) + + length [s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` 1 + outputDocumentVersion out `shouldBe` Just 2 + + it "sends the full output again on resync" $ do + (docDir, script) <- setup + (first, second) <- withServer docDir ["--render", script] $ do + void $ start docDir 50 mempty + (_, _, first) <- untilOutput + execute commandResync [toJSON ("t1" :: Text)] + (_, _, second) <- untilOutput + return (first, second) + + outputBaseRenderId second `shouldBe` Nothing + outputRenderId second `shouldBe` 2 + fullBytes second `shouldBe` fullBytes first + +-- The document directory with main.txt and inc.txt, and a render program that concatenates them +-- (the open buffer of inc.txt if there is one), appends the phase, and reports what it read +setup :: HasBaseContext context => ExampleT context IO (FilePath, FilePath) +setup = do + Just dir <- getCurrentFolder + let docDir = dir "doc" + liftIO $ createDirectoryIfMissing True docDir + liftIO $ writeFile (docDir "main.txt") "hello\n" + liftIO $ writeFile (docDir "inc.txt") "inc1\n" + script <- writeScript dir "render.sh" [__i|\#!/bin/sh + set -e + echo "rendering $RENDER_PHASE of $RENDER_JOB.$RENDER_FORMAT" + inc=inc.txt + [ -f "$RENDER_OVERLAY/inc.txt" ] && inc="$RENDER_OVERLAY/inc.txt" + cat "$RENDER_ENTRY" "$inc" > "$RENDER_OUTPUT" + echo "$RENDER_PHASE" >> "$RENDER_OUTPUT" + if [ -n "${RENDER_OPT_flavor:-}" ]; then echo "flavor=$RENDER_OPT_flavor size=${RENDER_OPT_size:-}" >> "$RENDER_OUTPUT"; fi + printf '%s\\n' "$RENDER_ENTRY" "$inc" /nix/store/abc-lib/x > "$RENDER_DEPS" + |] + return (docDir, script) + +writeScript :: FilePath -> FilePath -> String -> ExampleT context IO FilePath +writeScript dir name body = liftIO $ do + let path = dir name + writeFile path body + getPermissions path >>= setPermissions path . setOwnerExecutable True + return path + +-- The client does not offer workspace/configuration: lsp-test answers that request from its +-- listener thread while the session thread is still writing, and the two writes interleave on the +-- server's stdin +withServer :: FilePath -> [String] -> Session (ExampleT context IO) a -> ExampleT context IO a +withServer root args = runSessionWithConfig defaultConfig { messageTimeout = 20 } (proc "lsp-export-server" ("serve" : args)) caps root + where + caps = fullLatestClientCaps & L.workspace . traverse . L.configuration .~ Just False + +-- Opens main.txt and starts task t1 on it +start :: (MonadLoggerIO m, MonadUnliftIO m, MonadThrow m, Alternative m) => FilePath -> Int -> M.Map Text Text -> Session m TextDocumentIdentifier +start docDir debounceMs options = do + doc <- openDoc "main.txt" "plaintext" + execute commandStart [toJSON (StartParams "t1" (T.pack (filePathToUri' (docDir "main.txt"))) "txt" options (Just debounceMs))] + return doc + where + filePathToUri' = T.unpack . getUri . filePathToUri + +execute :: (MonadLoggerIO m, MonadUnliftIO m, MonadThrow m, Alternative m) => Text -> [Value] -> Session m () +execute cmd args = do + TResponseMessage {_result} <- request SMethod_WorkspaceExecuteCommand (ExecuteCommandParams Nothing cmd (Just args)) + case _result of + Left err -> liftIO $ expectationFailure [i|#{cmd} failed: #{err}|] + Right _ -> return () + +whole :: Text -> TextDocumentContentChangeEvent +whole text = TextDocumentContentChangeEvent (InR (TextDocumentContentChangeWholeDocument text)) + +data Event = EvStatus StatusParams | EvOutput OutputParams | EvLog LogParams | EvOther + +classify :: FromServerMessage -> Event +classify = \case + FromServerMess m msg -> case splitServerMethod m of + IsServerEither -> case msg of + NotMess (TNotificationMessage _ (SMethod_CustomMethod p) params) -> byName (T.pack (symbolVal p)) params + _ -> EvOther + _ -> EvOther + _ -> EvOther + where + byName name params + | name == methodStatus = parsed EvStatus params + | name == methodOutput = parsed EvOutput params + | name == methodLog = parsed EvLog params + | otherwise = EvOther + + parsed f params = case A.fromJSON params of + A.Success x -> f x + A.Error _ -> EvOther + +-- | The statuses and log lines up to the next output, and the output +untilOutput :: (MonadLoggerIO m, MonadUnliftIO m) => Session m ([StatusParams], [LogParams], OutputParams) +untilOutput = go [] [] + where + go statuses logs = anyMessage >>= \msg -> case classify msg of + EvOutput o -> return (reverse statuses, reverse logs, o) + EvStatus s | statusStatus s == StatusErrored -> liftIO $ expectationFailure [i|render failed (exit #{statusExitCode s}); log: #{[logText l | l <- reverse logs]}|] + EvStatus s -> go (s : statuses) logs + EvLog l -> go statuses (l : logs) + EvOther -> go statuses logs + +-- | The log lines up to the first status matching the predicate, and that status +untilStatus :: (MonadLoggerIO m, MonadUnliftIO m) => (StatusParams -> Bool) -> Session m ([LogParams], StatusParams) +untilStatus p = go [] + where + go logs = anyMessage >>= \msg -> case classify msg of + EvStatus s | p s -> return (reverse logs, s) + EvLog l -> go (l : logs) + _ -> go logs + +fileBytes :: OutputParams -> ByteString +fileBytes (OutputParams {outputFiles = [f]}) = B64.decodeLenient (T.encodeUtf8 (outputFileBytes f)) +fileBytes _ = error "expected exactly one output file" + +fullBytes :: OutputParams -> ByteString +fullBytes out@(OutputParams {outputFiles = [OutputFile {outputFileEncoding = EncodingFull}]}) = fileBytes out +fullBytes _ = error "expected a full output" + +patchBytes :: OutputParams -> ByteString +patchBytes out@(OutputParams {outputFiles = [OutputFile {outputFileEncoding = EncodingXdelta3}]}) = fileBytes out +patchBytes _ = error "expected an xdelta3 output" + main :: IO () -main = runSandwichWithCommandLineArgs defaultOptions spec +main = runSandwichWithCommandLineArgs options spec + where + options = defaultOptions { + optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (formatTime defaultTimeLocale "%Y-%m-%dT%H.%M.%S" <$> getCurrentTime) + } From 05c6e550bca6e28c1b2ea3a5b48e79340a59f54b Mon Sep 17 00:00:00 2001 From: thomasjm Date: Wed, 11 Nov 2026 00:45:24 -0800 Subject: [PATCH 3/5] Main: case on the parsed invocation directly --- app/Main.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7534940..4b7772b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -50,8 +50,7 @@ invocationParser = hsubparser ( main :: IO () main = do hSetBuffering stderr LineBuffering - invocation <- execParser (info (invocationParser <**> helper) (fullDesc <> progDesc "Renders documents, live from a language client or once from disk")) - case invocation of + execParser (info (invocationParser <**> helper) (fullDesc <> progDesc "Renders documents, live from a language client or once from disk")) >>= \case Serve (Common {..}) -> do tmp <- getCanonicalTemporaryDirectory withTempDirectory tmp "lsp-export-server" $ \workRoot -> From 52d361baf2a9ec39dd5af19b589c5c383047b18d Mon Sep 17 00:00:00 2001 From: thomasjm Date: Wed, 11 Nov 2026 00:45:37 -0800 Subject: [PATCH 4/5] Tests: sandwich discovery, helpers in a test-lib library --- .github/workflows/ci.yml | 3 +- lsp-export-server.cabal | 70 ++++++-- package.yaml | 35 ++-- test-lib/TestLib/Events.hs | 75 +++++++++ test-lib/TestLib/Main.hs | 14 ++ test-lib/TestLib/Session.hs | 82 +++++++++ test/Main.hs | 321 +----------------------------------- test/Spec.hs | 18 ++ test/Spec/Deps.hs | 16 ++ test/Spec/Protocol.hs | 25 +++ test/Spec/Server.hs | 170 +++++++++++++++++++ test/Spec/Xdelta.hs | 25 +++ 12 files changed, 513 insertions(+), 341 deletions(-) create mode 100644 test-lib/TestLib/Events.hs create mode 100644 test-lib/TestLib/Main.hs create mode 100644 test-lib/TestLib/Session.hs create mode 100644 test/Spec.hs create mode 100644 test/Spec/Deps.hs create mode 100644 test/Spec/Protocol.hs create mode 100644 test/Spec/Server.hs create mode 100644 test/Spec/Xdelta.hs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 562217a..064fa1c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -20,8 +20,9 @@ jobs: - name: Run tests run: | + SERVER=$(nix build --no-link --print-out-paths .#dynamic)/bin TESTS=$(nix build --no-link --print-out-paths .#tests)/bin/lsp-export-server-test - "$TESTS" --print + PATH="$SERVER:$PATH" "$TESTS" --print no-gmp: runs-on: arc-public-small diff --git a/lsp-export-server.cabal b/lsp-export-server.cabal index e537499..0bd0a7e 100644 --- a/lsp-export-server.cabal +++ b/lsp-export-server.cabal @@ -58,6 +58,7 @@ library FlexibleInstances LambdaCase ViewPatterns + RankNTypes MultiWayIf TupleSections NumericUnderscores @@ -90,6 +91,53 @@ library , unliftio default-language: Haskell2010 +library test-lib + exposed-modules: + TestLib.Events + TestLib.Main + TestLib.Session + other-modules: + Paths_lsp_export_server + autogen-modules: + Paths_lsp_export_server + hs-source-dirs: + test-lib + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ViewPatterns + RankNTypes + MultiWayIf + TupleSections + NumericUnderscores + TypeApplications + DataKinds + ghc-options: -Wunused-packages -Wall -fno-warn-name-shadowing + build-depends: + aeson + , base >=4.7 && <5 + , base64-bytestring + , bytestring + , containers + , directory + , filepath + , lens + , lsp-export-server + , lsp-test + , lsp-types + , process + , sandwich + , string-interpolate + , text + , time + default-language: Haskell2010 + executable lsp-export-server main-is: Main.hs other-modules: @@ -108,6 +156,7 @@ executable lsp-export-server FlexibleInstances LambdaCase ViewPatterns + RankNTypes MultiWayIf TupleSections NumericUnderscores @@ -115,8 +164,7 @@ executable lsp-export-server DataKinds ghc-options: -Wunused-packages -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N -O2 -W build-depends: - aeson - , base >=4.7 && <5 + base >=4.7 && <5 , bytestring , containers , directory @@ -133,6 +181,11 @@ test-suite lsp-export-server-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Spec + Spec.Deps + Spec.Protocol + Spec.Server + Spec.Xdelta Paths_lsp_export_server autogen-modules: Paths_lsp_export_server @@ -148,6 +201,7 @@ test-suite lsp-export-server-test FlexibleInstances LambdaCase ViewPatterns + RankNTypes MultiWayIf TupleSections NumericUnderscores @@ -155,25 +209,19 @@ test-suite lsp-export-server-test DataKinds ghc-options: -Wunused-packages -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N -W build-tool-depends: - lsp-export-server:lsp-export-server + sandwich:sandwich-discover + , lsp-export-server:lsp-export-server build-depends: aeson , base >=4.7 && <5 - , base64-bytestring , bytestring , containers - , directory - , exceptions , filepath - , lens , lsp-export-server , lsp-test - , lsp-types - , monad-logger - , process , sandwich , string-interpolate + , test-lib , text - , time , unliftio default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 5dae394..bbcf25c 100644 --- a/package.yaml +++ b/package.yaml @@ -12,11 +12,9 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 -- aeson - bytestring - containers - text -- unliftio default-extensions: - OverloadedStrings @@ -28,6 +26,7 @@ default-extensions: - FlexibleInstances - LambdaCase - ViewPatterns +- RankNTypes - MultiWayIf - TupleSections - NumericUnderscores @@ -45,6 +44,7 @@ library: include-dirs: cbits cc-options: -std=c11 -DHAVE_CONFIG_H dependencies: + - aeson - base64-bytestring - cryptohash-sha256 - directory @@ -57,6 +57,7 @@ library: - string-interpolate - time - unix + - unliftio executables: lsp-export-server: @@ -76,6 +77,24 @@ executables: - lsp-export-server - temporary - time + - unliftio + +internal-libraries: + test-lib: + source-dirs: test-lib + dependencies: + - aeson + - base64-bytestring + - directory + - filepath + - lens + - lsp-export-server + - lsp-test + - lsp-types + - process + - sandwich + - string-interpolate + - time tests: lsp-export-server-test: @@ -89,17 +108,13 @@ tests: - -W build-tools: - lsp-export-server:lsp-export-server + - sandwich:sandwich-discover dependencies: - - base64-bytestring - - directory + - aeson - filepath - lsp-export-server - lsp-test - - lsp-types - - monad-logger - - process - sandwich - string-interpolate - - lens - - exceptions - - time + - test-lib + - unliftio diff --git a/test-lib/TestLib/Events.hs b/test-lib/TestLib/Events.hs new file mode 100644 index 0000000..ddc6587 --- /dev/null +++ b/test-lib/TestLib/Events.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE GADTs #-} + +module TestLib.Events ( + untilOutput + , untilStatus + , fullBytes + , patchBytes + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 +import Data.String.Interpolate +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHC.TypeLits (symbolVal) +import Language.LSP.Protocol.Message +import Language.LSP.Test +import Render.Protocol +import Test.Sandwich + + +data Event = EvStatus StatusParams | EvOutput OutputParams | EvLog LogParams | EvOther + +classify :: FromServerMessage -> Event +classify = \case + FromServerMess m msg -> case splitServerMethod m of + IsServerEither -> case msg of + NotMess (TNotificationMessage _ (SMethod_CustomMethod p) params) -> byName (T.pack (symbolVal p)) params + _ -> EvOther + _ -> EvOther + _ -> EvOther + where + byName name params + | name == methodStatus = parsed EvStatus params + | name == methodOutput = parsed EvOutput params + | name == methodLog = parsed EvLog params + | otherwise = EvOther + + parsed f params = case A.fromJSON params of + A.Success x -> f x + A.Error _ -> EvOther + +-- | The statuses and log lines up to the next output, and the output. +untilOutput :: Session (ExampleT context IO) ([StatusParams], [LogParams], OutputParams) +untilOutput = go [] [] + where + go statuses logs = anyMessage >>= \msg -> case classify msg of + EvOutput o -> return (reverse statuses, reverse logs, o) + EvStatus s | statusStatus s == StatusErrored -> liftIO $ expectationFailure [i|render failed (exit #{statusExitCode s}); log: #{[logText l | l <- reverse logs]}|] + EvStatus s -> go (s : statuses) logs + EvLog l -> go statuses (l : logs) + EvOther -> go statuses logs + +-- | The log lines up to the first status matching the predicate, and that status. +untilStatus :: (StatusParams -> Bool) -> Session (ExampleT context IO) ([LogParams], StatusParams) +untilStatus p = go [] + where + go logs = anyMessage >>= \msg -> case classify msg of + EvStatus s | p s -> return (reverse logs, s) + EvLog l -> go (l : logs) + _ -> go logs + +fullBytes :: OutputParams -> ByteString +fullBytes out@(OutputParams {outputFiles = [OutputFile {outputFileEncoding = EncodingFull}]}) = fileBytes out +fullBytes _ = error "expected a full output" + +patchBytes :: OutputParams -> ByteString +patchBytes out@(OutputParams {outputFiles = [OutputFile {outputFileEncoding = EncodingXdelta3}]}) = fileBytes out +patchBytes _ = error "expected an xdelta3 output" + +fileBytes :: OutputParams -> ByteString +fileBytes (OutputParams {outputFiles = [f]}) = B64.decodeLenient (T.encodeUtf8 (outputFileBytes f)) +fileBytes _ = error "expected exactly one output file" diff --git a/test-lib/TestLib/Main.hs b/test-lib/TestLib/Main.hs new file mode 100644 index 0000000..d643d57 --- /dev/null +++ b/test-lib/TestLib/Main.hs @@ -0,0 +1,14 @@ +module TestLib.Main ( + specMain + ) where + +import Data.Time +import Test.Sandwich + + +specMain :: TopSpec -> IO () +specMain = runSandwichWithCommandLineArgs options + where + options = defaultOptions { + optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (formatTime defaultTimeLocale "%Y-%m-%dT%H.%M.%S" <$> getCurrentTime) + } diff --git a/test-lib/TestLib/Session.hs b/test-lib/TestLib/Session.hs new file mode 100644 index 0000000..23d3c1e --- /dev/null +++ b/test-lib/TestLib/Session.hs @@ -0,0 +1,82 @@ +module TestLib.Session ( + setupDocument + , writeScript + , withServer + , start + , execute + , whole + ) where + +import Control.Lens ((&), (.~)) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value, toJSON) +import qualified Data.Map as M +import Data.String.Interpolate +import Data.Text (Text) +import qualified Data.Text as T +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Test +import Render.Protocol +import System.Directory +import System.FilePath +import System.Process (proc) +import Test.Sandwich + + +-- | A document directory with main.txt and inc.txt, and a render program that concatenates them +-- (the open buffer of inc.txt if there is one), appends the phase, and reports what it read. +setupDocument :: HasBaseContext context => ExampleT context IO (FilePath, FilePath) +setupDocument = do + Just dir <- getCurrentFolder + let docDir = dir "doc" + liftIO $ createDirectoryIfMissing True docDir + liftIO $ writeFile (docDir "main.txt") "hello\n" + liftIO $ writeFile (docDir "inc.txt") "inc1\n" + script <- writeScript dir "render.sh" [__i| + \#!/bin/sh + set -e + echo "rendering $RENDER_PHASE of $RENDER_JOB.$RENDER_FORMAT" + inc=inc.txt + [ -f "$RENDER_OVERLAY/inc.txt" ] && inc="$RENDER_OVERLAY/inc.txt" + cat "$RENDER_ENTRY" "$inc" > "$RENDER_OUTPUT" + echo "$RENDER_PHASE" >> "$RENDER_OUTPUT" + if [ -n "${RENDER_OPT_flavor:-}" ]; then echo "flavor=$RENDER_OPT_flavor size=${RENDER_OPT_size:-}" >> "$RENDER_OUTPUT"; fi + printf '%s\\n' "$RENDER_ENTRY" "$inc" /nix/store/abc-lib/x > "$RENDER_DEPS" + |] + return (docDir, script) + +writeScript :: FilePath -> FilePath -> String -> ExampleT context IO FilePath +writeScript dir name body = liftIO $ do + let path = dir name + writeFile path body + getPermissions path >>= setPermissions path . setOwnerExecutable True + return path + +-- | Runs the built server on the given document directory. The client does not offer +-- workspace/configuration: lsp-test answers that request from its listener thread while the session +-- thread is still writing, and the two writes interleave on the server's stdin. +withServer :: FilePath -> [String] -> Session (ExampleT context IO) a -> ExampleT context IO a +withServer root args = runSessionWithConfig config (proc "lsp-export-server" ("serve" : args)) caps root + where + config = defaultConfig { messageTimeout = 20 } + caps = fullLatestClientCaps & L.workspace . traverse . L.configuration .~ Just False + +-- | Opens main.txt and starts task t1 on it. +start :: FilePath -> Int -> M.Map Text Text -> Session (ExampleT context IO) TextDocumentIdentifier +start docDir debounceMs options = do + doc <- openDoc "main.txt" "plaintext" + let uri = T.unpack (getUri (filePathToUri (docDir "main.txt"))) + execute commandStart [toJSON (StartParams "t1" (T.pack uri) "txt" options (Just debounceMs))] + return doc + +execute :: Text -> [Value] -> Session (ExampleT context IO) () +execute cmd args = do + TResponseMessage {_result} <- request SMethod_WorkspaceExecuteCommand (ExecuteCommandParams Nothing cmd (Just args)) + case _result of + Left err -> liftIO $ expectationFailure [i|#{cmd} failed: #{err}|] + Right _ -> return () + +whole :: Text -> TextDocumentContentChangeEvent +whole text = TextDocumentContentChangeEvent (InR (TextDocumentContentChangeWholeDocument text)) diff --git a/test/Main.hs b/test/Main.hs index 1024cb1..77ec8f9 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,324 +1,7 @@ -{-# LANGUAGE GADTs #-} - module Main (main) where -import Control.Applicative (Alternative) -import Control.Monad (forM_, void) -import Control.Monad.Catch (MonadThrow) -import Control.Monad.IO.Class (liftIO) -import Control.Lens ((&), (.~)) -import Control.Monad.Logger (MonadLoggerIO) -import Data.Aeson (Value, decode, encode, toJSON) -import qualified Data.Aeson as A -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Map as M -import Data.String.Interpolate -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Time -import GHC.TypeLits (symbolVal) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types -import Language.LSP.Test -import Render.Command (mapDeps) -import Render.Protocol -import qualified Render.Xdelta as Xdelta -import System.Directory -import System.FilePath -import System.Process (proc) -import Test.Sandwich -import UnliftIO (MonadUnliftIO) -import UnliftIO.Concurrent (threadDelay) - - -spec :: TopSpec -spec = do - describe "xdelta3" $ do - it "round-trips a patch" $ do - let old = B8.pack (concat (replicate 200 "the quick brown fox ")) - let new = B8.pack (concat (replicate 100 "the quick brown fox ") <> "jumped" <> concat (replicate 100 "the quick brown fox ")) - Right patch <- liftIO (Xdelta.encode new old) - Right rebuilt <- liftIO (Xdelta.decode patch old) - rebuilt `shouldBe` new - (B8.length patch < B8.length new) `shouldBe` True - - it "gives an empty patch for equal inputs" $ do - Right patch <- liftIO (Xdelta.encode "same" "same") - patch `shouldBe` "" - - describe "protocol" $ do - it "writes camelCase fields and lower-case tags" $ do - let params = StatusParams "t1" StatusErrored PhaseQuick (Just "edit to x.tex (v3)") (Just 12) Nothing [] - decode (encode params) `shouldBe` (decode [i|{"taskId":"t1","status":"errored","phase":"quick","reason":"edit to x.tex (v3)","exitCode":12,"timings":[]}|] :: Maybe Value) - - it "reads start params" $ do - decode [i|{"taskId":"a","uri":"file:///home/x.tex","format":"pdf","options":{"engine":"xelatex"},"debounceMs":50}|] - `shouldBe` Just (StartParams "a" "file:///home/x.tex" "pdf" (M.fromList [("engine", "xelatex")]) (Just 50)) - - describe "deps" $ do - it "maps the work directory's copies back to the documents they stand for" $ do - let reported = ["/nix/store/abc-texlive/article.cls", "/work/src/main.tex", "./sub/inc.tex", "/work/overlay/sub/other.tex", "/work/out/main.aux", "/home/u/other/img.png"] - mapDeps "/home/u/docs" "/home/u/docs/main.tex" "/work" reported - `shouldBe` ["/home/u/docs/main.tex", "/home/u/docs/sub/inc.tex", "/home/u/docs/sub/other.tex", "/home/u/other/img.png"] - - describe "server" $ do - it "renders on start and sends the full output with what it read from disk" $ do - (docDir, script) <- setup - (_, _, out) <- withServer docDir ["--render", script] $ do - void $ start docDir 50 mempty - untilOutput - - outputRenderId out `shouldBe` 1 - outputBaseRenderId out `shouldBe` Nothing - outputDeps out `shouldBe` [docDir "inc.txt"] - fullBytes out `shouldBe` "hello\ninc1\nquick\n" - - it "answers an edit with a diff against the last render, tagged with the document version" $ do - (docDir, script) <- setup - (first, second) <- withServer docDir ["--render", script] $ do - doc <- start docDir 50 mempty - (_, _, first) <- untilOutput - changeDoc doc [whole "bye\n"] - (_, _, second) <- untilOutput - return (first, second) - - outputBaseRenderId second `shouldBe` Just 1 - outputDocumentVersion second `shouldBe` Just 1 - Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) - rebuilt `shouldBe` "bye\ninc1\nquick\n" - - it "coalesces a burst of edits into one render" $ do - (docDir, script) <- setup - (statuses, out) <- withServer docDir ["--render", script] $ do - doc <- start docDir 300 mempty - void untilOutput - forM_ [1 .. 5 :: Int] $ \n -> do - changeDoc doc [whole [i|edit #{n}\n|]] - threadDelay 20_000 - (statuses, _, out) <- untilOutput - return (statuses, out) - - length [s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` 1 - outputDocumentVersion out `shouldBe` Just 5 - - it "runs the settle program once edits stay quiet" $ do - (docDir, script) <- setup - (first, second, settled) <- withServer docDir ["--render", script, "--settle", script] $ do - void $ start docDir 50 mempty - (_, _, first) <- untilOutput - (_, _, second) <- untilOutput - (_, settled) <- untilStatus ((== PhaseSettle) . statusPhase) - return (first, second, settled) - - fullBytes first `shouldBe` "hello\ninc1\nquick\n" - Right bytes <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) - bytes `shouldBe` "hello\ninc1\nsettle\n" - statusStatus settled `shouldBe` StatusReady - - it "has no settle pass without a settle program" $ do - (docDir, script) <- setup - statuses <- withServer docDir ["--render", script] $ do - doc <- start docDir 50 mempty - void untilOutput - threadDelay 2_500_000 - changeDoc doc [whole "bye\n"] - (statuses, _, _) <- untilOutput - return statuses - - [statusPhase s | s <- statuses] `shouldBe` [PhaseQuick, PhaseQuick] - - it "rebuilds only when a dependency changed on disk" $ do - (docDir, script) <- setup - (statuses, first, second) <- withServer docDir ["--render", script] $ do - void $ start docDir 50 mempty - (_, _, first) <- untilOutput - execute commandRebuild [toJSON ("t1" :: Text)] - liftIO $ writeFile (docDir "inc.txt") "inc2\n" - execute commandRebuild [toJSON ("t1" :: Text)] - (statuses, _, second) <- untilOutput - return (statuses, first, second) - - [statusReason s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` [Just "inc.txt changed on disk"] - Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) - rebuilt `shouldBe` "hello\ninc2\nquick\n" - - it "lets an open buffer shadow its disk copy and re-renders on its edits" $ do - (docDir, script) <- setup - (first, second) <- withServer docDir ["--render", script] $ do - inc <- openDoc "inc.txt" "plaintext" - void $ start docDir 50 mempty - (_, _, first) <- untilOutput - changeDoc inc [whole "inc-edited\n"] - (_, _, second) <- untilOutput - return (first, second) - - fullBytes first `shouldBe` "hello\ninc1\nquick\n" - outputDeps first `shouldBe` [] - Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) - rebuilt `shouldBe` "hello\ninc-edited\nquick\n" - - it "passes the task's options and the command line's defaults as RENDER_OPT variables" $ do - (docDir, script) <- setup - (_, _, out) <- withServer docDir ["--render", script, "-o", "flavor=cli", "-o", "size=big"] $ do - void $ start docDir 50 (M.fromList [("flavor", "vanilla")]) - untilOutput - - fullBytes out `shouldBe` "hello\ninc1\nquick\nflavor=vanilla size=big\n" - - it "reports a failing program with its exit code and stderr" $ do - (docDir, _) <- setup - failing <- writeScript docDir "fail.sh" "#!/bin/sh\necho boom >&2\nexit 3\n" - (logs, status) <- withServer docDir ["--render", failing] $ do - void $ start docDir 50 mempty - untilStatus ((== StatusErrored) . statusStatus) - - statusExitCode status `shouldBe` Just 3 - [logText l | l <- logs, logStream l == LogStderr, "boom" `T.isInfixOf` logText l] `shouldBe` ["boom"] - - it "holds renders while paused" $ do - (docDir, script) <- setup - (statuses, out) <- withServer docDir ["--render", script] $ do - doc <- start docDir 50 mempty - void untilOutput - execute commandSetPaused [toJSON ("t1" :: Text), toJSON True] - changeDoc doc [whole "one\n"] - threadDelay 500_000 - changeDoc doc [whole "two\n"] - execute commandSetPaused [toJSON ("t1" :: Text), toJSON False] - (statuses, _, out) <- untilOutput - return (statuses, out) - - length [s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` 1 - outputDocumentVersion out `shouldBe` Just 2 - - it "sends the full output again on resync" $ do - (docDir, script) <- setup - (first, second) <- withServer docDir ["--render", script] $ do - void $ start docDir 50 mempty - (_, _, first) <- untilOutput - execute commandResync [toJSON ("t1" :: Text)] - (_, _, second) <- untilOutput - return (first, second) - - outputBaseRenderId second `shouldBe` Nothing - outputRenderId second `shouldBe` 2 - fullBytes second `shouldBe` fullBytes first - --- The document directory with main.txt and inc.txt, and a render program that concatenates them --- (the open buffer of inc.txt if there is one), appends the phase, and reports what it read -setup :: HasBaseContext context => ExampleT context IO (FilePath, FilePath) -setup = do - Just dir <- getCurrentFolder - let docDir = dir "doc" - liftIO $ createDirectoryIfMissing True docDir - liftIO $ writeFile (docDir "main.txt") "hello\n" - liftIO $ writeFile (docDir "inc.txt") "inc1\n" - script <- writeScript dir "render.sh" [__i|\#!/bin/sh - set -e - echo "rendering $RENDER_PHASE of $RENDER_JOB.$RENDER_FORMAT" - inc=inc.txt - [ -f "$RENDER_OVERLAY/inc.txt" ] && inc="$RENDER_OVERLAY/inc.txt" - cat "$RENDER_ENTRY" "$inc" > "$RENDER_OUTPUT" - echo "$RENDER_PHASE" >> "$RENDER_OUTPUT" - if [ -n "${RENDER_OPT_flavor:-}" ]; then echo "flavor=$RENDER_OPT_flavor size=${RENDER_OPT_size:-}" >> "$RENDER_OUTPUT"; fi - printf '%s\\n' "$RENDER_ENTRY" "$inc" /nix/store/abc-lib/x > "$RENDER_DEPS" - |] - return (docDir, script) - -writeScript :: FilePath -> FilePath -> String -> ExampleT context IO FilePath -writeScript dir name body = liftIO $ do - let path = dir name - writeFile path body - getPermissions path >>= setPermissions path . setOwnerExecutable True - return path - --- The client does not offer workspace/configuration: lsp-test answers that request from its --- listener thread while the session thread is still writing, and the two writes interleave on the --- server's stdin -withServer :: FilePath -> [String] -> Session (ExampleT context IO) a -> ExampleT context IO a -withServer root args = runSessionWithConfig defaultConfig { messageTimeout = 20 } (proc "lsp-export-server" ("serve" : args)) caps root - where - caps = fullLatestClientCaps & L.workspace . traverse . L.configuration .~ Just False - --- Opens main.txt and starts task t1 on it -start :: (MonadLoggerIO m, MonadUnliftIO m, MonadThrow m, Alternative m) => FilePath -> Int -> M.Map Text Text -> Session m TextDocumentIdentifier -start docDir debounceMs options = do - doc <- openDoc "main.txt" "plaintext" - execute commandStart [toJSON (StartParams "t1" (T.pack (filePathToUri' (docDir "main.txt"))) "txt" options (Just debounceMs))] - return doc - where - filePathToUri' = T.unpack . getUri . filePathToUri - -execute :: (MonadLoggerIO m, MonadUnliftIO m, MonadThrow m, Alternative m) => Text -> [Value] -> Session m () -execute cmd args = do - TResponseMessage {_result} <- request SMethod_WorkspaceExecuteCommand (ExecuteCommandParams Nothing cmd (Just args)) - case _result of - Left err -> liftIO $ expectationFailure [i|#{cmd} failed: #{err}|] - Right _ -> return () - -whole :: Text -> TextDocumentContentChangeEvent -whole text = TextDocumentContentChangeEvent (InR (TextDocumentContentChangeWholeDocument text)) - -data Event = EvStatus StatusParams | EvOutput OutputParams | EvLog LogParams | EvOther - -classify :: FromServerMessage -> Event -classify = \case - FromServerMess m msg -> case splitServerMethod m of - IsServerEither -> case msg of - NotMess (TNotificationMessage _ (SMethod_CustomMethod p) params) -> byName (T.pack (symbolVal p)) params - _ -> EvOther - _ -> EvOther - _ -> EvOther - where - byName name params - | name == methodStatus = parsed EvStatus params - | name == methodOutput = parsed EvOutput params - | name == methodLog = parsed EvLog params - | otherwise = EvOther - - parsed f params = case A.fromJSON params of - A.Success x -> f x - A.Error _ -> EvOther - --- | The statuses and log lines up to the next output, and the output -untilOutput :: (MonadLoggerIO m, MonadUnliftIO m) => Session m ([StatusParams], [LogParams], OutputParams) -untilOutput = go [] [] - where - go statuses logs = anyMessage >>= \msg -> case classify msg of - EvOutput o -> return (reverse statuses, reverse logs, o) - EvStatus s | statusStatus s == StatusErrored -> liftIO $ expectationFailure [i|render failed (exit #{statusExitCode s}); log: #{[logText l | l <- reverse logs]}|] - EvStatus s -> go (s : statuses) logs - EvLog l -> go statuses (l : logs) - EvOther -> go statuses logs - --- | The log lines up to the first status matching the predicate, and that status -untilStatus :: (MonadLoggerIO m, MonadUnliftIO m) => (StatusParams -> Bool) -> Session m ([LogParams], StatusParams) -untilStatus p = go [] - where - go logs = anyMessage >>= \msg -> case classify msg of - EvStatus s | p s -> return (reverse logs, s) - EvLog l -> go (l : logs) - _ -> go logs - -fileBytes :: OutputParams -> ByteString -fileBytes (OutputParams {outputFiles = [f]}) = B64.decodeLenient (T.encodeUtf8 (outputFileBytes f)) -fileBytes _ = error "expected exactly one output file" - -fullBytes :: OutputParams -> ByteString -fullBytes out@(OutputParams {outputFiles = [OutputFile {outputFileEncoding = EncodingFull}]}) = fileBytes out -fullBytes _ = error "expected a full output" +import qualified Spec -patchBytes :: OutputParams -> ByteString -patchBytes out@(OutputParams {outputFiles = [OutputFile {outputFileEncoding = EncodingXdelta3}]}) = fileBytes out -patchBytes _ = error "expected an xdelta3 output" main :: IO () -main = runSandwichWithCommandLineArgs options spec - where - options = defaultOptions { - optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (formatTime defaultTimeLocale "%Y-%m-%dT%H.%M.%S" <$> getCurrentTime) - } +main = Spec.main diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..91c0c6c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -F -pgmF sandwich-discover #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Spec (tests, main) where + +#insert_test_imports + +import Test.Sandwich +import TestLib.Main + + +tests :: TopSpec +tests = $(getSpecFromFolder defaultGetSpecFromFolderOptions) + +main :: IO () +main = specMain tests diff --git a/test/Spec/Deps.hs b/test/Spec/Deps.hs new file mode 100644 index 0000000..4e3ade5 --- /dev/null +++ b/test/Spec/Deps.hs @@ -0,0 +1,16 @@ +module Spec.Deps (tests, main) where + +import Render.Command (mapDeps) +import Test.Sandwich +import TestLib.Main + + +tests :: SpecFree context IO () +tests = describe "deps" $ do + it "maps the work directory's copies back to the documents they stand for" $ do + let reported = ["/nix/store/abc-texlive/article.cls", "/work/src/main.tex", "./sub/inc.tex", "/work/overlay/sub/other.tex", "/work/out/main.aux", "/home/u/other/img.png"] + mapDeps "/home/u/docs" "/home/u/docs/main.tex" "/work" reported + `shouldBe` ["/home/u/docs/main.tex", "/home/u/docs/sub/inc.tex", "/home/u/docs/sub/other.tex", "/home/u/other/img.png"] + +main :: IO () +main = specMain tests diff --git a/test/Spec/Protocol.hs b/test/Spec/Protocol.hs new file mode 100644 index 0000000..307bb53 --- /dev/null +++ b/test/Spec/Protocol.hs @@ -0,0 +1,25 @@ +module Spec.Protocol (tests, main) where + +import Data.Aeson (Value, decode, encode) +import qualified Data.Map as M +import Data.String.Interpolate +import Render.Protocol +import Test.Sandwich +import TestLib.Main + + +tests :: SpecFree context IO () +tests = describe "protocol" $ do + it "writes camelCase fields and lower-case tags" $ do + let params = StatusParams "t1" StatusErrored PhaseQuick (Just "edit to x.tex (v3)") (Just 12) Nothing [] + decode (encode params) `shouldBe` (decode [i| + {"taskId":"t1","status":"errored","phase":"quick","reason":"edit to x.tex (v3)","exitCode":12,"timings":[]} + |] :: Maybe Value) + + it "reads start params" $ do + decode [i| + {"taskId":"a","uri":"file:///home/x.tex","format":"pdf","options":{"engine":"xelatex"},"debounceMs":50} + |] `shouldBe` Just (StartParams "a" "file:///home/x.tex" "pdf" (M.fromList [("engine", "xelatex")]) (Just 50)) + +main :: IO () +main = specMain tests diff --git a/test/Spec/Server.hs b/test/Spec/Server.hs new file mode 100644 index 0000000..5a88a90 --- /dev/null +++ b/test/Spec/Server.hs @@ -0,0 +1,170 @@ +module Spec.Server (tests, main) where + +import Control.Monad (forM_, void) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (toJSON) +import qualified Data.Map as M +import Data.String.Interpolate +import Data.Text (Text) +import qualified Data.Text as T +import Language.LSP.Test +import Render.Protocol +import qualified Render.Xdelta as Xdelta +import System.FilePath +import Test.Sandwich +import TestLib.Events +import TestLib.Main +import TestLib.Session +import UnliftIO.Concurrent (threadDelay) + + +tests :: HasBaseContext context => SpecFree context IO () +tests = describe "server" $ do + it "renders on start and sends the full output with what it read from disk" $ do + (docDir, script) <- setupDocument + (_, _, out) <- withServer docDir ["--render", script] $ do + void $ start docDir 50 mempty + untilOutput + + outputRenderId out `shouldBe` 1 + outputBaseRenderId out `shouldBe` Nothing + outputDeps out `shouldBe` [docDir "inc.txt"] + fullBytes out `shouldBe` "hello\ninc1\nquick\n" + + it "answers an edit with a diff against the last render, tagged with the document version" $ do + (docDir, script) <- setupDocument + (first, second) <- withServer docDir ["--render", script] $ do + doc <- start docDir 50 mempty + (_, _, first) <- untilOutput + changeDoc doc [whole "bye\n"] + (_, _, second) <- untilOutput + return (first, second) + + outputBaseRenderId second `shouldBe` Just 1 + outputDocumentVersion second `shouldBe` Just 1 + Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) + rebuilt `shouldBe` "bye\ninc1\nquick\n" + + it "coalesces a burst of edits into one render" $ do + (docDir, script) <- setupDocument + (statuses, out) <- withServer docDir ["--render", script] $ do + doc <- start docDir 300 mempty + void untilOutput + forM_ [1 .. 5 :: Int] $ \n -> do + changeDoc doc [whole [i|edit #{n}\n|]] + threadDelay 20_000 + (statuses, _, out) <- untilOutput + return (statuses, out) + + length [s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` 1 + outputDocumentVersion out `shouldBe` Just 5 + + it "runs the settle program once edits stay quiet" $ do + (docDir, script) <- setupDocument + (first, second, settled) <- withServer docDir ["--render", script, "--settle", script] $ do + void $ start docDir 50 mempty + (_, _, first) <- untilOutput + (_, _, second) <- untilOutput + (_, settled) <- untilStatus ((== PhaseSettle) . statusPhase) + return (first, second, settled) + + fullBytes first `shouldBe` "hello\ninc1\nquick\n" + Right bytes <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) + bytes `shouldBe` "hello\ninc1\nsettle\n" + statusStatus settled `shouldBe` StatusReady + + it "has no settle pass without a settle program" $ do + (docDir, script) <- setupDocument + statuses <- withServer docDir ["--render", script] $ do + doc <- start docDir 50 mempty + void untilOutput + threadDelay 2_500_000 + changeDoc doc [whole "bye\n"] + (statuses, _, _) <- untilOutput + return statuses + + [statusPhase s | s <- statuses] `shouldBe` [PhaseQuick, PhaseQuick] + + it "rebuilds only when a dependency changed on disk" $ do + (docDir, script) <- setupDocument + (statuses, first, second) <- withServer docDir ["--render", script] $ do + void $ start docDir 50 mempty + (_, _, first) <- untilOutput + execute commandRebuild [toJSON ("t1" :: Text)] + liftIO $ writeFile (docDir "inc.txt") "inc2\n" + execute commandRebuild [toJSON ("t1" :: Text)] + (statuses, _, second) <- untilOutput + return (statuses, first, second) + + [statusReason s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` [Just "inc.txt changed on disk"] + Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) + rebuilt `shouldBe` "hello\ninc2\nquick\n" + + it "lets an open buffer shadow its disk copy and re-renders on its edits" $ do + (docDir, script) <- setupDocument + (first, second) <- withServer docDir ["--render", script] $ do + inc <- openDoc "inc.txt" "plaintext" + void $ start docDir 50 mempty + (_, _, first) <- untilOutput + changeDoc inc [whole "inc-edited\n"] + (_, _, second) <- untilOutput + return (first, second) + + fullBytes first `shouldBe` "hello\ninc1\nquick\n" + outputDeps first `shouldBe` [] + Right rebuilt <- liftIO (Xdelta.decode (patchBytes second) (fullBytes first)) + rebuilt `shouldBe` "hello\ninc-edited\nquick\n" + + it "passes the task's options and the command line's defaults as RENDER_OPT variables" $ do + (docDir, script) <- setupDocument + (_, _, out) <- withServer docDir ["--render", script, "-o", "flavor=cli", "-o", "size=big"] $ do + void $ start docDir 50 (M.fromList [("flavor", "vanilla")]) + untilOutput + + fullBytes out `shouldBe` "hello\ninc1\nquick\nflavor=vanilla size=big\n" + + it "reports a failing program with its exit code and stderr" $ do + (docDir, _) <- setupDocument + failing <- writeScript docDir "fail.sh" [__i| + \#!/bin/sh + echo boom >&2 + exit 3 + |] + (logs, status) <- withServer docDir ["--render", failing] $ do + void $ start docDir 50 mempty + untilStatus ((== StatusErrored) . statusStatus) + + statusExitCode status `shouldBe` Just 3 + [logText l | l <- logs, logStream l == LogStderr, "boom" `T.isInfixOf` logText l] `shouldBe` ["boom"] + + it "holds renders while paused" $ do + (docDir, script) <- setupDocument + (statuses, out) <- withServer docDir ["--render", script] $ do + doc <- start docDir 50 mempty + void untilOutput + execute commandSetPaused [toJSON ("t1" :: Text), toJSON True] + changeDoc doc [whole "one\n"] + threadDelay 500_000 + changeDoc doc [whole "two\n"] + execute commandSetPaused [toJSON ("t1" :: Text), toJSON False] + (statuses, _, out) <- untilOutput + return (statuses, out) + + length [s | s <- statuses, statusStatus s == StatusRendering] `shouldBe` 1 + outputDocumentVersion out `shouldBe` Just 2 + + it "sends the full output again on resync" $ do + (docDir, script) <- setupDocument + (first, second) <- withServer docDir ["--render", script] $ do + void $ start docDir 50 mempty + (_, _, first) <- untilOutput + execute commandResync [toJSON ("t1" :: Text)] + (_, _, second) <- untilOutput + return (first, second) + + outputBaseRenderId second `shouldBe` Nothing + outputRenderId second `shouldBe` 2 + fullBytes second `shouldBe` fullBytes first + +main :: IO () +main = specMain tests diff --git a/test/Spec/Xdelta.hs b/test/Spec/Xdelta.hs new file mode 100644 index 0000000..6c96dc0 --- /dev/null +++ b/test/Spec/Xdelta.hs @@ -0,0 +1,25 @@ +module Spec.Xdelta (tests, main) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Char8 as B8 +import qualified Render.Xdelta as Xdelta +import Test.Sandwich +import TestLib.Main + + +tests :: SpecFree context IO () +tests = describe "xdelta3" $ do + it "round-trips a patch" $ do + let old = B8.pack (concat (replicate 200 "the quick brown fox ")) + let new = B8.pack (concat (replicate 100 "the quick brown fox ") <> "jumped" <> concat (replicate 100 "the quick brown fox ")) + Right patch <- liftIO (Xdelta.encode new old) + Right rebuilt <- liftIO (Xdelta.decode patch old) + rebuilt `shouldBe` new + (B8.length patch < B8.length new) `shouldBe` True + + it "gives an empty patch for equal inputs" $ do + Right patch <- liftIO (Xdelta.encode "same" "same") + patch `shouldBe` "" + +main :: IO () +main = specMain tests From b7091c15df34105fb9f25a110a1650fd299cde86 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Wed, 11 Nov 2026 00:45:37 -0800 Subject: [PATCH 5/5] Reset the version to 0.1.0.0 --- CHANGELOG.md | 47 +++++++++-------------------------------- lsp-export-server.cabal | 2 +- package.yaml | 2 +- 3 files changed, 12 insertions(+), 39 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7351ac2..cfc8569 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,41 +1,14 @@ # Changelog -## 0.5.0.0 - -- The server no longer knows any document format. `--render EXE` (and optionally `--settle EXE`) name the programs that render; they run in the document's directory with the task's layout and options in `RENDER_*` variables, write `RENDER_OUTPUT`, and may list what they read in `RENDER_DEPS`. The `latex` and `pandoc` backends and `--backend` are gone; their logic moves to the packaging. -- No settle pass without a `--settle` program. - -## 0.4.1.2 - -- Release artifacts for aarch64-linux, x86_64-darwin and aarch64-darwin alongside x86_64-linux. - -## 0.4.1.1 - -- A rebuild request before any dependency is known no longer restarts the first render. - -## 0.4.1.0 - -- A `pandoc` backend: pandoc converts the buffer, and the LaTeX-based writers go through the LaTeX backend's quick and settle passes. -- Tasks and one-shot renders see the output extension as the `format` option. - -## 0.4.0.0 - -- A rebuild request only renders when some on-disk dependency's content changed; the reason names the files. -- The settle pass is silent in the log unless it fails or changes the output. - -## 0.3.0.0 - -- Statuses carry the pass (`phase`: quick or settle) and the `reason` the render ran. -- The settle pass no longer reports `rendering`. -- Marker lines in the log say when each pass started, why, how long it took and what was sent. - -## 0.2.0.0 - -- Renamed from render-server. -- Renders stamp a fixed per-task SOURCE_DATE_EPOCH, and an output identical to the last one is not published. -- Reported dependencies leave out the buffers the client sends. -- Logs the debounce period when a task starts. - ## 0.1.0.0 -- First release: the LaTeX backend. +- First release. A language server that renders a document from the buffers the client sends and + streams the result back as xdelta3 diffs: `codedown.render.start/stop/rebuild/setPaused/resync` + with `codedown/render/status`, `output` and `log` notifications. +- `--render EXE`, and optionally `--settle EXE`, name the programs that render. They run in the + document's directory with the task's layout and options in `RENDER_*` variables, write + `RENDER_OUTPUT`, and may list what they read in `RENDER_DEPS`. +- An edit gets a quick render once edits pause for the debounce period, and the settle pass follows + once they stay quiet for longer. An output identical to the last one is not sent, and renders + stamp a fixed per-task `SOURCE_DATE_EPOCH` so unchanged input gives unchanged bytes. +- A rebuild request renders only when some on-disk dependency's content changed. diff --git a/lsp-export-server.cabal b/lsp-export-server.cabal index 0bd0a7e..47110ba 100644 --- a/lsp-export-server.cabal +++ b/lsp-export-server.cabal @@ -5,7 +5,7 @@ cabal-version: 2.2 -- see: https://github.com/sol/hpack name: lsp-export-server -version: 0.5.0.0 +version: 0.1.0.0 synopsis: A language server that renders documents from their in-memory buffers homepage: https://github.com/codedownio/lsp-export-server#readme bug-reports: https://github.com/codedownio/lsp-export-server/issues diff --git a/package.yaml b/package.yaml index bbcf25c..cfeb3b0 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: lsp-export-server -version: 0.5.0.0 +version: 0.1.0.0 synopsis: A language server that renders documents from their in-memory buffers license: BSD-3-Clause github: codedownio/lsp-export-server