/src/cl-async-irc.lisp
Lisp | 411 lines | 347 code | 54 blank | 10 comment | 3 complexity | 05dee46cbc3cadb7feaab0ec2e529d56 MD5 | raw file
- ;;;; cl-async-irc.lisp
- (in-package #:cl-async-irc)
- ;; Connection
- (defclass connection ()
- ((socket :initarg :socket :reader connection-socket)
- (line-buffer :initform nil :accessor connection-line-buffer)
- (message-cb :initarg :message-cb :initform nil :reader connection-message-cb)
- (event-cb :initarg :event-cb :initform nil :reader connection-event-cb)
- (handlers :initform nil :accessor connection-handlers)
- (handler-id :initform 0 :accessor connection-handler-id)
- (ping-timer :initform nil :accessor connection-ping-timer)
- (logging-stream :initarg :logging-stream :initform nil :reader connection-logging-stream))
- (:documentation "Opaque connection class. Returned by `connect'"))
- (defun connect (host port &key nick user real-name connect-cb message-cb event-cb tls logging-stream ping-timeout)
- (let* ((connection (make-instance 'connection
- :message-cb message-cb
- :event-cb event-cb
- :logging-stream logging-stream)))
- (bb:catcher
- (bb:alet ((socket (connect-internal host port connection tls)))
- (setf (slot-value connection 'socket) socket)
- (when nick (nick connection nick))
- (when user (user connection user (or real-name user)))
- (when connect-cb
- (funcall connect-cb connection)))
- (t (e) (signal e)))
- (add-handler connection :ping #'send-pong)
- (when ping-timeout
- (start-ping-timer connection ping-timeout))
- connection))
- (defun connect-internal (host port connection tlsp)
- (bb:with-promise (resolve reject)
- (funcall (if tlsp #'as-ssl:tcp-ssl-connect #'as:tcp-connect)
- host port
- (lambda (sock bytes)
- (declare (ignore sock))
- (handle-read connection bytes))
- :event-cb (lambda (event)
- (handle-event connection event))
- :connect-cb (lambda (sock)
- (resolve sock)))))
- (defun disconnect (connection)
- (as:close-socket (connection-socket connection))
- (cancle-ping-timeout connection))
- ;; Common commands
- (defun nick (connection nick)
- (command connection "NICK" nick))
- (defun user (connection user realname)
- (command connection "USER" user "*" "*" realname))
- ;; TODO Support multiple channels
- (defun join (connection channel &optional password)
- (apply #'command connection "JOIN" channel (ensure-list password)))
- ;; TODO Support multiple channels
- (defun part (connection channel &optional message)
- (apply #'command connection "PART" channel (ensure-list message)))
- (defun quit (connection &optional message)
- (apply #'command connection "QUIT" (ensure-list message)))
- (defun topic (connection channel &optional topic)
- (apply #'command connection "TOPIC" channel (ensure-list topic)))
- (defun pong (connection id)
- (command connection "PONG" id))
- ;; message commands
- (defun privmsg (connection target message)
- (command connection "PRIVMSG" target message))
- (defun action (connection target message)
- (privmsg connection target
- (format nil "~aACTION ~a~a" (code-char 1) message (code-char 1))))
- ;; handlers
- (defun add-handler (connection command closure &key timeout predicate)
- (let ((id (new-handler-id connection)))
- (push (list command id closure predicate) (connection-handlers connection))
- (when timeout
- (as:with-delay (timeout) (remove-handler connection id)))
- (lambda () (remove-handler connection id))))
- (defun remove-handler (connection handler)
- (if (numberp handler)
- (setf (connection-handlers connection)
- (delete-if (lambda (x) (= (second x) handler))
- (connection-handlers connection)))
- (funcall handler)))
- (defun new-handler-id (connection)
- (with-slots (handler-id) connection
- (prog1 handler-id
- (incf handler-id))))
- ;; implementation
- (defun handle-read (connection bytes)
- (let* ((str (concatenate 'string (or (connection-line-buffer connection) "")
- (babel:octets-to-string bytes :errorp nil)))
- (lines (split-sequence:split-sequence #\Newline str)))
- (setf (connection-line-buffer connection) nil)
- (restart-ping-timer connection)
- (loop for line on lines
- do (progn
- (cond
- ((equal line '("")) nil) ; ignore
- ((null (cdr line)) ; uh, no final newline
- (setf (connection-line-buffer connection) (car line)))
- (t
- (handle-line connection (string-right-trim '(#\Return) (car line)))))))))
- (defun handle-line (connection line)
- (let ((msg (parse-message line)))
- (when (connection-logging-stream connection)
- (format (connection-logging-stream connection)
- "Message: ~a~%" msg))
- (process-handlers connection msg)
- (when-let (msg-cb (connection-message-cb connection))
- (funcall msg-cb connection msg))))
- (defun process-handlers (connection msg)
- (loop for h in (connection-handlers connection)
- when (let ((res (and (equal (car h) (message-command msg))
- (if (fourth h)
- (funcall (fourth h) connection msg)
- t))))
- res)
- do (unless (funcall (third h) connection msg)
- (remove-handler connection (second h)))))
- (defun send-pong (connection msg)
- (pong connection (car (message-params msg)))
- t)
- (defun restart-ping-timer (connection)
- (with-slots (ping-timer) connection
- (when ping-timer
- (as:free-event (car ping-timer))
- (let ((time (cdr ping-timer)))
- (setf ping-timer
- (cons (as:delay (curry #'ping-timeout connection) :time time)
- time))))))
- (defun start-ping-timer (connection time)
- (with-slots (ping-timer) connection
- (setf ping-timer
- (cons (as:delay (curry #'ping-timeout connection) :time time)
- time))))
- (defun final-ping-timeout (connection)
- (funcall (connection-event-cb connection) connection 'ping-timeout))
- (defun ping-timeout (connection)
- "Send a ping to the server and if it doesn't answer, kill it."
- (command connection "PING" (get-universal-time))
- (with-slots (ping-timer) connection
- (setf ping-timer
- (cons (as:delay (curry #'final-ping-timeout connection)
- :time (cdr ping-timer))
- (cdr ping-timer)))))
- (defun cancle-ping-timeout (connection)
- (with-slots (ping-timer) connection
- (when ping-timer
- (as:free-event (car ping-timer))
- (setf ping-timer nil))))
- (defun handle-event (connection event)
- (when-let (event-cb (connection-event-cb connection))
- (funcall event-cb connection event)))
- (defun command (connection command &rest args)
- (as:write-socket-data (connection-socket connection)
- (format nil "~a~{ ~a~}~@[ :~a~]~a~a" command (butlast args) (car (last args))
- #\return #\newline)))
- ;; parsing
- (defclass message ()
- ((prefix :initarg :prefix
- :reader message-prefix)
- (command :initarg :command
- :reader message-command)
- (params :initarg :params
- :reader message-params)))
- (defgeneric message-user-nick (message))
- (defgeneric message-user-user (message))
- (defgeneric message-user-host (message))
- (defmethod message-user-nick ((self message))
- (first (message-prefix self)))
- (defmethod message-user-user ((self message))
- (second (message-prefix self)))
- (defmethod message-user-host ((self message))
- (third (message-prefix self)))
- (defmethod print-object ((self message) stream)
- (print-unreadable-object (self stream :type t)
- (with-slots (prefix command params) self
- (format stream "~a ~a ~a" prefix command params))))
- (defun parse-message (message)
- (destructuring-bind (prefix command &rest params)
- (parse-irc-msg-internal message)
- (make-instance 'message
- :prefix prefix
- :command command
- :params params)))
- (defun parse-irc-msg-internal (message)
- (if (starts-with #\: message)
- (destructuring-bind (prefix . command) (split-string #\Space message)
- (unless command
- (error "Malformed message from server"))
- (cons (parse-irc-msg-prefix (subseq prefix 1)) (parse-irc-msg-command command)))
- (cons nil (parse-irc-msg-command message))))
- (defun parse-irc-msg-prefix (prefix)
- (split-sequence:split-sequence-if (lambda (x) (member x '(#\@ #\!))) prefix))
- (defun parse-irc-msg-command (message)
- (destructuring-bind (cmd . params) (split-string #\Space message)
- (cons (convert-command cmd) (and params (parse-irc-msg-params params)))))
- (defun parse-irc-msg-params (message)
- (if (starts-with #\: message)
- (list (subseq message 1))
- (destructuring-bind (fst-param . rest) (split-string #\Space message)
- (cons fst-param (and rest (parse-irc-msg-params rest))))))
- (defun split-string (delim string)
- (multiple-value-bind (res index)
- (split-sequence:split-sequence delim string :count 1)
- (cons (car res)
- (when (< index (length string)) (subseq string index)))))
- (defparameter *numeric-replies*
- (alist-hash-table
- '((001 . :rpl-welcome)
- (002 . :rpl-yourhost)
- (003 . :rpl-created)
- (004 . :rpl-myinfo)
- (005 . :rpl-bounce)
- (200 . :rpl-tracelink)
- (201 . :rpl-traceconnecting)
- (202 . :rpl-tracehandshake)
- (203 . :rpl-traceunknown)
- (204 . :rpl-traceoperator)
- (205 . :rpl-traceuser)
- (206 . :rpl-traceserver)
- (207 . :rpl-traceservice)
- (208 . :rpl-tracenewtype)
- (209 . :rpl-traceclass)
- (210 . :rpl-tracereconnect)
- (261 . :rpl-tracelog)
- (262 . :rpl-traceend)
- (211 . :rpl-statslinkinfo)
- (212 . :rpl-statscommands)
- (219 . :rpl-endofstats)
- (242 . :rpl-statsuptime)
- (243 . :rpl-statsoline)
- (221 . :rpl-umodeis)
- (234 . :rpl-servlist)
- (235 . :rpl-servlistend)
- (251 . :rpl-luserclient)
- (252 . :rpl-luserop)
- (253 . :rpl-luserunknown)
- (254 . :rpl-luserchannels)
- (255 . :rpl-luserme)
- (256 . :rpl-adminme)
- (257 . :rpl-adminloc1)
- (258 . :rpl-adminloc2)
- (259 . :rpl-adminemail)
- (263 . :rpl-tryagain)
- (302 . :rpl-userhost)
- (303 . :rpl-ison)
- (301 . :rpl-away)
- (305 . :rpl-unaway)
- (306 . :rpl-nowaway)
- (311 . :rpl-whoisuser)
- (312 . :rpl-whoisserver)
- (313 . :rpl-whoisoperator)
- (317 . :rpl-whoisidle)
- (318 . :rpl-endofwhois)
- (319 . :rpl-whoischannel)
- (314 . :rpl-whowasuser)
- (314 . :rpl-endofwhowas)
- (321 . :rpl-liststart)
- (322 . :rpl-list)
- (323 . :rpl-listend)
- (325 . :rpl-uniqopis)
- (324 . :rpl-channelmodeis)
- (331 . :rpl-notopic)
- (332 . :rpl-topic)
- (341 . :rpl-inviting)
- (342 . :rpl-summoning)
- (346 . :rpl-invitelist)
- (347 . :rpl-endofinvitelist)
- (348 . :rpl-exceptlist)
- (349 . :rpl-endofexceptlist)
- (351 . :rpl-version)
- (352 . :rpl-whoreply)
- (315 . :rpl-endofwho)
- (353 . :rpl-namreply)
- (366 . :rpl-endofnames)
- (364 . :rpl-links)
- (365 . :rpl-endoflinks)
- (367 . :rpl-banlist)
- (368 . :rpl-endofbanlist)
- (371 . :rpl-info)
- (374 . :rpl-endofinfo)
- (375 . :rpl-motdstart)
- (372 . :rpl-motd)
- (376 . :rpl-endofmotd)
- (381 . :rpl-youreoper)
- (382 . :rpl-rehashing)
- (383 . :rpl-youreservice)
- (391 . :rpl-time)
- (392 . :rpl-usersstart)
- (393 . :rpl-users)
- (394 . :rpl-endofusers)
- (395 . :rpl-nousers)
- ;; errors
- (401 . :err-nosuchnick)
- (402 . :err-nosuchserver)
- (403 . :err-nosuchchannel)
- (404 . :err-cannotsendtochan)
- (405 . :err-toomanychannels)
- (406 . :err-wasnosuchnick)
- (407 . :err-toomanyargets)
- (408 . :err-nosuchservice)
- (409 . :err-noorigin)
- (411 . :err-norecipient)
- (412 . :err-notexttosend)
- (413 . :err-notoplevel)
- (414 . :err-wildtoplevel)
- (415 . :err-badmask)
- (421 . :err-unknowncommand)
- (422 . :err-nomotd)
- (423 . :err-noadmininfo)
- (424 . :err-fileerror)
- (431 . :err-nonicknamegiven)
- (432 . :err-erroneusnickname)
- (433 . :err-nicknameinuse)
- (436 . :err-nickcollision)
- (437 . :err-unavailresource)
- (441 . :err-usernotinchannel)
- (442 . :err-notonchannel)
- (443 . :err-useronchannel)
- (444 . :err-nologin)
- (445 . :err-summondisabled)
- (446 . :err-userdisabled)
- (451 . :err-notregistered)
- (461 . :err-needmoreparams)
- (462 . :err-alreadyregistred)
- (463 . :err-nopermforhost)
- (464 . :err-passwdmismatch)
- (465 . :err-yourebannedcreep)
- (466 . :err-youwillbebanned)
- (467 . :err-keyset)
- (471 . :err-channelisfull)
- (472 . :err-unknownmode)
- (473 . :err-inviteonlychan)
- (474 . :err-bannedfromchan)
- (475 . :err-badchannelkey)
- (476 . :err-badchanmask)
- (477 . :err-nochanmodes)
- (478 . :err-banlistfull)
- (481 . :err-noprivileges)
- (482 . :err-chanoprivsneeded)
- (483 . :err-cantkillserver)
- (484 . :err-restricted)
- (485 . :err-uniqopprivsneeded)
- (491 . :err-nooperhost)
- (501 . :err-umodeunknownflag)
- (502 . :err-usersdontmatch))))
- (defparameter *commands*
- (alist-hash-table
- '(("PRIVMSG" . :privmsg)
- ("JOIN" . :join)
- ("PART" . :part)
- ("PING" . :ping)
- ("TOPIC" . :topic))
- :test 'equal))
- (defun convert-command (cmd)
- (if (every (lambda (x) (digit-char-p x)) cmd)
- (let ((num-reply (parse-integer cmd)))
- (or (gethash num-reply *numeric-replies*) num-reply))
- (or (gethash cmd *commands*) cmd)))