#!/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. 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.) 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 landing (stake-a-name prompt) $SCRIPT/login + name#secret mint a session, return its link $SCRIPT/diggers gold leaderboard + recent strikes $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//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 `INSERT OR IGNORE` 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. 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.Maybe (fromMaybe, isJust, 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 = 5 -- extra gold for a first-ever discovery > > 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 > > postsOnLeaderboard :: Int > postsOnLeaderboard = 10 -- latest posts shown on the leaderboard > > nameMax, secretMax, bodyMax :: Int > nameMax = 24 > secretMax = 128 > bodyMax = 2000 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 ok > where ok 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 > > -- | 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 10 . 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 > > -- | 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, six 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))" > ] > > -- | 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'" > ] 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) 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'. > addPost :: Connection -> Loc -> T.Text -> T.Text -> T.Text -> Int -> IO () > addPost conn (Loc h p s t) name trip body now = execute conn > "INSERT INTO post (host, port, sel, typ, name, trip, body, posted)\ > \ VALUES (?,?,?,?,?,?,?,?)" (h, p, s, T.singleton t, name, trip, body, now) > > -- | 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)) Leaderboard queries. > 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 > -- "global activity" half of the leaderboard. > 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 landing stays sparse: a three-line blurb, one stake-a-name search box, one leaderboard link. Everything else is reachable from a session menu or a thread page, which are the canonical per-resource surfaces. > landing :: Ctx -> IO () > landing ctx = 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 "" > , selfRow ctx '7' "Stake your name (type: name#secret)" "/login" > , selfRow ctx '1' "Diggers --- gold leaderboard & recent strikes" "/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, a surf box, a resume > -- link if you have been somewhere, and the leaderboard. > 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 > 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 <> ".") > , infoLine "Surf to a hole to strike gold on new ground." > , infoLine "" > , selfRow ctx '7' "Surf to a hole (host[:port][/][/sel])" ("/s/" <> tok) > ] ++ resumeRow ++ > [ 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 and who's here > -- 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 () > 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)) > 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, 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 > 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) ] > 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 > ] ++ hereRow ++ > [ infoLine "" > , selfRow ctx '1' "Surf here (enter this page 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 "" > , 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 "" > , 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, confirm. > 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) > if T.null body > then mapM_ putLine > [ errorItem "Empty post --- nothing was saved." > , selfRow ctx '7' "Try again" ("/s/" <> tok <> "/post/" <> encodeLoc loc) > , terminator > ] > else do > now <- epochNow > addPost (ctxConn ctx) loc name trip body now > touchPresence (ctxConn ctx) tok loc now > mapM_ putLine > [ infoLine ("Posted to " <> gopherUri loc <> " as " <> ident name trip <> ".") > , infoLine "(Don't refresh --- that would re-post. Use a link below.)" > , 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: top gold, then the most recent first-ever > -- strikes, and the latest posts across all threads. Threads the > -- viewer's session token (if any) through every link, so a look > -- never logs you out. > leaderboard :: Ctx -> Maybe T.Text -> IO () > leaderboard ctx mtok = do > tops <- topPlayers (ctxConn ctx) 15 > discs <- recentDiscoveries (ctxConn ctx) 10 > posts <- latestPosts (ctxConn ctx) postsOnLeaderboard > mapM_ putLine $ > [ infoLine "[diggings] diggers --- gold leaderboard" > , infoLine "" > ] ++ > (if null tops > then [ infoLine "(nobody has struck gold yet)" ] > else zipWith rankRow [1 ..] tops) ++ > [ infoLine "" > , infoLine "recent strikes (first-ever discoveries):" > ] ++ > (if null discs > then [ infoLine "(none yet)" ] > else map discRow discs) ++ > [ infoLine "" > , infoLine "latest posts (across all threads):" > ] ++ > (if null posts > then [ infoLine "(no posts yet --- be the first)" ] > else map postRow posts) ++ > [ 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") > 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/" > > 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" > > -- | 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 <> ") ---" > > -- | 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 > (["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, "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)