#!/usr/bin/env stack
> -- stack script --resolver nightly-2025-12-01 --package text --package process --package time --package bytestring --package liquidhaskell
girc.lhs: a gopher-to-IRC client
================================
A small literate-Haskell applet that bridges a single gopher
request onto an IRC channel. Each hit opens a TLS connection to
`irc.someodd.zip:6697`, registers with a nick derived from the
caller's IP, `JOIN`s a channel, optionally posts the search query
as a `PRIVMSG`, lurks for a few seconds streaming whatever live
traffic shows up, then `QUIT`s and renders the snapshot as a
gophermap.
Gopher is request/response and IRC is a persistent session, so rather
than hold a connection open, girc reads the channel's *shared log* —
the on-disk transcript the always-on `oddbot` logger (`ii`) appends
to, the same `out` file `qdb` mines for quotes. The page you land on
*is* that scrollback, current to the last line `ii` wrote: no
connection, no lurk, just a fast file read.
Posting is the only time girc dials IRC. A "say something" query opens
a short-lived connection, sends one line, and disconnects; `ii` logs
the echo, so your message reappears in the scrollback when the page
re-renders. Because a gopher client re-sends the query on refresh,
girc checks the log first and won't re-post a line it already sent
within the last 'dedupWindow' seconds — so a refresh never
double-sends. (For ranked text search of the gopherhole itself, that's
`grep.lhs`, not this.)
The IRC protocol is spoken through `openssl s_client` rather than a
Haskell TLS stack, keeping the runtime dependencies to boot libraries
(`text`, `process`, `time`, `bytestring`) plus one external binary,
`openssl`, on PATH — which a box that already terminates TLS has —
and no certificate-store plumbing. The resolver is pinned to
`nightly-2025-12-01` (matching `grep.lhs`) so the file can opt into
LiquidHaskell; see "LiquidHaskell verification" below.
URL design
----------
/applets/girc.lhs -> scrollback for the default
channel, with a "say something"
prompt above and below the log.
/applets/girc.lhs + text -> post `text` to the channel as
this caller's nick, then show
the scrollback including it.
/applets/girc.lhs/#ops -> path-info picks the channel:
`/#ops` -> `#ops`, `/lobby` ->
`#lobby`. Only channels the
oddbot logger sits in have a
log to show.
The search prompt loops back to the same selector, so posting keeps
you in the same channel.
Identity
--------
The caller never picks a name. The nick (and the IRC `USER`
username) is a hash of `$remote_ip` rendered as six lowercase
letters — deterministic per IP, so the same visitor keeps the same
handle across requests, and anonymous enough that it isn't their
address in clear. Six letters because that sits comfortably under
every server's `NICKLEN`; the base-26 expansion of the hash is
truncated to fit. An empty IP (peer not looked up) falls back to
`guest`. On a `433 nick in use` collision we retry a handful of
times with a digit-suffixed variant.
Everything that reaches the wire from untrusted input — the query
text and the path-info-derived channel — is stripped of CR/LF/TAB
first (see `sanitize` / `sanitizeChan`), so a query like
`hi\r\nQUIT` can't smuggle a second IRC command onto the socket.
Configuration
-------------
Env vars (all optional) let you retarget without editing the file:
IRC_HOST default irc.someodd.zip
IRC_PORT default 6697
IRC_TLS default 1 ("0" -> plaintext via `nc`, e.g. localhost)
IRC_CHANNEL default #main (path-info overrides per request)
IRC_LISTEN default 6 (seconds to lurk; clamped to 1..30)
GOPHER_HOST default gopher.someodd.zip (for self-links)
GOPHER_PORT default 70
GIRC_IRC_BASE default /home/venusia/irc (ii's -i data dir; /log reads
/127.0.0.1//out)
So a local test box with a plaintext ircd is:
IRC_HOST=localhost IRC_PORT=6667 IRC_TLS=0 ./girc.lhs /applets/girc.lhs "hello" "" 127.0.0.1
Running the doctests
--------------------
doctest-lhs girc.lhs
Reuses this file's own `-- stack` directive and language pragmas, so
doctest sees the same packages and extensions `run-cached-lhs`
compiles against. The pure helpers (nick derivation, IRC line
parsing, channel/selector munging, gophermap builders, the log-line
parser and timestamp formatter) carry `>>>` examples; the IO half
(the socket loop, the log read) is exercised by hitting the applet.
LiquidHaskell verification
--------------------------
Like `grep.lhs`, this applet enables the LiquidHaskell GHC plugin for
a few targeted refinements — not a full totality/termination proof.
The two `--no-*` options switch those defaults off (the nick
expansion `lettersOf` is deliberately infinite, and `parseArgs` is a
cons-pattern catch-all), leaving the specific checks we want:
* `maxLogLines`, `maxMsgLen`, `maxNickRetries` carry *verified*
numeric bounds — drop one below its bound and compilation fails
before the binary is cached.
* `sanitize :: T.Text -> SafeText` is *assumed*: LH trusts, without
proving, that it yields text free of CR/LF/TAB row-breaks. The
body is six characters of `T.map`, doctested below — a deliberate,
auditable trust boundary, and groundwork for later refining the
gophermap builders to demand sanitised input.
The compile reuses the same `nightly-2025-12-01` snapshot `grep.lhs`
already builds, so the LH dependency tree is paid once per resolver,
not per applet; `z3` must be on PATH at build time. As with grep,
`doctest-lhs` rewrites the plugin pragma to an inert comment for the
doctest run.
Module header and imports
-------------------------
> {-# LANGUAGE OverloadedStrings #-}
> {-# OPTIONS_GHC -fplugin=LiquidHaskell #-}
>
> {-@ LIQUID "--no-totality" @-}
> {-@ LIQUID "--no-termination" @-}
>
> module Main (main) where
>
> import Control.Exception (SomeException, try)
> import Data.Bits (xor)
> import qualified Data.ByteString as BS
> import Data.Char (chr, ord)
> import Data.Maybe (fromMaybe, mapMaybe)
> import qualified Data.Text as T
> import qualified Data.Text.Encoding as TE
> import qualified Data.Text.Encoding.Error as TEE
> import qualified Data.Text.IO as TIO
> import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime,
> getCurrentTime)
> import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
> import Data.Time.Format (defaultTimeLocale, formatTime)
> import Data.Word (Word32)
> import System.Environment (getArgs, lookupEnv)
> import System.IO (BufferMode (..), Handle, IOMode (..),
> hFlush, hGetLine, hSetBuffering,
> hSetEncoding, hSetNewlineMode,
> hWaitForInput, openFile, stdout,
> universalNewlineMode, utf8)
> import System.Process (CreateProcess (..), ProcessHandle,
> StdStream (..), createProcess, proc,
> terminateProcess)
> import Text.Read (readMaybe)
Defaults
--------
> defaultIrcHost, defaultIrcPort, defaultChan :: T.Text
> defaultIrcHost = "irc.someodd.zip"
> defaultIrcPort = "6697"
> defaultChan = "#main"
> defaultGopherHost, defaultGopherPort :: T.Text
> defaultGopherHost = "gopher.someodd.zip"
> defaultGopherPort = "70"
The public IRC endpoint we advertise to humans in the page footer.
Deliberately separate from the host/port the bridge itself dials
(which can be overridden to loopback via `IRC_HOST`/`IRC_PORT`): the
footer should always show the address a visitor types into their own
IRC client, not whatever internal socket we happen to use.
> publicHost, publicPort :: T.Text
> publicHost = "irc.someodd.zip"
> publicPort = "6697"
> defaultListen :: Int
> defaultListen = 6 -- seconds to lurk after joining
> {-@ maxMsgLen :: {v:Int | v >= 1} @-}
> maxMsgLen :: Int
> maxMsgLen = 400 -- IRC lines cap at 512 incl. CRLF
> {-@ maxNickRetries :: {v:Int | v >= 0} @-}
> maxNickRetries :: Int
> maxNickRetries = 3 -- 433 (nick-in-use) retry budget
Scrollback comes from the shared on-disk log that the `oddbot` `ii`
logger appends to — the same `out` file `qdb` reads. `ii` runs as
the `venusia` user (the user that runs applets), so the applet can
read `out` directly; no mirror, no second connection. `ii` names its
data dir after the host it dialled, hence `logNetDir = 127.0.0.1`
(loopback to the local ngircd). Override the base with
`GIRC_IRC_BASE` if `ii`'s `-i` dir differs.
> logIrcBase, logNetDir :: T.Text
> logIrcBase = "/home/venusia/irc"
> logNetDir = "127.0.0.1"
> {-@ maxLogLines :: {v:Int | v >= 1} @-}
> maxLogLines :: Int
> maxLogLines = 100 -- scrollback rows shown (tail of the log)
> -- | Window (seconds) within which an identical (nick, message) already
> -- in the log is treated as a refresh of an already-sent line rather
> -- than a new post. Long enough to absorb a refresh, short enough that
> -- a deliberate repeat a minute or two later still goes through.
> {-@ dedupWindow :: {v:Int | v >= 0} @-}
> dedupWindow :: Int
> dedupWindow = 90
Request context
---------------
Everything resolved for one request: where to talk IRC, who we are,
what to say, and the gopher coordinates for self-links.
> data Ctx = Ctx
> { ctxIrcHost :: T.Text
> , ctxIrcPort :: T.Text
> , ctxTLS :: Bool
> , ctxListen :: Int
> , ctxChan :: T.Text
> , ctxNick :: T.Text
> , ctxMsg :: T.Text -- already sanitized; empty = lurk only
> , ctxSel :: T.Text -- full selector that resolved (for the prompt)
> , ctxScriptSel :: T.Text -- selector minus path-info (for /log self-links)
> , ctxGHost :: T.Text
> , ctxGPort :: T.Text
> }
Request parsing
---------------
Four positional argv from Venusia (`$selector`, `$search`,
`$pathinfo`, `$remote_ip`), matched with a cons pattern so future
arg additions don't break us. Empty argv still yields a usable
selector default — unlike grep we don't hard-fail, because a missing
selector only costs us a slightly wrong self-link, not correctness.
> data Args = Args
> { argSel :: T.Text
> , argQ :: T.Text
> , argP :: T.Text
> , argIp :: T.Text
> }
> {-@ ignore parseArgs @-}
> parseArgs :: [String] -> Args
> parseArgs (s:q:p:ip:_) = Args (T.pack s) (T.pack q) (T.pack p) (T.pack ip)
> parseArgs [s,q,p] = Args (T.pack s) (T.pack q) (T.pack p) T.empty
> parseArgs [s,q] = Args (T.pack s) (T.pack q) T.empty T.empty
> parseArgs [s] = Args (T.pack s) T.empty T.empty T.empty
> parseArgs [] = Args "/applets/girc.lhs" T.empty T.empty T.empty
Identity helpers
----------------
A 32-bit FNV-1a hash over the IP's characters, then expanded into
lowercase letters base-26 and truncated to six. Letters-only means
the result is always a valid IRC nick (no leading digit, no special
bytes), and deterministic means one visitor keeps one handle.
> fnv1a :: T.Text -> Word32
> fnv1a = T.foldl' step 2166136261
> where step h c = (h `xor` fromIntegral (ord c)) * 16777619
> -- | A six-character IRC nick derived from a client IP. Always six
> -- lowercase letters for a non-empty IP; @"guest"@ when the peer
> -- couldn't be looked up. Stable per IP, so a visitor keeps their
> -- handle across requests.
> --
> -- >>> nickFromIp ""
> -- "guest"
> --
> -- >>> T.length (nickFromIp "203.0.113.7")
> -- 6
> --
> -- >>> T.all (\c -> c >= 'a' && c <= 'z') (nickFromIp "203.0.113.7")
> -- True
> --
> -- >>> nickFromIp "203.0.113.7" == nickFromIp "203.0.113.7"
> -- True
> nickFromIp :: T.Text -> T.Text
> nickFromIp ip
> | T.null ip = "guest"
> | otherwise = T.pack (take 6 (lettersOf (fnv1a ip)))
> where
> lettersOf h = let (q, r) = h `divMod` 26
> in chr (ord 'a' + fromIntegral r) : lettersOf q
> -- | A collision fallback nick: same stem, last letter swapped for a
> -- digit, still six characters.
> --
> -- >>> altNick "abcdef" 0
> -- "abcde0"
> --
> -- >>> altNick "abcdef" 2
> -- "abcde2"
> altNick :: T.Text -> Int -> T.Text
> altNick base n = T.take 6 (T.dropEnd 1 base <> T.pack (show n))
Channel + selector munging
--------------------------
> -- | Strip the bytes a channel name must never contain. Channels can't
> -- hold spaces, commas, or row-break bytes.
> --
> -- >>> sanitizeChan "#foo bar"
> -- "#foobar"
> --
> -- >>> sanitizeChan "#a,b\r\n"
> -- "#ab"
> sanitizeChan :: T.Text -> T.Text
> sanitizeChan = T.filter (\c -> c `notElem` (" ,\r\n\t\0" :: String))
> -- | Pick the channel for this request: path-info first segment wins,
> -- otherwise the configured default. A leading @#@ is preserved; a
> -- bare name gets one prepended.
> --
> -- >>> channelFrom "#default" ""
> -- "#default"
> --
> -- >>> channelFrom "#default" "/lobby"
> -- "#lobby"
> --
> -- >>> channelFrom "#default" "/#ops/sub"
> -- "#ops"
> channelFrom :: T.Text -> T.Text -> T.Text
> channelFrom def pinfo = case pathSegments pinfo of
> (seg:_) -> toChannel seg
> [] -> sanitizeChan def
> -- | Normalise a path segment into a channel name: keep a leading @#@,
> -- add one otherwise, then strip bytes a channel can't hold.
> --
> -- >>> toChannel "lobby"
> -- "#lobby"
> --
> -- >>> toChannel "#ops"
> -- "#ops"
> toChannel :: T.Text -> T.Text
> toChannel name = sanitizeChan (if "#" `T.isPrefixOf` name then name else "#" <> name)
> -- | Split path-info into non-empty, slash-delimited segments. The
> -- first segment selects the view (@log@) or, for the live view, the
> -- channel.
> --
> -- >>> pathSegments "/log/#ops"
> -- ["log","#ops"]
> --
> -- >>> pathSegments ""
> -- []
> --
> -- >>> pathSegments "/lobby"
> -- ["lobby"]
> pathSegments :: T.Text -> [T.Text]
> pathSegments = filter (not . T.null) . T.splitOn "/" . T.strip
IRC line helpers
----------------
> -- | If the line is a server PING, the PONG to send back; otherwise
> -- 'Nothing'. We mirror the token verbatim.
> --
> -- >>> pongReply "PING :irc.someodd.zip"
> -- Just "PONG :irc.someodd.zip"
> --
> -- >>> pongReply "PRIVMSG #x :hi"
> -- Nothing
> pongReply :: T.Text -> Maybe T.Text
> pongReply line = case T.stripPrefix "PING" line of
> Just rest | T.isPrefixOf " " rest || T.isPrefixOf ":" rest -> Just ("PONG" <> rest)
> _ -> Nothing
> -- | Parse a channel @PRIVMSG@ into (sender nick, target, message).
> -- 'Nothing' for anything that isn't one.
> --
> -- >>> parsePrivmsg ":alice!a@h PRIVMSG #chan :hello there"
> -- Just ("alice","#chan","hello there")
> --
> -- >>> parsePrivmsg ":bob!b@h PRIVMSG #chan :"
> -- Just ("bob","#chan","")
> --
> -- >>> parsePrivmsg "PING :x"
> -- Nothing
> parsePrivmsg :: T.Text -> Maybe (T.Text, T.Text, T.Text)
> parsePrivmsg line
> | not (T.isPrefixOf ":" line) = Nothing
> | otherwise =
> let rest = T.drop 1 line
> (prefix, after) = T.breakOn " " rest
> who = T.takeWhile (/= '!') prefix
> body = T.drop 1 after
> in case T.stripPrefix "PRIVMSG " body of
> Nothing -> Nothing
> Just r ->
> let (target, afterT) = T.breakOn " " r
> raw = T.drop 1 afterT
> msg = fromMaybe raw (T.stripPrefix ":" raw)
> in Just (who, target, msg)
> -- | Parse a JOIN/PART/QUIT into (actor, past-tense verb). The actor is
> -- returned separately so the caller can suppress narrating itself.
> --
> -- >>> parseEvent ":alice!a@h JOIN #chan"
> -- Just ("alice","joined")
> --
> -- >>> parseEvent ":bob!b@h QUIT :bye"
> -- Just ("bob","quit")
> --
> -- >>> parseEvent ":x!y@z PRIVMSG #c :hi"
> -- Nothing
> parseEvent :: T.Text -> Maybe (T.Text, T.Text)
> parseEvent line
> | not (T.isPrefixOf ":" line) = Nothing
> | otherwise =
> let rest = T.drop 1 line
> (prefix, after) = T.breakOn " " rest
> who = T.takeWhile (/= '!') prefix
> body = T.drop 1 after
> (cmd, _) = T.breakOn " " body
> in case lookup cmd [("JOIN", "joined"), ("PART", "left"), ("QUIT", "quit")] of
> Just verb -> Just (who, verb)
> Nothing -> Nothing
> -- | An event rendered as a snapshot notice.
> --
> -- >>> renderEvent ("alice", "joined")
> -- "* alice joined"
> renderEvent :: (T.Text, T.Text) -> T.Text
> renderEvent (who, verb) = "* " <> who <> " " <> verb
> -- | Did this line complete registration (numeric 001, RPL_WELCOME)?
> isWelcome :: T.Text -> Bool
> isWelcome = T.isInfixOf " 001 "
> -- | A chat line as the snapshot renders it.
> --
> -- >>> renderMsg "alice" "hi"
> -- " hi"
> renderMsg :: T.Text -> T.Text -> T.Text
> renderMsg who msg = "<" <> who <> "> " <> msg
Gophermap line builders
-----------------------
Same conventions as the other applets. `sanitize` strips CR/LF/TAB
out of any field carrying user-supplied or off-network text so a
stray byte can't forge a gophermap row.
> putLine :: T.Text -> IO ()
> putLine t = TIO.putStr (t <> "\r\n") >> hFlush stdout
> -- | An info-line gophermap row (item type @i@).
> --
> -- >>> infoLine "hello"
> -- "ihello\tnull\terror.host\t1"
> infoLine :: T.Text -> T.Text
> infoLine msg = "i" <> sanitize msg <> "\tnull\terror.host\t1"
> -- | A type-7 search prompt row.
> --
> -- >>> searchLine "Say" "/s" "host" "70"
> -- "7Say\t/s\thost\t70"
> searchLine :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text
> searchLine display sel host port =
> "7" <> sanitize display <> "\t" <> sel <> "\t" <> host <> "\t" <> port
> -- | A type-3 error row.
> --
> -- >>> errorItem "oops"
> -- "3oops\tnull\terror.host\t1"
> errorItem :: T.Text -> T.Text
> errorItem msg = "3" <> sanitize msg <> "\tnull\terror.host\t1"
> terminator :: T.Text
> terminator = "."
> -- | Replace CR, LF, and TAB with spaces so off-network text can't
> -- smuggle gophermap row breaks.
> --
> -- >>> sanitize "ok"
> -- "ok"
> --
> -- >>> sanitize "a\tb"
> -- "a b"
> --
> -- >>> sanitize "line\nbreak"
> -- "line break"
> {-@ measure noRowBreaks :: T.Text -> Bool @-}
> {-@ type SafeText = {t:T.Text | noRowBreaks t} @-}
> {-@ assume sanitize :: T.Text -> SafeText @-}
> sanitize :: T.Text -> T.Text
> sanitize = T.map (\c -> if c == '\r' || c == '\n' || c == '\t' then ' ' else c)
Scrollback (the shared channel log)
-----------------------------------
The default view reads the tail of the `oddbot` logger's `out` file —
the same append-only transcript `qdb` mines for quotes. Because `ii`
runs as `venusia`, the applet reads it directly: no mirror, no second
connection. ii writes one line per event as ` message`
(and ` -!- …` for joins/parts, which we skip). We keep only
the last 'maxLogLines' chat lines and render each with a short UTC
timestamp.
> -- | On-disk path of a channel's shared log, under @base@.
> logFilePath :: T.Text -> T.Text -> FilePath
> logFilePath base chan = T.unpack (base <> "/" <> logNetDir <> "/" <> chan <> "/out")
> -- | Keep the last @n@ elements of a list.
> --
> -- >>> lastN 2 [1,2,3,4 :: Int]
> -- [3,4]
> lastN :: Int -> [a] -> [a]
> lastN n xs = drop (max 0 (length xs - n)) xs
> -- | Parse one ii @out@ line, @\ \ message@, into its
> -- parts. Server/meta lines (@-!- …@) and anything unparseable yield
> -- 'Nothing', so the scrollback shows only chat.
> --
> -- >>> parseLogLine "1779382701 hello world"
> -- Just (1779382701,"someodd","hello world")
> --
> -- >>> parseLogLine "1779383092 -!- oddbot has joined"
> -- Nothing
> --
> -- >>> parseLogLine "garbage"
> -- Nothing
> parseLogLine :: T.Text -> Maybe (Int, T.Text, T.Text)
> parseLogLine line =
> let (epochT, rest) = T.breakOn " " line
> in case readMaybe (T.unpack epochT) of
> Nothing -> Nothing
> Just epoch ->
> let body = T.drop 1 rest
> in if "<" `T.isPrefixOf` body
> then let (nickB, msgB) = T.breakOn "> " body
> in if T.null msgB
> then Nothing
> else Just (epoch, T.drop 1 nickB, T.drop 2 msgB)
> else Nothing
> -- | Render a Unix epoch (seconds) as a short @MM-DD HH:MM@ UTC stamp.
> --
> -- >>> formatLogTime 0
> -- "01-01 00:00"
> --
> -- >>> formatLogTime 86400
> -- "01-02 00:00"
> formatLogTime :: Int -> T.Text
> formatLogTime epoch =
> T.pack (formatTime defaultTimeLocale "%m-%d %H:%M"
> (posixSecondsToUTCTime (fromIntegral epoch)))
> -- | A scrollback row as the @/log@ page renders it.
> --
> -- >>> renderLogRow (0, "bob", "hi")
> -- "[01-01 00:00] hi"
> renderLogRow :: (Int, T.Text, T.Text) -> T.Text
> renderLogRow (epoch, nick, msg) =
> "[" <> formatLogTime epoch <> "] <" <> nick <> "> " <> msg
URL linkification
-----------------
Chat is full of links, and a gopher menu can make them clickable. When
a log line contains a `gopher://` URL we emit a real menu row of the
URL's *own* item type -- the char after the path's leading slash -- so
an image URL becomes a type-`I` row, a sound a type-`s` row, a text
file a type-`0` row, and so on, with no extension-guessing. `http` and
`https` URLs become type-`h` rows with a `URL:` selector. The chat
line is still shown verbatim above the link(s); if the message is a
single URL plus some words, those words become the link's display
text, otherwise the URL labels itself.
This is injection-safe: URL tokens are whitespace-delimited (so they
contain no tabs that could forge gophermap fields), and the display
string is routed through 'sanitize'.
> -- | Trim trailing sentence punctuation a URL probably isn't part of.
> --
> -- >>> stripTrailingPunct "http://x.com/a."
> -- "http://x.com/a"
> --
> -- >>> stripTrailingPunct "gopher://h/0/f"
> -- "gopher://h/0/f"
> stripTrailingPunct :: T.Text -> T.Text
> stripTrailingPunct = T.dropWhileEnd (`elem` (".,;:!?)]}>\"'" :: String))
> -- | Does this whitespace-delimited token look like a URL we handle?
> isUrlToken :: T.Text -> Bool
> isUrlToken t = any (`T.isPrefixOf` t) ["gopher://", "http://", "https://"]
> -- | The URLs in a message, in order, with trailing punctuation trimmed.
> --
> -- >>> extractUrls "see gopher://h/I/a.jpg and http://x.com cool"
> -- ["gopher://h/I/a.jpg","http://x.com"]
> --
> -- >>> extractUrls "no links here"
> -- []
> extractUrls :: T.Text -> [T.Text]
> extractUrls = map stripTrailingPunct . filter isUrlToken . T.words
> -- | A message with its URL tokens removed -- the human "caption".
> --
> -- >>> caption "nice pic gopher://h/I/a.jpg"
> -- "nice pic"
> --
> -- >>> caption "gopher://h/I/a.jpg"
> -- ""
> caption :: T.Text -> T.Text
> caption = T.strip . T.unwords . filter (not . isUrlToken) . T.words
> -- | Turn one URL into a gophermap menu row, or 'Nothing' for a scheme
> -- we don't handle. A `gopher://` URL keeps its own item type (the char
> -- after the path's leading slash; a typeless path falls back to `1`);
> -- `http(s)://` becomes a type-`h` @URL:@ row at the given gopher
> -- host/port.
> --
> -- >>> urlToLine "g.zip" "70" "A nice image" "gopher://gopher.someodd.zip:70/I/uploads/x.jpg"
> -- Just "IA nice image\t/uploads/x.jpg\tgopher.someodd.zip\t70"
> --
> -- >>> urlToLine "g.zip" "70" "my site" "https://example.com/p"
> -- Just "hmy site\tURL:https://example.com/p\tg.zip\t70"
> --
> -- >>> urlToLine "g.zip" "70" "x" "ftp://nope/"
> -- Nothing
> urlToLine :: T.Text -> T.Text -> T.Text -> T.Text -> Maybe T.Text
> urlToLine gHost gPort display url
> | Just rest <- T.stripPrefix "gopher://" url =
> let (auth, path) = T.breakOn "/" rest
> (host, portR) = T.breakOn ":" auth
> port = if T.null portR then "70" else T.drop 1 portR
> (typ, sel) = case T.uncons (T.drop 1 path) of
> Nothing -> ('1', "")
> Just (t, s)
> | T.null s -> (t, "")
> | "/" `T.isPrefixOf` s -> (t, s)
> | otherwise -> ('1', path)
> in Just (T.cons typ d <> "\t" <> sel <> "\t" <> host <> "\t" <> port)
> | T.isPrefixOf "http://" url || T.isPrefixOf "https://" url =
> Just ("h" <> d <> "\tURL:" <> url <> "\t" <> gHost <> "\t" <> gPort)
> | otherwise = Nothing
> where d = sanitize display
> -- | Render one log entry: the chat line, then a menu row for each URL
> -- it carries. A single URL with surrounding words uses those words as
> -- its display; otherwise each URL labels itself.
> --
> -- >>> renderLogEntry "g.zip" "70" (0, "bob", "look gopher://h:70/I/pix/cat.png")
> -- ["i[01-01 00:00] look gopher://h:70/I/pix/cat.png\tnull\terror.host\t1","Ilook\t/pix/cat.png\th\t70"]
> renderLogEntry :: T.Text -> T.Text -> (Int, T.Text, T.Text) -> [T.Text]
> renderLogEntry gHost gPort row@(_, _, msg) =
> infoLine (renderLogRow row) : mapMaybe link urls
> where
> urls = extractUrls msg
> cap = caption msg
> label u = if length urls == 1 && not (T.null cap) then cap else u
> link u = urlToLine gHost gPort (label u) u
> -- | Read the last 'maxLogLines' chat lines of a channel's log,
> -- lenient-decoding bytes so a stray non-UTF-8 byte can't crash the
> -- read. A missing/unreadable file yields @[]@ (rendered "no log yet").
> readLogRows :: T.Text -> T.Text -> IO [(Int, T.Text, T.Text)]
> readLogRows base chan = do
> r <- try (BS.readFile (logFilePath base chan))
> :: IO (Either SomeException BS.ByteString)
> case r of
> Left _ -> pure []
> Right bs -> pure . lastN maxLogLines
> . mapMaybe parseLogLine
> . T.lines
> $ TE.decodeUtf8With TEE.lenientDecode bs
> -- | Has this (nick, message) already appeared in the log within
> -- 'dedupWindow' seconds of @now@? This makes a gopher refresh
> -- idempotent: a re-submitted query we just posted is recognised and
> -- not sent again.
> --
> -- >>> recentlyPosted 1000 "bob" "hi" [(950, "bob", "hi")]
> -- True
> --
> -- >>> recentlyPosted 1000 "bob" "hi" [(800, "bob", "hi")]
> -- False
> --
> -- >>> recentlyPosted 1000 "bob" "hi" [(990, "bob", "bye")]
> -- False
> --
> -- >>> recentlyPosted 1000 "bob" "hi" [(990, "al", "hi")]
> -- False
> recentlyPosted :: Int -> T.Text -> T.Text -> [(Int, T.Text, T.Text)] -> Bool
> recentlyPosted now nick msg = any match
> where match (e, n, m) = n == nick && m == msg && now - e <= dedupWindow
Main dispatch
-------------
`stdout` is `NoBuffering` so each row reaches the pipe immediately;
combined with Venusia's `stream = true` for `.lhs` applets the client
sees the page fill as the IRC window unfolds. The whole body is
wrapped in `try` so any uncaught exception becomes a visible type-3
row rather than a blank response.
> 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 ("girc.lhs crashed: " <> T.pack (show e))
> , terminator
> ]
> mainBody :: IO ()
> mainBody = do
> a <- parseArgs <$> getArgs
> ircHost <- envT "IRC_HOST" defaultIrcHost
> ircPort <- envT "IRC_PORT" defaultIrcPort
> tls <- envT "IRC_TLS" "1"
> chanDef <- envT "IRC_CHANNEL" defaultChan
> listen <- envI "IRC_LISTEN" defaultListen
> gHost <- envT "GOPHER_HOST" defaultGopherHost
> gPort <- envT "GOPHER_PORT" defaultGopherPort
> logBase <- envT "GIRC_IRC_BASE" logIrcBase
> let chan = channelFrom chanDef (argP a)
> ctx = Ctx
> { ctxIrcHost = ircHost
> , ctxIrcPort = ircPort
> , ctxTLS = tls /= "0"
> , ctxListen = clamp 1 30 listen
> , ctxChan = chan
> , ctxNick = nickFromIp (argIp a)
> , ctxMsg = sanitize (T.take maxMsgLen (T.strip (argQ a)))
> , ctxSel = argSel a -- loops back with the same channel
> , ctxScriptSel = argSel a
> , ctxGHost = gHost
> , ctxGPort = gPort
> }
> -- A query means "post this". But a gopher client re-sends the same
> -- selector+query on refresh, which would double-post; so read the
> -- log first and, if this exact line from us is already there within
> -- 'dedupWindow' seconds, treat it as a refresh and skip sending.
> -- With no query we never touch IRC -- the page is a pure log read.
> rows0 <- readLogRows logBase chan
> now <- round <$> getPOSIXTime
> post <- if T.null (ctxMsg ctx)
> then pure NoQuery
> else if recentlyPosted now (ctxNick ctx) (ctxMsg ctx) rows0
> then pure (Duplicate (ctxNick ctx))
> else do (fn, _, reg) <- runIrc ctx
> pure (if reg then Sent fn else Failed fn)
> rows <- case post of
> Sent _ -> readLogRows logBase chan -- re-read to include our line
> _ -> pure rows0
> emitPage ctx post rows
> envT :: String -> T.Text -> IO T.Text
> envT name def = maybe def T.pack <$> lookupEnv name
> envI :: String -> Int -> IO Int
> envI name def = maybe def (\s -> fromMaybe def (readMaybe s)) <$> lookupEnv name
> clamp :: Ord a => a -> a -> a -> a
> clamp lo hi = max lo . min hi
The IRC session
---------------
The posting path, used only when there's a query. We spawn `openssl
s_client` (or `nc` for the plaintext path), send `NICK`/`USER`, then
read lines until a short deadline: answering `PING`, retrying on a
nick clash, and `JOIN`ing + `PRIVMSG`ing once the welcome numeric
lands. Staying connected those few seconds lets `ii` see and log our
line before we `QUIT`; the page itself is rendered from the log, not
from what we collect here (the collected lines are ignored).
`std_err` is routed to `/dev/null` so `openssl`'s handshake chatter
never reaches the gopher response, and reads use `hWaitForInput` with
a short poll so the deadline is honoured without interrupting a
line mid-read.
> data St = St
> { stAcc :: [T.Text] -- collected display lines, newest first
> , stReg :: Bool -- have we seen RPL_WELCOME?
> , stCur :: T.Text -- current nick (may change on 433)
> , stAtt :: Int -- nick retries used
> }
> connectProc :: Ctx -> CreateProcess
> connectProc ctx
> | ctxTLS ctx = proc "openssl"
> ["s_client", "-quiet", "-connect", target]
> | otherwise = proc "nc" [T.unpack (ctxIrcHost ctx), T.unpack (ctxIrcPort ctx)]
> where target = T.unpack (ctxIrcHost ctx) ++ ":" ++ T.unpack (ctxIrcPort ctx)
> connName :: Ctx -> T.Text
> connName ctx = if ctxTLS ctx then "openssl s_client" else "nc"
> ircSend :: Handle -> T.Text -> IO ()
> ircSend h t = TIO.hPutStr h (t <> "\r\n") >> hFlush h
> runIrc :: Ctx -> IO (T.Text, [T.Text], Bool)
> runIrc ctx = do
> devnull <- openFile "/dev/null" WriteMode
> let cp = (connectProc ctx)
> { std_in = CreatePipe
> , std_out = CreatePipe
> , std_err = UseHandle devnull
> }
> spawned <- try (createProcess cp)
> :: IO (Either SomeException (Maybe Handle, Maybe Handle, Maybe Handle, ProcHandle))
> case spawned of
> Left e -> pure ( ctxNick ctx
> , ["(could not start " <> connName ctx <> ": " <> T.pack (show e) <> ")"]
> , False )
> Right (Just hin, Just hout, _, ph) -> do
> hSetBuffering hin LineBuffering
> hSetBuffering hout LineBuffering
> hSetEncoding hin utf8
> hSetEncoding hout utf8
> hSetNewlineMode hout universalNewlineMode
> ircSend hin ("NICK " <> ctxNick ctx)
> ircSend hin ("USER " <> ctxNick ctx <> " 0 * :gopher-irc")
> start <- getCurrentTime
> let deadline = addUTCTime (fromIntegral (ctxListen ctx)) start
> final <- listenLoop ctx hin hout deadline (St [] False (ctxNick ctx) 0)
> _ <- try (ircSend hin "QUIT :gopher-irc") :: IO (Either SomeException ())
> terminateProcess ph
> pure (stCur final, reverse (stAcc final), stReg final)
> Right _ -> pure (ctxNick ctx, ["(connection pipes unavailable)"], False)
`ProcHandle` is just `System.Process`'s `ProcessHandle`; we alias it
locally only so the `try` annotation above reads cleanly.
> type ProcHandle = ProcessHandle
> listenLoop :: Ctx -> Handle -> Handle -> UTCTime -> St -> IO St
> listenLoop ctx hin hout deadline = go
> where
> go st = do
> now <- getCurrentTime
> let remain = realToFrac (diffUTCTime deadline now) :: Double
> if remain <= 0
> then pure st
> else do
> let ms = max 1 (min 400 (round (remain * 1000)))
> ready <- try (hWaitForInput hout ms) :: IO (Either SomeException Bool)
> case ready of
> Left _ -> pure st -- EOF / closed
> Right False -> go st -- nothing yet; recheck clock
> Right True -> do
> eline <- try (hGetLine hout) :: IO (Either SomeException String)
> case eline of
> Left _ -> pure st
> Right raw -> handleLine ctx hin st (T.dropWhileEnd (== '\r') (T.pack raw)) >>= go
> handleLine :: Ctx -> Handle -> St -> T.Text -> IO St
> handleLine ctx hin st line
> | Just pong <- pongReply line = ircSend hin pong >> pure st
> | not (stReg st) && " 433 " `T.isInfixOf` line =
> if stAtt st >= maxNickRetries
> then pure st
> else do
> let n' = altNick (ctxNick ctx) (stAtt st)
> ircSend hin ("NICK " <> n')
> pure st { stCur = n', stAtt = stAtt st + 1 }
> | not (stReg st) && isWelcome line = do
> ircSend hin ("JOIN " <> ctxChan ctx)
> extra <- if T.null (ctxMsg ctx)
> then pure []
> else do
> ircSend hin ("PRIVMSG " <> ctxChan ctx <> " :" <> ctxMsg ctx)
> pure [renderMsg (stCur st) (ctxMsg ctx)]
> pure st { stReg = True, stAcc = extra ++ stAcc st }
> | Just (who, _, msg) <- parsePrivmsg line = pure st { stAcc = renderMsg who msg : stAcc st }
> | Just ev@(who, _) <- parseEvent line =
> if who == stCur st -- don't narrate ourselves joining/leaving
> then pure st
> else pure st { stAcc = renderEvent ev : stAcc st }
> | otherwise = pure st
The page
--------
Scrollback *is* the page. A two-line header names the channel, the
public connection address, and the caller's auto-assigned handle; a
"say something" prompt sits directly under it and again at the foot
of the log, so you can post without scrolling either way. No footer,
no separate live view — the shared log is already current to the last
line `ii` wrote. @post@ records the outcome: 'NoQuery' for a plain
view, 'Sent' / 'Failed' after a post attempt (the nick may differ
from the IP-hash one if a `433` clash forced a retry), or 'Duplicate'
when a refresh re-submitted a line we had already sent.
> data Post = NoQuery | Sent T.Text | Failed T.Text | Duplicate T.Text
> emitPage :: Ctx -> Post -> [(Int, T.Text, T.Text)] -> IO ()
> emitPage ctx post rows = mapM_ putLine $
> [ infoLine "girc - IRC over gopher"
> , infoLine (ctxChan ctx <> " on " <> publicHost <> ":" <> publicPort
> <> " (SSL) - you are \"" <> who <> "\"")
> , infoLine ""
> , prompt
> ]
> ++ postNote
> ++ [ infoLine "" ]
> ++ body
> ++ [ infoLine "", prompt, terminator ]
> where
> who = case post of
> NoQuery -> ctxNick ctx
> Sent n -> n
> Failed n -> n
> Duplicate n -> n
> prompt = searchLine ("Say something as " <> who)
> (ctxSel ctx) (ctxGHost ctx) (ctxGPort ctx)
> body = if null rows
> then [ infoLine ("(no log yet for " <> ctxChan ctx <> ")") ]
> else concatMap (renderLogEntry (ctxGHost ctx) (ctxGPort ctx)) rows
> postNote = case post of
> NoQuery -> []
> Sent _ -> [ infoLine "(sent)" ]
> Failed _ -> [ infoLine "(could not reach IRC -- message not sent)" ]
> Duplicate _ -> [ infoLine "(already sent -- a refresh will not repost)" ]