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.
 

98 lines
4.7 KiB

;; Shortcut functions for common IRC message types.
(in-package :nea/irc)
(defparameter *numeric-regex* (create-scanner "[0-9]+"))
;; Slightly stolen from protocol.lisp in cl-irc...
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun define-irc-message-class (name)
(let ((cname (intern (concatenate 'string "MSG-" (symbol-name name))))
(pname (intern (concatenate 'string "IS-MSG" (symbol-name name) "-P"))))
`(progn (defclass ,cname (irc-message) ())
(defun ,pname (obj)
(eql (class-of obj) (find-class ',cname)))
(export ',cname)
(export ',pname)))))
(defmacro define-irc-message-classes (names)
`(progn ,@(mapcar #'define-irc-message-class names)))
(define-irc-message-classes (:cap-ls :cap-req :cap-ack :cap-nak :cap-end
:nick :quit :user :error :numeric
:authenticate :privmsg :ping :pong :pass :join
:part :topic-query :topic-set :mode-query
:mode-set :names :list :notice))
(defclass msg-authenticate (irc-message-notrailing) ())
(define-condition invalid-arguments ()
((command :initarg :command :reader attempted-command-name)))
(define-condition invalid-command-name ()
((command :initarg :command :reader attempted-command-name)))
(defun irc-message-find-class (msg)
(with-accessors
((cmd message-command) (params message-parameters)) msg
(find-class
(cond
((and (equal cmd "PASS") (eql (length params) 1)) 'msg-pass)
((equal cmd "PASS") (error 'invalid-arguments :command "PASS"))
((and (equal cmd "CAP") (equal (car params) "LS")) 'msg-cap-ls)
((and (equal cmd "CAP") (equal (car params) "END")) 'msg-cap-end)
((and (equal cmd "CAP") (equal (car params) "REQ") (eql (length params) 2)) 'msg-cap-req)
((and (equal cmd "CAP") (equal (car params) "ACK") (eql (length params) 2)) 'msg-cap-ack)
((and (equal cmd "CAP") (equal (car params) "NAK") (eql (length params) 2)) 'msg-cap-nak)
((equal cmd "CAP") (error 'invalid-arguments :command "CAP"))
((and (equal cmd "NICK") (eql (length params) 1)) 'msg-nick)
((equal cmd "NICK") (error 'invalid-arguments :command "NICK"))
((and (equal cmd "PRIVMSG") (eql (length params) 2)) 'msg-privmsg)
((equal cmd "PRIVMSG") (error 'invalid-arguments :command "PRIVMSG"))
((and (equal cmd "NOTICE") (eql (length params) 2)) 'msg-notice)
((equal cmd "NOTICE") (error 'invalid-arguments :command "NOTICE"))
((and (equal cmd "JOIN") (eql (length params) 1)) 'msg-join)
((equal cmd "JOIN") (error 'invalid-arguments :command "JOIN"))
((and (equal cmd "PART") (>= (length params) 1)) 'msg-part)
((equal cmd "PART") (error 'invalid-arguments :command "PART"))
((and (equal cmd "TOPIC") (eql (length params) 1)) 'msg-topic-query)
((and (equal cmd "TOPIC") (eql (length params) 2)) 'msg-topic-set)
((equal cmd "TOPIC") (error 'invalid-arguments :command "TOPIC"))
((and (equal cmd "MODE") (eql (length params) 1)) 'msg-mode-query)
((and (equal cmd "MODE") (>= (length params) 2)) 'msg-mode-set)
((equal cmd "MODE") (error 'invalid-arguments :command "MODE"))
((equal cmd "QUIT") 'msg-quit)
((equal cmd "NAMES") 'msg-names)
((equal cmd "LIST") 'msg-list)
((and (equal cmd "USER") (eql (length params) 4)) 'msg-user)
((equal cmd "USER") (error 'invalid-arguments :command "USER"))
((and (equal cmd "AUTHENTICATE") (eql (length params) 1)) 'msg-authenticate)
((equal cmd "AUTHENTICATE") (error 'invalid-arguments :command "AUTHENTICATE"))
((equal cmd "ERROR") 'msg-error)
((equal cmd "PING") 'msg-ping)
((equal cmd "PONG") 'msg-pong)
((scan *numeric-regex* cmd) 'msg-numeric)
(t (error 'invalid-command-name :command cmd))))))
(defun irc-message-ascend (msg)
(let ((new-class (restart-case
(irc-message-find-class msg)
(parse-as-generic () (find-class 'irc-message)))))
(change-class msg new-class)))
(defun make-irc-message-source (host &key nick user)
"Makes a new IRC-MESSAGE-SOURCE instance."
(make-instance 'irc-message-source :host host :nick nick :user user))
(defun make-irc-message (command &key tags source params (lax nil))
"Makes a new IRC-MESSAGE instance."
(let ((msg (make-instance 'irc-message
:command (string-upcase command)
:tags tags :source source :parameters params)))
(if lax
msg
(irc-message-ascend msg))))
(defun parse-as-generic (c)
(declare (ignore c))
(invoke-restart 'parse-as-generic))