;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: DE.DATAHEAVEN.WEIRD; -*-
;;;;										;
;;;; (c) 2002 by Jochen Schmidt.
;;;;
;;;; File:            weird-irc.lisp
;;;; Revision:        0.3.0
;;;; Description:     A simple Lisp IRC Client with CLIM GUI
;;;; Date:            14.Jun.2002
;;;; Authors:         Jochen Schmidt
;;;; Tel:             (+49 9 11) 47 20 603
;;;; Email:           jsc@@dataheaven.de
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions
;;;; are met:
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above copyright
;;;;    notice, this list of conditions and the following disclaimer in the
;;;;    documentation and/or other materials provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER 
;;;; EXPRESSED NOR IMPLIED WARRANTIES -  THIS INCLUDES, BUT 
;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE
;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ;
;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION)
;;;; 
;;;; For further details contact the authors of this software.
;;;;
;;;;  Jochen Schmidt        
;;;;  Zuckmantelstr. 11     
;;;;  91616 Neusitz         
;;;;  GERMANY               
;;;;
;;;; Nürnberg, 14.Jun.2002 Jochen Schmidt
;;;;

(in-package "CL-USER")

#+lispworks
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "comm")
  (require "clim")
)

(defpackage :de.dataheaven.weird-irc
  #+mcclim (:use :clim-lisp)
  #-mcclim (:use :common-lisp)
  (:nicknames :weird-irc)
  (:export 
   #:run-weird-irc
   #:irc-message
   #:irc-privmsg-message
   #:irc-join-message
   #:irc-part-message
   #:irc-quit-message
   #:irc-notice-message
   #:arguments
   #:command
   #:source
   #:nickname
   #:trailing-argument
   #:note-irc-message))

(in-package :de.dataheaven.weird-irc)

(defconstant +soh+ #.(code-char 1))

(defun debug-log (message)
  (let ((log-file-stream (log-file-stream clim:*application-frame*)))
    (when log-file-stream
      (write-sequence message log-file-stream)
      (force-output log-file-stream))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; And now for something completely different... ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Presentation Types ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass user ()
  ((nickname :initarg :nickname :accessor nickname)
   (username :initarg :username :accessor username)
   (hostname :initarg :hostname :accessor hostname))
  (:default-initargs :nickname "Unsupplied" 
                     :username "Unsupplied"
                     :hostname "Unsupplied"))

(clim:define-presentation-method clim:present (object (type user) stream view &key)
  (declare (ignore view))
  (clim:with-text-family (stream :sans-serif)
    (write-string (nickname object) stream)))

;;; Cheap little URI hack - need something better here...

(clim:define-presentation-type uri ())
(clim:define-presentation-type url () :inherit-from 'uri)
(clim:define-presentation-type urn () :inherit-from 'uri)

#+nil
(clim:define-presentation-method clim:presentation-typep (object (type uri))
  (stringp object))

;;;;;;;;;;;;;;;;;;;;
;;; IRC Protocol ;;;
;;;;;;;;;;;;;;;;;;;;

(defun tokenize-string (string 
                        &key (delimiters '(#\Space #\Return #\Linefeed #\Newline))
                        (test (lambda (c) (find c delimiters)))
                        (start 0) (end (length string)) (omit-delimiters t))
  (flet ((get-token (start)
           (if (< start end)
             (let* ((delimiterp (funcall test (char string start)))
                    (end-of-token (funcall (if delimiterp #'position-if-not #'position-if)
                                           test string :start start)))
               (values (subseq string start end-of-token) end-of-token delimiterp))
             (values nil nil nil))))
    (let ((tokens nil)
          token delimiterp)
      (loop (multiple-value-setq (token start delimiterp) (get-token start))
            (unless (and delimiterp omit-delimiters)
              (push token tokens))
            (unless start (return-from tokenize-string (nreverse tokens)))))))

(defclass irc-message ()
  ((source :accessor source
           :initarg :source
           :type string)
   (user :accessor user
         :initarg :user)
   (host :accessor host
         :initarg :host
         :type string)
   (command :accessor command
            :initarg :command
            :type string)
   (arguments :accessor arguments
              :initarg :arguments
              :type list)
   (trailing-argument :accessor trailing-argument
                      :initarg :trailing-argument
                      :type string)
   (source-stream :accessor source-stream
                  :initarg :source-stream)
   (receive-time :accessor receive-time
                 :initarg :receive-time)
   (raw-message-string :accessor raw-message-string
                       :initarg :raw-message-string
                       :type string)))

(defclass irc-error-reply (irc-message) ())

(defmacro define-irc-message (command superclasses slots)
  (let ((name (intern (format nil "IRC-~A-MESSAGE" command))))
    `(progn
       (defmethod find-irc-message-class ((type (eql ,command)))
         (find-class ',name))
       (defclass ,name (,@@superclasses irc-message) ,slots))))

(define-irc-message :privmsg () ())
(define-irc-message :notice () ())

(define-irc-message :kick () ())
(define-irc-message :ping () ())

;; This is mixed in into all messages that cause a change to
;; some user object
(defclass user-event-mixin () ())

(define-irc-message :nick (user-event-mixin) ())
(define-irc-message :join (user-event-mixin) ())
(define-irc-message :part (user-event-mixin) ())
(define-irc-message :quit (user-event-mixin) ())
(define-irc-message :rpl_endofnames (user-event-mixin) ())
(define-irc-message :rpl_namreply () ()) ;; The endofnames reply ends this so user-event-mixin does not need to be in here

(define-irc-message :rpl_whoisuser () ())

(defmethod find-irc-message-class (type)
  (find-class 'irc-message))

(defclass ctcp-mixin ()
  ((ctcp-command :initarg :ctcp-command :accessor ctcp-command)))

(defmacro define-ctcp-message (ctcp-command superclasses slots)
  (let ((name (intern (format nil "CTCP-~A-MESSAGE" ctcp-command))))
    `(progn
       (defmethod find-ctcp-message-class ((type (eql ,ctcp-command)))
         (find-class ',name))
       (defclass ,name (,@@superclasses ctcp-mixin irc-message) ,slots)
       #+cmu(clim:define-presentation-type ,name ()
                    :inherit-from 'irc-message))))

(defclass standard-ctcp-message (ctcp-mixin irc-message) ())

(define-ctcp-message :action () ())
(define-ctcp-message :source () ())
(define-ctcp-message :finger () ())
(define-ctcp-message :version () ())
(define-ctcp-message :userinfo () ())
(define-ctcp-message :time () ())

(defmethod find-ctcp-message-class (type)
  (find-class 'standard-ctcp-message))

;; Convert a general IRC-MESSAGE to a CTCP message
(defmethod update-instance-for-different-class :before 
  ((previous irc-message)(current ctcp-mixin) &rest initargs &key &allow-other-keys)
  (let* ((text (trailing-argument previous))
         (start (position #\space text)))
    (setf (trailing-argument current)
          (if (and start (< start (length text)))
              (subseq text (1+ start) (position +soh+ text :from-end t))
            ""))))

(defmethod irc-message-sender ((msg irc-message))
  (cond ((string-equal "PRIVMSG" (command msg))
         (if (eql (char (first (arguments msg)) 0) #\#)
             (first (arguments msg))
           (source msg)))
        (t (source msg))))

(defun read-irc-message (stream)
  "Read an IRC-message from the stream"
  (let ((msg (parse-irc-message (read-line stream))))
    (setf (source-stream msg) stream)
    msg))

(declaim (inline parse-irc-message-1))
(defun parse-irc-message-1 (raw-message-string)
  (let ((index 0))
    (macrolet ((accept-char (char)
                 `(when (eql (char raw-message-string index) ,char)
                    (incf index)
                    ,char))
               (accept-to-chars (&rest chars)
                 `(let ((start index)
                        (end (position-if (lambda (char) (find char ',chars)) raw-message-string 
                                          :start index)))
                    (when end
                      (setf index end)
                      (subseq raw-message-string start end)))))
      (labels ((accept-source ()
               (and (accept-char #\:) (accept-to-chars #\! #\space)))
             (accept-user ()
               (and (accept-char #\!) (accept-to-chars #\@@ #\space)))
             (accept-host ()
               (and (accept-char #\@@) (accept-to-chars #\space)))
             (accept-command ()
               (or (and (accept-char #\space) (accept-to-chars #\space))
                   (accept-to-chars #\space)))
             (accept-arguments ()
               (tokenize-string (or (accept-to-chars #\:) (subseq raw-message-string index)) 
                                :delimiters " "))
             (accept-trailing-argument ()
               ;; A line in the IRC Protocol ends in CRLF =>
               ;; Unix  READ-LINE reads until a Linefeed occurs: "...CR"LF
               ;; Win32 READ-LINE reads until a CR followed by a Linefeed occurs: "..."CRLF
               ;; MacOS READ-LINE reads until a Carriage Return occurs: "..."CRLF
               (and (accept-char #\:)
                    #+unix (accept-to-chars #\Return)
                    #-unix (subseq raw-message-string index)))
             (irc-message (&aux source user host command arguments trailing-argument)
               (if (and (or (and (setf source (accept-source))
                                 (setf user (accept-user))
                                 (setf host (accept-host)))
                            t)
                        (setf command (accept-command))
                        (or (setf arguments (accept-arguments)) t)
                        (or (setf trailing-argument (accept-trailing-argument)) t))
                   (values source user host command arguments trailing-argument)
                 (error "IRC Message parse error
                       source: ~A
                       user: ~A
                       host: ~A
                       command: ~A
                       arguments: ~A
                       trailing-argument: ~A~%"))))
        (irc-message)))))
           
(defun parse-irc-message (raw-message-string)
  (multiple-value-bind (source user host command arguments trailing-argument)
      (parse-irc-message-1 raw-message-string)
    (let ((ctcp (parse-ctcp-message trailing-argument))
          (class (cond ((every #'digit-char-p command)
                        (case (char command 0)
                          ((#\4 #\5) (setf command (find-error-reply-name (parse-integer command)))
                           'irc-error-reply)
                          (otherwise 
                           (find-irc-message-class 
                            (setf command (find-reply-name (parse-integer command)))))))
                       (t (find-irc-message-class 
                           (setf command (intern (string-upcase command) 
                                                 (find-package :keyword))))))))
      (let ((msg (make-instance class
                                :source source
                                :user user
                                :host host
                                :command command
                                :arguments arguments
                                :source-stream nil
                                :trailing-argument trailing-argument
                                :receive-time (get-universal-time)
                                :raw-message-string raw-message-string)))
        (when ctcp
          #-cmu(change-class msg (find-ctcp-message-class ctcp) :ctcp-command ctcp)
          #+cmu
          (progn
            (change-class msg (find-ctcp-message-class ctcp))
            (reinitialize-instance msg :ctcp-command ctcp)))
        msg))))

(defun parse-ctcp-message (string)
  (flet ((is (type)
           (if (string-equal (subseq string 1 (min (length string)
                                                   (1+ (length (symbol-name type)))))
                             type)
               type nil)))
    (if (or (not (stringp string))
            (zerop (length string))
            (not (eql (char string 0) +soh+)))
        nil
      (case (char string 1)
        (#\A (is :action))
        (#\C (is :clientinfo))
        (#\P (is :ping))
        (#\S (is :source))
        (#\F (is :finger))
        (#\V (is :version))
        (#\T (is :time))
        (#\U (is :userinfo))
        (otherwise nil)))))

(defun weird-irc-main-loop (clim-frame)
  (let ((clim:*application-frame* clim-frame)
        (*debug-io* *terminal-io*))
    (with-slots (server-stream channel) clim-frame
      (%send-irc-message server-stream :join nil channel)
      (format t "joined channel ~A~%" channel)
      (format t "about to enter main-loop...~%")
      (handler-case
          (loop while (connectedp clim-frame) do
                (let ((msg (read-irc-message server-stream)))
                  (debug-log (raw-message-string msg))
                  (present-message msg)
                  (note-irc-message msg)))
        (stream-error () nil)))))

(defun present-message (message)
  (clim:present message (type-of message) :stream (clim:get-frame-pane clim:*application-frame* 'log)))

(defun %send-irc-message (stream command trailing-argument &rest arguments)
  (let ((raw-message (format nil "~A~{ ~A~}~A~A~A~A" command arguments (if trailing-argument " :" "")
                             (or trailing-argument "") #\Return #\Linefeed)))
    (write-sequence raw-message stream)
    (force-output stream)
    raw-message))

(defun send-irc-message (stream command trailing-argument &rest arguments)
  "This function should be used for messages which are meant to get displayed in the message log.
   If you want to prevent this you can use %send-irc-message"
  (send-local-message 
   (parse-irc-message
    (apply #'%send-irc-message stream command trailing-argument arguments))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Message Event handlers ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric NOTE-IRC-MESSAGE (msg))

(defmethod note-irc-message (msg))

(defmethod note-irc-message ((msg irc-error-reply))
  (format *debug-io* "[~A] ~A~%" (command msg) (trailing-argument msg))
  (force-output *debug-io*))

(defmethod note-irc-message ((msg irc-ping-message))
  (format t "PONG----> ~A~%" (trailing-argument msg))
  (%send-irc-message (source-stream msg) :pong (trailing-argument msg)))

(defmethod note-irc-message ((msg ctcp-time-message))
  (flet ((day (nr)
           (case nr (0 "Mon")(1 "Tue")(2 "Wed")(3 "Thu")(4 "Fri")(5 "Sat")(6 "Sun")
             (otherwise "Error invalid day")))
         (month (nr)
           (case nr (1 "Jan")(2 "Feb")(3 "Mar")(4 "Apr")(5 "May")(6 "Jun")
                    (7 "Jul")(8 "Aug")(9 "Sep")(10 "Oct")(11 "Nov")(12 "Dec")
             (otherwise "Error invalid day"))))
    (multiple-value-bind (second minute hour date month year day) (get-decoded-time)
      (%send-irc-message (source-stream msg) :notice 
                         (format nil "~ATIME ~A ~A ~2D ~2,'0D:~2,'0D:~2,'0D ~D~A"
                                 +soh+ (day day) (month month) date hour minute second year +soh+)
                         (source msg)))))

;; This is for fixing an issue when connecting to some EUIRC Servers
(defmethod note-irc-message ((msg irc-notice-message))
  (when (equal (subseq (trailing-argument msg) 0 (min 30 (length (trailing-argument msg))))
               (subseq "*** If you are having problems connecting due to ping timeouts, please type /notice D51890EB nospoof now." 0 30))
    (format t "Sending nospoof notice~%")
    (%send-irc-message (source-stream msg) :notice "nospoof" (no-spoof (trailing-argument msg)))))

(defun no-spoof (ta)
  (let* ((nseq (subseq ta (+ (search "/notice" ta) 8)))
         (pos1 (position #\Space nseq)))
    (subseq nseq 0 pos1)))

;;; NAMES Handling ;;;

(defun canonicalize-nickname (nick)
  (if (find (char nick 0) "@@+*")
    (subseq nick 1)
    nick))

(defun find-user (nickname &optional (frame clim:*application-frame*))
  (find nickname (users frame) :key #'nickname :test #'string-equal))

(defun intern-user (nickname &key hostname username (frame clim:*application-frame*))
  (let ((user (find-user nickname frame)))
    (cond ((null user) 
           (setf user (make-instance 'user :nickname nickname :username username :hostname hostname))
           (push user (users frame))
           (values user t))
          (t (values user nil)))))

(defun unintern-user (nickname &optional (frame clim:*application-frame*))
  (let ((user (find-user nickname frame)))
    (when user
      (setf (users frame) (delete user (users frame))))))

(defmethod self-message-p ((msg irc-message))
  (string-equal (source msg) (nickname clim:*application-frame*)))

(defmethod note-irc-message ((msg irc-rpl_namreply-message))
  (dolist (nickname (tokenize-string (trailing-argument msg)))
    (let ((canonic-nick (canonicalize-nickname nickname)))
      (intern-user canonic-nick))))

(defmethod note-irc-message ((msg irc-rpl_endofnames-message)))

(defmethod note-irc-message ((msg irc-join-message))
  (intern-user (source msg) :hostname (host msg) :username (user msg)))

(defmethod note-irc-message ((msg irc-part-message))
  (when (and (not (self-message-p msg))
             (string-equal (channel clim:*application-frame*) (first (arguments  msg))))
    (unintern-user (source msg))))

(defmethod note-irc-message ((msg irc-quit-message))
  (unless (self-message-p msg)
    (unintern-user (source msg))))

(defmethod note-irc-message ((msg irc-nick-message))
  (when (self-message-p msg)
    (setf (%nickname clim:*application-frame*) (trailing-argument msg)))
  
  (let ((user (find-user (source msg))))
    (if user
        (setf (nickname user) (trailing-argument msg))
      (warn "NICK: Could not find userobject with nick ~S~%" (source msg)))))

(defmethod note-irc-message :after ((msg user-event-mixin))
  #-cmu(clim:redisplay-frame-pane clim:*application-frame* 
                                  (clim:get-frame-pane clim:*application-frame* 'users))
  #+cmu(clim:window-refresh (clim:get-frame-pane clim:*application-frame* 'users)))

;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Application Frame ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;

(clim:define-application-frame weird-irc ()
  ((server :accessor server :initform "irc.freenode.net"
           :initarg :server)
   (port :accessor port :initform 6667 :initarg :port)
   (nickname :initform "weirdirc" :initarg :nickname :accessor %nickname)
   (channel :initform "#lisp" :initarg :channel :accessor channel)
   (initial-channel :initform "#lisp" :initarg :initial-channel :accessor initial-channel)
   (channels :initform nil :accessor channels)
   (users :initform nil :accessor users)
   (names-reply :initform  nil :accessor names-reply)
   (server-stream :accessor server-stream :initarg :server-stream :initform nil)
   (log-file-stream :accessor log-file-stream :initarg :log-file-stream)
   (message-handler :accessor message-handler :initform nil))
  (:menu-bar nil)
  (:command-table (weird-irc-command-table :inherit-from (clim:user-command-table)))
  #-mcclim(:pointer-documentation t)
  #-mcclim(:geometry :width 800 :height 600)
  (:panes 
   (interactor :interactor #+mcclim :width #+mcclim 800)
   (input-line clim:text-field 
               :activate-callback  
               (lambda (gadget) 
                 (let ((message (clim:gadget-value gadget)))
                   (when (> (length message) 0)
                     (with-slots (server-stream channel) clim:*application-frame*
                       (com-send-message channel message)
                       (setf (clim:gadget-value gadget) ""))))))
                                                           
   (log :application 
        :display-after-commands :no-clear
        :display-time t
        :end-of-line-action :wrap
        :end-of-page-action :scroll
        :initial-cursor-visibility nil)
   (users :application
          :label "Users"
          :incremental-redisplay t
          :display-function 'display-users))
  (:layouts
   (default
    (clim:vertically ()
      (clim:horizontally ()
        #-cmu (:fill (clim:outlining () log))
	#+cmu (4/5 (clim:outlining () log))
        (1/5  (clim:outlining () users)))
      input-line
      interactor))))

(defmethod connectedp ((frame weird-irc))
  (let ((stream (server-stream frame)))
    (and (streamp stream) (open-stream-p stream))))
           
(defmethod display-users ((frame weird-irc) stream)
  (dolist (user (sort (copy-seq (users frame)) #'string-lessp :key #'nickname))
    (clim:updating-output (stream :unique-id user)
      (clim:present user 'user :stream stream)
      (terpri stream)))
  (force-output stream))

(defmacro with-output-as-irc-message ((sym stream message) &body body)
  (let ((-second- (gensym))
        (-minute- (gensym))
        (-hour- (gensym))
        (-msg- (gensym)))
    `(let ((,sym ,stream)
           (,-msg- ,message))
       (multiple-value-bind (,-second- ,-minute- ,-hour-)
           (decode-universal-time (receive-time ,-msg-))
         (clim:with-text-family (,sym :sans-serif)
           (format ,sym "[~2,'0D:~2,'0D:~2,'0D] " ,-hour- ,-minute- ,-second-)
           ,@@body))
       (terpri ,sym))))

(clim:define-presentation-method clim:present (object (type irc-message) stream view &key)
  (declare (ignore view object type stream)))

#-cmu
(clim:define-presentation-method clim:present :after (object (type irc-message) stream view &key)
  (force-output stream))

(defun recognize-token (token)
  (flet ((is (type)
           (if (string-equal (subseq token 0 (min (length token)
                                                   (length (symbol-name type))))
                             type)
             'url nil)))
    (if (or (not (stringp token))
            (zerop (length token)))
      nil
      (case (char token 0)
        ((#\H #\h) (or (is :https) (is :http) 'string))
        ((#\F #\f) (or (is :ftp) 'string))
        (otherwise 'string)))))

(clim:define-presentation-method clim:present (msg (type irc-privmsg-message) stream view &key)
  (with-output-as-irc-message (stream stream msg)
    (clim:with-text-face (stream (if (eql (char (first (arguments msg)) 0) #\#) nil :bold))
      (clim:with-drawing-options (stream :ink (clim:make-rgb-color 0 0 1.0))
        (write-char #\< stream)
        (let ((user (find-user (source msg))))
          (cond (user (clim:present user 'user :stream stream))
                (t (warn "PRESENT PRIVMSG: Could not find userobject with nick ~S~%" (source msg))
                   (write-string "!! " stream)
                   (write-string (source msg) stream)
                   (write-string "!! " stream))))
        (write-string "> " stream))
      (loop for token in (tokenize-string (trailing-argument msg) :omit-delimiters nil)
            for token-type = (recognize-token token)
            do (case token-type
                 (string (write-string token stream))
                 (otherwise (clim:present token token-type :stream stream)))))))

(clim:define-presentation-method clim:present (msg (type ctcp-action-message) stream view &key)
  (with-output-as-irc-message (stream stream msg)
    (clim:with-drawing-options (stream :ink (clim:make-rgb-color 1.0 0 0))
      (format stream " ~A " (source msg))
      (let ((trailing-argument (trailing-argument msg)))
        (if (eql (char (first (arguments msg)) 0) #\#)
          (write-string trailing-argument stream)
          (clim:with-text-face (stream :bold)
            (write-string trailing-argument stream)))))))

(clim:define-presentation-method clim:present (msg (type irc-join-message) stream view &key)
  (with-output-as-irc-message (stream stream msg)
    (clim:with-drawing-options (stream :ink (clim:make-rgb-color 1.0 0 0))
      (format stream " ~A joins ~A" (source msg) (trailing-argument msg)))))

(clim:define-presentation-method clim:present (msg (type irc-nick-message) stream view &key)
  (with-output-as-irc-message (stream stream msg)
    (clim:with-drawing-options (stream :ink (clim:make-rgb-color 1.0 0.1 0.5))
      (format stream " ~A is now ~A " (source msg) (trailing-argument msg)))))

(clim:define-presentation-method clim:present (msg (type irc-quit-message) stream view &key)
  (with-output-as-irc-message (stream stream msg)
      (clim:with-drawing-options (stream :ink (clim:make-rgb-color 1.0 0.1 0.5))
            (format stream " ~A leaves IRC: ~A" (source msg) (trailing-argument msg)))))
  
(clim:define-presentation-method clim:present (msg (type irc-part-message) stream view &key)
  (with-output-as-irc-message (stream stream msg)
    (clim:with-drawing-options (stream :ink (clim:make-rgb-color 1.0 0.1 0.5))
      (format stream " ~A leaves channel ~A " (source msg) (trailing-argument msg)))))

(clim:define-presentation-method clim:present (msg (type irc-rpl_whoisuser-message) stream view &key)
  (with-output-as-irc-message (stream stream msg)
    (clim:with-drawing-options (stream :ink (clim:make-rgb-color 0.0 0.6 0.2))
      (format stream "Userinfo for ~A ( ~A <~A@@~A> )" 
              (second (arguments msg))
              (trailing-argument msg)
              (third (arguments msg))
              (fourth (arguments msg))
              (source msg)))))

(defun run-weird-irc 
       (&key (channel "#lisp")(server "irc.freenode.net") (port 6667)(nickname "NeonSquare")
             (log-file (format nil "~A-~A.log" server nickname)))
  (let ((weird-irc (clim:make-application-frame 'weird-irc :channel channel :initial-channel channel
                         :server server :port port :nickname nickname :log-file-stream *terminal-io*)))
    (unwind-protect 
        (clim:run-frame-top-level weird-irc)
      (when (connectedp weird-irc)
        (disconnect-from-server weird-irc)))))

(defun connect-to-server (weird-irc server port)
  (when (connectedp weird-irc)
    (disconnect-from-server weird-irc))
  (let ((stream #+lispworks (comm:open-tcp-stream server port :errorp t)
                #+cmu       (sys:make-fd-stream (ext:connect-to-inet-socket server
                                                                            port)
                                                :input t 
                                                :output t
                                                :element-type 'character)
                #+allegro (socket:make-socket :remote-host server :remote-port port)))
    
    (setf (server-stream weird-irc) stream)
    
    (let ((nickname (nickname weird-irc)))
      (%send-irc-message stream :nick nil nickname)
      (%send-irc-message stream :user nil nickname 0 "*" nickname)
      
      (loop for msg = (read-irc-message stream) ;Wait for End of MotD
            until (or (eql (command msg) :rpl_endofmotd)
                      (eql (command msg) :err_nomotd))
            do (note-irc-message msg))

      (setf (message-handler weird-irc) (clim-sys:make-process (lambda () 
                                                                 (weird-irc-main-loop weird-irc))
                                                               :name "WeirdIRC")))))

(defun disconnect-from-server (weird-irc)
  (close (server-stream weird-irc))
  (clim:window-clear (clim:get-frame-pane weird-irc 'log)))

  
(defmethod send-local-message (irc-message))

(defmethod send-local-message :before ((irc-message irc-message))
  (setf (source irc-message) (nickname clim:*application-frame*)))

(defmethod send-local-message ((irc-message irc-privmsg-message))
  (clim:present irc-message 'irc-privmsg-message 
                :stream (clim:get-frame-pane clim:*application-frame* 'log)))

(defmethod send-local-message ((irc-message ctcp-action-message))
  (clim:present irc-message 'ctcp-action-message 
                :stream (clim:get-frame-pane clim:*application-frame* 'log)))

(defmethod nickname ((frame weird-irc))
  (%nickname frame))

(defmethod (setf nickname) (new-nick (frame weird-irc))
  (if (connectedp frame)
    (send-irc-message (server-stream frame) :nick nil new-nick)
    (setf (%nickname frame) new-nick)))

;; mIRC Color handling ;;
#|
(defun draw-colored-irc-text (text frame stream)
  (flet ((parse-color-spec (index)
           (multiple-value-bind (n end) (parse-integer text :start index :junk-allowed)
             (values n 
                     (if (and n (eql (char text n-end) #\,) (< n-end (length text)))
                         (setf end (parse-integer text :start (1+ end) :junk-allowed))
                       nil)
                     end))))
    (
|#

;;;;;;;;;;;;;;;;
;;; Commands ;;;
;;;;;;;;;;;;;;;;

(define-weird-irc-command (com-change-nick :name t)
    ((new-nick 'string :prompt "New Nickname"))
  (setf (nickname clim:*application-frame*) new-nick))

(define-weird-irc-command (com-send-message :name t)
    ((receiver '(or string user) :prompt "Receiver" :default (channel clim:*application-frame*))
     (message '(or string irc-privmsg-message user) :prompt "Message"))
  (let ((message (typecase message
                   (string message)
                   (irc-privmsg-message (trailing-argument message))
                   (user (nickname message)))))
    (when (> (length message) 0)
      (with-slots (server-stream channel nickname) clim:*application-frame*
        (send-irc-message server-stream :privmsg
                          message 
                          (let ((receiver (if (stringp receiver) receiver (nickname receiver))))
                            (if (zerop (length receiver))
                                (channel clim:*application-frame*)
                              receiver)))))))

(define-weird-irc-command (com-send-action-message :name t)
    ((receiver '(or string user) :prompt "Receiver" :default (channel clim:*application-frame*))
     (message 'string :prompt "Message"))
  (unless (zerop (length message))
    (com-send-message receiver (format nil "~AACTION ~A~A" +soh+ message +soh+))))

(define-weird-irc-command (com-join-channel :name t)
    ((channel 'string :prompt "Channel"))
  (send-irc-message (server-stream clim:*application-frame*) :join nil channel))

(define-weird-irc-command (com-select-receiver :name t)
    ((receiver '(or string user) :prompt "Receiver"))
  (setf (channel clim:*application-frame*) 
        (etypecase receiver
          (user (nickname receiver))
          (string receiver))))

(define-weird-irc-command (com-describe-user :name t)
    ((user '(or string user) :prompt "User"))
  (with-slots (server-stream channel nickname) clim:*application-frame*
    (send-irc-message server-stream :whois
                      nil
                      (if (stringp user) user (nickname user)))))

(define-weird-irc-command (com-leave-channel :name t)
    ((channel 'string :prompt "Channel" :default (channel clim:*application-frame*)))
  (send-irc-message (server-stream clim:*application-frame*)
                    :part
                    ""
                    (if (zerop (length channel))
                        (channel clim:*application-frame*)
                      channel)))

(define-weird-irc-command (com-visit-url :name t)
    ((url '(or string url) :prompt "Url" :default "http://www.dataheaven.de/weird-irc/"))
  #+lispworks
  (let ((*standard-output* *terminal-io*)
        (url (if (zerop (length url)) "http://www.dataheaven.de/weird-irc/" url)))
    (hqn-web:browse url)))

(define-weird-irc-command (com-clear-interactor :name t) ()
    (clim:window-clear (clim:frame-query-io clim:*application-frame*)))

(define-weird-irc-command (com-connect :name t)
   ((server 'string :prompt "Server" :default (server clim:*application-frame*))
    (port 'integer :prompt "Port" :default (port clim:*application-frame*)))                        
   (let ((server (if (zerop (length server)) (server clim:*application-frame*) server)))
     (connect-to-server clim:*application-frame* server port)))

(define-weird-irc-command (com-disconnect :name t) ()
  (disconnect-from-server clim:*application-frame*))

(define-weird-irc-command (com-quit :name t) ()
  (clim:frame-exit clim:*application-frame*))

;;;;;;;;;;;;;;;;;;;
;;; Translators ;;;
;;;;;;;;;;;;;;;;;;;

(clim:define-presentation-to-command-translator
    select-receiver
    (user com-select-receiver weird-irc-command-table
          :documentation "Select as receiver"
          :gesture :select)
    (object)
  (list object))

(clim:define-presentation-to-command-translator
    describe-user
    (user com-describe-user weird-irc-command-table
          :documentation "Describe User"
          :gesture :describe)
    (object)
  (list object))

(clim:define-presentation-to-command-translator
    visit-url
    (url com-visit-url weird-irc-command-table
         :documentation "Visit URL"
         :gesture :select)
    (object)
  (list object))

(clim:define-presentation-to-command-translator
    select-channel-as-receiver
    (clim:blank-area com-select-receiver weird-irc-command-table
                     :documentation "Select channel as receiver"
                     :gesture :select)
    (x y)
  (list (initial-channel clim:*application-frame*)))


;;;;;;;;;;;;;;;;;;;
;;; DCC Receive ;;;
;;;;;;;;;;;;;;;;;;;

(clim:define-application-frame dcc-receive ()
  ((host :initarg :host)
   (port :initarg :port)
   (nickname :initarg :nickname :accessor nickname)
   (filename :initarg :filename :accessor filename)
   (buffer :initform (make-array 4096 :element-type (unsigned-byte 8)) :accessor buffer)
   (down-stream :accessor down-stream :initform nil))
  (:menu-bar nil)
  #-cmu(:pointer-documentation nil)
  (:geometry :width 320 :height 100)
  (:panes 
   (progress :application 
             :display-after-commands :no-clear
             :display-time t
             :initial-cursor-visibility nil))
  (:layouts
   (default
    (clim:labelling (:label "Downloading File")
                    progress))))

(defun do-dcc-receive (filename size host port nickname)
  (with-open-stream (stream (comm:open-tcp-stream server port))
    (let ((dcc-receive (clim:make-application-frame 'dcc-receive
                                                    :down-stream stream
                                                    :host host
                                                    :port port
                                                    :nickname nickname
                                                    :filename filename)))
      (let (dcc-receiver)
        (unwind-protect 
            (progn
              (setf dcc-receiver (clim-sys:make-process 
                                  (lambda ())
                                  :name (format nil "DCC receive: ~A (~A)" filename size)))
              (clim:run-frame-top-level weird-irc))
          (when dcc-receiver
            (clim-sys:destroy-process dcc-receiver)))))))


;;;;;;;;;;;;;;;;;;;;;
;;; Message codes ;;;
;;;;;;;;;;;;;;;;;;;;;

(defun find-error-reply-name (reply-nr)
  (ecase reply-nr
    (401 :err_nosuchnick)(402 :err_nosuchserver)(403 :err_nosuchchannel)
    (404 :err_cannotsendtochan)(405 :err_toomanychannels)(406 :err_wasnosuchnick)
    (407 :err_toomanytargets)(409 :err_noorigin)(411 :err_norecipient)
    (412 :err_notexttosend)(413 :err_notoplevel)(414 :err_wildtoplevel)
    (421 :err_unknowncommand)(422 :err_nomotd)(423 :err_noadmininfo)
    (424 :err_fileerror)(431 :err_nonicknamegiven)(432 :err_erroneusnickname)
    (433 :err_nicknameinuse)(436 :err_nickcollision)(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_alreadyregistered)(463 :err_nopermforhost)
    (464 :err_passwdmismatch)(465 :err_yourebannedcreep)(467 :err_keyset)
    (471 :err_channelisfull)(472 :err_unknownmode)(473 :err_inviteonlychan)
    (474 :err_bannedfromchan)(475 :err_badchannelkey)(481 :err_noprivileges)
    (482 :err_chanoprivsneeded)(483 :err_cantkillserver)(491 :err_nooperhost)
    (501 :err_umodeunknownflag)(502 :err_usersdontmatch)))

(defun find-reply-name (reply-nr)
  (case reply-nr
    (300 :rpl_none)(302 :rpl_userhost)(303 :rpl_ison)(304 :rpl_away)
    (305 :rpl_unaway)(306 :rpl_noaway)(311 :rpl_whoisuser)(312 :rpl_whoisserver)
    (313 :rpl_whoisoperator)(317 :rpl_whoisidle)(318 :rpl_endofwhois)(319 :rpl_whoischannels)
    (314 :rpl_whowasuser)(369 :rpl_endofwhowas)(321 :rpl_liststart)(322 :rpl_list)
    (323 :rpl_listend)(324 :rpl_channelmodeis)(331 :rpl_notopic)(332 :rpl_topic)
    (341 :rpl_inviting)(342 :rpl_summoning)(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)(391 :rpl_time)(392 :rpl_usersstart)
    (393 :rpl_users)(394 :rpl_endofusers)(395 :rpl_nousers)(200 :rpl_tracelink)
    (201 :rpl_traceconnecting)(202 :rpl_tracehandshake)(203 :rpl_traceunknown)
    (204 :rpl_traceoperator)(205 :rpl_traceuser)(206 :rpl_traceserver)(208 :rpl_tracenewtype)
    (261 :rpl_tracelog)(211 :rpl_statslinkinfo)(212 :rpl_statscommands)
    (otherwise :unknown-reply)))