#!/usr/bin/env stack > -- stack script --resolver lts-22.6 --package sqlite-simple --package text --package bytestring --package base64-bytestring --package process --package time --package SHA diggings: prospect gopherspace ============================== A gopher applet with three layers sharing one SQLite file: * a *proxy* that fetches any remote gopher menu or page, rewrites its links so clicks re-enter diggings, and wraps it in an overlay; * a *textboard* --- every gopher selector, anywhere, is a thread you can read and leave verified posts on, 4chan-tripcode style; * a *game* --- surf to a selector you have never visited and you strike gold; be the first player *ever* to reach it and you strike a bonus and your name is recorded as its discoverer. Only selectors that actually resolve count --- a failed or empty fetch earns nothing. Posting pays too, on a scale that favours breaking a silence over adding to a crowd (see *Rewards* below). It is the spiritual successor to the old `grpg`: same soul (surf gopherspace, discover, get rewarded, leave a mark), none of the battle/stats/death machinery, the four legacy argument dialects, or the hand-rolled mkdir locks --- SQLite in WAL mode does the concurrency now. (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.) Rewards ------- Gold is struck two ways, walking and talking: +1 surf a selector you have never reached `awardVisit` +100 ...and be the FIRST digger ever to reach it `discoveryBonus` +50 open a thread --- the first post on a selector `openThreadBonus` +10 leave the first reply on a thread `firstReplyBonus` +1 every reply after that `replyBonus` The posting tiers are a *total*, not a bonus stacked on a base: the digger who opens a thread banks 50 and nothing further. The tier comes from the post's ordinal on its thread --- 1st, 2nd, or later --- counted by `addPost` from the row it just wrote, never from a count taken beforehand, so two diggers racing to open the same thread get one opener and one first-replier rather than two 50s (the same single-statement, `changes()`-decides discipline the discovery bonus uses). A post that is dropped as a duplicate is not a post: it pays nothing. Why this shape: an unanswered thread is a note in a bottle, and the scarce, valuable act is speaking where nobody has spoken yet or answering someone nobody has answered. Once a thread is alive, a reply is worth exactly what new ground is worth --- +1, keep going, it simply stops being an event. The rules live in one list, `goldRules`, built from the constants that pay them, so every page that explains gold is quoting the code rather than paraphrasing it. Two rules sit on the posting tiers. Ground first: undiscovered ground takes no posts at all. Storing one would be worse than refusing it --- the post would take ordinal 1 and spend `openThreadBonus` with nobody paid it, so one line on a silent selector would destroy that rung for everybody, permanently. Surf it once (the walk pays you) and the thread opens. And conversation: `firstReplyBonus` is for answering *somebody*, so a thread's opener replying to themselves drops to `replyBonus`. The page says which tier it paid and never announces one it withheld. What that first rule does **not** buy is a farming guarantee, and it is worth being exact about why. A `thread` row proves somebody reached a selector, not that anybody looked at one: `surf` fetches nothing for non-renderable types and takes the link's word, a trade it makes deliberately and documents. So a fabricated `gopher://nowhere/I/x` can still be surfed into existence and then posted on. That was already the cheaper farm before any of this --- the unverified surf itself pays +1 and `discoveryBonus` --- so the posting tiers add nothing to the ceiling. The hot board is the thing that needed a harder guarantee, and it gets one; see below. What's hot ---------- The front doors and `/hot` answer one question --- *is anybody out there?* --- and answer it with the only evidence in this database that proves a human turned up on purpose: a comment. A visit is a click, and a click is cheap, half-automatable, and produced in bulk by walking a menu; a post had to be read up to, thought about, typed into a search box, and be something nobody had already said on that thread. So `hotSelectors` ranks by *distinct commenters* and nothing else, ties falling to whichever thread was spoken on most recently. That makes for a short board, and often a board of one. This is on purpose. A padded board is a worse board: one row reading "2 diggers talked here --- 2 days ago" is better proof that gopherspace is still inhabited than ten rows of somebody's afternoon crawl, and an empty board is an opening rather than a failure --- `hotEmpty` says so. The `scaleLine` above it carries the other half of the claim (how much ground is staked, how much of it lately, by how many), and that is the one place the discovery count still earns its keep: as evidence the map is filling in, never as a ranking. The board deliberately ranks *selectors*, which the README's own "no quality signal" paragraph would seem to forbid. The line that paragraph draws is against **taste** --- votes, likes, scores on somebody's writing --- and this crosses none of it. It reports attendance: who turned up, nobody's opinion of what they found. Two properties keep it honest. A digger can only ever be counted once per thread per window, so a place cannot compound --- the board provably turns over instead of crowning a permanent favourite. And the join in `hotSelectors` admits only ground that was actually *fetched*, which is a stronger test than the posting rule uses and deliberately so: this is the first screen a stranger sees, so it is the one surface where an unverified location must not be able to buy its way in. `busiestGround` is the same question asked of the present tense, in one line on the leaderboard. It reads `presence` rather than `visit` (a `visit` row is only a digger's *first* arrival, so it goes blind to everyone coming back) and it publishes a count and a hole, never a name --- `whoIsHere` shows you who is about only when you are standing in the same place, and a global board is not the place to loosen that. There is no archive of past windows, and none is needed to keep the option: `visit`, `post` and `thread` are append-only --- the only deletes in this file are on `session` and `presence` --- so any past month can be recomputed exactly, whenever somebody wants a scrapbook. URL design ---------- `$SCRIPT` stands for whatever `routes.toml` mounts this file at; the script computes its own mount point from `$selector - $pathinfo`, so substitute your own selector freely. `` is a base64url-encoded gopher location (`host\nport\nselector`); `` is a 32-hex-digit session bearer token. $SCRIPT front door (stake-a-name prompt) $SCRIPT/login + name#secret mint a session, return its link $SCRIPT/hot what's hot --- last 30 days $SCRIPT/inbox what a call is, and how to get one $SCRIPT/diggers gold leaderboard $SCRIPT/go + host/sel surf a typed hole anonymously $SCRIPT/go/ surf anonymously (no gold) $SCRIPT/thread/ a selector's thread page (anon) $SCRIPT/s/ your session menu $SCRIPT/s/ + host/sel surf box: jump to a typed hole $SCRIPT/s//hot what's hot, keeps your session $SCRIPT/s//inbox your inbox: who has called your name $SCRIPT/s//diggers leaderboard, keeps your session $SCRIPT/s//logout kill this session link $SCRIPT/s//logout-all kill ALL session links for this name!trip $SCRIPT/s//go/ surf as you (awards gold) $SCRIPT/s//thread/ thread page with a post box $SCRIPT/s//post/ + m leave post `m` on 's thread Anything else under path-info falls through to a type-3 error row. From the command line --------------------- Stake a name (the `#` splits display-name from tripcode secret; the secret is never stored, only its hash): printf '/applets/diggings/diggings.lhs/login\tsomeodd#hunter2\r\n' \ | nc gopher.someodd.zip 70 That returns a one-row menu linking to your session selector (`/s/`) --- bookmark it, it is your login. Surf anonymously without staking a name at all: printf '/applets/diggings/diggings.lhs/go\tgopher.floodgap.com\r\n' \ | nc gopher.someodd.zip 70 Anonymous surfing renders the proxy + overlay but earns no gold and cannot post; everything social needs a staked name. Storage and concurrency ----------------------- Every gopher request spawns a fresh, short-lived `diggings` process, so the durable state cannot live in process memory --- it lives in one SQLite file, `.diggings.db`, opened in WAL mode with a five-second `busy_timeout`. WAL lets the many concurrent reader processes run without blocking the occasional writer, and `busy_timeout` plus the atomicity of a *single write statement* is the entire concurrency story: no lock files, no mkdir dance. Two processes racing to be a selector's first discoverer both run `INSERT OR IGNORE INTO thread`; exactly one sees `changes() > 0` and gets the bonus. `addPost` wants that same shape for a rule a unique index could almost express --- one copy of any given body per thread --- but a handful of legacy rows already violate it and `openDb` replays `schema` on every request, so the test rides inside the insert as a `WHERE NOT EXISTS` instead: still one statement, still one winner, still `changes()` to say who won. The DB path is **load-bearing and environment-sensitive**. Venusia sets a script's working directory to the directory the script lives in, so the default `.diggings.db` lands beside this file --- but that directory must be *writable by the user the Venusia daemon runs as* (`venusia` on the reference host). The deployment makes the `applets/diggings/` directory group-`venusia`, group-writable, and setgid so the daemon can create `.diggings.db` (and its `-wal` / `-shm` siblings) there. Override with `DIGGINGS_DB` if you would rather keep state elsewhere. The server-side tripcode salt is resolved at startup by `loadSalt`, in order of precedence: the `DIGGINGS_SALT` environment variable (handy for a one-off staging override), then a `.salt` file beside the script (`DIGGINGS_SALT_FILE` to relocate it), then the in-source `fallbackSalt`. Keeping the real salt in `.salt` --- gitignored --- lets this source be published without leaking it; without any salt, trips are still stable on this host but trivially precomputable, so a `.salt` belongs on every production deployment. Changing the salt re-hashes every tripcode, so existing identities only survive if the salt does. Running the doctests -------------------- Pure helpers below carry `>>>` examples that doctest verifies: stack exec --resolver lts-22.6 \ --package doctest \ --package sqlite-simple --package text --package bytestring \ --package base64-bytestring --package process --package time --package SHA \ -- doctest -XOverloadedStrings diggings.lhs `-XOverloadedStrings` is needed because doctest's GHCi session does not pick up the module's `LANGUAGE` pragma. Module header and imports ------------------------- > {-# LANGUAGE OverloadedStrings #-} > module Main (main) where > > import Control.Exception (SomeException, try) > import Control.Monad (forM_, unless, when) > import qualified Data.ByteString as BS > import qualified Data.ByteString.Base64.URL as B64 > import qualified Data.ByteString.Lazy as BSL > import Data.Char (isAlphaNum, isControl, isDigit, isHexDigit) > import Data.Digest.Pure.SHA (sha256, showDigest) > import Data.List (nub) > import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, > listToMaybe) > import qualified Data.Text as T > import qualified Data.Text.Encoding as TE > import qualified Data.Text.IO as TIO > import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) > import Data.Time.Format (defaultTimeLocale, formatTime) > import Database.SQLite.Simple > import System.Environment (getArgs, lookupEnv) > import System.IO (BufferMode (..), IOMode (..), hClose, > hFlush, hSetBuffering, hSetEncoding, > openBinaryFile, stdout, utf8) > import System.Process (readProcess) Configuration ------------- Host/port are overridable via `GOPHER_HOST` / `GOPHER_PORT` so the same script runs on staging and production unedited. The numeric knobs are deliberately hardcoded --- an applet's tuning is part of its source, not its deployment. > defaultHost, defaultPort :: T.Text > defaultHost = "gopher.someodd.zip" > defaultPort = "70" > > defaultDb :: FilePath > defaultDb = ".diggings.db" -- hidden, beside the script; override: DIGGINGS_DB > > defaultSaltFile :: FilePath > defaultSaltFile = ".salt" -- hidden, beside the script; override: DIGGINGS_SALT_FILE > > fallbackSalt :: T.Text > fallbackSalt = "CHANGEME" -- last resort if no env var and no .salt; set a real .salt in production (see loadSalt) > > discoveryBonus :: Int > discoveryBonus = 100 -- extra gold for a first-ever discovery > > -- Posting pays on a sliding scale, by a post's ordinal on its > -- thread: opening a silent selector is the scarce act, answering > -- one that has never been answered is the next scarcest, and every > -- reply after that is worth the same +1 a new selector is. See > -- 'postReward'. > openThreadBonus, firstReplyBonus, replyBonus :: Int > openThreadBonus = 50 -- 1st post on a thread: you opened it > firstReplyBonus = 10 -- 2nd post: the first reply to it > replyBonus = 1 -- every reply after that > > presenceTTL :: Int > presenceTTL = 300 -- seconds a heartbeat counts as "here" > > postsOnThread :: Int > postsOnThread = 25 -- posts shown on a thread page > > postsOnOverlay :: Int > postsOnOverlay = 3 -- posts shown in the surf overlay > > postsOnHot :: Int > postsOnHot = 10 -- latest posts shown on the hot board > > strikesOnHot :: Int > strikesOnHot = 10 -- recent first-ever strikes shown on the hot board > > topGoldOnLeaderboard :: Int > topGoldOnLeaderboard = 15 -- ranks printed on the gold leaderboard > > -- Mentions. Writing @name!trip in a post puts a row in that > -- digger's inbox; both numbers are ceilings on work, not on > -- speech. 'mentionsPerPost' is applied before any database lookup, > -- so a body stuffed with a hundred @-signs costs eight SELECTs and > -- not a hundred; the post itself is never truncated or refused for > -- carrying more. > mentionsPerPost :: Int > mentionsPerPost = 8 -- most diggers one post can call > > inboxRows :: Int > inboxRows = 30 -- mentions shown on the inbox page > > -- The hot board. Thirty days is the window because it is true on > -- every day of the year: a named calendar month would read "nothing > -- yet" for the first week of every month, and this server has gone > -- two whole months without an event. See 'hotSelectors'. > hotWindow :: Int > hotWindow = 30 * 86400 -- seconds counted as "lately" > > busyWindow :: Int > busyWindow = 7 * 86400 -- seconds counted as "right now" > > hotOnBoard, hotOnFrontDoor :: Int > hotOnBoard = 10 -- selectors in the ranked section of the hot board > hotOnFrontDoor = 3 -- and on a front door, which stays tight > > nameMax, secretMax, bodyMax :: Int > nameMax = 24 > secretMax = 128 > bodyMax = 2000 > > -- How many hex digits of the salted hash a tripcode keeps. Read by > -- 'tripcode', which writes them, and by 'parseMentions', which > -- reads them back out of a post --- one number, so a call cannot > -- go looking for a trip of a length nobody has. > tripLen :: Int > tripLen = 10 Request parsing --------------- Venusia passes positional argv: `$selector`, `$search`, `$pathinfo`, and (if the routes block forwards it) `$remote_ip`. The cons-pattern `parseArgs` degrades gracefully for manual testing and aborts loudly on empty argv --- the script cannot invent its own mount point. > data Req = Req > { reqSel :: T.Text -- ^ full selector that resolved here > , reqQ :: T.Text -- ^ search text after the tab, or empty > , reqP :: T.Text -- ^ selector portion after this script's filename > , reqIP :: T.Text -- ^ connecting client's IP, or empty > } deriving (Eq, Show) > > -- | Parse framework argv into a 'Req'; extras past the fourth slot > -- are ignored, empty argv is a usage error. > -- > -- >>> parseArgs ["/a/diggings.lhs/s/abc", "", "/s/abc", "10.0.0.1"] > -- Req {reqSel = "/a/diggings.lhs/s/abc", reqQ = "", reqP = "/s/abc", reqIP = "10.0.0.1"} > -- > -- >>> parseArgs ["/a/diggings.lhs", "someodd#pw", ""] > -- Req {reqSel = "/a/diggings.lhs", reqQ = "someodd#pw", reqP = "", reqIP = ""} > parseArgs :: [String] -> Req > parseArgs (s:q:p:ip:_) = Req (T.pack s) (T.pack q) (T.pack p) (T.pack ip) > parseArgs (s:q:p:_) = Req (T.pack s) (T.pack q) (T.pack p) T.empty > parseArgs (s:q:_) = Req (T.pack s) (T.pack q) T.empty T.empty > parseArgs [s] = Req (T.pack s) T.empty T.empty T.empty > parseArgs [] = error > "diggings.lhs: missing argv[0] (gopher selector). When run by Venusia \ > \this is automatic ($selector in routes.toml); for manual testing pass \ > \selector + search + path-info explicitly, e.g. \ > \`./diggings.lhs /diggings.lhs '' ''`." > > -- | Everything the handlers need: where we are mounted, who we tell > -- clients we are, the open DB handle, and the tripcode salt. > data Ctx = Ctx > { ctxSel :: T.Text > , ctxHost :: T.Text > , ctxPort :: T.Text > , ctxConn :: Connection > , ctxSalt :: T.Text > } Locations --------- A 'Loc' is a gopher location: host, port, selector, and the gopher item-type digit ('1' menu, '0' text, etc.) supplied by whatever pointed at it (the first byte of a gophermap row, or the @//@ prefix in a @gopher://@ URL). It is the key the textboard and the game are organised around. In a URL it travels base64url-encoded (the four fields joined by newline, which none of them can contain) so it survives intact as a single path-info segment. Legacy three-field tokens minted before the type was preserved still decode --- they default to type @'1'@. > data Loc = Loc > { locHost :: T.Text > , locPort :: T.Text > , locSel :: T.Text > , locType :: Char > } deriving (Eq, Show) > > -- | Encode a 'Loc' as one base64url path segment. > -- > -- >>> encodeLoc (Loc "example.org" "70" "/x" '1') > -- "ZXhhbXBsZS5vcmcKNzAKL3gKMQ" > encodeLoc :: Loc -> T.Text > encodeLoc (Loc h p s t) = > TE.decodeUtf8 . B64.encodeUnpadded . TE.encodeUtf8 $ > T.intercalate "\n" [h, p, s, T.singleton t] > > -- | Inverse of 'encodeLoc'; 'Nothing' on malformed input. Accepts > -- both the current four-field shape and the legacy three-field > -- shape minted before the item-type was preserved --- legacy tokens > -- decode with type @'1'@ (menu) so old bookmarks keep working. > -- > -- >>> decodeLoc "ZXhhbXBsZS5vcmcKNzAKL3gKMQ" > -- Just (Loc {locHost = "example.org", locPort = "70", locSel = "/x", locType = '1'}) > -- > -- >>> decodeLoc "ZXhhbXBsZS5vcmcKNzAKL3g" > -- Just (Loc {locHost = "example.org", locPort = "70", locSel = "/x", locType = '1'}) > -- > -- >>> decodeLoc "not valid base64!" > -- Nothing > decodeLoc :: T.Text -> Maybe Loc > decodeLoc t = case B64.decodeUnpadded (TE.encodeUtf8 t) of > Left _ -> Nothing > Right bs -> case T.splitOn "\n" (TE.decodeUtf8 bs) of > [h, p, s] -> Just (Loc h p (canonicalSel s) '1') > [h, p, s, typ] -> Just (Loc h p (canonicalSel s) (firstCharOr '1' typ)) > _ -> Nothing > > -- | First character of a 'Text', or a default if it is empty. > firstCharOr :: Char -> T.Text -> Char > firstCharOr d = maybe d fst . T.uncons > > -- | Split a typed selector of the form @//@ (or @/@) > -- into its item-type byte and the remaining selector. Accepts any > -- character as a type byte per RFC 4266 (digits, @T g I h s M d c > -- U p@, etc.); the caller decides which contexts trust which > -- characters. Defaults to @('1', input)@ when no @//...@ shape > -- is present. > -- > -- 'parseLoc' is the trust gate: when the user pastes a full > -- @gopher://@ URL, any type byte captured here is honoured; when > -- they type a bare @host/sel@, only digits are honoured (to avoid > -- mis-stripping real selectors like @/h/foo@ or @/p/bar@). > -- > -- >>> splitGopherType "/0/file.txt" > -- ('0',"/file.txt") > -- > -- >>> splitGopherType "/1" > -- ('1',"/") > -- > -- >>> splitGopherType "/9/binary" > -- ('9',"/binary") > -- > -- >>> splitGopherType "/I/cat.png" > -- ('I',"/cat.png") > -- > -- >>> splitGopherType "/caps" > -- ('1',"/caps") > -- > -- >>> splitGopherType "/home/user" > -- ('1',"/home/user") > -- > -- >>> splitGopherType "" > -- ('1',"") > splitGopherType :: T.Text -> (Char, T.Text) > splitGopherType s = case T.uncons s of > Just ('/', rest) -> case T.uncons rest of > Just (c, more) > | T.null more -> (c, "/") > | "/" `T.isPrefixOf` more -> (c, more) > _ -> ('1', s) > _ -> ('1', s) > > -- | Parse a user-typed location. Forms accepted: > -- > -- * @host@, @host:port@ --- type defaults to @'1'@ > -- * @host/selector@ --- type defaults to @'1'@ > -- * @host//selector@ --- type captured (digit only) > -- * @gopher://host[:port]/selector@ --- type captured (any byte) > -- > -- The bare-input form only honours @0-9@ as type bytes, because > -- real gopher selectors can start with @/h/foo@, @/p/bar@ etc. and > -- we don't want to mis-strip those. For non-digit types (images, > -- HTML, sounds) paste the full @gopher://@ URL --- the prefix is > -- the trust signal that says "the next byte really is a type". > -- > -- >>> parseLoc "gopher://example.org:7070/0/file.txt" > -- Right (Loc {locHost = "example.org", locPort = "7070", locSel = "/file.txt", locType = '0'}) > -- > -- >>> parseLoc "gopher://example.org/I/cat.png" > -- Right (Loc {locHost = "example.org", locPort = "70", locSel = "/cat.png", locType = 'I'}) > -- > -- >>> parseLoc "example.org/0/file.txt" > -- Right (Loc {locHost = "example.org", locPort = "70", locSel = "/file.txt", locType = '0'}) > -- > -- >>> parseLoc "example.org/I/cat.png" > -- Right (Loc {locHost = "example.org", locPort = "70", locSel = "/I/cat.png", locType = '1'}) > -- > -- >>> parseLoc "example.org/h/foo" > -- Right (Loc {locHost = "example.org", locPort = "70", locSel = "/h/foo", locType = '1'}) > -- > -- >>> parseLoc "example.org" > -- Right (Loc {locHost = "example.org", locPort = "70", locSel = "", locType = '1'}) > -- > -- >>> parseLoc "host/" > -- Right (Loc {locHost = "host", locPort = "70", locSel = "", locType = '1'}) > -- > -- >>> parseLoc " " > -- Left "missing host" > parseLoc :: T.Text -> Either T.Text Loc > parseLoc raw = > let u = T.strip raw > isUrl = "gopher://" `T.isPrefixOf` u > u1 = fromMaybe u (T.stripPrefix "gopher://" u) > (hostPort, sel0) = T.break (== '/') u1 > (typ, selRaw) = let (c, rest) = splitGopherType sel0 > in if isUrl || isDigit c then (c, rest) else ('1', sel0) > sel = canonicalSel . sanitizeSel $ selRaw > (h0, p0) = T.break (== ':') hostPort > host = sanitizeHost h0 > port = case T.uncons p0 of > Just (':', rest) -> sanitizePort rest > _ -> "70" > in if T.null host then Left "missing host" else Right (Loc host port sel typ) > > -- | A 'Loc' rendered as a human-facing @gopher://@ URI (port 70 > -- elided) per RFC 4266 --- the @//@ between host and selector is > -- the gopher item-type byte. > -- > -- >>> gopherUri (Loc "example.org" "70" "/x" '1') > -- "gopher://example.org/1/x" > -- > -- >>> gopherUri (Loc "example.org" "7070" "/file.txt" '0') > -- "gopher://example.org:7070/0/file.txt" > gopherUri :: Loc -> T.Text > gopherUri (Loc h p s t) = > "gopher://" <> h <> (if p == "70" then "" else ":" <> p) > <> "/" <> T.singleton t <> s Sanitisers ---------- Hosts, ports, names, tokens and selectors all become either filesystem-free DB keys or bytes on a gopher wire, so each is filtered to a known-safe alphabet. This is the only defence-in-depth claim the file makes: read it before extending any schema. `sanitize` (further down) is the separate, mandatory scrub for display fields. > -- | Lowercase; keep @[a-z0-9.-]@; cap length. > -- > -- >>> sanitizeHost "Example.ORG" > -- "example.org" > sanitizeHost :: T.Text -> T.Text > sanitizeHost = T.take 255 . T.toLower . T.filter ok > where ok c = isAlphaNum c || c == '.' || c == '-' > > -- | Digits only; default @70@; cap to five digits. > -- > -- >>> sanitizePort "70abc" > -- "70" > -- > -- >>> sanitizePort "xx" > -- "70" > sanitizePort :: T.Text -> T.Text > sanitizePort t = let d = T.take 5 (T.filter isDigit t) > in if T.null d then "70" else d > > -- | Keep @[A-Za-z0-9_-]@; cap at 'nameMax'. Mixed case is preserved > -- (it is part of the identity). > -- > -- >>> sanitizeName "someodd the Digger!" > -- "someoddtheDigger" > sanitizeName :: T.Text -> T.Text > sanitizeName = T.take nameMax . T.filter nameChar > > -- | The identity alphabet: what 'sanitizeName' keeps when a name is > -- staked, and what 'parseMentions' reads back when somebody calls > -- that name in a post. One definition rather than two matching > -- predicates, because the writer and the reader of a name drifting > -- apart would quietly make some diggers uncallable --- and it would > -- be the diggers with the unusual names, who are the least likely to > -- be told about it. > -- > -- >>> map nameChar "aZ9_-" > -- [True,True,True,True,True] > -- > -- >>> map nameChar "@! ." > -- [False,False,False,False] > nameChar :: Char -> Bool > nameChar c = isAlphaNum c || c == '_' || c == '-' > > -- | Strip control bytes from a selector --- it ends up both a DB > -- key and bytes in a menu row's selector field, where a stray TAB > -- or newline would corrupt the wire. > -- > -- >>> sanitizeSel "/caps\tfake\trow" > -- "/capsfakerow" > sanitizeSel :: T.Text -> T.Text > sanitizeSel = T.filter (not . isControl) > > -- | Canonical form for a 'Loc' selector. The gopher root is the > -- empty string (RFC 1436); @"/"@ is just a courtesy synonym that > -- some servers accept and strict ones (geomyidae-family, e.g. > -- verisimilitudes.net) reject. We pick the spec form and flatten > -- @"/"@ to @""@ at every 'Loc' construction point, so storage, > -- wire, and display all share one form --- no conversion needed > -- at any wire-output site, and the same place keyed two ways > -- (typed @host@ vs proxy-rewritten empty-selector row) collapses > -- to one DB row. > -- > -- >>> canonicalSel "" > -- "" > -- > -- >>> canonicalSel "/" > -- "" > -- > -- >>> canonicalSel "/phlog" > -- "/phlog" > canonicalSel :: T.Text -> T.Text > canonicalSel "/" = "" > canonicalSel s = s > > -- | Last path segment of a selector --- the "filename" --- used to > -- label exit rows informatively ("open @2026_05_andrew.jpg@" beats > -- "open this content"). Empty for the root or for selectors that > -- are just slashes; callers fall back to a generic label. > -- > -- >>> selBasename "/letters/2026/2026_05_andrew.jpg" > -- "2026_05_andrew.jpg" > -- > -- >>> selBasename "/foo/bar/" > -- "bar" > -- > -- >>> selBasename "/" > -- "" > -- > -- >>> selBasename "" > -- "" > -- > -- >>> selBasename "noslash" > -- "noslash" > selBasename :: T.Text -> T.Text > selBasename = T.takeWhileEnd (/= '/') . T.dropWhileEnd (== '/') > > -- | Label for "exit and open at origin" menu rows: filename if we > -- can extract one from the selector, else the generic phrase. > -- > -- >>> exitOpenLabel "/letters/2026/2026_05_andrew.jpg" > -- "open 2026_05_andrew.jpg on its own server" > -- > -- >>> exitOpenLabel "" > -- "open this content on its own server" > exitOpenLabel :: T.Text -> T.Text > exitOpenLabel sel = "open " <> what <> " on its own server" > where what = case selBasename sel of > "" -> "this content" > fn -> fn > > -- | The selector one level up, or 'Nothing' at a host's root --- > -- there is nothing above it. Trailing slashes are trimmed first, so > -- @\/foo\/bar\/@ and @\/foo\/bar@ climb to the same place, and the > -- result is canonical (the root is @""@, never @"\/"@). A selector > -- with no slash at all is treated as sitting directly under the > -- root, which is where such a thing would in fact live. > -- > -- >>> parentSel "/users/alberti/phlog" > -- Just "/users/alberti" > -- > -- >>> parentSel "/foo/bar/" > -- Just "/foo" > -- > -- >>> parentSel "/users" > -- Just "" > -- > -- >>> parentSel "noslash" > -- Just "" > -- > -- >>> parentSel "/" > -- Nothing > -- > -- >>> parentSel "" > -- Nothing > parentSel :: T.Text -> Maybe T.Text > parentSel s > | T.null trimmed = Nothing > | otherwise = Just (T.dropWhileEnd (== '/') (T.dropWhileEnd (/= '/') trimmed)) > where trimmed = T.dropWhileEnd (== '/') s > > -- | 'parentSel' lifted to a 'Loc'. The parent of anything is a > -- directory, so the item type is '1' regardless of what we came > -- from: climbing out of a text file lands you in a menu. > parentLoc :: Loc -> Maybe Loc > parentLoc (Loc h p s _) = (\up -> Loc h p up '1') <$> parentSel s > > -- | A session token is exactly 32 lowercase hex digits. > -- > -- >>> validToken "0123456789abcdef0123456789abcdef" > -- True > -- > -- >>> validToken "tooshort" > -- False > validToken :: T.Text -> Bool > validToken t = T.length t == 32 && T.all isHexDigit t Identity and tripcodes ---------------------- A tripcode is the classic stateless identity: @name#secret@ yields @name!trip@ where @trip@ is a salted hash of the secret. Same secret always yields the same trip; nobody without the secret can forge it. The secret is never stored --- only its hash. The session layer is a convenience on top: 'mintSession' stores a random 'token' mapped to @(name, trip)@ and hands back a `/s/` URL. That URL is a bearer credential --- anyone holding it acts as you, exactly the trust model the old `mksession` random-id selectors already shipped. Lose it and you simply re-stake the same @name#secret@: same durable @name!trip@, fresh disposable token. > -- | The salted-hash half of a tripcode (10 hex digits). > -- > -- >>> tripcode "salt" "hunter2" > -- "63f81cc5ca" > tripcode :: T.Text -> T.Text -> T.Text > tripcode salt secret = > T.take tripLen . T.pack . showDigest . sha256 > . BSL.fromStrict . TE.encodeUtf8 $ salt <> "\NUL" <> secret > > -- | Render a verified identity as @name!trip@. > -- > -- >>> ident "someodd" "8e6c9c8d2d" > -- "someodd!8e6c9c8d2d" > ident :: T.Text -> T.Text -> T.Text > ident name trip = name <> "!" <> trip > > -- | Every @\@name!trip@ called in a post body, in the order they > -- were written, each one once. The reader for what 'ident' writes: > -- it reads back exactly what 'ident' prints with an @\@@ in front, > -- and nothing looser. > -- > -- A bare @\@name@ is deliberately not a call. A name is not an > -- identity here --- `player` is keyed on the pair, so two secrets > -- can stake the same name --- which makes a bare name not a digger > -- but a set, and delivering to the set would hand anybody who > -- squats a popular name every word meant for anyone else. The trip > -- is the half that says which digger you mean, and it is printed > -- beside every post they have ever left, so calling somebody is > -- copying, never remembering. > -- > -- A name run longer than 'nameMax', or a trip run that is not > -- exactly ten lowercase hex digits, is refused whole rather than > -- trimmed to fit. Trimming would quietly redirect a word meant for > -- one digger into another digger's inbox --- the one failure here > -- that neither of them could see. > -- > -- >>> parseMentions "howdy @sue!63f81cc5ca, look at this" > -- [("sue","63f81cc5ca")] > -- > -- >>> parseMentions "@sue!63f81cc5ca and @bo!0123456789 both" > -- [("sue","63f81cc5ca"),("bo","0123456789")] > -- > -- >>> parseMentions "@sue!63f81cc5ca said it, @sue!63f81cc5ca said it again" > -- [("sue","63f81cc5ca")] > -- > -- Inside a word is not a call, which is what keeps a mail address > -- from calling somebody by accident; doubling the @\@@ is how you > -- write a name out without calling it. > -- > -- >>> map parseMentions ["mail@sue!63f81cc5ca", "quoting @@sue!63f81cc5ca"] > -- [[],[]] > -- > -- >>> map parseMentions ["@sue", "@sue!63f81cc5", "@sue!63f81cc5cab", "@sue!63F81CC5CA"] > -- [[],[],[],[]] > parseMentions :: T.Text -> [(T.Text, T.Text)] > parseMentions = nub . catMaybes . scanCalls > > -- | Was a name written with an @ in front of it and no trip after > -- it? Such a name calls nobody, and 'handlePost' says so --- a > -- silent nothing is the one outcome that would make the feature > -- look broken to somebody who had almost used it right, and diggers > -- were already writing bare names in posts before any of this > -- existed. > -- > -- >>> map bareCall ["I bet @someodd would enjoy this", "@sue!63f81cc5ca would"] > -- [True,False] > -- > -- >>> map bareCall ["nothing here", "mail@sue", "@@sue"] > -- [False,False,False] > bareCall :: T.Text -> Bool > bareCall = any isNothing . scanCalls > > -- | The scanner both of those read: every @-name in the body, in > -- order, as @Just (name, trip)@ when it is a whole identity and > -- 'Nothing' when it is a name that stops short of one. Kept as one > -- pass rather than two, so the reader that delivers calls and the > -- reader that complains about them cannot come to disagree about > -- what a call is. > -- > -- >>> scanCalls "@sue!63f81cc5ca and @bo, and mail@nobody" > -- [Just ("sue","63f81cc5ca"),Nothing] > scanCalls :: T.Text -> [Maybe (T.Text, T.Text)] > scanCalls = go ' ' > where > go prev t = case T.uncons t of > Nothing -> [] > Just ('@', rest) > | not (nameChar prev), prev /= '@' > , let (n, r) = T.span nameChar rest > , not (T.null n) > -> case whole n r of > Just tr -> Just (n, tr) : go (T.last tr) (T.drop (T.length tr + 1) r) > Nothing -> Nothing : go (T.last n) r > Just (c, rest) -> go c rest > -- The name run and the trip run are both maximal, so whatever > -- follows the trip is not an identity character and the right > -- boundary needs no rule of its own: a full stop, a bracket, a > -- newline or the end of the post all close a call cleanly. > whole n r = case T.uncons r of > Just ('!', r') | T.length n <= nameMax > , let tr = T.takeWhile nameChar r' > , T.length tr == tripLen, T.all tripChar tr -> Just tr > _ -> Nothing > > -- | The trip alphabet. Lowercase only: 'tripcode' is a > -- 'showDigest', which emits lowercase, and no surface in this file > -- ever displays a trip any other way --- so an uppercase run is not > -- a trip somebody typed carelessly, it is a trip nobody has. > -- > -- >>> map tripChar "0af" > -- [True,True,True] > -- > -- >>> map tripChar "gAF!" > -- [False,False,False,False] > tripChar :: Char -> Bool > tripChar c = isDigit c || (c >= 'a' && c <= 'f') > > -- | Split a staked @name#secret@; the secret may itself contain @#@. > -- > -- >>> splitStake "someodd#hunter2" > -- Just ("someodd","hunter2") > -- > -- >>> splitStake "nosecret" > -- Nothing > splitStake :: T.Text -> Maybe (T.Text, T.Text) > splitStake t = case T.breakOn "#" t of > (_, rest) | T.null rest -> Nothing > (n, rest) -> Just (n, T.drop 1 rest) > > -- | 16 random bytes from @/dev/urandom@, hex-encoded to a 32-char token. > genToken :: IO T.Text > genToken = do > h <- openBinaryFile "/dev/urandom" ReadMode > bs <- BS.hGet h 16 > hClose h > pure (hexEncode bs) > > -- | Lowercase-hex-encode a 'BS.ByteString'. > -- > -- >>> hexEncode (BS.pack [0, 15, 255]) > -- "000fff" > hexEncode :: BS.ByteString -> T.Text > hexEncode = T.pack . concatMap byte . BS.unpack > where > digits = "0123456789abcdef" > byte w = [ digits !! fromIntegral (w `div` 16) > , digits !! fromIntegral (w `mod` 16) ] The database ------------ One file, seven tables, WAL mode. `openDb` is idempotent: the `CREATE TABLE IF NOT EXISTS` statements make first-run and hundredth-run identical, and a tiny try-and-swallow @ALTER TABLE ... ADD COLUMN@ block upgrades pre-type-column databases in place --- SQLite has no @ADD COLUMN IF NOT EXISTS@, so the duplicate-column error on a fully-migrated DB is the no-op signal. > openDb :: FilePath -> IO Connection > openDb path = do > conn <- open path > -- journal_mode / busy_timeout return a row; consume it via query_. > _ <- query_ conn "PRAGMA journal_mode=WAL" :: IO [Only T.Text] > _ <- query_ conn "PRAGMA busy_timeout=5000" :: IO [Only Int] > execute_ conn "PRAGMA synchronous=NORMAL" > mapM_ (execute_ conn) schema > mapM_ (migrate conn) migrations > pure conn > where > migrate c q = do > r <- try (execute_ c q) :: IO (Either SomeException ()) > case r of > Right () -> pure () > Left e -> let msg = T.pack (show e) > isDup = "duplicate column" `T.isInfixOf` msg > in if isDup then pure () > else error ("migration crash: " ++ show q ++ " -> " ++ show e) > > schema :: [Query] > schema = > [ "CREATE TABLE IF NOT EXISTS player\ > \ (name TEXT, trip TEXT, gold INTEGER NOT NULL DEFAULT 0,\ > \ created INTEGER NOT NULL, PRIMARY KEY(name, trip))" > , "CREATE TABLE IF NOT EXISTS session\ > \ (token TEXT PRIMARY KEY, name TEXT NOT NULL, trip TEXT NOT NULL,\ > \ created INTEGER NOT NULL)" > , "CREATE TABLE IF NOT EXISTS thread\ > \ (host TEXT, port TEXT, sel TEXT, typ TEXT NOT NULL DEFAULT '1',\ > \ disc_name TEXT, disc_trip TEXT,\ > \ discovered INTEGER NOT NULL, PRIMARY KEY(host, port, sel))" > , "CREATE TABLE IF NOT EXISTS visit\ > \ (name TEXT, trip TEXT, host TEXT, port TEXT, sel TEXT,\ > \ typ TEXT NOT NULL DEFAULT '1',\ > \ first_seen INTEGER NOT NULL, PRIMARY KEY(name, trip, host, port, sel))" > , "CREATE TABLE IF NOT EXISTS post\ > \ (id INTEGER PRIMARY KEY AUTOINCREMENT, host TEXT, port TEXT, sel TEXT,\ > \ typ TEXT NOT NULL DEFAULT '1',\ > \ name TEXT, trip TEXT, body TEXT, posted INTEGER NOT NULL)" > , "CREATE TABLE IF NOT EXISTS presence\ > \ (token TEXT, host TEXT, port TEXT, sel TEXT,\ > \ typ TEXT NOT NULL DEFAULT '1',\ > \ last_seen INTEGER NOT NULL,\ > \ PRIMARY KEY(token, host, port, sel))" > , "CREATE TABLE IF NOT EXISTS mention\ > \ (name TEXT, trip TEXT, post_id INTEGER NOT NULL,\ > \ created INTEGER NOT NULL, PRIMARY KEY(name, trip, post_id))" > ] > > -- | Idempotent column additions for databases created before 'typ' > -- existed. Each statement either succeeds (column added) or fails > -- with "duplicate column", which 'openDb' swallows. > migrations :: [Query] > migrations = > [ "ALTER TABLE thread ADD COLUMN typ TEXT NOT NULL DEFAULT '1'" > , "ALTER TABLE visit ADD COLUMN typ TEXT NOT NULL DEFAULT '1'" > , "ALTER TABLE post ADD COLUMN typ TEXT NOT NULL DEFAULT '1'" > , "ALTER TABLE presence ADD COLUMN typ TEXT NOT NULL DEFAULT '1'" > , "ALTER TABLE player ADD COLUMN inbox_seen INTEGER NOT NULL DEFAULT 0" > -- inbox_seen is a `mention` rowid, not a `post` id: see 'inboxMentions'. > ] Identity / session queries. > ensurePlayer :: Connection -> T.Text -> T.Text -> Int -> IO () > ensurePlayer conn name trip now = > execute conn > "INSERT OR IGNORE INTO player (name, trip, gold, created) VALUES (?,?,0,?)" > (name, trip, now) > > mintSession :: Connection -> T.Text -> T.Text -> Int -> IO T.Text > mintSession conn name trip now = do > tok <- genToken > execute conn > "INSERT INTO session (token, name, trip, created) VALUES (?,?,?,?)" > (tok, name, trip, now) > pure tok > > lookupSession :: Connection -> T.Text -> IO (Maybe (T.Text, T.Text)) > lookupSession conn tok = listToMaybe <$> query conn > "SELECT name, trip FROM session WHERE token = ?" (Only tok) > > getGold :: Connection -> T.Text -> T.Text -> IO Int > getGold conn name trip = do > rs <- query conn "SELECT gold FROM player WHERE name=? AND trip=?" (name, trip) > pure (maybe 0 fromOnly (listToMaybe rs)) The game: visiting a 'Loc' awards gold. `awardVisit` is the whole loop. `INSERT OR IGNORE` into `visit` tells us, via `changes`, whether this is personally new ground (+1). `INSERT OR IGNORE` into `thread` tells us whether the player is its first-ever discoverer (+'discoveryBonus', name recorded). Both inserts are atomic, so a race resolves to exactly one winner with no application lock. > -- | Returns @(personallyNew, firstEverDiscovery)@. > awardVisit :: Connection -> T.Text -> T.Text -> Loc -> Int -> IO (Bool, Bool) > awardVisit conn name trip (Loc h p s t) now = do > execute conn > "INSERT OR IGNORE INTO visit (name, trip, host, port, sel, typ, first_seen)\ > \ VALUES (?,?,?,?,?,?,?)" (name, trip, h, p, s, T.singleton t, now) > personalNew <- (> 0) <$> changes conn > when personalNew $ > execute conn "UPDATE player SET gold = gold + 1 WHERE name=? AND trip=?" > (name, trip) > execute conn > "INSERT OR IGNORE INTO thread (host, port, sel, typ, disc_name, disc_trip, discovered)\ > \ VALUES (?,?,?,?,?,?,?)" (h, p, s, T.singleton t, name, trip, now) > firstDisc <- (> 0) <$> changes conn > when firstDisc $ > execute conn "UPDATE player SET gold = gold + ? WHERE name=? AND trip=?" > (discoveryBonus, name, trip) > pure (personalNew, firstDisc) > > threadInfo :: Connection -> Loc -> IO (Maybe (T.Text, T.Text, Int)) > threadInfo conn (Loc h p s _) = listToMaybe <$> query conn > "SELECT disc_name, disc_trip, discovered FROM thread\ > \ WHERE host=? AND port=? AND sel=?" (h, p, s) > > -- | How many diggers have ever reached a 'Loc' --- the same `visit` > -- rows 'awardVisit' writes, counted by place instead of by player. > -- No @DISTINCT@ is needed: @PRIMARY KEY(name, trip, host, port, sel)@ > -- already makes it one row per digger per selector. `typ` stays out > -- of the predicate, as in 'threadInfo' and 'postCount' --- the > -- item-type byte is a display attribute, not part of a place's > -- identity, so a hole reached as '0' and as '1' stays one place. > -- > -- The viewer is counted too: 'awardVisit' writes their row before > -- either page renders. That is deliberate --- the number is a > -- property of the place, the same for every reader, rather than a > -- relative-to-you count that no two diggers would ever agree on. > diggerCount :: Connection -> Loc -> IO Int > diggerCount conn (Loc h p s _) = do > rs <- query conn > "SELECT COUNT(*) FROM visit WHERE host=? AND port=? AND sel=?" (h, p, s) > pure (maybe 0 fromOnly (listToMaybe rs)) Presence: a heartbeat per @(token, loc)@, read back through a TTL filter and joined to `session` for the @name!trip@ display. > touchPresence :: Connection -> T.Text -> Loc -> Int -> IO () > touchPresence conn tok (Loc h p s t) now = execute conn > "INSERT OR REPLACE INTO presence (token, host, port, sel, typ, last_seen)\ > \ VALUES (?,?,?,?,?,?)" (tok, h, p, s, T.singleton t, now) > > whoIsHere :: Connection -> Maybe T.Text -> Loc -> Int -> IO [T.Text] > whoIsHere conn mtok (Loc h p s _) now = do > rs <- query conn > "SELECT DISTINCT se.name, se.trip FROM presence pr\ > \ JOIN session se ON pr.token = se.token\ > \ WHERE pr.host=? AND pr.port=? AND pr.sel=? AND pr.last_seen > ?\ > \ AND pr.token <> ?" > (h, p, s, now - presenceTTL, fromMaybe "" mtok) > pure [ ident n tr | (n, tr) <- rs ] > > -- | The location whose presence row this token touched most recently > -- --- i.e. where the player is. Powers the session menu's "resume". > lastLoc :: Connection -> T.Text -> IO (Maybe Loc) > lastLoc conn tok = do > rs <- query conn > "SELECT host, port, sel, typ FROM presence WHERE token=?\ > \ ORDER BY last_seen DESC LIMIT 1" (Only tok) > pure $ case rs of > ((h, p, s, typ) : _) -> Just (Loc h p s (firstCharOr '1' typ)) > _ -> Nothing The textboard: posts on a 'Loc'. A thread holds one copy of any given body, no matter who typed it. That covers the mechanical case --- a type-7 post box is an ordinary selector, so a refresh or a replayed history entry re-submits the whole post --- but it is the stricter rule on purpose: a thread of identical lines is nobody's idea of a conversation. `addPost` folds the "has this already been said here?" test into the insert rather than asking the reader not to refresh. > -- | Returns @Just (ordinal, post id)@ --- the post's place in its > -- thread, 1 for the post that opens it, and the rowid it was > -- written at --- if a row was actually written, and @Nothing@ if it > -- was not. A body byte-equal to one already on this > -- 'Loc' is dropped --- from *anyone*, however long ago. Deliberately > -- not scoped to the poster: the rule is one copy per thread, not one > -- copy per person, so it catches the client re-request and the > -- unoriginal reply with the same predicate. > -- > -- The test rides inside the insert, so the check and the write are > -- one statement and a race resolves the way 'awardVisit' does: > -- exactly one writer sees @changes() > 0@. Read `changes` here and > -- not in the caller --- the next write on this connection overwrites > -- the answer, and 'handlePost' does three (the gold update, a > -- presence touch, and any mention rows the post earns). > -- > -- The rowid is handed out for the same reason it is read here: the > -- mention rows 'recordMentions' writes point at this post, and > -- @last_insert_rowid()@ is a per-connection register that the first > -- of those writes would overwrite. Reading it here and passing it > -- out costs nothing --- it is already read, at the only moment it > -- is still true. > -- > -- The ordinal is counted the same way and for the same reason: from > -- the row we just wrote (@id <=@ its rowid), not from a @COUNT(*)@ > -- taken before the insert, which two racing first-posters would both > -- read as zero and both bank 'openThreadBonus' on. Counting by id up > -- to your own row hands each writer a distinct place in line, so the > -- thread has exactly one opener and exactly one first reply however > -- the writes interleave. It must be read here for the same reason > -- `changes` is --- the next write on this connection (a presence > -- touch, a gold update) moves @last_insert_rowid()@. > -- > -- Comparison is byte-exact. Bodies arrive 'T.strip'ped from > -- 'handlePost', so trailing whitespace cannot fork a duplicate, but > -- case and inner punctuation still can. @typ@ stays out of the > -- predicate, as in 'threadInfo' and 'diggerCount': the item-type > -- byte is a display attribute, not part of a place's identity. > addPost :: Connection -> Loc -> T.Text -> T.Text -> T.Text -> Int > -> IO (Maybe (Int, Int)) > addPost conn (Loc h p s t) name trip body now = do > execute conn > "INSERT INTO post (host, port, sel, typ, name, trip, body, posted)\ > \ SELECT ?,?,?,?,?,?,?,?\ > \ WHERE NOT EXISTS (SELECT 1 FROM post\ > \ WHERE host=? AND port=? AND sel=? AND body=?)" > ( (h, p, s, T.singleton t, name, trip, body, now) > :. (h, p, s, body) ) > wrote <- (> 0) <$> changes conn > if not wrote > then pure Nothing > else do > rid <- lastInsertRowId conn > rs <- query conn > "SELECT COUNT(*) FROM post\ > \ WHERE host=? AND port=? AND sel=? AND id <= ?" (h, p, s, rid) > pure (Just (maybe 1 fromOnly (listToMaybe rs), fromIntegral rid)) > > -- | Pay a player. The one place gold moves by an arbitrary amount; > -- 'awardVisit' predates it and still writes its own updates inline. > addGold :: Connection -> T.Text -> T.Text -> Int -> IO () > addGold conn name trip n = when (n /= 0) $ > execute conn "UPDATE player SET gold = gold + ? WHERE name=? AND trip=?" > (n, name, trip) > > -- | Recent posts, newest first. > recentPosts :: Connection -> Loc -> Int -> IO [(T.Text, T.Text, T.Text, Int)] > recentPosts conn (Loc h p s _) n = query conn > "SELECT name, trip, body, posted FROM post\ > \ WHERE host=? AND port=? AND sel=? ORDER BY id DESC LIMIT ?" > (h, p, s, n) > > postCount :: Connection -> Loc -> IO Int > postCount conn (Loc h p s _) = do > rs <- query conn > "SELECT COUNT(*) FROM post WHERE host=? AND port=? AND sel=?" (h, p, s) > pure (maybe 0 fromOnly (listToMaybe rs)) > -- | Who left the first post on a 'Loc', if anyone has. Used to stop > -- a thread's opener claiming 'firstReplyBonus' by answering > -- themselves: a note followed by another note from the same hand is > -- not a conversation, whatever the ordinals say. > threadOpener :: Connection -> Loc -> IO (Maybe (T.Text, T.Text)) > threadOpener conn (Loc h p s _) = listToMaybe <$> query conn > "SELECT name, trip FROM post WHERE host=? AND port=? AND sel=?\ > \ ORDER BY id LIMIT 1" (h, p, s) Mentions and the inbox ---------------------- Write `@name!trip` in a post and that digger finds the thread in their inbox. It is the one push channel in the file, so it is built as narrowly as it can be: a `mention` row is a pointer to a post and nothing else --- who was called, which post called them, when --- and the inbox renders a date, a place and a name, never a word the caller chose. What was actually said stays on the thread, behind a click, in the renderer that already handles it. Three rules do most of the work and all of them fall out of decisions the file had already made. A call pays no gold to anybody, because staking a name is free and unlimited, so any payout here would be a print-money button two identities could work forever --- and because gold is for walking new ground and for breaking silences, and a call is neither. A post that was dropped as a duplicate calls nobody, for the same reason it pays nobody: the post box is an ordinary gopher selector, so a refresh or a "back" would otherwise be a cannon anybody could hold down. And nobody is called twice by the same post, which is the `mention` table's primary key rather than a rule the parser has to remember. `mention` is append-only like `visit`, `post` and `thread`. What is read and what is new are kept apart from it entirely, in a single high-water mark on `player` --- the highest `mention` rowid that digger has looked at. One monotone `MAX()` write marks a whole page read, two windows open at once cannot lose each other's update, and the table stays a record of what happened rather than a record of who has got round to it. > -- | Record one call: this post, this digger. @INSERT OR IGNORE@ > -- against @PRIMARY KEY(name, trip, post_id)@, so "one post calls > -- one digger at most once" is the database's rule and not the > -- parser's --- a re-scan or a replay cannot manufacture a second > -- one. > addMention :: Connection -> T.Text -> T.Text -> Int -> Int -> IO () > addMention conn name trip pid now = execute conn > "INSERT OR IGNORE INTO mention (name, trip, post_id, created)\ > \ VALUES (?,?,?,?)" (name, trip, pid, now) > > -- | Is this exact @name!trip@ staked? The gate between a call that > -- is well-formed and a call that lands: 'parseMentions' decides > -- shape, this decides whether there is anybody there. Compared > -- byte-exact, like every other identity comparison here. > playerExists :: Connection -> T.Text -> T.Text -> IO Bool > playerExists conn name trip = do > rs <- query conn "SELECT 1 FROM player WHERE name=? AND trip=? LIMIT 1" > (name, trip) :: IO [Only Int] > pure (not (null rs)) > > -- | Record every call a stored post makes on a digger who exists. > -- Returns @(who was called, how many named nobody)@ --- the first so > -- the poster is told it landed, the second so a mistyped trip is > -- reported once instead of vanishing. > -- > -- Self-calls are dropped before the cap, not after, so calling > -- yourself cannot eat one of the eight slots; and the cap is > -- applied before any lookup, so a body stuffed with a hundred > -- @-signs costs eight SELECTs. Dropping the self-call is not a > -- rule about spam --- there is nothing to tell you that you do not > -- already know, since you are the one writing it. > recordMentions :: Connection -> Int -> T.Text -> T.Text -> T.Text -> Int > -> IO ([T.Text], Int) > recordMentions conn pid name trip body now = do > let called = take mentionsPerPost > . filter (/= (name, trip)) > $ parseMentions body > found <- mapM land called > pure ([ who | Just who <- found ], length [ () | Nothing <- found ]) > where > land (n, tr) = do > there <- playerExists conn n tr > if not there then pure Nothing else do > addMention conn n tr pid now > pure (Just (ident n tr)) > > -- | A digger's inbox, newest first. Returns @(mention rowid, host, > -- port, sel, typ, caller name, caller trip, posted)@ --- everything > -- a row prints, plus the rowid the read mark is measured in. > -- > -- Ordered and marked by the mention's own rowid rather than by the > -- post's id, which is the difference between arrival order and > -- authorship order. They almost always agree; when they do not, it > -- is because two posts were written at once and the older of them > -- got its call recorded second, and ordering by the post would then > -- file that call *below* a mark already set above it --- delivered, > -- and never once shown as new. A mark in arrival order cannot do > -- that, because nothing can arrive beneath it. > -- > -- Rowids are handed out in insertion order and no two share one, so > -- this needs no tie-break; the join cannot dangle, because `post` > -- is append-only. > inboxMentions :: Connection -> T.Text -> T.Text -> Int > -> IO [(Int, T.Text, T.Text, T.Text, T.Text, T.Text, T.Text, Int)] > inboxMentions conn name trip n = query conn > "SELECT m.rowid, p.host, p.port, p.sel, p.typ, p.name, p.trip, p.posted\ > \ FROM mention m JOIN post p ON p.id = m.post_id\ > \ WHERE m.name=? AND m.trip=? ORDER BY m.rowid DESC LIMIT ?" > (name, trip, n) > > mentionCount :: Connection -> T.Text -> T.Text -> IO Int > mentionCount conn name trip = do > rs <- query conn "SELECT COUNT(*) FROM mention WHERE name=? AND trip=?" > (name, trip) > pure (maybe 0 fromOnly (listToMaybe rs)) > > -- | The read mark: the highest mention rowid this digger has looked > -- at. > -- Zero for a player row written before the column existed, and zero > -- for one that somehow is not there --- both of which read as > -- "everything is new", which is the safe direction to be wrong in > -- for mail. > inboxSeen :: Connection -> T.Text -> T.Text -> IO Int > inboxSeen conn name trip = do > rs <- query conn "SELECT inbox_seen FROM player WHERE name=? AND trip=?" > (name, trip) > pure (maybe 0 fromOnly (listToMaybe rs)) > > -- | How many calls sit above the mark. Takes the mark rather than > -- re-reading it, so a page's count and a page's rows are provably > -- measured against the same water line. > unreadCount :: Connection -> T.Text -> T.Text -> Int -> IO Int > unreadCount conn name trip seen = do > rs <- query conn > "SELECT COUNT(*) FROM mention WHERE name=? AND trip=? AND rowid > ?" > (name, trip, seen) > pure (maybe 0 fromOnly (listToMaybe rs)) > > -- | Advance the read mark. @MAX()@ so it only ever goes up: a slow > -- render cannot rewind it and two open windows cannot fight over > -- it, which is what lets this be one statement with no transaction, > -- the same discipline 'awardVisit' and 'addPost' keep. > -- > -- The caller passes the greatest rowid it actually put on the wire > -- --- never @now@, and never a fresh @SELECT MAX@, either of which > -- would sweep past a call that landed while the page was being > -- built and mark it read unseen. Zero is a no-op, so glancing at an > -- empty inbox writes nothing at all. > markInboxSeen :: Connection -> T.Text -> T.Text -> Int -> IO () > markInboxSeen conn name trip pid = when (pid > 0) $ execute conn > "UPDATE player SET inbox_seen = MAX(inbox_seen, ?) WHERE name=? AND trip=?" > (pid, name, trip) The hot board. What is *hot* is where people have been talking, because a comment is the only thing in this database that proves a human was here on purpose: a visit is a click, and a click is cheap and half-automatable, but a post had to be read up to, thought about, typed into a search box, and be something nobody had already said on that thread. So the board counts *distinct commenters*, and nothing else --- ties fall to whichever thread was spoken on most recently, which needs no second table and never goes stale. The `thread` join is the reality gate, and it is load-bearing rather than decorative: a `thread` row exists only where 'awardVisit' wrote one after 'isRealPlace' passed, so a selector nobody has ever successfully surfed cannot reach the board. Without it, two staked names and two posts on a fabricated location would buy the top row of the front door for the price of four gopher requests. > -- | Selectors with at least one commenter inside the window, most > -- distinct commenters first, ties broken by the most recent post. > -- Returns @(host, port, sel, typ, commenters, latest)@. > -- > -- @p.typ@ is a bare column under a @MAX@ aggregate, which in SQLite > -- means "from the row that supplied the max" --- so a thread is > -- typed as whatever its newest post called it, matching the rest of > -- the file's treatment of the item-type byte as display-only. > -- > -- @t.typ@ is the exception to that rule, and the only place in this > -- file where the item-type byte is load-bearing rather than > -- decorative. A `thread` row proves somebody *reached* a selector, > -- but not that anybody *looked* at it: 'surf' fetches nothing for > -- non-renderable types and takes the link's word (see its haddock, > -- which accepts that trade for gold). So the row alone is not > -- evidence the place exists. A row typed @'0'@ or @'1'@ is, because > -- those are exactly the types 'surf' fetches and puts through > -- 'isRealPlace' before 'awardVisit' ever runs. The test is one-way > -- --- a place first reached as an image keeps that type and stays > -- off the board even once somebody surfs it as a menu --- and > -- one-way in the safe direction is what a front door wants. > hotSelectors :: Connection -> Int -> Int > -> IO [(T.Text, T.Text, T.Text, T.Text, Int, Int)] > hotSelectors conn since n = query conn > "SELECT p.host, p.port, p.sel, p.typ,\ > \ COUNT(DISTINCT p.name || '!' || p.trip) AS talkers,\ > \ MAX(p.posted) AS latest\ > \ FROM post p JOIN thread t\ > \ ON t.host = p.host AND t.port = p.port AND t.sel = p.sel\ > \ WHERE p.posted > ? AND t.typ IN ('0','1')\ > \ GROUP BY p.host, p.port, p.sel\ > \ ORDER BY talkers DESC, latest DESC LIMIT ?" (since, n) > > -- | @(claims staked ever, claims staked inside the window, diggers > -- who have actually been out there)@ --- the "gopherspace isn't > -- done" line, which is the one place the discovery count still earns > -- its keep: as evidence the map is still filling in, not as a > -- ranking. > -- > -- The third number counts distinct diggers in `visit`, not rows in > -- `player`. A `player` row is written the moment somebody stakes a > -- name and is never removed, so @COUNT(*) FROM player@ is a signup > -- tally --- it counts the curious, the abandoned and every test > -- login, and it can only ever go up. This line's whole job is to be > -- honest evidence, and it reads as though those diggers staked those > -- claims, so it counts the ones who went somewhere. > diggingsScale :: Connection -> Int -> IO (Int, Int, Int) > diggingsScale conn since = do > claims <- one "SELECT COUNT(*) FROM thread" () > lately <- one "SELECT COUNT(*) FROM thread WHERE discovered > ?" (Only since) > diggers <- one "SELECT COUNT(DISTINCT name || '!' || trip) FROM visit" () > pure (claims, lately, diggers) > where > one q ps = maybe 0 fromOnly . listToMaybe <$> query conn q ps > > -- | The hole the most diggers have actually stood in lately, for the > -- leaderboard's one-line pulse. Reads `presence` rather than `visit` > -- because this one is about who was *there*, returns included, and a > -- `visit` row is only ever a digger's first arrival. Counts only --- > -- names stay where 'whoIsHere' keeps them, visible to somebody > -- standing in the same place, not published to the whole board. > busiestGround :: Connection -> Int -> IO (Maybe (T.Text, Int, Int)) > busiestGround conn since = listToMaybe <$> query conn > "SELECT pr.host, COUNT(DISTINCT se.name || '!' || se.trip) AS diggers,\ > \ COUNT(DISTINCT pr.sel) AS claims\ > \ FROM presence pr JOIN session se ON pr.token = se.token\ > \ WHERE pr.last_seen > ?\ > \ GROUP BY pr.host ORDER BY diggers DESC, claims DESC LIMIT 1" > (Only since) Leaderboard and hot-board queries. Only 'topPlayers' still answers to the leaderboard; the other two moved with their sections. > topPlayers :: Connection -> Int -> IO [(T.Text, T.Text, Int)] > topPlayers conn n = query conn > "SELECT name, trip, gold FROM player ORDER BY gold DESC, created ASC LIMIT ?" > (Only n) > > recentDiscoveries :: Connection -> Int > -> IO [(T.Text, T.Text, T.Text, T.Text, T.Text, T.Text)] > recentDiscoveries conn n = query conn > "SELECT host, port, sel, typ, disc_name, disc_trip FROM thread\ > \ ORDER BY discovered DESC LIMIT ?" (Only n) > > -- | The N most recent posts across every thread, newest first. The > -- hot board's ranking unaggregated --- the same evidence > -- 'hotSelectors' counts, one post at a time. Note it applies the > -- looser test of the two: no join to `thread` and no type filter, > -- so a post left on ground diggings never fetched can appear here > -- while the ranking above it stays closed to that place. > latestPosts :: Connection -> Int > -> IO [(T.Text, T.Text, T.Text, T.Text, T.Text, T.Text, T.Text, Int)] > latestPosts conn n = query conn > "SELECT host, port, sel, typ, name, trip, body, posted FROM post\ > \ ORDER BY id DESC LIMIT ?" (Only n) Gophermap line builders ----------------------- Same conventions as the other applets in `applets/`: a single generic `menuRow`, info/error helpers in the minimal `\t\t\t0` form, every row ending `\r\n`, `putLine` flushing each row so output reaches the wire even mid-crash. Every display field passes through `sanitize`. > putLine :: T.Text -> IO () > putLine t = TIO.putStr (t <> "\r\n") >> hFlush stdout > > -- | >>> infoLine "hello" > -- "ihello\t\t\t0" > infoLine :: T.Text -> T.Text > infoLine msg = "i" <> sanitize msg <> "\t\t\t0" > > -- | >>> 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 > > -- | >>> errorItem "nope" > -- "3nope\t\t\t0" > errorItem :: T.Text -> T.Text > errorItem msg = "3" <> sanitize msg <> "\t\t\t0" > > terminator :: T.Text > terminator = "." > > -- | Replace the three structural bytes with spaces, so a value > -- carrying a TAB cannot smuggle extra fields onto the wire. > -- > -- >>> sanitize "ok" > -- "ok" > -- > -- >>> sanitize "evil\tfake\trow" > -- "evil fake row" > sanitize :: T.Text -> T.Text > sanitize = T.map (\c -> if c == '\r' || c == '\n' || c == '\t' then ' ' else c) > > -- | A menu row that points back under this script's mount point. > selfRow :: Ctx -> Char -> T.Text -> T.Text -> T.Text > selfRow ctx t display sub = > menuRow t display (ctxSel ctx <> sub) (ctxHost ctx) (ctxPort ctx) The proxy --------- `fetchGopher` shells out to `curl` with an argv array --- no `sh -c`, so no shell metacharacter survives --- and the host/port have already been through the sanitisers. The @/@ in the URL is the gopher item-type byte curl's URL parser consumes; only the selector after it reaches the remote server. `rewriteItem` is the heart of "surf without leaving": almost every remote menu row is rewritten to point back through diggings, carrying the session token *and* the row's own item-type byte, so clicks re-enter the proxy for both renderable types (`1` menu, `0` text) and non-renderable types (`I` image, `9` binary, `s` sound, `g` GIF, `M` MIME, `d` document, `p` PNG, `h` HTML, `c` calendar, `4`/`5`/`6` various binaries). For the non-renderable types, the thread page becomes the surface (a menu carrying a clearly-typed exit link to the origin); 'emitFetched' refuses to render those bytes inline. What we *do* pass through verbatim: info (`i`) and error (`3`) rows (no clickable destination); interactive types `7` (search), `8` (telnet), `T` (tn3270) where diggings has no way to honour the protocol; `+` redundant-server pointers; `U` URL-type links; and any `h` row whose selector starts with `URL:` (a web hyperlink, not a gopher resource). > -- Only called for renderable types ('0' text, '1' menu); 'surf' > -- skips this for non-renderable types so we never need to handle > -- binary content here. 'readProcess' returns a locale-text String, > -- which is fine for text/menu bodies. > fetchGopher :: Loc -> IO (Either T.Text T.Text) > fetchGopher (Loc h p s t) = do > let url = "gopher://" <> T.unpack h <> ":" <> T.unpack p > <> "/" <> [t] <> T.unpack s > r <- try (readProcess "curl" ["-s", "-g", "--max-time", "20", url] "") > :: IO (Either SomeException String) > pure $ either (const (Left "fetch failed")) (Right . T.pack) r > > -- | Does a fetched body look like a gopher menu (vs a text file)? > -- > -- >>> seemsMenu ["1a\t/x\thost\t70", "iblah"] > -- True > -- > -- >>> seemsMenu ["just some prose", "more prose"] > -- False > seemsMenu :: [T.Text] -> Bool > seemsMenu = any looksRow > where > looksRow l = case T.uncons l of > Just (t, rest) | t `elem` ("0123456789+TgIhsMdcUp" :: String) -> > length (T.splitOn "\t" rest) >= 3 > _ -> False > > -- | Is a fetch result a *real place* --- something actually worth > -- gold? A connection failure ('Left'), an empty body, or a body > -- that is only gopher error/info rows (a "selector not found" page) > -- are not. This is what stops dead selectors being farmed for gold: > -- 'surf' awards nothing, and records no discovery, unless this holds. > -- > -- >>> isRealPlace (Left "fetch failed") > -- False > -- > -- >>> isRealPlace (Right "") > -- False > -- > -- >>> isRealPlace (Right "3Not found\terr\terror.host\t1\r\n.\r\n") > -- False > -- > -- >>> isRealPlace (Right "1A real item\t/x\thost\t70\r\n.\r\n") > -- True > -- > -- >>> isRealPlace (Right "just prose in a text file\nmore prose\n") > -- True > isRealPlace :: Either T.Text T.Text -> Bool > isRealPlace (Left _) = False > isRealPlace (Right body) = > let ls = filter (not . T.null) . filter (/= ".") > . map (T.dropWhileEnd (== '\r')) . T.lines $ body > in case ls of > [] -> False > _ | seemsMenu ls -> any isItemRow ls > | otherwise -> True > where > isItemRow l = case T.uncons l of > Just (t, _) -> t /= 'i' && t /= '3' > Nothing -> False > > -- | The gopher item-type a fetched page should carry when linked to > -- *natively* (outside the proxy): @'1'@ for a menu or a failed fetch, > -- @'0'@ for a text file. Powers the "exit diggings" row. > -- > -- >>> nativeType (Right "1Item\t/x\thost\t70") > -- '1' > -- > -- >>> nativeType (Right "just prose\nmore prose") > -- '0' > -- > -- >>> nativeType (Left "fetch failed") > -- '1' > nativeType :: Either T.Text T.Text -> Char > nativeType (Left _) = '1' > nativeType (Right body) > | seemsMenu (filter (/= ".") (T.lines body)) = '1' > | otherwise = '0' > > -- | Rewrite one remote menu line so its destination re-enters > -- diggings. @mtok@ is 'Just' the session token, or 'Nothing' for > -- anonymous surfing. The remote row's own item-type byte (the > -- first character of the line) is preserved into the 'Loc' so it > -- survives the round-trip through the base64 token. > -- > -- >>> rewriteItem "/d.lhs" "me" "70" (Just "tok") "1Sub\t/sub\trmt.org\t70" > -- "1Sub\t/d.lhs/s/tok/go/cm10Lm9yZwo3MAovc3ViCjE\tme\t70" > -- > -- >>> rewriteItem "/d.lhs" "me" "70" Nothing "Imy image\t/cat.png\trmt.org\t70" > -- "1my image\t/d.lhs/go/cm10Lm9yZwo3MAovY2F0LnBuZwpJ\tme\t70" > -- > -- >>> rewriteItem "/d.lhs" "me" "70" Nothing "9Binary\t/b\trmt.org\t70" > -- "1Binary\t/d.lhs/go/cm10Lm9yZwo3MAovYgo5\tme\t70" > -- > -- >>> rewriteItem "/d.lhs" "me" "70" Nothing "7Search server\t/s\trmt.org\t70" > -- "7Search server\t/s\trmt.org\t70" > -- > -- >>> rewriteItem "/d.lhs" "me" "70" Nothing "hAnthropic\tURL:https://anthropic.com\trmt.org\t70" > -- "hAnthropic\tURL:https://anthropic.com\trmt.org\t70" > -- > -- >>> rewriteItem "/d.lhs" "me" "70" Nothing "ian info line\t\t\t0" > -- "ian info line\t\t\t0" > rewriteItem :: T.Text -> T.Text -> T.Text -> Maybe T.Text -> T.Text -> T.Text > rewriteItem scriptSel ourHost ourPort mtok line0 = > let line = T.dropWhileEnd (== '\r') line0 > in case T.uncons line of > Nothing -> infoLine "" > Just (t, rest) > | t `elem` ("i3" :: String) -> line > | otherwise -> case T.splitOn "\t" rest of > (disp : sel : h : p : _) > | passThrough t sel -> line > | otherwise -> > let loc = Loc (sanitizeHost h) (sanitizePort p) > (canonicalSel (sanitizeSel sel)) t > base = case mtok of > Just tok -> scriptSel <> "/s/" <> tok <> "/go/" > Nothing -> scriptSel <> "/go/" > newSel = base <> encodeLoc loc > in menuRow '1' disp newSel ourHost ourPort > _ -> infoLine line > where > -- Interactive (search/telnet/tn3270) and pointer-only ('+' redundant > -- server, 'U' URL link, 'h' with 'URL:' selector) types: nothing > -- diggings can usefully thread on, so leave them at the origin. > passThrough c sel = c `elem` ("78T+U" :: String) || "URL:" `T.isPrefixOf` sel > > -- | Emit an already-fetched body: a menu is rewritten line by line, > -- a text file becomes a block of info-lines, a failed fetch becomes > -- one parenthetical info-line. The remote terminator is dropped --- > -- the caller emits its own. The fetch is lifted out of this function > -- so 'surf' can inspect the result ('isRealPlace') before deciding > -- whether to award gold. Only called for renderable types ('0' > -- text, '1' menu); 'surf' skips it for everything else, so we never > -- have to make a render-or-not decision based on 'locType' here. > emitFetched :: Ctx -> Maybe T.Text -> Loc -> Either T.Text T.Text -> IO () > emitFetched ctx mtok loc fetched = case fetched of > Left e -> putLine (infoLine ("(" <> e <> ": " <> gopherUri loc <> ")")) > Right bod -> do > let ls = filter (/= ".") . map (T.dropWhileEnd (== '\r')) $ T.lines bod > if seemsMenu ls > then mapM_ (putLine . rewriteItem (ctxSel ctx) (ctxHost ctx) (ctxPort ctx) mtok) ls > else mapM_ (putLine . infoLine) ls Rendering: the pages -------------------- Each handler emits a complete gophermap (a search response in gopher *must* be a menu) ending in 'terminator'. The front door used to be sparse on purpose --- a three-line blurb, a stake-a-name box, a leaderboard link --- and now carries the scale line and the top few hot rows as well. That is a deliberate revision, not drift: a stranger's first screen was a signup form, and the best thing that space can do is show them other people are out there. It is still tight (see 'hotOnFrontDoor'); everything else is reachable from a session menu or a thread page, which remain the canonical per-resource surfaces. > landing :: Ctx -> IO () > landing ctx = do > now <- epochNow > (claims, lately, diggers) <- diggingsScale (ctxConn ctx) (now - hotWindow) > hot <- frontDoorHot ctx Nothing > mapM_ putLine $ > [ infoLine "diggings --- howdy, partner: welcome to the frontier of" > , infoLine "gopherspace. Every selector is unclaimed ground to strike" > , infoLine "gold on, and a thread to leave your mark on. Stake a name." > , infoLine (scaleLine claims lately diggers) > , infoLine "" > , infoLine "what's hot (last 30 days):" > ] ++ hot ++ > [ infoLine "" > , selfRow ctx '1' "What's hot --- the whole board" "/hot" > , selfRow ctx '7' "Stake your name (type: name#secret)" "/login" > , selfRow ctx '1' "Diggers --- gold leaderboard" "/diggers" > , terminator > ] > > loginPrompt :: Ctx -> IO () > loginPrompt ctx = mapM_ putLine > [ infoLine "Stake a name. Type name#secret --- the secret is never" > , infoLine "stored, only its hash, and the same secret always yields" > , infoLine "the same verified name!trip." > , infoLine "" > , selfRow ctx '7' "Stake your name (type: name#secret)" "/login" > , terminator > ] > > -- | Handle a staked @name#secret@: derive the trip, ensure the > -- player row, mint a session, hand back its bookmarkable link. > handleLogin :: Ctx -> T.Text -> IO () > handleLogin ctx raw = case splitStake (T.strip raw) of > Nothing -> mapM_ putLine > [ errorItem "Stake a name as name#secret (the # is required)." > , selfRow ctx '7' "Try again (type: name#secret)" "/login" > , terminator > ] > Just (rawName, rawSecret) -> do > let name = sanitizeName rawName > secret = T.take secretMax rawSecret > if T.null name > then mapM_ putLine > [ errorItem "That name has no usable characters ([A-Za-z0-9_-])." > , selfRow ctx '7' "Try again (type: name#secret)" "/login" > , terminator > ] > else do > now <- epochNow > let trip = tripcode (ctxSalt ctx) secret > ensurePlayer (ctxConn ctx) name trip now > tok <- mintSession (ctxConn ctx) name trip now > gold <- getGold (ctxConn ctx) name trip > mapM_ putLine > [ infoLine ("Welcome to the diggings, " <> ident name trip <> " --- " <> goldLabel gold <> ".") > , infoLine "Bookmark the link below: it is your session. Anyone" > , infoLine "holding it acts as you. Lost it? Re-stake the same" > , infoLine "name#secret for the same name!trip and a fresh link." > , infoLine "" > , selfRow ctx '1' ("Enter your session (" <> ident name trip <> ")") > ("/s/" <> tok) > , terminator > ] > > -- | The session menu: who you are, your gold, whether anybody has > -- called your name, a surf box, a resume link if you have been > -- somewhere, your inbox, and the two boards. > sessionMenu :: Ctx -> T.Text -> IO () > sessionMenu ctx tok = do > ms <- lookupSession (ctxConn ctx) tok > case ms of > Nothing -> emitUnknownSession ctx > Just (name, trip) -> do > gold <- getGold (ctxConn ctx) name trip > hot <- frontDoorHot ctx (Just tok) > -- Looking at your own front door is not reading your mail, so > -- nothing here moves the read mark --- only the inbox itself > -- does, or the flag would be gone before you could follow it. > -- Counted in this order on purpose. Each of the three is its > -- own statement on its own snapshot, so a call landing between > -- two of them is invisible to the earlier one; taking the > -- total last means the worst a race can do is hide a call that > -- has only just arrived, rather than print "2 NEW (1 in all)". > seen <- inboxSeen (ctxConn ctx) name trip > unread <- unreadCount (ctxConn ctx) name trip seen > total <- mentionCount (ctxConn ctx) name trip > mlast <- lastLoc (ctxConn ctx) tok > let resumeRow = case mlast of > Just loc -> > [ selfRow ctx '1' ("Resume surfing (" <> gopherUri loc <> ")") > ("/s/" <> tok <> "/go/" <> encodeLoc loc) ] > Nothing -> [] > mapM_ putLine $ > [ infoLine ("Session of " <> ident name trip <> " --- " <> goldLabel gold <> ".") ] > ++ inboxAlertRows unread ++ > [ infoLine "Surf to a hole to strike gold on new ground." > , infoLine postPayLine > , infoLine "" > , infoLine "what's hot (last 30 days):" > ] ++ hot ++ > [ infoLine "" > , selfRow ctx '7' "Surf to a hole (host[:port][/][/sel])" ("/s/" <> tok) > ] ++ resumeRow ++ > [ selfRow ctx '1' (inboxLabel total unread) ("/s/" <> tok <> "/inbox") > , selfRow ctx '1' "What's hot --- the whole board" ("/s/" <> tok <> "/hot") > , selfRow ctx '1' "Diggers --- gold leaderboard" ("/s/" <> tok <> "/diggers") > , selfRow ctx '1' "Log out (kill this session link)" ("/s/" <> tok <> "/logout") > , selfRow ctx '1' "Log out everywhere (kill all session links for this name!trip)" ("/s/" <> tok <> "/logout-all") > , terminator > ] > > -- | The surf box on the session menu: parse a typed location and > -- jump straight into it as this session. > handleSurfBox :: Ctx -> T.Text -> T.Text -> IO () > handleSurfBox ctx tok raw = case parseLoc raw of > Left e -> mapM_ putLine > [ errorItem ("Bad location: " <> e) > , selfRow ctx '1' "Back to your session" ("/s/" <> tok) > , terminator > ] > Right loc -> surf ctx (Just tok) loc > > -- | Log out: delete the session (and presence) rows so the bearer > -- token is dead. The durable identity --- player row, name!trip, > -- gold --- is untouched; re-stake the same name#secret for a fresh > -- token whenever you like. > handleLogout :: Ctx -> T.Text -> IO () > handleLogout ctx tok = do > execute (ctxConn ctx) "DELETE FROM session WHERE token = ?" (Only tok) > execute (ctxConn ctx) "DELETE FROM presence WHERE token = ?" (Only tok) > mapM_ putLine > [ infoLine "Logged out. That session link is dead now --- anyone" > , infoLine "who had it can no longer act as you. Your name, trip" > , infoLine "and gold are untouched; re-stake the same name#secret" > , infoLine "any time for a fresh link." > , infoLine "" > , selfRow ctx '7' "Stake your name again (type: name#secret)" "/login" > , selfRow ctx '1' "Back to diggings" "" > , terminator > ] > > -- | Log out *everywhere*: delete every session row for this identity > -- (not just the current token), plus their presence rows. Useful > -- when a token of yours is loose somewhere you no longer control --- > -- the personal '/logout' only kills the one you're currently holding. > handleLogoutAll :: Ctx -> T.Text -> IO () > handleLogoutAll ctx tok = do > ms <- lookupSession (ctxConn ctx) tok > case ms of > Nothing -> emitUnknownSession ctx > Just (name, trip) -> do > execute (ctxConn ctx) > "DELETE FROM presence WHERE token IN\ > \ (SELECT token FROM session WHERE name = ? AND trip = ?)" > (name, trip) > execute (ctxConn ctx) > "DELETE FROM session WHERE name = ? AND trip = ?" > (name, trip) > mapM_ putLine > [ infoLine ("Logged out everywhere. Every session link for " > <> ident name trip <> " is dead now ---") > , infoLine "any bookmark, anywhere, for this identity is no" > , infoLine "longer a login. Your name, trip and gold survive;" > , infoLine "re-stake the same name#secret for a fresh link." > , infoLine "" > , selfRow ctx '7' "Stake your name again (type: name#secret)" "/login" > , selfRow ctx '1' "Back to diggings" "" > , terminator > ] > > -- | The anonymous surf box (no session): parse a typed location and > -- surf it with no token, or show a clean error with a way back --- > -- the same courtesy 'handleSurfBox' gives a logged-in digger. > handleGoBox :: Ctx -> T.Text -> IO () > handleGoBox ctx raw = case parseLoc raw of > Left e -> mapM_ putLine > [ errorItem ("Bad location: " <> e) > , selfRow ctx '1' "Back to diggings" "" > , terminator > ] > Right loc -> surf ctx Nothing loc > > -- | Shown when the anonymous surf box is hit with no text. > goPrompt :: Ctx -> IO () > goPrompt ctx = mapM_ putLine > [ infoLine "Type a gopher hole to surf it anonymously --- a host," > , infoLine "optionally :port and /selector. Earns no gold; stake a" > , infoLine "name to strike gold and post." > , infoLine "" > , selfRow ctx '7' "Surf to a hole (host[:port][/][/sel])" "/go" > , selfRow ctx '1' "Back to diggings" "" > , terminator > ] > > -- | Surf a 'Loc'. For *renderable* types (@'0'@ text, @'1'@ menu) > -- we fetch the body first: 'isRealPlace' on the fetch is what > -- gates gold-awarding / discovery / presence, so dead selectors > -- cannot be farmed, and the body is then rewritten/info-lined into > -- the proxied page beneath the overlay. > -- > -- For *non-renderable* types (images, binaries, sounds, HTML, > -- etc.) we do not fetch at all --- the diggings page becomes a > -- pure menu, "pretending to be" that file: the standard overlay > -- (gold info, thread link, recent posts) is the header, and the > -- exit row is the only line in the content area, linking to the > -- file at its origin with the correct type byte. We trust the > -- link's claim that the resource is real (it came from a remote > -- menu row or a user-typed URL); without fetching we would be > -- gambling a bit on gold farming, but it is the right tradeoff > -- versus pulling down arbitrarily large binaries on every click. > surf :: Ctx -> Maybe T.Text -> Loc -> IO () > surf ctx mtok loc = do > now <- epochNow > let renderable = locType loc `elem` ("01" :: String) > fetched <- if renderable then fetchGopher loc else pure (Right T.empty) > let real = if renderable then isRealPlace fetched else True > -- The header block reports back whether *this* request announced a > -- first-ever discovery, so the common overlay can skip the > -- persistent "first found by" row that would just repeat it. > justDiscovered <- case mtok of > Nothing -> do > putLine (infoLine ("[diggings] surfing anonymously --- " <> gopherUri loc)) > putLine (infoLine "[diggings] stake a name to earn gold and post here:") > putLine (selfRow ctx '7' " Stake your name (type: name#secret)" "/login") > pure False > Just tok -> do > ms <- lookupSession (ctxConn ctx) tok > case ms of > Nothing -> do > putLine (infoLine "[diggings] unknown session --- surfing anonymously.") > pure False > Just (name, trip) > | not real -> do > gold <- getGold (ctxConn ctx) name trip > putLine (infoLine ("[diggings] " <> ident name trip > <> " --- " <> goldLabel gold)) > putLine (infoLine "[diggings] no gold --- fetch failed or nothing here.") > pure False > | otherwise -> do > (personalNew, firstDisc) <- awardVisit (ctxConn ctx) name trip loc now > touchPresence (ctxConn ctx) tok loc now > gold <- getGold (ctxConn ctx) name trip > putLine (infoLine ("[diggings] " <> ident name trip > <> " --- " <> goldLabel gold)) > when personalNew $ > putLine (infoLine "[diggings] +1 gold --- new ground for you!") > when firstDisc $ > putLine (infoLine ("[diggings] +" <> tshow discoveryBonus > <> " gold --- you are the FIRST here ever!")) > pure firstDisc > -- Overlay common to every mode: discovery credit, how many > -- diggers have been through, and who's here right now when we > -- have them; thread link + recent posts only when the > -- place is real or already has history (no inviting users to > -- "be the first" on a fetch-failed selector); the exit row only > -- when the place is real (a broken native link is no help); > -- always the jump box and the way back to your session. > mdisc <- threadInfo (ctxConn ctx) loc > case mdisc of > Just (dn, dt, dw) | not justDiscovered -> > putLine (infoLine ("[diggings] first found by " <> ident dn dt > <> " on " <> fmtDay dw)) > _ -> pure () > -- Past (who found it, how many have been through) before present > -- (who is standing here now). Suppressed at one: a lone digger is > -- either the discoverer credited above or the reader themselves. > dc <- diggerCount (ctxConn ctx) loc > when (dc > 1) $ > putLine (infoLine ("[diggings] " <> diggersLabel dc)) > here <- whoIsHere (ctxConn ctx) mtok loc now > unless (null here) $ > putLine (infoLine ("[diggings] also here: " <> T.intercalate ", " here)) > pc <- postCount (ctxConn ctx) loc > recent <- recentPosts (ctxConn ctx) loc postsOnOverlay > let hasHistory = pc > 0 || isJust mdisc > threadSub = case mtok of > Just tok -> "/s/" <> tok <> "/thread/" <> encodeLoc loc > Nothing -> "/thread/" <> encodeLoc loc > when (real || hasHistory) $ do > putLine (selfRow ctx '1' (threadLinkLabel pc (length recent)) threadSub) > forM_ (reverse recent) $ \(n, tr, body, _) -> > putLine (infoLine (" " <> ident n tr <> ": " <> firstLine body)) > -- Exit-to-origin row, in its usual overlay position for every > -- type. Type byte: for renderable surfs the post-fetch sniff > -- ('nativeType') is ground truth, since the body is what we just > -- looked at; for non-renderable surfs there is no body, so we > -- fall back to the claimed type from the link that brought us > -- here ('locType'). > when real $ > let exitType = if renderable then nativeType fetched else locType loc > in putLine (menuRow exitType > ("[diggings] exit --- " <> exitOpenLabel (locSel loc)) > (locSel loc) (locHost loc) (locPort loc)) > -- Up one level, then the free-form jump, then home: the three > -- "where next" rows together. Emitted even when the fetch failed > -- --- a dead selector is exactly when you most want to climb out > -- of it --- and suppressed only at a host's root, where there is > -- nothing above. Parents are menus by construction, so type '1'. > let goSub = case mtok of > Just tok -> "/s/" <> tok <> "/go/" > Nothing -> "/go/" > forM_ (parentLoc loc) $ \up -> > putLine (selfRow ctx '1' ("[diggings] up --- " <> gopherUri up) > (goSub <> encodeLoc up)) > let jumpSub = case mtok of > Just tok -> "/s/" <> tok > Nothing -> "/go" > putLine (selfRow ctx '7' > "[diggings] strike out --- surf to a hole (host[:port][/][/sel])" > jumpSub) > case mtok of > Just tok -> putLine > (selfRow ctx '1' "[diggings] back to your session" ("/s/" <> tok)) > Nothing -> pure () > -- Horizontal rule + body only for renderable types: the rule > -- exists to mark "end of diggings UI, body follows", so emitting > -- it on a non-renderable page would promise a body we can't > -- show. For non-renderable types the overlay's exit row is how > -- you actually reach the file; the page just ends here. > when renderable $ do > putLine (infoLine "[diggings] ----------------------------------------") > emitFetched ctx mtok loc fetched > putLine terminator > > -- | A selector's thread page: the canonical per-resource surface > -- --- who found it first, how many diggers have been through, > -- who's here, two ways in (surf it through > -- diggings, or exit to it natively), the post box (if you have a > -- session), and the posts oldest-first. > threadPage :: Ctx -> Maybe T.Text -> Loc -> IO () > threadPage ctx mtok loc = do > now <- epochNow > mdisc <- threadInfo (ctxConn ctx) loc > here <- whoIsHere (ctxConn ctx) mtok loc now > posts <- recentPosts (ctxConn ctx) loc postsOnThread > pc <- postCount (ctxConn ctx) loc > dc <- diggerCount (ctxConn ctx) loc > let discRow = case mdisc of > Just (dn, dt, when') -> > infoLine ("first found by " <> ident dn dt <> " on " <> fmtDay when') > Nothing -> infoLine "undiscovered --- surf here to claim it" > hereRow = if null here then [] > else [ infoLine ("here now: " <> T.intercalate ", " here) ] > diggersRow = if dc > 1 then [ infoLine (diggersLabel dc) ] else [] > enterSub = case mtok of > Just tok -> "/s/" <> tok <> "/go/" <> encodeLoc loc > Nothing -> "/go/" <> encodeLoc loc > actionRows = case mtok of > Just tok -> > [ selfRow ctx '7' "Leave a post" ("/s/" <> tok <> "/post/" <> encodeLoc loc) ] > Nothing -> > [ selfRow ctx '1' "Stake a name to post here" "/login" ] > mapM_ putLine $ > [ infoLine ("[diggings] thread --- " <> gopherUri loc) > , discRow > ] ++ diggersRow ++ hereRow ++ > [ infoLine "" > , selfRow ctx '1' "The page itself --- surf it through diggings" enterSub > -- Exit-row type from 'locType': the link that brought us to > -- this thread (URL paste, menu-row click, or token) told us > -- what this resource is. The thread page does not fetch, so we > -- defer to that claimed type rather than guessing menu. > , menuRow (locType loc) ("Exit diggings --- " <> exitOpenLabel (locSel loc)) > (locSel loc) (locHost loc) (locPort loc) > ] ++ actionRows ++ > [ infoLine postPayLine > , infoLine "" > , infoLine (postsHeader pc (length posts)) > ] > if null posts > then putLine (infoLine "(no posts yet --- be the first)") > else forM_ (reverse posts) (emitPost) > putLine terminator > where > emitPost (n, tr, body, ts) = do > putLine (infoLine "") > putLine (infoLine (ident n tr <> " " <> fmtTime ts)) > mapM_ (putLine . infoLine . (" " <>)) (T.splitOn "\n" body) > > -- | Prompt shown when the post box is hit with no text. > postPrompt :: Ctx -> T.Text -> Loc -> IO () > postPrompt ctx tok loc = mapM_ putLine > [ infoLine ("Leave a post on " <> gopherUri loc <> ".") > , infoLine postPayLine > , infoLine mentionHint > , infoLine "" > , selfRow ctx '7' "Type your post" ("/s/" <> tok <> "/post/" <> encodeLoc loc) > , selfRow ctx '1' "Back to the thread" ("/s/" <> tok <> "/thread/" <> encodeLoc loc) > , terminator > ] > > -- | Handle a submitted post: validate the session, store it unless > -- the thread already holds that line, confirm either way. > handlePost :: Ctx -> T.Text -> Loc -> T.Text -> IO () > handlePost ctx tok loc raw = do > ms <- lookupSession (ctxConn ctx) tok > case ms of > Nothing -> emitUnknownSession ctx > Just (name, trip) -> do > let body = T.take bodyMax (T.strip raw) > ground <- threadInfo (ctxConn ctx) loc > if T.null body > then mapM_ putLine > [ errorItem "Empty post --- nothing was saved." > , selfRow ctx '7' "Try again" ("/s/" <> tok <> "/post/" <> encodeLoc loc) > , terminator > ] > -- Undiscovered ground takes no posts. Storing one anyway > -- would be worse than refusing: the post takes ordinal 1 and > -- spends 'openThreadBonus' without anybody being paid it, so > -- a single line on a silent selector would destroy that rung > -- for every digger, forever. Refusing keeps the rung, keeps > -- fabricated locations out of the hot board's latest-posts > -- panel, and makes the way out one click --- which is what > -- the thread page has always said here anyway. > else if not (isJust ground) > then mapM_ putLine > [ errorItem "Nobody has surfed here yet --- nothing was saved." > , infoLine "Ground has to be reached before it can be talked on." > , infoLine "Surf it once and the thread opens --- and the walk" > , infoLine "pays you for it." > , infoLine "" > , selfRow ctx '1' "Surf here" ("/s/" <> tok <> "/go/" <> encodeLoc loc) > , selfRow ctx '1' "Back to the thread" > ("/s/" <> tok <> "/thread/" <> encodeLoc loc) > , terminator > ] > else do > now <- epochNow > -- 'addPost' reads its own `changes` and rowid, so nothing > -- may write on this connection between it and the ordinal > -- and post id it hands back: pay, touch presence and > -- record any calls only after. > ord <- addPost (ctxConn ctx) loc name trip body now > -- 'firstReplyBonus' is for answering *somebody*, so a > -- thread's opener answering themselves drops to > -- 'replyBonus'. A read, so it is safe here --- 'addPost' > -- has already taken its own answers. > opener <- threadOpener (ctxConn ctx) loc > let selfReply = case opener of > Just (on, ot) -> on == name && ot == trip > Nothing -> False > reward = case ord of > Nothing -> 0 > Just (n, _) > | n == 2 && selfReply -> replyBonus > | otherwise -> postReward n > addGold (ctxConn ctx) name trip reward > touchPresence (ctxConn ctx) tok loc now > -- Calls are read out of the body that was *stored*, and > -- only when a row was stored: a dropped duplicate has no > -- post to point at, and pointing at the copy already on > -- the thread would either forge a call onto somebody > -- else's post or fire a second one at a digger who has > -- already had it. It is the same rule the gold keeps --- > -- nothing was added, so nothing was sent either. > (called, missed) <- case ord of > Nothing -> pure ([], 0) > Just (_, pid) -> recordMentions (ctxConn ctx) pid name trip body now > gold <- getGold (ctxConn ctx) name trip > let refreshRow = case ord of > Nothing -> [ infoLine "(Nothing was added, so no gold either.)" ] > Just (n, _) -> [ infoLine (postRewardLabel n reward) > , infoLine ("You are up to " <> goldLabel gold <> ".") ] > -- Says who was reached, or why nobody was, and never > -- both --- a note about a call that missed is only > -- worth printing when there is no better news, and > -- the two ways to miss want different advice. > calledRows > | not (null called) = > [ infoLine ("Called out there: " <> T.intercalate ", " called > <> " --- it is in their inbox now.") ] > | missed > 0 = > [ infoLine "(Nobody answers to the name!trip you called ---" > , infoLine " copy it whole, trip and all, off one of their posts.)" > ] > | bareCall body = > [ infoLine "(A name with no trip calls nobody --- write it" > , infoLine " as @name!trip and it will land in their inbox.)" > ] > | otherwise = [] > mapM_ putLine $ > [ infoLine (postedLabel (isJust ord) (gopherUri loc) (ident name trip)) ] > ++ refreshRow ++ calledRows ++ > [ infoLine "" > , selfRow ctx '1' "Back to the thread" > ("/s/" <> tok <> "/thread/" <> encodeLoc loc) > , selfRow ctx '1' "Surf here" ("/s/" <> tok <> "/go/" <> encodeLoc loc) > , terminator > ] > > -- | The leaderboard: who has struck the most gold, over a one-line > -- pulse of where diggers are this week, under the table of how gold > -- is struck at all. > -- > -- Recent strikes and the latest posts used to sit here too. They > -- moved to 'hotBoard', which is the page that asks whether anybody > -- is out there --- and both of them are evidence for that question > -- rather than for this one. What is left is a scoreboard, which is > -- all this page ever claimed to be: it keeps score, and the other > -- page keeps watch. > leaderboard :: Ctx -> Maybe T.Text -> IO () > leaderboard ctx mtok = do > now <- epochNow > tops <- topPlayers (ctxConn ctx) topGoldOnLeaderboard > busy <- busiestGround (ctxConn ctx) (now - busyWindow) > mapM_ putLine $ > [ infoLine "[diggings] diggers --- gold leaderboard" ] ++ > -- Suppressed at one digger, for the reason 'diggersLabel' gives: > -- a line naming the single place a single person has been is a > -- report on that person, not a pulse. > (case busy of > Just (h, d, c) | d > 1 -> [ infoLine (busiestLabel h d c) ] > _ -> []) ++ > [ infoLine "" > ] ++ > (if null tops > then [ infoLine "(nobody has struck gold yet)" ] > else zipWith rankRow [1 ..] tops) ++ > [ infoLine "" > , infoLine "how gold is struck:" > ] ++ map infoLine goldRules ++ > [ infoLine "" > , backRow > , terminator > ] > where > backRow = case mtok of > Just tok -> selfRow ctx '1' "Back to your session" ("/s/" <> tok) > Nothing -> selfRow ctx '1' "Back to diggings" "" > rankRow :: Int -> (T.Text, T.Text, Int) -> T.Text > rankRow i (n, tr, g) = > infoLine (T.justifyRight 3 ' ' (tshow i) <> ". " > <> T.justifyLeft 36 ' ' (ident n tr) <> tshow g <> " gold") > > -- | One hot-board row: the place, who talked, how long ago. Links to > -- the thread page rather than the page itself --- what is hot here > -- is the conversation, so land the reader on it. > hotRow :: Ctx -> Maybe T.Text -> Int > -> (T.Text, T.Text, T.Text, T.Text, Int, Int) -> T.Text > hotRow ctx mtok now (h, p, s, typ, talkers, latest) = > let loc = Loc h p s (firstCharOr '1' typ) > sub = case mtok of > Just tok -> "/s/" <> tok <> "/thread/" > Nothing -> "/thread/" > in selfRow ctx '1' > (gopherUri loc <> " --- " <> hotRowLabel talkers (now - latest)) > (sub <> encodeLoc loc) > > -- | What a quiet board says. Never an apology and never a blank --- > -- an empty board is an opening, and this is the one page where > -- saying so is the whole point. > hotEmpty :: [T.Text] > hotEmpty = > [ infoLine "(nobody has said anything out there in thirty days ---" > , infoLine " go be the one who does)" > ] > > -- | The hot rows for a front door: at most 'hotOnFrontDoor' of them, > -- shared by 'landing' and 'sessionMenu' so the two doors can never > -- disagree about what is hot. > frontDoorHot :: Ctx -> Maybe T.Text -> IO [T.Text] > frontDoorHot ctx mtok = do > now <- epochNow > hot <- hotSelectors (ctxConn ctx) (now - hotWindow) hotOnFrontDoor > pure $ if null hot then hotEmpty else map (hotRow ctx mtok now) hot > > -- | The hot board: the selectors people have actually been talking > -- on lately, then the talk itself, then the ground that has just > -- been claimed. The ranked board is deliberately short and > -- deliberately allowed to be a board of one --- a padded board is a > -- worse board, and one row reading "2 diggers talked here" is > -- stronger proof that gopherspace is still inhabited than ten rows > -- of somebody's crawl. > -- > -- The two sections under it are the same evidence unaggregated, and > -- they came here from the leaderboard, which is a page about score. > -- They answer the question this page asks: the ranking says where > -- people have been talking, the posts say what was said and by > -- whom, and the strikes say the map is still filling in. Order > -- follows how much each one proves --- talk is the scarce thing, so > -- it goes above the walking. > hotBoard :: Ctx -> Maybe T.Text -> IO () > hotBoard ctx mtok = do > now <- epochNow > hot <- hotSelectors (ctxConn ctx) (now - hotWindow) hotOnBoard > posts <- latestPosts (ctxConn ctx) postsOnHot > discs <- recentDiscoveries (ctxConn ctx) strikesOnHot > (claims, lately, diggers) <- diggingsScale (ctxConn ctx) (now - hotWindow) > mapM_ putLine $ > [ infoLine "[diggings] what's hot --- the last 30 days" > , infoLine (scaleLine claims lately diggers) > , infoLine "" > , infoLine "where diggers have been talking:" > ] ++ > (if null hot then hotEmpty else map (hotRow ctx mtok now) hot) ++ > [ infoLine "" > , infoLine "(ranked by how many different diggers spoke there ---" > , infoLine " a post is the only thing here that proves a human" > , infoLine " came by on purpose. Ties go to the newest.)" > , infoLine "" > , infoLine "latest posts (across all threads):" > ] ++ > (if null posts > then [ infoLine "(no posts yet --- be the first)" ] > else map postRow posts) ++ > [ infoLine "" > , infoLine "recent strikes (first-ever discoveries):" > ] ++ > (if null discs > then [ infoLine "(none yet)" ] > else map discRow discs) ++ > [ infoLine "" > , case mtok of > Just tok -> selfRow ctx '1' "Back to your session" ("/s/" <> tok) > Nothing -> selfRow ctx '1' "Back to diggings" "" > , terminator > ] > where > -- Both rows land on the thread page rather than the place > -- itself, exactly as 'hotRow' does: what is hot here is the > -- conversation, so put the reader on it. > discRow (h, p, s, typ, dn, dt) = > let loc = Loc h p s (firstCharOr '1' typ) > in selfRow ctx '1' > (gopherUri loc <> " --- by " <> ident dn dt) > (threadSub <> encodeLoc loc) > postRow (h, p, s, typ, n, tr, body, _) = > let loc = Loc h p s (firstCharOr '1' typ) > in selfRow ctx '1' > (ident n tr <> ": " <> ellipsize 60 (firstLine body) > <> " --- " <> gopherUri loc) > (threadSub <> encodeLoc loc) > threadSub = case mtok of > Just tok -> "/s/" <> tok <> "/thread/" > Nothing -> "/thread/" > > -- | A digger's inbox: every post that has called their name, newest > -- first. The one private surface in this file, so it checks the > -- session and stops when there is none. 'surf' can fall back to > -- anonymous because surfing needs no identity; an inbox is nothing > -- but identity, so there is nothing here to fall back to. > -- > -- What a row prints is a date, a place and a name. Not a word of > -- the post: this is a private page an arbitrary stranger can cause > -- to render, one line at a time, and keeping the rows to those > -- three fields means the only parts a caller chooses are which > -- thread and which name --- both of them already public. What was > -- actually said is one click away, on the thread, in the renderer > -- that already handles it. > inboxPage :: Ctx -> T.Text -> IO () > inboxPage ctx tok = do > ms <- lookupSession (ctxConn ctx) tok > case ms of > Nothing -> emitUnknownSession ctx > Just (name, trip) -> do > -- The mark is read before the rows and moved after them, so > -- the page you are looking at still shows you what was new > -- when you opened it. Reading it the other way round would > -- print a page on which nothing is ever new. > seen <- inboxSeen (ctxConn ctx) name trip > rows <- inboxMentions (ctxConn ctx) name trip inboxRows > total <- mentionCount (ctxConn ctx) name trip > mapM_ putLine $ > [ infoLine ("[diggings] inbox --- " <> ident name trip) > , infoLine (inboxHeader total (length rows)) > , infoLine "" > , infoLine "who called your name:" > ] ++ > (if null rows then inboxEmpty else map (row seen) rows) ++ > [ infoLine "" > ] ++ map infoLine mentionRules ++ > [ infoLine "" > , selfRow ctx '1' "Back to your session" ("/s/" <> tok) > , terminator > ] > -- Only as far as what actually reached the wire: never `now` > -- and never a fresh maximum, either of which would swallow a > -- call that landed while this page was being built. > markInboxSeen (ctxConn ctx) name trip > (maximum (0 : [ mid | (mid, _, _, _, _, _, _, _) <- rows ])) > where > row seen (mid, h, p, s, typ, n, tr, ts) = > let loc = Loc h p s (firstCharOr '1' typ) > in selfRow ctx '1' > (inboxRowLabel (mid > seen) ts (gopherUri loc) (ident n tr)) > ("/s/" <> tok <> "/thread/" <> encodeLoc loc) > > -- | The inbox as somebody without a name finds it. There is no mail > -- to show --- an inbox is addressed to a name!trip and there is no > -- anonymous one --- but the endpoint is documented, so a stranger > -- who types it is told what the thing is and how to get one, rather > -- than handed a path error. > inboxSignpost :: Ctx -> IO () > inboxSignpost ctx = mapM_ putLine $ > [ infoLine "[diggings] inbox" > , infoLine "An inbox is addressed to a name!trip, so there is no" > , infoLine "anonymous one. Stake a name and yours starts here." > , infoLine "" > ] ++ map infoLine mentionRules ++ > [ infoLine "" > , selfRow ctx '7' "Stake your name (type: name#secret)" "/login" > , selfRow ctx '1' "Back to diggings" "" > , terminator > ] > > emitUnknownSession :: Ctx -> IO () > emitUnknownSession ctx = mapM_ putLine > [ errorItem "Unknown session token." > , selfRow ctx '7' "Stake your name again (type: name#secret)" "/login" > , terminator > ] > > emitPathError :: Ctx -> T.Text -> IO () > emitPathError ctx pinfo = mapM_ putLine > [ errorItem ("Unrecognised path-info: " <> pinfo) > , selfRow ctx '1' "Back to diggings" "" > , terminator > ] Small helpers ------------- > -- | Current POSIX time, whole seconds. > epochNow :: IO Int > epochNow = round <$> getPOSIXTime > > -- | >>> tshow (42 :: Int) > -- "42" > tshow :: Show a => a -> T.Text > tshow = T.pack . show > > -- | >>> goldLabel 1 > -- "1 gold" > goldLabel :: Int -> T.Text > goldLabel g = tshow g <> " gold" > > -- | Count and noun, pluralised the lazy English way. > -- > -- >>> plural 1 "digger" > -- "1 digger" > -- > -- >>> plural 3 "claim" > -- "3 claims" > plural :: Int -> T.Text -> T.Text > plural n w = tshow n <> " " <> w <> (if n == 1 then "" else "s") > > -- | How long ago, in words, from a count of seconds. Deliberately > -- coarse: the hot board is answering "is this still warm?", not > -- "when exactly?", and 'fmtTime' is there for the exact answer. > -- Clamps anything negative (clock skew between writer and reader) to > -- the present rather than printing a post from the future. > -- > -- >>> map agoLabel [30, 900, 3600, 7200, 86400, 259200] > -- ["just now","15 minutes ago","an hour ago","2 hours ago","yesterday","3 days ago"] > agoLabel :: Int -> T.Text > agoLabel s > | s < 300 = "just now" > | s < 3600 = plural (s `div` 60) "minute" <> " ago" > | s < 7200 = "an hour ago" > | s < 86400 = plural (s `div` 3600) "hour" <> " ago" > | s < 172800 = "yesterday" > | otherwise = plural (s `div` 86400) "day" <> " ago" > > -- | The tail of a hot-board row: who talked, and how long ago. > -- > -- >>> hotRowLabel 2 172800 > -- "2 diggers talked here --- 2 days ago" > -- > -- >>> hotRowLabel 1 60 > -- "1 digger talked here --- just now" > hotRowLabel :: Int -> Int -> T.Text > hotRowLabel talkers ago = > plural talkers "digger" <> " talked here --- " <> agoLabel ago > > -- | The "gopherspace isn't done" line: how much ground has been > -- claimed, how much of it lately, and by how many. > -- > -- >>> scaleLine 101 46 18 > -- "101 claims staked, 46 in the last 30 days, by 18 diggers." > scaleLine :: Int -> Int -> Int -> T.Text > scaleLine claims lately diggers = > plural claims "claim" <> " staked, " <> tshow lately > <> " in the last 30 days, by " <> plural diggers "digger" <> "." > > -- | The leaderboard's pulse line. Names no one --- a count and a > -- hole, so it says "there are people out there" without publishing > -- anybody's whereabouts. > -- > -- Counts *selectors walked*, and says so. Not "claims": a claim is a > -- first-ever discovery everywhere else in diggings, and this number > -- comes from `presence`, which is refreshed every time somebody goes > -- back somewhere they have been for years. Calling re-walked ground > -- a claim would put this line at odds with every other number in > -- the file --- and it used to sit directly above "recent strikes", > -- where the contradiction would have been on one screen. That > -- section is on the hot board now, which loosens nothing: the word > -- has to mean one thing across the whole applet, not just within a > -- page. > -- > -- >>> busiestLabel "sdf.org" 2 25 > -- "busiest hole right now: sdf.org --- 2 diggers, 25 selectors walked this week" > busiestLabel :: T.Text -> Int -> Int -> T.Text > busiestLabel h diggers sels = > "busiest hole right now: " <> h <> " --- " <> plural diggers "digger" > <> ", " <> plural sels "selector" <> " walked this week" > > -- | Every way gold is struck, in one list, built from the constants > -- that actually pay it --- so a page explaining the rules cannot > -- drift from the code enforcing them. Only the leaderboard prints > -- the whole table; the session menu, the thread page and the post > -- prompt print the one-line 'postPayLine' instead. > -- > -- >>> mapM_ (putStrLn . T.unpack) goldRules > -- +1 surf a selector you have never reached > -- +100 ...and be the FIRST digger ever to reach it > -- +50 open a thread --- the first post on a selector > -- +10 leave the first reply on a thread > -- +1 every reply after that > goldRules :: [T.Text] > goldRules = > [ rule 1 "surf a selector you have never reached" > , rule discoveryBonus "...and be the FIRST digger ever to reach it" > , rule openThreadBonus "open a thread --- the first post on a selector" > , rule firstReplyBonus "leave the first reply on a thread" > , rule replyBonus "every reply after that" > ] > where rule g t = T.justifyLeft 7 ' ' ("+" <> tshow g) <> t > > -- | The posting half of 'goldRules', squeezed onto one line for > -- pages that have no room for the table. > -- > -- >>> postPayLine > -- "posts pay: +50 to open a thread, +10 for the first reply, +1 after that" > postPayLine :: T.Text > postPayLine = > "posts pay: +" <> tshow openThreadBonus <> " to open a thread, +" > <> tshow firstReplyBonus <> " for the first reply, +" > <> tshow replyBonus <> " after that" > > -- | Label for the digger-count line, from 'diggerCount'. Says > -- "have been here", never "before you": the viewer's own `visit` > -- row is already written by the time either page draws, so the > -- count includes them. No @[diggings]@ prefix --- 'surf' prepends > -- one, 'threadPage' does not. Callers suppress the line below two, > -- where "you are the FIRST here ever!" and "first found by ..." > -- already say it, and say it better. > -- > -- >>> diggersLabel 1 > -- "1 digger has been here" > -- > -- >>> diggersLabel 7 > -- "7 diggers have been here" > diggersLabel :: Int -> T.Text > diggersLabel n > | n == 1 = "1 digger has been here" > | otherwise = tshow n <> " diggers have been here" > > -- | First line of a (possibly multi-line) body, for compact previews. > -- > -- >>> firstLine "one\ntwo\nthree" > -- "one" > firstLine :: T.Text -> T.Text > firstLine = fromMaybe "" . listToMaybe . T.splitOn "\n" > > -- | Trim a 'Text' to at most @n@ characters total, appending @"..."@ > -- when shortening. Callers should pass @n >= 4@. > -- > -- >>> ellipsize 10 "hello" > -- "hello" > -- > -- >>> ellipsize 10 "hello, world" > -- "hello, ..." > ellipsize :: Int -> T.Text -> T.Text > ellipsize n t > | T.length t <= n = t > | otherwise = T.take (n - 3) t <> "..." > > -- | Label for the overlay's thread row. @total@ is every post on the > -- 'Loc'; @shown@ is how many the overlay is about to preview inline > -- beneath it --- the actual preview count, never the cap, so a short > -- thread cannot claim more than it has. > -- > -- >>> threadLinkLabel 0 0 > -- "[diggings] thread --- no posts yet, be the first" > -- > -- >>> threadLinkLabel 3 3 > -- "[diggings] thread --- 3 post(s), read & reply" > -- > -- >>> threadLinkLabel 12 3 > -- "[diggings] thread --- 12 posts, latest 3 below (+9 more)" > threadLinkLabel :: Int -> Int -> T.Text > threadLinkLabel total shown > | total <= 0 = "[diggings] thread --- no posts yet, be the first" > | omitted <= 0 = "[diggings] thread --- " <> tshow total <> " post(s), read & reply" > | otherwise = "[diggings] thread --- " <> tshow total <> " posts, latest " > <> tshow shown <> " below (+" <> tshow omitted <> " more)" > where omitted = total - shown > > -- | The threadPage posts-section header. Flags when the page shows > -- only the most recent slice of a thread longer than 'postsOnThread'. > -- > -- >>> postsHeader 0 0 > -- "--- posts (0) ---" > -- > -- >>> postsHeader 4 4 > -- "--- posts (4) ---" > -- > -- >>> postsHeader 30 25 > -- "--- posts (30 total, showing latest 25) ---" > postsHeader :: Int -> Int -> T.Text > postsHeader total shown > | shown >= total = "--- posts (" <> tshow total <> ") ---" > | otherwise = "--- posts (" <> tshow total <> " total, showing latest " > <> tshow shown <> ") ---" > > -- | The same header for the inbox, on the same rule: say so when > -- the page is a slice rather than the lot. > -- > -- >>> inboxHeader 0 0 > -- "--- calls (0) ---" > -- > -- >>> inboxHeader 4 4 > -- "--- calls (4) ---" > -- > -- >>> inboxHeader 51 30 > -- "--- calls (51 total, showing latest 30) ---" > inboxHeader :: Int -> Int -> T.Text > inboxHeader total shown > | shown >= total = "--- calls (" <> tshow total <> ") ---" > | otherwise = "--- calls (" <> tshow total <> " total, showing latest " > <> tshow shown <> ") ---" > > -- | One inbox row: whether it is new, the day it was written, the > -- thread it is on, and who wrote it. 'fmtDay' and not 'agoLabel' --- > -- "3 days ago" is the hot board's voice, where the question is > -- whether a place is still warm, and mail wants a date you can refer > -- to twice. The exact minute is on the thread page, one click away. > -- > -- The NEW column is fixed-width so the dates stay in a column > -- whether or not anything is new. > -- > -- >>> inboxRowLabel True 1786924800 "gopher://sdf.org/0/phlog" "Cat!451f15e229" > -- "NEW 2026-08-17 --- thread for gopher://sdf.org/0/phlog --- by Cat!451f15e229" > -- > -- >>> inboxRowLabel False 1786665600 "gopher://tilde.town/1/~x" "sue!63f81cc5ca" > -- " 2026-08-14 --- thread for gopher://tilde.town/1/~x --- by sue!63f81cc5ca" > inboxRowLabel :: Bool -> Int -> T.Text -> T.Text -> T.Text > inboxRowLabel isNew ts uri who = > T.justifyLeft 5 ' ' (if isNew then "NEW" else "") > <> fmtDay ts <> " --- thread for " <> uri <> " --- by " <> who > > -- | The inbox's row on the session menu. Always there, even at > -- nothing, so a digger who has never been called still finds out the > -- inbox exists; it is the count that changes, not the row. > -- > -- >>> inboxLabel 0 0 > -- "Your inbox --- nobody has called your name yet" > -- > -- >>> inboxLabel 5 0 > -- "Your inbox --- 5 calls, nothing new" > -- > -- >>> inboxLabel 5 2 > -- "Your inbox --- 2 NEW (5 in all)" > inboxLabel :: Int -> Int -> T.Text > inboxLabel total unread > | total == 0 = "Your inbox --- nobody has called your name yet" > | unread == 0 = "Your inbox --- " <> plural total "call" <> ", nothing new" > | otherwise = "Your inbox --- " <> tshow unread <> " NEW (" > <> tshow total <> " in all)" > > -- | The line on the session menu that says somebody said your name. > -- Nothing at all when nobody has: a menu that reports zero every > -- time teaches you to stop reading it. > -- > -- >>> inboxAlertRows 0 > -- [] > -- > -- >>> inboxAlertRows 1 > -- ["i*** 1 new call --- somebody said your name out there.\t\t\t0"] > -- > -- >>> inboxAlertRows 3 > -- ["i*** 3 new calls --- somebody said your name out there.\t\t\t0"] > inboxAlertRows :: Int -> [T.Text] > inboxAlertRows 0 = [] > inboxAlertRows n = > [ infoLine ("*** " <> plural n "new call" > <> " --- somebody said your name out there.") ] > > -- | What an empty inbox says. Same rule 'hotEmpty' keeps: an empty > -- page is an opening, so never an apology and never a blank. > inboxEmpty :: [T.Text] > inboxEmpty = > [ infoLine "(nobody has called your name out there yet --- which is" > , infoLine " what a frontier sounds like. Go say something to" > , infoLine " somebody and they will have a name to say back.)" > ] > > -- | How calling somebody works, in one list, printed by every page > -- that has to explain it --- the inbox, and the signpost an > -- anonymous visitor gets. Built the way 'goldRules' is, from the > -- rules the code actually keeps, so the page and the mechanism > -- cannot drift apart. > mentionRules :: [T.Text] > mentionRules = > [ "how a call works:" > , " Write @name!trip in a post --- the whole verified" > , " identity, copied off one of their posts, with an @" > , " in front of it --- and that digger finds the thread" > , " waiting here." > , " A bare @name does nothing, on purpose: names are not" > , " unique in the diggings, two secrets can stake the same" > , " one, and the trip is the half that says who you mean." > , " Names keep their case; trips are ten lowercase hex" > , " digits, no more and no fewer. Write @@name!trip to" > , " say a name out without calling it." > , " A call pays no gold, to either of you --- gold is for" > , " walking new ground and for breaking silences, and this" > , " is neither. Nobody is called twice by the same post," > , " you cannot call yourself, and a post dropped as a" > , " duplicate calls nobody at all." > ] > > -- | The one-line version, for the post box, where somebody is > -- already writing and the whole list would be a lecture. > -- > -- >>> mentionHint > -- "Say @name!trip in a post and it lands in that digger's inbox." > mentionHint :: T.Text > mentionHint = "Say @name!trip in a post and it lands in that digger's inbox." > > -- | The verdict line after a post attempt, from whether > -- 'addPost' stored a row. Never an error row: nothing went wrong, the > -- thread simply already holds that line. The rejection names neither > -- the URI nor the poster --- the duplicate may well be somebody > -- else's, so there is no "you" to address and nothing to truncate. > -- > -- >>> postedLabel True "gopher://sdf.org/0/phlog" "Cat!451f15e229" > -- "Posted to gopher://sdf.org/0/phlog as Cat!451f15e229." > -- > -- >>> postedLabel False "gopher://sdf.org/0/phlog" "Cat!451f15e229" > -- "Be more original --- that's already been posted in this thread!" > postedLabel :: Bool -> T.Text -> T.Text -> T.Text > postedLabel False _ _ = > "Be more original --- that's already been posted in this thread!" > postedLabel True uri who = > "Posted to " <> uri <> " as " <> who <> "." > > -- | What a post pays, from its ordinal on the thread (1 = the post > -- that opened it). The scale is the textboard's whole incentive: a > -- selector nobody has ever spoken on is the scarce thing, so opening > -- one pays like a small discovery; answering a thread that has never > -- been answered pays less but still well, because a lone post is a > -- note in a bottle until somebody replies; after that a reply is > -- worth the same +1 as new ground, which is to say: keep going, it > -- just stops being an event. > -- > -- Total, not a bonus on top of one --- an opener gets > -- 'openThreadBonus' and nothing else. Ordinals below 1 cannot come > -- from 'addPost' (it counts the row it just wrote), but the guard > -- form keeps the function total rather than partial on them. > -- > -- >>> map postReward [1, 2, 3, 40] > -- [50,10,1,1] > -- > -- >>> postReward 0 > -- 1 > postReward :: Int -> Int > postReward n > | n == 1 = openThreadBonus > | n == 2 = firstReplyBonus > | otherwise = replyBonus > > -- | The line that tells a poster what they just earned. Takes the > -- reward alongside the ordinal rather than re-deriving it, so the > -- number shown is provably the number banked. > -- > -- >>> postRewardLabel 1 50 > -- "+50 gold --- you opened this thread!" > -- > -- >>> postRewardLabel 2 10 > -- "+10 gold --- first reply on this thread!" > -- > -- >>> postRewardLabel 7 1 > -- "+1 gold --- post #7 on this thread." > -- > -- A tier the caller withheld reports itself honestly rather than > -- announcing a bonus that was not paid --- an opener answering > -- themselves lands at ordinal 2 but pays 'replyBonus', and says so: > -- > -- >>> postRewardLabel 2 1 > -- "+1 gold --- post #2 on this thread." > postRewardLabel :: Int -> Int -> T.Text > postRewardLabel n g > | n == 1 = plus <> " --- you opened this thread!" > | n == 2 && g == firstReplyBonus > = plus <> " --- first reply on this thread!" > -- Numbered as a *post*, not a reply: the tier above is announced as > -- "first reply", so "reply #3" for the very next one would read as a > -- skipped #2. The ordinal counts posts, so say posts. > | otherwise = plus <> " --- post #" <> tshow n <> " on this thread." > where plus = "+" <> goldLabel g > > -- | A POSIX timestamp as @YYYY-MM-DD HH:MM UTC@. > fmtTime :: Int -> T.Text > fmtTime n = T.pack $ > formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" > (posixSecondsToUTCTime (fromIntegral n)) > > -- | A POSIX timestamp as just the @YYYY-MM-DD@ day. > fmtDay :: Int -> T.Text > fmtDay n = T.pack $ > formatTime defaultTimeLocale "%Y-%m-%d" > (posixSecondsToUTCTime (fromIntegral n)) Main dispatch ------------- `main` sets up the wire (no buffering, UTF-8) and wraps the body in `try` so any uncaught exception becomes a visible type-3 row rather than a blank response --- the worst failure a gopher client can be handed. `mainBody` parses argv, opens the DB, derives the mount point by subtracting path-info off the selector, splits path-info into segments, and routes on `(segments, hasQuery)`. Segment validators (`validToken`, `decodeLoc`) live in the pattern guards, so anything malformed falls straight through to the error page. > main :: IO () > main = do > hSetBuffering stdout NoBuffering > hSetEncoding stdout utf8 > result <- try mainBody :: IO (Either SomeException ()) > case result of > Right () -> pure () > Left e -> mapM_ putLine > [ errorItem ("diggings.lhs crashed: " <> tshow e) > , terminator > ] Resolve the tripcode salt: `DIGGINGS_SALT` in the environment wins (a convenient staging override), else the first non-blank content of the `.salt` file beside the script (relocatable via `DIGGINGS_SALT_FILE`), else the in-source `fallbackSalt`. Surrounding whitespace is stripped so a trailing newline from `echo ... > .salt` does not change the hash; a missing or empty file falls through rather than crashing. > loadSalt :: IO T.Text > loadSalt = do > envSalt <- lookupEnv "DIGGINGS_SALT" > case envSalt of > Just s -> pure (T.pack s) > Nothing -> do > saltFile <- fromMaybe defaultSaltFile <$> lookupEnv "DIGGINGS_SALT_FILE" > efile <- try (TIO.readFile saltFile) :: IO (Either SomeException T.Text) > pure $ case efile of > Right contents | not (T.null trimmed) -> trimmed > where trimmed = T.strip contents > _ -> fallbackSalt > > mainBody :: IO () > mainBody = do > req <- parseArgs <$> getArgs > host <- maybe defaultHost T.pack <$> lookupEnv "GOPHER_HOST" > port <- maybe defaultPort T.pack <$> lookupEnv "GOPHER_PORT" > dbp <- fromMaybe defaultDb <$> lookupEnv "DIGGINGS_DB" > salt <- loadSalt > conn <- openDb dbp > let pinfo = reqP req > scriptSel = T.dropEnd (T.length pinfo) (reqSel req) > ctx = Ctx scriptSel host port conn salt > segs = filter (not . T.null) (T.splitOn "/" pinfo) > query = T.strip (reqQ req) > hasQuery = not (T.null query) > dispatch ctx segs query hasQuery > close conn > > dispatch :: Ctx -> [T.Text] -> T.Text -> Bool -> IO () > dispatch ctx segs query hasQuery = case (segs, hasQuery) of > ([], False) -> landing ctx > (["login"], True ) -> handleLogin ctx query > (["login"], False) -> loginPrompt ctx > (["diggers"], _ ) -> leaderboard ctx Nothing > (["hot"], _ ) -> hotBoard ctx Nothing > (["inbox"], _ ) -> inboxSignpost ctx > (["go"], True ) -> handleGoBox ctx query > (["go"], False) -> goPrompt ctx > (["go", b], _ ) | Just loc <- decodeLoc b -> surf ctx Nothing loc > (["thread", b], _ ) | Just loc <- decodeLoc b -> threadPage ctx Nothing loc > (["s", tok], True ) | validToken tok -> handleSurfBox ctx tok query > (["s", tok], False) | validToken tok -> sessionMenu ctx tok > (["s", tok, "diggers"], _ ) | validToken tok -> leaderboard ctx (Just tok) > (["s", tok, "hot"], _ ) | validToken tok -> hotBoard ctx (Just tok) > (["s", tok, "inbox"], _ ) | validToken tok -> inboxPage ctx tok > (["s", tok, "logout"], _ ) | validToken tok -> handleLogout ctx tok > (["s", tok, "logout-all"], _ ) | validToken tok -> handleLogoutAll ctx tok > (["s", tok, "go", b], _ ) | validToken tok, Just loc <- decodeLoc b -> > surf ctx (Just tok) loc > (["s", tok, "thread", b], _ ) | validToken tok, Just loc <- decodeLoc b -> > threadPage ctx (Just tok) loc > (["s", tok, "post", b], True ) | validToken tok, Just loc <- decodeLoc b -> > handlePost ctx tok loc query > (["s", tok, "post", b], False) | validToken tok, Just loc <- decodeLoc b -> > postPrompt ctx tok loc > _ -> emitPathError ctx (T.intercalate "/" segs)