You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
345 lines
15 KiB
345 lines
15 KiB
(defpackage :paroxysm |
|
(:use :cl)) |
|
|
|
(in-package :paroxysm) |
|
|
|
(defparameter *quote-recursion-limit* 5) |
|
(defparameter +irc-bold+ (code-char #x02)) |
|
(defparameter +irc-colour+ (code-char #x03)) |
|
(defparameter +irc-reset+ (code-char #x0f)) |
|
(defparameter +ctcp-action-prefix+ |
|
(format nil "~AACTION " (code-char #x01))) |
|
|
|
(defvar *connection* nil) |
|
|
|
(defun parse-bracketed-integer (idx) |
|
(if (string= idx "[*]") |
|
-1 |
|
(when (and idx (> (length idx) 2)) |
|
(ignore-errors |
|
(parse-integer (subseq idx 1 (1- (length idx)))))))) |
|
|
|
(defun parse-learn (message) |
|
(cl-ppcre:register-groups-bind (subj val) |
|
("^\\?\\?([^\\[:]*):\\s*(.+)" message) |
|
(list subj val))) |
|
|
|
(defun parse-query (message) |
|
(cl-ppcre:register-groups-bind (subj idx) |
|
("^\\?\\?\\s*([^\\[:]*)(\\[[^\\]]+\\])?" message) |
|
(list |
|
subj |
|
(parse-bracketed-integer idx)))) |
|
|
|
(defun parse-qlast (message) |
|
(cl-ppcre:register-groups-bind (subj) |
|
("^\\?\\?\\s*([^\\[:]*)!" message) |
|
subj)) |
|
|
|
(defun parse-move (message) |
|
(cl-ppcre:register-groups-bind (subj idx new-idx) |
|
("^\\?\\?([^\\[:]*)(\\[[^\\]]+\\])->(.*)" message) |
|
(let ((idx-1 (parse-bracketed-integer idx)) |
|
(new-idx-1 (ignore-errors (parse-integer new-idx)))) |
|
(when (and idx-1 new-idx-1) |
|
(list subj idx-1 new-idx-1))))) |
|
|
|
(defun retrieve-quotes-raw (channel subject) |
|
"Retrieve a list of quotes for SUBJECT in CHANNEL, ignoring redirects." |
|
(tq::with-prepared-statements |
|
((get-stmt "SELECT id, quote, created_ts FROM quotes WHERE channel = ? AND subject = ? ORDER BY created_ts ASC")) |
|
(tq::bind-parameters get-stmt channel subject) |
|
(loop |
|
while (sqlite:step-statement get-stmt) |
|
collect (tq::with-bound-columns (id quote created) get-stmt |
|
(list id quote created))))) |
|
|
|
(defun retrieve-quotes (channel subject) |
|
"Retrieve a list of quotes for SUBJECT in CHANNEL, honouring redirects. Returns the quote list, and the actual subject used (after redirects)." |
|
(loop |
|
for i from 0 |
|
with cur = subject |
|
with ret |
|
while (setf ret (retrieve-quotes-raw channel cur)) |
|
if (uiop:string-prefix-p "see: " (cadar ret)) |
|
if (> i *quote-recursion-limit*) |
|
do (return-from retrieve-quotes) |
|
else |
|
do (setf cur (subseq (cadar ret) #.(length "see: "))) |
|
else |
|
do (return-from retrieve-quotes (values ret cur)))) |
|
|
|
(defun insert-quote (channel subject quote creator &optional ts) |
|
"Insert a quote into the quote database." |
|
(tq::with-prepared-statements |
|
((insert-stmt "INSERT INTO quotes (channel, subject, created_ts, quote, creator) VALUES (?, ?, ?, ?, ?)")) |
|
(let ((created-ts (or ts (get-universal-time)))) |
|
(tq::bind-parameters insert-stmt channel subject created-ts quote creator) |
|
(sqlite:step-statement insert-stmt)))) |
|
|
|
(defun delete-quote-with-id (id) |
|
"Delete the quote with the given database ID." |
|
(tq::with-prepared-statements |
|
((delete-stmt "DELETE FROM quotes WHERE id = ?")) |
|
(tq::bind-parameters delete-stmt id) |
|
(sqlite:step-statement delete-stmt))) |
|
|
|
(defun zwspize (text) |
|
"Insert a zero-width space into TEXT, to avoid it highlighting people." |
|
(if (> (length text) 1) |
|
(format nil "~A~A~A" |
|
(subseq text 0 1) |
|
(code-char #x200b) |
|
(subseq text 1)) |
|
text)) |
|
|
|
(defun iso-8601 (universal-ts) |
|
"Format a universal timestamp as ISO 8601." |
|
(multiple-value-bind (sec min hour day month year) |
|
(decode-universal-time universal-ts) |
|
(declare (ignore sec min hour)) |
|
(format nil "~4,'0D-~2,'0D-~2,'0D" year month day))) |
|
|
|
(defun irc-colour (colour-code) |
|
"Emit a string for the IRC colour code COLOUR-CODE." |
|
(format nil "~A~D" +irc-colour+ colour-code)) |
|
|
|
(defun format-quote (subject idx total-idx quote created-ts &key (with-irc-colours t)) |
|
(format nil |
|
"~A~A~A~A[~A/~A]~A: ~A ~A[~A]~A" |
|
(if with-irc-colours +irc-bold+ "") |
|
(zwspize subject) |
|
(if with-irc-colours +irc-reset+ "") |
|
(if with-irc-colours (irc-colour 15) "") |
|
idx |
|
total-idx |
|
(if with-irc-colours +irc-reset+ "") |
|
quote |
|
(if with-irc-colours (irc-colour 14) "") |
|
(iso-8601 created-ts) |
|
(if with-irc-colours +irc-reset+ ""))) |
|
|
|
(defclass quotebot (birch:connection) |
|
((autojoin |
|
:initarg :autojoin |
|
:reader autojoin) |
|
(upload-url |
|
:initarg :upload-url |
|
:initform nil |
|
:reader upload-url) |
|
(last-messages |
|
:initform (make-hash-table :test 'equalp) |
|
:accessor last-messages))) |
|
|
|
(defun irc-insert-quote (conn learn channel nick) |
|
(multiple-value-bind (quotes real-name) |
|
(retrieve-quotes channel (car learn)) |
|
(let ((name-to-use (or real-name (car learn))) |
|
(num-quotes (or (length quotes) 0)) |
|
(quote (cadr learn))) |
|
(insert-quote channel name-to-use quote nick) |
|
(birch:/notice conn channel |
|
(format-quote name-to-use |
|
(1+ num-quotes) |
|
(1+ num-quotes) |
|
quote |
|
(get-universal-time)))))) |
|
|
|
(defun format-msg-as-quote (msg nickname) |
|
"If MSG is a CTCP ACTION, translate it to a human-readable string using the NICKNAME; otherwise, add the NICKNAME on to the front of the MSG." |
|
(if (and |
|
(uiop:string-prefix-p +ctcp-action-prefix+ msg) |
|
(> (length msg) (length +ctcp-action-prefix+))) |
|
(format nil "* ~A ~A" |
|
(zwspize nickname) |
|
(subseq msg (length +ctcp-action-prefix+) |
|
(1- (length msg)))) |
|
(format nil "<~A> ~A" (zwspize nickname) msg))) |
|
|
|
(defmethod birch:handle-event ((conn quotebot) (event birch:privmsg-event)) |
|
(block nil |
|
(unless (and (birch:channel event) (birch:user event)) |
|
(return)) |
|
(let ((channel (birch:name (birch:channel event))) |
|
(nick (birch:nick (birch:user event))) |
|
(msg (birch:message event))) |
|
(alexandria:when-let ((qlast (parse-qlast msg))) |
|
(let ((last (gethash (cons qlast channel) (last-messages conn)))) |
|
(unless last |
|
(birch:/notice conn channel |
|
(format nil "~A~A~A: no previous message found" |
|
+irc-bold+ |
|
qlast |
|
+irc-reset+)) |
|
(return)) |
|
(format t "[~A in ~A] inserted last-quote for ~A~%" nick channel qlast) |
|
(irc-insert-quote conn (list qlast last) channel nick) |
|
(return))) |
|
(alexandria:when-let ((move (parse-move msg))) |
|
(destructuring-bind (subj idx new-idx) move |
|
(multiple-value-bind (quotes real-name) |
|
(retrieve-quotes channel subj) |
|
(unless quotes |
|
(birch:/notice conn channel |
|
(format nil "~A~A~A: never heard of it" |
|
+irc-bold+ |
|
subj |
|
+irc-reset+)) |
|
(return)) |
|
(unless (eql new-idx -1) |
|
(birch:/notice conn channel |
|
"error: moving quotes not supported any more") |
|
(return)) |
|
(unless (and (< (1- idx) (length quotes)) |
|
(> idx 0)) |
|
(birch:/notice conn channel |
|
(format nil "~A~A~A: only has ~A quotes" |
|
+irc-bold+ real-name +irc-reset+ |
|
(length quotes))) |
|
(return)) |
|
(delete-quote-with-id (first (elt quotes (1- idx)))) |
|
(format t "[~A in ~A] deleted quote ~A of ~A~%" nick channel idx real-name) |
|
(birch:/notice conn channel |
|
(format nil "~A~A~A: deleted quote ~A" |
|
+irc-bold+ real-name +irc-reset+ |
|
idx)) |
|
(return)))) |
|
(alexandria:when-let ((learn (parse-learn msg))) |
|
(irc-insert-quote conn learn channel nick) |
|
(format t "[~A in ~A] learned quote for ~A~%" nick channel (car learn)) |
|
(return)) |
|
(alexandria:when-let ((query (parse-query msg))) |
|
(multiple-value-bind (quotes real-name) |
|
(retrieve-quotes channel (car query)) |
|
(unless quotes |
|
(birch:/notice conn channel |
|
(format nil "~A~A~A: never heard of it" |
|
+irc-bold+ |
|
(car query) |
|
+irc-reset+)) |
|
(return)) |
|
(let ((idx (or (second query) |
|
(1+ (random (length quotes)))))) |
|
(when (eql idx -1) |
|
;; ??subject[*] parses as this |
|
(let ((quote-list |
|
(with-output-to-string (out) |
|
(loop |
|
for (id quote ts) in quotes |
|
for idx from 1 |
|
do (format out "~A~%" |
|
(format-quote |
|
real-name |
|
idx (length quotes) |
|
quote ts |
|
:with-irc-colours nil)))))) |
|
(unless (upload-url conn) |
|
(birch:/notice conn channel |
|
"error: no upload url set") |
|
(return)) |
|
(multiple-value-bind (body status) |
|
(drakma:http-request |
|
(upload-url conn) |
|
:method :put |
|
:content-type "text/plain" |
|
:content quote-list |
|
:external-format-out :utf-8 |
|
:additional-headers '(("Linx-Expiry" . "7200")) |
|
:user-agent "paroxysm-ng/0.1") |
|
(unless (eql status 200) |
|
(birch:/notice conn channel |
|
(format nil "error: returned status ~A" |
|
status)) |
|
(return)) |
|
(let ((url (string-right-trim '(#\Return #\Linefeed #\Space) body))) |
|
(format t "[~A in ~A] uploaded ~A to ~A~%" nick channel real-name url) |
|
(birch:/notice conn channel |
|
(format nil "~A~A~A: uploaded ~A quotes to ~A~A11~A~A" |
|
+irc-bold+ real-name +irc-reset+ |
|
(length quotes) |
|
+irc-bold+ +irc-colour+ url |
|
+irc-reset+)) |
|
(return))))) |
|
(unless (and (< (1- idx) (length quotes)) |
|
(> idx 0)) |
|
(birch:/notice conn channel |
|
(format nil "~A~A~A: only has ~A quotes" |
|
+irc-bold+ real-name +irc-reset+ |
|
(length quotes))) |
|
(return)) |
|
(let ((quote (elt quotes (1- idx)))) |
|
(format t "[~A in ~A] retrieved ~A of ~A~%" nick channel idx real-name) |
|
(birch:/notice conn channel |
|
(format-quote real-name idx (length quotes) |
|
(second quote) |
|
(third quote)))) |
|
(return)))) |
|
;; record the message for later "quote last message" action |
|
(setf (gethash (cons nick channel) (last-messages conn)) |
|
(format-msg-as-quote msg nick))))) |
|
|
|
(defmethod birch:handle-message ((conn quotebot) |
|
prefix |
|
(command (eql :RPL_WELCOME)) |
|
params) |
|
(format t "[+] connected to IRC, joining channels~%") |
|
(dolist (chan (autojoin conn)) |
|
(birch:/join conn chan))) |
|
|
|
(defun database-has-schema-p () |
|
"Returns T if the database has the 'quotes' table in it." |
|
(tq::with-prepared-statements |
|
((get-stmt "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'quotes'")) |
|
(sqlite:step-statement get-stmt))) |
|
|
|
(defun make-quotebot-from-config (file) |
|
"Makes a new QUOTEBOT instance from the config file at FILE; also initializes SQLite with the configured database file." |
|
(let* ((config (cl-ini:parse-ini file)) |
|
(database (or (cl-ini:ini-value config :database) |
|
(error "specify 'database' in configuration"))) |
|
(server (or (cl-ini:ini-value config :server) |
|
(error "specify 'server' in configuration"))) |
|
(nick (or (cl-ini:ini-value config :nick) |
|
(error "specify 'nick' in configuration"))) |
|
(ssl (alexandria:when-let (v (cl-ini:ini-value config :ssl)) |
|
(unless (string= v "true") |
|
(error "value for 'ssl' should be 'true' or 'false'")) |
|
v)) |
|
(port (or (cl-ini:ini-value config :port) |
|
(if ssl 6697 6667))) |
|
(ssl-verify (or (cl-ini:ini-value config :ssl-verify) |
|
t)) |
|
(realname (or (cl-ini:ini-value config :realname) |
|
"paroxysm-ng")) |
|
(upload-url (cl-ini:ini-value config :upload-url)) |
|
(password (cl-ini:ini-value config :password)) |
|
(autojoin (alexandria:when-let (aj (cl-ini:ini-value config :autojoin)) |
|
(if (atom aj) (list aj) aj)))) |
|
(unless autojoin |
|
(warn "No channels will be automatically joined. This is probably not what you want; set 'autojoin' to a list of channels, comma-separated, in the configuration.")) |
|
(tq::connect-database database) |
|
(unless (database-has-schema-p) |
|
(error "database has no 'quotes' table: import schema.sql into it")) |
|
(make-instance 'quotebot |
|
:server-host server |
|
:server-port port |
|
:nick nick |
|
:ssl ssl |
|
:ssl-verify ssl-verify |
|
:real-name realname |
|
:pass password |
|
:upload-url upload-url |
|
:autojoin autojoin))) |
|
|
|
(defun main () |
|
(when (< (length sb-ext:*posix-argv*) 2) |
|
(format *error-output* "fatal: a path to the config file must be provided~%") |
|
(format *error-output* "usage: ~A CONFIG_FILE~%" (elt sb-ext:*posix-argv* 0)) |
|
(sb-ext:exit :code 2 :abort t)) |
|
(let ((config-file (elt sb-ext:*posix-argv* 1))) |
|
(format t "[*] paroxysm-ng / an eta project <https://eta.st>~%") |
|
(format t "[+] loading configuration at ~A~%" config-file) |
|
(setf *connection* (make-quotebot-from-config config-file)) |
|
(format t "[+] connecting to IRC~%") |
|
(birch:connect *connection*) |
|
(birch:process-message-loop *connection*)))
|
|
|