CL reimplementation of paroxysm
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

(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 "[*]")
(when (and idx (> (length idx) 2))
(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)
(parse-bracketed-integer idx))))
(defun parse-qlast (message)
(cl-ppcre:register-groups-bind (subj)
("^\\?\\?\\s*([^\\[:]*)!" message)
(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."
((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)
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)."
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)
do (setf cur (subseq (cadar ret) #.(length "see: ")))
do (return-from retrieve-quotes (values ret cur))))
(defun insert-quote (channel subject quote creator &optional ts)
"Insert a quote into the quote database."
((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."
((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))
(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) "")
(if with-irc-colours +irc-reset+ "")
(if with-irc-colours (irc-colour 14) "")
(iso-8601 created-ts)
(if with-irc-colours +irc-reset+ "")))
(defclass quotebot (birch:connection)
:initarg :autojoin
:reader autojoin)
:initarg :upload-url
:initform nil
:reader upload-url)
: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)
(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))
(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"
(format t "[~A in ~A] inserted last-quote for ~A~%" nick channel qlast)
(irc-insert-quote conn (list qlast last) channel nick)
(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"
(unless (eql new-idx -1)
(birch:/notice conn channel
"error: moving quotes not supported any more")
(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)))
(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+
(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))
(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"
(car query)
(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)
for (id quote ts) in quotes
for idx from 1
do (format out "~A~%"
idx (length quotes)
quote ts
:with-irc-colours nil))))))
(unless (upload-url conn)
(birch:/notice conn channel
"error: no upload url set")
(multiple-value-bind (body status)
(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"
(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
(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)))
(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))))
;; 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)
(command (eql :RPL_WELCOME))
(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."
((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'"))
(port (or (cl-ini:ini-value config :port)
(if ssl 6697 6667)))
(ssl-verify (or (cl-ini:ini-value config :ssl-verify)
(realname (or (cl-ini:ini-value config :realname)
(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 <>~%")
(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*)))