#!/usr/bin/env stack > -- stack script --resolver lts-22.6 --package http-client --package http-client-tls --package bytestring --package text --package process --package case-insensitive --package base64-bytestring icecast.lhs: any Icecast/HTTP audio stream over gopher ====================================================== A gopher applet that relays HTTP/Icecast audio streams and offers a per-station menu page for each one. Submitting a URL via the type-7 box lands on the station's menu --- metadata, Listen / Watch links, a copy-pasteable curl for each, and a "Radio menu URI" permalink that survives bookmarking. (This file is markdown-flavoured literate Haskell. Headings use setext underlines rather than ATX-style `#` because GHC's literate parser interprets `#` at column 1 of a non-code line as the start of a pragma --- setext sidesteps that.) URL design ---------- `$SCRIPT` stands for whatever `routes.toml` mounts this file at; the script computes its own mount point from `$selector - $pathinfo`. Landing and query entry points: $SCRIPT landing menu $SCRIPT + type-7 query (URL) per-station menu for URL $SCRIPT/menu "paste a URL" prompt $SCRIPT/menu + type-7 query (URL) per-station menu for URL Default station (`$GOPHER_RADIO_URL`, falling back to `https://radio.someodd.zip/`): $SCRIPT/default audio passthrough $SCRIPT/default/audio audio passthrough (alias) $SCRIPT/default/with_visualization 144p MPEG-TS showcqt $SCRIPT/default/menu per-station menu Arbitrary URL station (base64url-encoded in path-info, no padding): $SCRIPT/url/ audio passthrough $SCRIPT/url//audio audio passthrough (alias) $SCRIPT/url//with_visualization 144p MPEG-TS showcqt $SCRIPT/url//menu per-station menu Anything else under path-info falls through to a type-3 error row. From the command line --------------------- Default-station audio (the elevator pitch): curl gopher://gopher.someodd.zip/9/applets/icecast/icecast.lhs/default | mpv - Default-station with visualization (showcqt, 144p MPEG-TS, ~38 kbps): curl gopher://gopher.someodd.zip/9/applets/icecast/icecast.lhs/default/with_visualization | mpv - Default-station menu (gophermap with metadata and curl recipes): curl gopher://gopher.someodd.zip/1/applets/icecast/icecast.lhs/default/menu Open a per-station menu for an arbitrary URL (selector + TAB + URL): printf '/applets/icecast/icecast.lhs/menu\thttp://ice1.somafm.com/groovesalad-128-mp3\r\n' \ | nc gopher.someodd.zip 70 That returns a menu whose Listen / Watch links carry the base64url-encoded URL in their selectors --- so you can bookmark the menu (the permalink is printed inside it) or copy a Listen curl straight to a player. Hard dependencies on $PATH: `ffmpeg` (with libx264 and libopus) is required only for the visualization endpoints. Audio passthrough and the menu pages are pure Haskell. Running the doctests -------------------- Pure functions below carry `>>>` examples that doctest verifies: stack exec --resolver lts-22.6 \ --package doctest --package text --package process \ --package http-client --package http-client-tls \ --package bytestring --package case-insensitive \ --package base64-bytestring \ -- doctest -XOverloadedStrings icecast.lhs `-XOverloadedStrings` is needed because doctest's GHCi session doesn't pick up the module's `LANGUAGE` pragmas. Module header and imports ------------------------- > {-# LANGUAGE OverloadedStrings #-} > module Main (main) where > > import qualified Data.ByteString as BS > import qualified Data.ByteString.Base64.URL as B64 > import qualified Data.ByteString.Lazy as L > import Control.Exception (SomeException, try) > import qualified Data.CaseInsensitive as CI > import qualified Data.Text as T > import qualified Data.Text.Encoding as TE > import qualified Data.Text.Encoding.Error as TEE > import qualified Data.Text.IO as TIO > import Network.HTTP.Client (brRead, brReadSome, parseRequest, > Request, requestHeaders, > responseBody, responseHeaders, > responseTimeout, > responseTimeoutMicro, > responseTimeoutNone, > withResponse) > import Network.HTTP.Client.TLS (newTlsManager) > import System.Environment (getArgs, lookupEnv) > import System.IO (BufferMode (..), hFlush, > hSetBuffering, hSetEncoding, > stdout, utf8) > import System.Process (CreateProcess (..), > StdStream (..), createProcess, > proc, waitForProcess) > import Text.Read (readMaybe) Defaults -------- Host/port/default-station overridable via environment, matching the contract of the other applets in this tree. > defaultHost, defaultPort, defaultStream :: T.Text > defaultHost = "gopher.someodd.zip" > defaultPort = "70" > defaultStream = "https://radio.someodd.zip/" Request parsing --------------- Three positional argv slots from Venusia's script-extension contract (after `run-cached-lhs` consumes `$file`): - argv[0] = `$selector` --- full selector that resolved here - argv[1] = `$search` --- query after the tab; `""` when none - argv[2] = `$pathinfo` --- selector portion AFTER the .lhs name The script's self-link base is `$selector` with `$pathinfo` stripped off the end --- a one-line subtraction at request time. > data Req = Req > { reqSel :: T.Text > , reqQ :: T.Text > , reqP :: T.Text > } deriving Show > > -- | Parse the framework's argv into a 'Req'. Extras past the third > -- position (e.g. `$remote_ip`) are ignored. Empty argv is an error. > -- > -- >>> parseArgs ["/applets/icecast/icecast.lhs/default", "", "/default"] > -- Req {reqSel = "/applets/icecast/icecast.lhs/default", reqQ = "", reqP = "/default"} > -- > -- >>> parseArgs ["/applets/icecast/icecast.lhs", "http://example.com/s", ""] > -- Req {reqSel = "/applets/icecast/icecast.lhs", reqQ = "http://example.com/s", reqP = ""} > -- > -- >>> parseArgs ["/applets/icecast/icecast.lhs", "q", "", "ignored"] > -- Req {reqSel = "/applets/icecast/icecast.lhs", reqQ = "q", reqP = ""} > 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 > "icecast.lhs: missing argv[0] (gopher selector). \ > \When run by Venusia this is automatic; for manual testing pass it \ > \explicitly, e.g. \ > \`runghc icecast.lhs /applets/icecast/icecast.lhs '' '/default/menu'`." > > data Ctx = Ctx > { ctxScriptSel :: T.Text > , ctxHost :: T.Text > , ctxPort :: T.Text > } Station references ------------------ A station is either the default (implicit upstream URL) or an arbitrary URL encoded as a base64url path segment. The encoding keeps selectors compact and free of slashes / colons that would otherwise collide with path-info parsing. > data StationRef > = StationDefault > | StationUrl T.Text -- ^ base64url-encoded upstream URL > > -- | Path-info that identifies the station under the script mount. > -- > -- >>> stationSel StationDefault > -- "/default" > -- > -- >>> stationSel (StationUrl "aHR0cDovL2V4YW1wbGUuY29tLw") > -- "/url/aHR0cDovL2V4YW1wbGUuY29tLw" > stationSel :: StationRef -> T.Text > stationSel StationDefault = "/default" > stationSel (StationUrl b64) = "/url/" <> b64 Main dispatch ------------- Path-info is split into segments (empties dropped, so trailing slashes don't matter); the dispatch routes on `(segs, hasQuery)`. Menu paths are wrapped in 'runMenu' so any exception becomes a visible type-3 row. Streaming paths run bare --- once binary bytes have hit stdout we can't switch back to gophermap mode, and a mid-stream broken pipe is the normal shutdown path anyway (the exception unwinds, http-client / ffmpeg cleans up, Venusia reaps). > main :: IO () > main = do > hSetBuffering stdout NoBuffering > hSetEncoding stdout utf8 > req <- parseArgs <$> getArgs > host <- maybe defaultHost T.pack <$> lookupEnv "GOPHER_HOST" > port <- maybe defaultPort T.pack <$> lookupEnv "GOPHER_PORT" > def <- maybe defaultStream T.pack <$> lookupEnv "GOPHER_RADIO_URL" > 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 > query = T.strip (reqQ req) > hasQuery = not (T.null query) > case (segs, hasQuery) of > -- landing > ([], False) -> runMenu (landingMenu ctx def) > ([], True ) -> runMenu (queryToMenu ctx query) > -- menu entry point for type-7 query submissions > (["menu"], False) -> runMenu (menuPrompt ctx) > (["menu"], True ) -> runMenu (queryToMenu ctx query) > -- default station > (["default"], _ ) -> streamAudio def > (["default", "audio"], _ ) -> streamAudio def > (["default", "with_visualization"], _ ) -> streamViz def > (["default", "menu"], _ ) -> runMenu (stationMenu ctx StationDefault def) > -- arbitrary URL station (b64url-encoded in path) > (["url", b64], _ ) -> withDecodedUrl ctx b64 streamAudio > (["url", b64, "audio"], _ ) -> withDecodedUrl ctx b64 streamAudio > (["url", b64, "with_visualization"], _ ) -> withDecodedUrl ctx b64 streamViz > (["url", b64, "menu"], _ ) -> withDecodedUrl ctx b64 > (\u -> runMenu (stationMenu ctx (StationUrl b64) u)) > _ -> runMenu (emitPathError ctx pinfo) > > -- | Validate a type-7 query as a URL and hand it off to > -- 'stationMenu'. On invalid URL emit a gophermap error. > queryToMenu :: Ctx -> T.Text -> IO () > queryToMenu ctx raw = case validateStreamUrl raw of > Right u -> stationMenu ctx (StationUrl (encodeStationUrl u)) u > Left e -> emitUrlError ctx e > > -- | Decode a base64url path segment to an upstream URL and pass > -- it to a continuation. Errors emit a gophermap menu --- never > -- safe to mix with binary output if anything has been written > -- yet, but at the moment of decode nothing has. > withDecodedUrl :: Ctx -> T.Text -> (T.Text -> IO ()) -> IO () > withDecodedUrl ctx b64 k = case decodeStationUrl b64 >>= validateStreamUrl of > Right u -> k u > Left e -> runMenu (emitUrlError ctx e) > > -- | Run a menu-producing action with crash safety. Any uncaught > -- exception becomes a type-3 row + terminator instead of a blank > -- response. Only safe for actions that produce gophermap text --- > -- never wrap a binary stream this way, or the type-3 row will > -- corrupt audio/video bytes already on the wire. > runMenu :: IO () -> IO () > runMenu action = do > result <- try action :: IO (Either SomeException ()) > case result of > Right () -> pure () > Left e -> mapM_ putLine > [ errorItem ("icecast.lhs crashed: " <> T.pack (show e)) > , terminator > ] URL validation -------------- Anything that goes near the visualization endpoint is also handed to ffmpeg as an argv element. ffmpeg supports many input protocols (`file:`, `concat:`, `subfile:`, etc.), so we restrict to http/https by parsing via @http-client@'s 'parseRequest', whose Maybe instance returns 'Nothing' for anything outside http/https. We never build shell strings, so the check is policy, not safety. > -- | Validate a stream URL: accept http:// or https:// only (via > -- http-client's parser), trim whitespace, cap length at 2 KiB. > -- Returns the trimmed URL on success or a human-readable error. > -- > -- >>> validateStreamUrl "https://example.com/stream" > -- Right "https://example.com/stream" > -- > -- >>> validateStreamUrl " http://ice1.somafm.com/groovesalad-128-mp3 " > -- Right "http://ice1.somafm.com/groovesalad-128-mp3" > -- > -- >>> validateStreamUrl "ftp://nope/" > -- Left "not a valid http/https URL: ftp://nope/" > -- > -- >>> validateStreamUrl "" > -- Left "not a valid http/https URL: " > validateStreamUrl :: T.Text -> Either T.Text T.Text > validateStreamUrl raw > | T.length trimmed > 2048 = Left "URL too long (>2 KiB)" > | otherwise = case parseRequest (T.unpack trimmed) :: Maybe Request of > Just _ -> Right trimmed > Nothing -> Left ("not a valid http/https URL: " <> trimmed) > where > trimmed = T.strip raw Base64url station URL encoding ------------------------------ We encode upstream URLs into single path segments so that selectors like `/url/aHR0cDovL2V4YW1wbGUuY29tLw/menu` parse cleanly. URL-safe base64 alphabet (`A-Z a-z 0-9 - _`) avoids `/`, `+`, and `=` which would conflict with selector splitting or with gopher URL escaping. Padding `=` is stripped on encode and re-added on decode --- shorter selectors, same bytes. > -- | Base64url-encode an upstream URL (no padding). > -- > -- >>> encodeStationUrl "" > -- "" > -- > -- >>> decodeStationUrl (encodeStationUrl "https://example.com/stream") > -- Right "https://example.com/stream" > -- > -- >>> decodeStationUrl (encodeStationUrl "http://ice1.somafm.com/groovesalad-128-mp3") > -- Right "http://ice1.somafm.com/groovesalad-128-mp3" > encodeStationUrl :: T.Text -> T.Text > encodeStationUrl = T.dropWhileEnd (== '=') . TE.decodeUtf8 . B64.encode . TE.encodeUtf8 > > -- | Decode a base64url path segment back to a URL. Re-pads if > -- needed before handing off to 'B64.decode'. > -- > -- >>> decodeStationUrl "" > -- Right "" > -- > -- >>> case decodeStationUrl "!" of { Left _ -> True; Right _ -> False } > -- True > decodeStationUrl :: T.Text -> Either T.Text T.Text > decodeStationUrl raw = > let pad = T.replicate ((4 - T.length raw `mod` 4) `mod` 4) "=" > bytes = TE.encodeUtf8 (raw <> pad) > in case B64.decode bytes of > Right b -> Right (decodeUtf8Lenient b) > Left err -> Left ("base64url decode failed: " <> T.pack err) > > decodeUtf8Lenient :: BS.ByteString -> T.Text > decodeUtf8Lenient = TE.decodeUtf8With TEE.lenientDecode Audio path (passthrough) ------------------------ The original icecast.lhs's pump, lifted and parameterised by URL. Important details: - 'Icy-MetaData: 0' --- Icecast must not interleave metadata into the audio (would corrupt MP3 for non-icy-aware players). - 'responseTimeoutNone' --- http-client's default ~30 s timeout would kill the unbounded stream. - 'withResponse' --- bracket-style; on stdout broken-pipe (gopher client disconnects) the exception unwinds and the upstream TLS connection closes. Venusia's child-process bracket then reaps this script. > streamAudio :: T.Text -> IO () > streamAudio url = do > mgr <- newTlsManager > req0 <- parseRequest (T.unpack url) > let req = req0 > { requestHeaders = ("Icy-MetaData", "0") : requestHeaders req0 > , responseTimeout = responseTimeoutNone > } > withResponse req mgr $ \res -> pump (responseBody res) > > -- | Read chunks from the upstream body and write them to stdout > -- until either upstream closes (empty chunk) or stdout breaks > -- (gopher client disconnects --- exception propagates out, > -- 'withResponse' cleans up). > pump :: IO BS.ByteString -> IO () > pump body = go > where > go = do > chunk <- brRead body > if BS.null chunk > then pure () > else BS.hPut stdout chunk >> go Visualization path ------------------ ffmpeg renders the audio into a 144p showcqt MPEG-TS at roughly the same bandwidth envelope as yt.lhs's video pipeline (~38 kbps total). We spawn it with 'createProcess' + 'proc' (the URL is an argv element, never touches a shell) and inherit stdout straight to Venusia's pipe to the socket. Lifecycle: client disconnect → SIGPIPE → ffmpeg exits → 'waitForProcess' returns → script exits → Venusia reaps. > streamViz :: T.Text -> IO () > streamViz url = do > hFlush stdout > (_, _, _, ph) <- createProcess > (proc "ffmpeg" (vizArgs url)) { std_out = Inherit } > _ <- waitForProcess ph > pure () > > -- | ffmpeg argv for the showcqt visualization pipeline. 144p at > -- 15 fps, ~32 kbps H.264 + ~6 kbps Opus, muxed MPEG-TS. > -- > -- >>> take 6 (vizArgs "http://example.com/stream") > -- ["-loglevel","error","-i","http://example.com/stream","-filter_complex","[0:a]showcqt=s=256x144:r=15:fps=15,format=yuv420p[v]"] > -- > -- >>> last (vizArgs "http://example.com/stream") > -- "pipe:1" > vizArgs :: T.Text -> [String] > vizArgs url = > [ "-loglevel", "error" > , "-i", T.unpack url > , "-filter_complex", "[0:a]showcqt=s=256x144:r=15:fps=15,format=yuv420p[v]" > , "-map", "[v]" > , "-map", "0:a" > , "-c:v", "libx264" > , "-preset", "veryfast" > , "-tune", "zerolatency" > , "-b:v", "32k" > , "-maxrate", "40k" > , "-bufsize", "80k" > , "-g", "30" > , "-c:a", "libopus" > , "-b:a", "6k" > , "-ac", "1" > , "-ar", "12000" > , "-application", "voip" > , "-f", "mpegts" > , "pipe:1" > ] Station metadata ---------------- The per-station menu fetches a brief one-shot connection to the upstream to read its `ice-*` / `icy-*` response headers plus the first inline `StreamTitle` block (when the server is Icecast and honours `Icy-MetaData: 1`). Everything is wrapped in a 4-second timeout and a top-level @try@ --- a slow or offline upstream degrades the menu to "no metadata available", never to a hang. > data StationMeta = StationMeta > { metaContentType :: Maybe T.Text > , metaName :: Maybe T.Text > , metaGenre :: Maybe T.Text > , metaDescription :: Maybe T.Text > , metaBitrate :: Maybe T.Text > , metaNowPlaying :: Maybe T.Text > } > > emptyMeta :: StationMeta > emptyMeta = StationMeta Nothing Nothing Nothing Nothing Nothing Nothing > > fetchStationMeta :: T.Text -> IO StationMeta > fetchStationMeta url = do > result <- try go :: IO (Either SomeException StationMeta) > pure (either (const emptyMeta) id result) > where > go = do > mgr <- newTlsManager > req0 <- parseRequest (T.unpack url) > let req = req0 > { requestHeaders = ("Icy-MetaData", "1") : requestHeaders req0 > , responseTimeout = responseTimeoutMicro 4000000 > } > withResponse req mgr $ \res -> do > let hdrs = responseHeaders res > look n = T.strip . decodeUtf8Lenient <$> lookup (CI.mk n) hdrs > intervalMb = look "icy-metaint" >>= readMaybeT > np <- maybe (pure Nothing) > (readFirstStreamTitle (responseBody res)) > intervalMb > pure StationMeta > { metaContentType = look "Content-Type" > , metaName = firstJust (look "icy-name") (look "ice-name") > , metaGenre = firstJust (look "icy-genre") (look "ice-genre") > , metaDescription = firstJust (look "icy-description") (look "ice-description") > , metaBitrate = firstJust (look "icy-br") (look "ice-bitrate") > , metaNowPlaying = np > } > > readMaybeT :: T.Text -> Maybe Int > readMaybeT = readMaybe . T.unpack > > firstJust :: Maybe a -> Maybe a -> Maybe a > firstJust (Just x) _ = Just x > firstJust Nothing y = y > > -- | Read enough body bytes to cover one full metadata frame > -- (`iv` audio bytes, 1 length byte, up to 4080 metadata bytes) > -- and pull `StreamTitle` out of it. Uses 'brReadSome' so over-read > -- bytes from the underlying chunked transfer are kept rather than > -- discarded; calling brRead repeatedly with the naive > -- "accumulate and truncate" pattern silently drops the length > -- byte and metadata when a chunk straddles offset @iv@. > -- > -- Any exception or short body returns @Nothing@; the menu page > -- does not depend on this. > readFirstStreamTitle :: IO BS.ByteString -> Int -> IO (Maybe T.Text) > readFirstStreamTitle body iv = do > let maxMeta = 255 * 16 > needed = iv + 1 + maxMeta > result <- try (brReadSome body needed) :: IO (Either SomeException L.ByteString) > case result of > Left _ -> pure Nothing > Right lbs -> > let bs = L.toStrict lbs > in if BS.length bs <= iv > then pure Nothing > else > let metaLen = fromIntegral (BS.index bs iv) * (16 :: Int) > in if metaLen == 0 || BS.length bs < iv + 1 + metaLen > then pure Nothing > else pure $ parseStreamTitle $ decodeUtf8Lenient $ > BS.take metaLen (BS.drop (iv + 1) bs) > > -- | Pull the value of @StreamTitle@ out of a Shoutcast-style > -- inline metadata block. The block is ASCII text shaped like > -- @StreamTitle='Foo - Bar';StreamUrl='...';@, NUL-padded to a > -- multiple of 16 bytes. > -- > -- >>> parseStreamTitle "StreamTitle='Artist - Song';StreamUrl='';" > -- Just "Artist - Song" > -- > -- >>> parseStreamTitle "StreamTitle='Just title';" > -- Just "Just title" > -- > -- >>> parseStreamTitle "no metadata here" > -- Nothing > -- > -- >>> parseStreamTitle "" > -- Nothing > -- > -- >>> parseStreamTitle "StreamTitle='with\ttab';" > -- Just "with tab" > parseStreamTitle :: T.Text -> Maybe T.Text > parseStreamTitle s = > let key = "StreamTitle='" > (_, after) = T.breakOn key s > in if T.null after > then Nothing > else let body = T.drop (T.length key) after > (title, end) = T.breakOn "';" body > in if T.null end > then Nothing > else Just (sanitize (T.strip title)) Per-station menu ---------------- Renders a gophermap for one station: a header info-line block with upstream URL, station name / genre / etc., and (when available) the current StreamTitle; then Listen and Watch links each followed by an exact curl recipe; then the "Radio menu URI" permalink so the page is bookmarkable; then a back-link to the landing. > stationMenu :: Ctx -> StationRef -> T.Text -> IO () > stationMenu ctx ref url = do > meta <- fetchStationMeta url > let base = stationSel ref > audioPath = base <> "/audio" > vizPath = base <> "/with_visualization" > menuPath = base <> "/menu" > audioUrl = gopherUrl ctx '9' audioPath > vizUrl = gopherUrl ctx '9' vizPath > menuUri = gopherUrl ctx '1' menuPath > headerLine = case metaName meta of > Just n -> "Station: " <> n > Nothing -> "Station menu" > mapM_ putLine $ > [ infoLine headerLine > , infoLine "" > ] ++ map infoLine (metaLines meta url) ++ > [ infoLine "" > , selfLink ctx '9' "Listen (audio passthrough)" audioPath > , infoLine (" curl " <> audioUrl <> " | mpv -") > , infoLine "" > , selfLink ctx '9' "Watch (showcqt visualization)" vizPath > , infoLine (" curl " <> vizUrl <> " | mpv -") > , infoLine "" > , selfLink ctx '1' ("Radio menu URI: " <> menuUri) menuPath > , infoLine "" > , backLink ctx > , terminator > ] > > -- | Build the info-line block for whatever metadata is available. > -- Always emits an @Upstream:@ row so a station with no other > -- metadata still shows something useful. > metaLines :: StationMeta -> T.Text -> [T.Text] > metaLines m url = concat > [ ["Upstream: " <> url] > , maybe [] (\v -> ["Now playing: " <> v]) (metaNowPlaying m) > , maybe [] (\v -> ["Name: " <> v]) (metaName m) > , maybe [] (\v -> ["Genre: " <> v]) (metaGenre m) > , maybe [] (\v -> ["Description: " <> v]) (metaDescription m) > , maybe [] (\v -> ["Bitrate: " <> v <> " kbps"]) (metaBitrate m) > , maybe [] (\v -> ["Type: " <> v]) (metaContentType m) > ] Gophermap helpers ----------------- Every gophermap row ends with `\r\n` and passes its display field through 'sanitize' so a stray byte (user-typed URL echoed back, metadata with surprising content) can't smuggle a row break. > putLine :: T.Text -> IO () > putLine t = TIO.putStr (t <> "\r\n") > > -- | Info-line row (item type @i@). > -- > -- >>> 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" > > -- | Type-3 error row. > -- > -- >>> errorItem "nope" > -- "3nope\t\t\t0" > errorItem :: T.Text -> T.Text > errorItem msg = "3" <> sanitize msg <> "\t\t\t0" > > -- | A typed menu row. > -- > -- >>> menuRow '1' "home" "/" "host" "70" > -- "1home\t/\thost\t70" > menuRow :: Char -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text > menuRow t display selector host port = > T.singleton t <> sanitize display <> "\t" <> selector > <> "\t" <> host <> "\t" <> port > > terminator :: T.Text > terminator = "." Sanitisation ------------ User-/upstream-supplied bytes (search queries, station names echoed into rows, StreamTitle text) land inside display fields. Without scrubbing tabs / newlines, a value containing `"\tfake-selector\thost\t70"` would parse as extra fields on the wire and smuggle a fake row. > -- | Replace CR, LF, TAB with single spaces. > -- > -- >>> 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 ----------------- 'selfLink' builds a path-info'd selector under this script's mount point. 'backLink' is the "back to landing" row reused on error pages and at the foot of the per-station menu. 'gopherUrl' renders a full @gopher://...@ URL for curl recipes printed inside menus. > selfLink :: Ctx -> Char -> T.Text -> T.Text -> T.Text > selfLink ctx t display sub = > menuRow t display (ctxScriptSel ctx <> sub) (ctxHost ctx) (ctxPort ctx) > > backLink :: Ctx -> T.Text > backLink ctx = selfLink ctx '1' "back to landing" "" > > -- | Build a full @gopher://...@ URL pointing at this script with > -- the given gopher item-type byte and a sub-path appended to the > -- script's selector. Used to print sample @curl@ commands. > -- > -- >>> gopherUrl (Ctx "/applets/icecast/icecast.lhs" "host" "70") '9' "/default" > -- "gopher://host/9/applets/icecast/icecast.lhs/default" > -- > -- >>> gopherUrl (Ctx "/applets/icecast/icecast.lhs" "host" "7070") '9' "/default" > -- "gopher://host:7070/9/applets/icecast/icecast.lhs/default" > gopherUrl :: Ctx -> Char -> T.Text -> T.Text > gopherUrl ctx t sub = > let portPart = if ctxPort ctx == "70" then "" else ":" <> ctxPort ctx > in "gopher://" <> ctxHost ctx <> portPart > <> "/" <> T.singleton t <> ctxScriptSel ctx <> sub Landing menus ------------- The main landing is intentionally sparse: one type-1 row linking to the default station's menu (the label carries the upstream URL so visitors see at a glance what the default points at) plus one type-7 box that opens the menu for any other URL. Listen / Watch and the curl recipes live inside the per-station menu --- no landing-level duplication. 'menuPrompt' is a smaller variant served when someone hits `