#!/usr/bin/env stack > -- stack script --resolver lts-22.6 --package text --package process --package directory --package filepath Figlet renderer for Venusia =========================== A gopher applet served via Venusia's `[[files.script_extension]]` auto-routing in `routes.toml`. Each installed figlet font becomes its own type-7 search item — no `fontname|text` encoding, just click a font and type the text. Path-info dispatch (Venusia 0.8.0.0) keeps a single applet behind a virtual sub-tree of font-specific URLs. (This file is markdown-flavoured literate Haskell. Headings use setext underlines rather than ATX-style `#` because GHC's literate parser interprets a `#` at column 1 of a non-code line as the start of a pragma — setext sidesteps that.) URL design ---------- Below, `$SCRIPT` stands for whatever `routes.toml` mounts this file at — `/applets/figlet.lhs` on this server, but the script computes its own mount-point from `$selector` at runtime (see "Path-info derivation" below), so substitute your own selector freely. $SCRIPT → font picker (one type-7 search item per installed font) $SCRIPT/banner → "enter text to render" (rare; reached if a client submits an empty query to a font's prompt, or the selector is hit directly) $SCRIPT/banner + text → render `text` in `banner` (the normal flow) $SCRIPT + text → render `text` in figlet's default font (degenerate fallback for selectors without a font) Every render-page footer offers two ways forward: a type-7 "enter more text" search item (primary action), and a type-1 menu link back to the font picker. Search responses in gopher must be menus, not raw text — every output here is a complete gophermap. Running the doctests -------------------- Pure functions below carry haddock `>>>` examples that the [`doctest`][doctest] tool verifies. To run them locally, `cd` to the directory containing this file and run: doctest-lhs figlet.lhs The wrapper reads the file's `-- stack` directive and language pragmas, so doctest sees the same packages and extensions `run-cached-lhs` compiles against — no `-X` flags to remember. A passing run reports something like `Examples: 18 Tried: 18 Errors: 0 Failures: 0`. The doctest tool looks for `>>>` blocks inside haddock comments attached to function definitions, so the per-function docs below stay inline with the code rather than living up in the prose sections. [doctest]: https://hackage.haskell.org/package/doctest Module header and imports ------------------------- > {-# LANGUAGE OverloadedStrings #-} > module Main (main) where > > import Control.Exception (IOException, try) > import Data.List (nub, sort) > import qualified Data.Text as T > import qualified Data.Text.IO as TIO > import System.Directory (doesDirectoryExist, listDirectory) > import System.Environment (getArgs, lookupEnv) > import System.Exit (ExitCode (..)) > import System.FilePath (dropExtension, takeExtension) > import System.IO (BufferMode (..), hSetBuffering, stdout) > import System.Process (readProcessWithExitCode) Defaults -------- Host and port are overridable via `GOPHER_HOST` / `GOPHER_PORT` environment variables so the same script works on staging and production without editing. There is deliberately no hardcoded fallback for the gopher selector — the script can't determine its own mount point from disk (that's a `routes.toml` decision), so it requires the daemon (or, in manual shell testing, you) to pass it as argv[0]. `parseArgs []` aborts loudly rather than silently inventing a path that would only be right by coincidence. > defaultHost, defaultPort :: T.Text > defaultHost = "gopher.someodd.zip" > defaultPort = "70" Request parsing --------------- The framework hands the script three positional arguments, all straight from `routes.toml`'s substitution surface (Venusia 0.8.0.0+): - argv[0] = `$selector` — full gopher selector that resolved here, including any path-info suffix - argv[1] = `$search` — query after the tab; `""` when none - argv[2] = `$pathinfo` — selector portion AFTER this script's filename (leading slash if non-empty, `""` when the script was addressed directly) The script's self-link base is `$selector` with `$pathinfo` stripped off the end — a one-line subtraction at request time. That keeps navigation loops (back-to-listing, render-more-in-same-font) correct even when the script is mounted under an unusual `[[files]]` selector. > data Req = Req > { reqSel :: T.Text -- $selector > , reqQ :: T.Text -- $search > , reqP :: T.Text -- $pathinfo > } deriving Show Cons-pattern argv parsing ignores any extras gracefully, so a fifth argv slot in `routes.toml` won't break the script. Empty argv is a usage error — the script has no way to invent its own mount-point selector. > -- | Parse the framework's argv into a 'Req'. Any extras past > -- the third position are ignored. > -- > -- >>> parseArgs ["/cgi/figlet.lhs/banner", "hello", "/banner"] > -- Req {reqSel = "/cgi/figlet.lhs/banner", reqQ = "hello", reqP = "/banner"} > -- > -- >>> parseArgs ["/anywhere/figlet.lhs", "", ""] > -- Req {reqSel = "/anywhere/figlet.lhs", reqQ = "", reqP = ""} > -- > -- >>> parseArgs ["/cgi/figlet.lhs", "hello"] > -- Req {reqSel = "/cgi/figlet.lhs", reqQ = "hello", reqP = ""} > -- > -- >>> parseArgs ["/cgi/figlet.lhs", "hello", "/banner", "ignored-extra"] > -- Req {reqSel = "/cgi/figlet.lhs", reqQ = "hello", reqP = "/banner"} > parseArgs :: [String] -> Req > parseArgs (s:q:p:_) = Req (T.pack s) (T.pack q) (T.pack p) > parseArgs (s:q:_) = Req (T.pack s) (T.pack q) T.empty > parseArgs [s] = Req (T.pack s) T.empty T.empty > parseArgs [] = error > "figlet.lhs: missing argv[0] (gopher selector). \ > \When run by Venusia this is automatic ($selector in routes.toml); \ > \for manual testing pass it explicitly, e.g. \ > \`runghc figlet.lhs /applets/figlet.lhs hello /banner`." Request context --------------- Bundling `(scriptSelector, host, port)` into a single record so the emit/render functions don't each take three plumbing args. > data Ctx = Ctx > { ctxScriptSel :: T.Text -- selector path to this script, no path-info > , ctxHost :: T.Text > , ctxPort :: T.Text > } Main dispatch ------------- Split the path-info into segments, drop empties (so trailing slashes don't matter), and route on `(segs, hasText)`: - `([], False)` — landing page; show the font picker - `([], True)` — text but no font; render in default font - `([font], False)` — font but no text; re-prompt for text - `([font], True)` — font and text; render - anything else — malformed path-info; error page > main :: IO () > main = do > hSetBuffering stdout NoBuffering > req <- parseArgs <$> getArgs > host <- maybe defaultHost T.pack <$> lookupEnv "GOPHER_HOST" > port <- maybe defaultPort T.pack <$> lookupEnv "GOPHER_PORT" > let pinfo = reqP req > scriptSel = T.dropEnd (T.length pinfo) (reqSel req) > ctx = Ctx scriptSel host port > segs = filter (not . T.null) . T.splitOn "/" $ pinfo > text = T.strip (reqQ req) > hasText = not (T.null text) > case (segs, hasText) of > ([], False) -> emitListing ctx > ([], True ) -> renderFiglet ctx Nothing text > ([font], False) -> emitRenderPrompt ctx font > ([font], True ) -> renderFiglet ctx (Just font) text > _ -> emitPathError ctx pinfo Gophermap line builders ----------------------- Every byte of output is built through these so we don't accidentally emit a malformed gophermap row. Each row ends with `\r\n` (gopher RFC requires CRLF) and each row's display field passes through `sanitize` so a stray byte from `figlet` — or, more dangerously, from a user query echoed back — can't smuggle a row break. > putLine :: T.Text -> IO () > putLine t = TIO.putStr (t <> "\r\n") > -- | An info-line gophermap row (item type @i@). Display only; > -- selector/host/port fields are blanked. > -- > -- >>> infoLine "hello" > -- "ihello\t\t\t0" > -- > -- >>> infoLine "with\ttab" > -- "iwith tab\t\t\t0" > infoLine :: T.Text -> T.Text > infoLine msg = "i" <> sanitize msg <> "\t\t\t0" > -- | A menu/directory link row (item type @1@). > -- > -- >>> menuLine "home" "/" "host" "70" > -- "1home\t/\thost\t70" > menuLine :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text > menuLine display selector host port = > "1" <> sanitize display <> "\t" <> selector <> "\t" <> host <> "\t" <> port > -- | A type-7 search prompt row — clients ask for text on click. > -- > -- >>> searchLine "search" "/q" "host" "70" > -- "7search\t/q\thost\t70" > searchLine :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text > searchLine display selector host port = > "7" <> sanitize display <> "\t" <> selector <> "\t" <> host <> "\t" <> port > -- | A type-3 error row. > -- > -- >>> errorItem "nope" > -- "3nope\t\t\t0" > errorItem :: T.Text -> T.Text > errorItem msg = "3" <> sanitize msg <> "\t\t\t0" > terminator :: T.Text > terminator = "." Sanitisation ------------ User-provided bytes (search queries, font names from URLs) land inside the display fields of menu rows. Without scrubbing control characters, a query like `"injection\tfake-selector"` would parse as two tab-separated fields on the wire and the client would render a fake menu item. This single function is the gate. > -- | Replace CR, LF, and TAB with spaces so user-provided text can't > -- smuggle gophermap row breaks. > -- > -- >>> sanitize "ok" > -- "ok" > -- > -- >>> sanitize "with\ttab" > -- "with tab" > -- > -- >>> sanitize "newline\nhere" > -- "newline here" > sanitize :: T.Text -> T.Text > sanitize = T.map (\c -> if c == '\r' || c == '\n' || c == '\t' then ' ' else c) Self-link helpers ----------------- `link` builds a path-info'd selector under this script's mount point. `homeMenu` is the "back to font list" row reused on every page that isn't the picker. > link :: Ctx -> T.Text -> T.Text > link c sub = ctxScriptSel c <> "/" <> sub > homeMenu :: Ctx -> T.Text > homeMenu c = menuLine "← back to font list" (ctxScriptSel c) (ctxHost c) (ctxPort c) Pages ----- Three landing pages exist besides the rendering path: - the font picker (`emitListing`) - a re-prompt page for when the user landed on a font's selector with no text yet (`emitRenderPrompt`) - a type-3 error page for malformed multi-segment path-info (`emitPathError`) Font picker ----------- Each installed font becomes its own type-7 search item, so the client prompts for text on click — no `fontname|text` encoding, no separate "render any font" item; pick a font, type the text, get the render. > emitListing :: Ctx -> IO () > emitListing ctx = do > fonts <- installedFonts > mapM_ putLine $ > [ infoLine "FIGlet — pick a font, then type your text" > , infoLine "" > ] ++ > [ searchLine f (link ctx f) (ctxHost ctx) (ctxPort ctx) | f <- fonts ] ++ > [ infoLine "" > , infoLine "(Each entry above is a search item; clicking it" > , infoLine "asks your client for text to render in that font.)" > , terminator > ] Render prompt ------------- Reached when the user lands on a font's selector with no query. Most clients suppress empty submissions but some send the bare selector through, and direct manual visits hit this path too. Re-offer the prompt rather than render nothing. > emitRenderPrompt :: Ctx -> T.Text -> IO () > emitRenderPrompt ctx font = mapM_ putLine > [ infoLine ("Render in '" <> font <> "' — please enter your text.") > , infoLine "" > , searchLine ("Enter text in '" <> font <> "'") > (link ctx font) (ctxHost ctx) (ctxPort ctx) > , homeMenu ctx > , terminator > ] Path-info error --------------- If path-info has more than a single segment, treat as malformed and route to a friendly error page rather than letting figlet guess at a non-existent font. > emitPathError :: Ctx -> T.Text -> IO () > emitPathError ctx pinfo = mapM_ putLine > [ errorItem ("Unrecognised path-info: " <> pinfo) > , homeMenu ctx > , terminator > ] Rendering --------- `renderFiglet` is the entry point used by the dispatch table. It guards three failure cases before letting `doRender` actually call `figlet`: - empty text → typed error page - font specified but not in `installedFonts` → typed error - no font (`Nothing`) → straight to render with default font Validating the font name up front gives a friendlier "Unknown font: 'xyz'" rather than figlet's bare "Couldn't find a font, sorry!". The error path uses the same type-3 + home-link template as the empty-text and process-exception paths via `failPage`. > renderFiglet :: Ctx -> Maybe T.Text -> T.Text -> IO () > renderFiglet ctx _ "" = failPage ctx "Empty text after stripping whitespace." > renderFiglet ctx Nothing txt = doRender ctx Nothing txt > renderFiglet ctx (Just f) txt = do > fonts <- installedFonts > if f `elem` fonts > then doRender ctx (Just f) txt > else failPage ctx ("Unknown font: '" <> sanitize f <> > "'. Pick one from the font list.") The actual figlet invocation and result-page assembly. Called only after the input has been validated. The footer offers "enter more text" as the primary action (more likely than going back to pick a different font) above the home link. > doRender :: Ctx -> Maybe T.Text -> T.Text -> IO () > doRender ctx mFont txt = do > let args = case mFont of > Just f -> ["-f", T.unpack f, T.unpack txt] > Nothing -> [T.unpack txt] > fontLabel = maybe "(default)" id mFont > r <- try $ readProcessWithExitCode "figlet" args "" > case r of > Left e -> failPage ctx ("figlet failed: " <> T.pack (show (e :: IOException))) > Right (ExitSuccess, out, _) -> mapM_ putLine $ > [ infoLine ("font: " <> fontLabel <> " text: " <> txt) > , infoLine "" > ] ++ map infoLine (T.lines (T.pack out)) ++ > [ infoLine "" > , reprompt > , homeMenu ctx > , terminator > ] > Right (_, _, err) -> failPage ctx ("figlet error: " <> T.strip (T.pack err)) > where > reprompt = case mFont of > Just f -> searchLine ("Enter more text in '" <> f <> "'") > (link ctx f) (ctxHost ctx) (ctxPort ctx) > Nothing -> searchLine "Enter more text (default font)" > (ctxScriptSel ctx) (ctxHost ctx) (ctxPort ctx) The top-level "this didn't work" page: a type-3 error row plus the home menu link. Used by the empty-text guard, the font validator, and the figlet failure paths. > failPage :: Ctx -> T.Text -> IO () > failPage ctx msg = mapM_ putLine > [ errorItem msg > , homeMenu ctx > , terminator > ] Font discovery -------------- Run `figlet -I2` to learn where figlet keeps its fonts on this system, then enumerate `.flf` and `.flf.gz` files there. On any failure (no figlet, can't open the directory) emit a single info-line explaining the problem; the listing page still renders. > installedFonts :: IO [T.Text] > installedFonts = do > r <- try $ readProcessWithExitCode "figlet" ["-I2"] "" > case r of > Left e -> pure ["(unable to query figlet: " <> T.pack (show (e :: IOException)) <> ")"] > Right (ExitSuccess, out, _) -> findFonts (T.unpack . T.strip $ T.pack out) > Right (_, _, err) -> pure ["(figlet -I2 failed: " <> T.pack err <> ")"] > findFonts :: FilePath -> IO [T.Text] > findFonts dir = do > ok <- doesDirectoryExist dir > if not ok > then pure [] > else do > entries <- listDirectory dir > pure . map T.pack . nub . sort $ [stripFontExt e | e <- entries, isFontFile e] `.flf` and `.flf.gz` are the two extensions figlet recognises. Both recognisers and the extension-stripper are top-level (rather than where-clause helpers of `findFonts`) so doctest can verify them independently. > -- | True for filenames figlet would treat as a font. > -- > -- >>> isFontFile "banner.flf" > -- True > -- > -- >>> isFontFile "big.flf.gz" > -- True > -- > -- >>> isFontFile "README" > -- False > -- > -- >>> isFontFile "fontmap.dat" > -- False > isFontFile :: FilePath -> Bool > isFontFile p = takeExtension p == ".flf" > || (takeExtension p == ".gz" > && takeExtension (dropExtension p) == ".flf") > -- | Strip the @.flf@ or @.flf.gz@ extension to recover the font name. > -- > -- >>> stripFontExt "banner.flf" > -- "banner" > -- > -- >>> stripFontExt "big.flf.gz" > -- "big" > stripFontExt :: FilePath -> FilePath > stripFontExt p > | takeExtension p == ".gz" = dropExtension (dropExtension p) > | otherwise = dropExtension p