/src/cl-async-irc.lisp

;;;; 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)))