;;; --------------------------------------------------------------------
;;; CLAIM -- An implementation of the AIM TOC protocol in Lisp.
;;;
;;; Copyright 2001, 2002 I/NET Inc. (http://www.inetmi.com/)
;;; John Wiseman (jjwiseman@yahoo.com)
;;; 2002-07-21
;;; Licensed under the MIT license--see the accompanying LICENSE.txt
;;; file.
;;;
;;; * Introduction
;;;
;;; CLAIM is an implementation of AOL's semi-open Instant Messaging
;;; protocol, TOC (see PROTOCOL.txt).  It allows one to build chatbots
;;; and other AIM clients.
;;;
;;; * Quickstart
;;;
;;; Load this code, then load the examples/gossip-bot.lisp file.  At
;;; the listener, run the start-gossip-bot function:
;;;
;;;   ? (start-gossip-bot "myusername" "mypassword")
;;;
;;; You must use the username and password of an existing AIM account
;;; (see <http://aim.aol.com/> on how to create a free AIM account) .
;;;
;;; Anyone can now send messages to and interact with the gossip bot.
;;;
;;; * Requirements & Dependencies
;;;
;;; CLAIM requires a lisp that supports the ACL socket API (see
;;; <http://www.franz.com/support/documentation/6.1/doc/socket.htm>,
;;; and <http://ww.telent.net/cliki/ACL-COMPAT>).  Actually, all you
;;; need is a function socket:make-socket for connecting to a remote
;;; host (in text mode).
;;;
;;; For example, in OpenMCL the following is sufficient:
;;;
;;;   (defpackage :socket
;;;     (:use :common-lisp)
;;;     (:shadowing-import-from :ccl #:make-socket)
;;;     (:export #:make-socket))
;;;
;;; * Implementation Notes
;;;
;;; The TOC protcol is slightly binary, mostly text.  Accordingly, I
;;; open socket streams in text mode and fake the binary parts.  It
;;; won't work unless your Lisp's code-char and char-code functions
;;; use ASCII.
;;;
;;; I've written the code without assuming multiprocessing, but in a
;;; way that will work with most multiprocessing implementations.  Let
;;; me know if it doesn't work out that way.
;;;
;;; I checked all the other AIM libraries I could find, and nobody
;;; even tries to deal with the "server speed limit", which was a
;;; constant problem for me.  See the comments at the end of this file
;;; for one attempt to solve this problem.
;;;
;;; The following implementations of TOC were helpful when writing
;;; this one:
;;;
;;;   http://sourceforge.net/projects/tnt/
;;;   http://www.wiredfool.com/ftoc/ (Eric Soroos)
;;;
;;; This code has been tested in ACL/Linux, OpenMCL and MCL.
;;;
;;; * Bugs
;;;
;;; There should be much more documentation.  I've tried to structure
;;; the code so that it is easy to extend and use for chat clients,
;;; but documenting what I did would help a lot too.  Sorry.


(defpackage #:com.lemonodor.claim
  (:use :common-lisp
	:socket)
  (:export 
   #:aim-connection
   #:open-aim-connection
   #:close-aim-connection

   #:aim-connection-username
   #:aim-connection-last-error
   
   #:receive-event
   #:handle-event
   #:receive-events

   #:do-send-im
   #:do-add-buddies
   #:do-remove-buddies
   #:do-add-permits
   #:do-add-denies
   #:do-warn
   #:do-set-config
   #:do-set-idle-time
   #:do-set-away-message
   #:do-get-info
   #:do-set-info
   #:do-chat-invite
   #:do-chat-accept
   #:do-chat-leave
   #:do-chat-whisper
   #:do-chat-send
   #:do-chat-join
   #:do-get-dir
   #:do-set-dir
   #:do-dir-search

   #:handle-im-in
   #:handle-update-buddy
   #:handle-warned
   #:handle-chat-join
   #:handle-chat-in
   #:handle-chat-update-buddy
   #:handle-chat-invite
   #:handle-chat-left
   #:handle-goto-url
   #:handle-pause

   #:*default-toc-host*
   #:*default-toc-port*
   #:*default-login-host*
   #:*default-language*
   #:*default-agent*
   
   #:disconnect-error))

(in-package :com.lemonodor.claim)

   
(defvar *default-toc-host* "toc.oscar.aol.com")
(defvar *default-toc-port* 9898)
(defvar *default-login-host* "login.oscar.aol.com")
(defvar *default-login-port* 5190)
(defvar *default-language* "english")
(defvar *default-agent* "CLAIM 2.3.2")


(defclass aim-connection ()
  (
   ;; Connection parameters
   (toc-host     :accessor aim-connection-toc-host     :initarg :toc-host
		 :initform *default-toc-host*)
   (toc-port     :accessor aim-connection-toc-port     :initarg :toc-port
		 :initform *default-toc-port*)
   (login-host   :accessor aim-connection-login-host   :initarg :login-host
		 :initform *default-login-host*)
   (login-port   :accessor aim-connection-login-port   :initarg :login-port
		 :initform *default-login-port*)
   (language     :accessor aim-connection-language     :initarg :language
		 :initform *default-language*)
   (agent        :accessor aim-connection-agent        :initarg :agent
		 :initform *default-agent*)
   (username     :accessor aim-connection-username     :initarg :username)
   (password     :accessor aim-connection-password     :initarg :password)
   (profile      :accessor aim-connection-profile      :initarg :profile
		 :initform nil)
   ;; Once it's connected
   (stream       :accessor aim-connection-stream
		 :initform nil)
   (last-error   :accessor aim-connection-last-error
		 :initform nil)
   (running-p    :accessor running-p :initform T)
   (ignore-events-p :accessor ignore-events-p :initform NIL)

   ;; Automatic reconnection
   (auto-reconnect-p :accessor aim-connection-auto-reconnect-p :initarg :auto-reconnect-p)
   (last-disconnection-time :accessor aim-connection-last-disconnection-time
		 :initform nil)
   (disconnection-count :accessor aim-connection-disconnection-count
		 :initform 0))
  (:default-initargs
   :profile "You're talking to the Common Lisp TOC interface, by John Wiseman (jjwiseman@yahoo.com)"
   :auto-reconnect-p T))


(defmethod initialize-instance :after ((self aim-connection) &key)
  (setf (aim-connection-password self) (roast-string (aim-connection-password self))))

(defmethod open-aim-connection ((self aim-connection))
  (when (aim-connection-stream self)
    (close (aim-connection-stream self)))
  (handler-case
   (let ((socket (open-socket self))
	 (crlf (format nil "~A~A" (code-char 13) (code-char 10))))
     (setf (aim-connection-last-error self) nil)
     (setf (aim-connection-stream self) socket)
     (%send-string socket (format nil "FLAPON~A" crlf))
     (%send-string socket (format nil "~A" crlf)))
   (error (e) (error 'disconnect-error :original-error e)))
  (values))

(defmethod close-aim-connection ((self aim-connection))
  (when (aim-connection-stream self)
    (close (aim-connection-stream self))
    (setf (aim-connection-stream self) nil)))

(defmethod open-socket ((self aim-connection))
  (make-socket :connect :active
	       :remote-host (aim-connection-toc-host self)
	       :remote-port (aim-connection-toc-port self)))


(defstruct toc-event
  type
  payload
  sequence-number)

(defmethod receive-event ((self aim-connection))
  (multiple-value-bind (payload type sequence-number)
      (read-flap (aim-connection-stream self))
    (make-toc-event :type type :payload payload :sequence-number sequence-number)))

(defmethod handle-event ((self aim-connection) event)
  (let ((type (toc-event-type event))
	(payload (toc-event-payload event)))
    (ecase type
      (:sign-on (handle-flap-sign-on self payload))
      (:data (toc-handle-receive self payload)))))

(defmethod receive-would-block-p ((self aim-connection))
  (let* ((stream (aim-connection-stream self))
	 (char (read-char-no-hang stream NIL :eof)))
    (when (and char (not (eq char :eof)))
      (unread-char char stream))
    (and char T)))

(defmethod receive-events ((self aim-connection))
  (loop while (running-p self)
	do
	(let ((event (receive-event self)))
	  (unless (ignore-events-p self)
	    (handle-event self event)))))


;; ------------------------------------------------
;; Events
;; ------------------------------------------------

(defmethod handle-flap-sign-on ((self aim-connection) version)
  (declare (ignore version))
  (send-flap-sign-on self)
  (send-toc-sign-on self))

(defmethod handle-toc-sign-on ((self aim-connection) version)
  (declare (ignore version))
  (send-toc-sign-on self)
  ;; Required for proper initialization.
  (send-toc self "toc_add_buddy ~A" (encode-string (normalize-string (aim-connection-username self))))
  (when (aim-connection-profile self)
    (do-set-info self (aim-connection-profile self)))
  (handle-pre-init-done self)
  (send-toc-init-done self))


(defmethod handle-pre-init-done ((self aim-connection))
  "Initial permit/deny items should be sent after receiving SIGN_ON
but before sending toc_init_done, otherwise the user will flash on
peoples buddylist who the user has denied.  handle-pre-init-done is
called just before toc_init_done is sent.  You may also want to
send the toc_add_buddies at this time."
  )
   
(defmethod handle-toc-config ((self aim-connection) config)
  (declare (ignore config)))

(defmethod send-toc-init-done ((self aim-connection))
  (send-toc self "toc_init_done"))

(defmethod handle-toc-nick ((self aim-connection) nick)
  (declare (ignore nick)))
(defmethod handle-im-in ((self aim-connection) user auto-p message)
  (declare (ignore user message auto-p)))
(defmethod handle-update-buddy ((self aim-connection) nick online warn sign-on idle away)
  (declare (ignore nick online warn sign-on idle away)))


(defmethod handle-toc-error ((self aim-connection) code args)
  (warn "AIM error: ~A" (error-string code args)))


(defvar *error-strings*
    '(;; ----- General errors
      901 "~A not currently available."
      902 "Warning of ~A not currently available."
      903 "A message has been dropped, you are exceeding the server speed limit."
      ;; ----- Chat errors
      950 "Chat in ~A is unavailable."
      ;; ----- IM & info errors
      960 "You are sending message too fast to ~A."
      961 "You missed an IM from ~A because it was too big."
      962 "You missed an IM from ~A because it was sent too fast."
      ;; ----- Directory errors
      970 "Failure."
      971 "Too many matches."
      972 "Need more qualifiers."
      973 "Dir service temporarily unavailable."
      974 "Email lookup restricted."
      975 "Keyword Ignored."
      976 "No Keywords."
      977 "Language not supported."
      978 "Country not supported."
      979 "Failure unknown: ~A."
      ;; ----- Authorization errors
      980 "Incorrect nickname or password."
      981 "The service is temporarily unavailable."
      982 "Your warning level is currently too high to sign on."
      983 "You have been connecting and disconnecting too frequently.  Wait 10 minutes and try again.  If you continue to try, you will need to wait even longer."
      989 "An unknown signon error has occurred: ~A"))

(defun error-string (code args)
  (let ((format (getf *error-strings* code)))
    (if format
      (apply #'format nil format args)
      nil)))
       
(defmethod handle-warned ((self aim-connection) warn-level warner)
  (declare (ignore warn-level warner)))
(defmethod handle-chat-join ((self aim-connection) room-id room)
  (declare (ignore room-id room)))
(defmethod handle-chat-in ((self aim-connection) room-id user whisper-p message)
  (declare (ignore room-id user whisper-p message)))
(defmethod handle-chat-update-buddy ((self aim-connection) room-id inside-p users)
  (declare (ignore room-id inside-p users)))
(defmethod handle-chat-invite ((self aim-connection) room room-id sender message)
  (declare (ignore room room-id sender message)))
(defmethod handle-chat-left ((self aim-connection) room-id)
  (declare (ignore room-id)))
(defmethod handle-goto-url ((self aim-connection) window-id url)
  (declare (ignore window-id url)))
(defmethod handle-pause ((self aim-connection)))

(defvar *min-connection-threshold* 600)
(defvar *max-reconnection-attempts* 10)
    
(defmethod handle-disconnection ((self aim-connection))
  (let ((now (get-universal-time))
	(last-time (or (aim-connection-last-disconnection-time self) 0)))
    (setf (aim-connection-last-disconnection-time self) now)
    (when (> (- now last-time) *min-connection-threshold*)
      (setf (aim-connection-disconnection-count self) 0))
    (labels ((reconnect ()
	       (let ((num-attempts (incf (aim-connection-disconnection-count self))))
		 (if (> num-attempts *max-reconnection-attempts*)
		   (progn
		     (warn "Made ~S attempts to reconnect to AIM; giving up." (- num-attempts 1))
		     NIL)
		   (let ((delay (backoff-time num-attempts)))
		     (warn "Waiting ~S seconds before trying to reconnect to AIM." delay)
		     (sleep delay)
		     (setf (aim-connection-last-disconnection-time self) (get-universal-time))
		     (handler-case
			 (progn
			   (open-aim-connection self)
			   (warn "Connected.")
			   T)
		       (error (e)
			 (warn "While trying to reconnect to AIM got socket error ~A." e)
			 (reconnect))))))))
      (reconnect))))

;; Returns the number of seconds to wait before making a reconnection
;; attempt, using the Truncated Binary Exponential Backoff algorithm
;; (http://www.iol.unh.edu/testsuites/ge/mac/test_4.6.2.html).
;;
;; The time is random; the maximum is about 1 hour after 6 or
;; more attempts.

(defvar *backoff-time-scale* 60)
(defun backoff-time (attempt-number)
  (let* ((k (min 6 attempt-number))
	 (limit (expt 2 k)))
    (random (* limit *backoff-time-scale*))))


(defmacro with-toc-args ((toc-str &optional next-fn rest-fn rest-string-fn) &body body)
  (setf next-fn (or next-fn 'next-toc-arg))
  (setf rest-fn (or rest-fn 'rest-toc-args))
  (setf rest-string-fn (or rest-string-fn 'rest-toc-string))
  (let ((index-var (gensym "INDEX"))
	(string-var (gensym "TOC-STRING")))
    `(let ((,index-var 0)
	   (,string-var ,toc-str))
       (labels ((,next-fn () (if (null ,index-var)
			       nil
			       (multiple-value-bind (arg next)
				   (parse-toc-arg ,string-var :start ,index-var)
				 (setf ,index-var next)
				 arg)))
		(,rest-fn () (let ((args '()))
			       (do ((arg (,next-fn) (,next-fn)))
				   ((null arg) (reverse args))
				 (push arg args))))
		(,rest-string-fn () (subseq ,string-var ,index-var)))
	 ,@body))))

(defun parse-toc-arg (message &key (start 0))
  (let ((colon-position (position #\: message :start start)))
    (if colon-position
      (values (subseq message start colon-position)
	      (if (> (length message) colon-position)
		(+ colon-position 1)
		nil))
      (values (subseq message start) nil))))


(defmacro stringcase (string-key &rest clauses)
  (flet ((str (x)
	   (unless (stringp x)
	     (warn "~S is not a string literal in stringcase." x))
	   x))
    (let ((string-var (gensym)))
      `(let ((,string-var ,string-key))
	 (cond
	  ,@(mapcar #'(lambda (clause)
			(cond ((or (eq (car clause) 'otherwise)
				   (eq (car clause) T))
			       `(T ,@(cdr clause)))
			      ((not (listp (car clause)))
			       `((string= ,string-var ,(str (car clause)))
				 ,@(cdr clause)))
			      (T
			       `((or ,@(mapcar #'(lambda (val)
						   `(string= ,string-var ,(str val)))
					       (car clause)))
				 ,@(cdr clause)))))
		    clauses))))))

(defmethod toc-handle-receive ((self aim-connection) string)
  (with-toc-args (string)
    (let ((command (next-toc-arg)))
      (stringcase command
       ("SIGN_ON"
	(handle-toc-sign-on self (next-toc-arg)))
       ("CONFIG"
	(handle-toc-config self (next-toc-arg)))
       ("NICK"
	(handle-toc-nick self (next-toc-arg)))
       ("IM_IN"
	(handle-im-in self (next-toc-arg) (string= "T" (next-toc-arg)) (rest-toc-string)))
       ("UPDATE_BUDDY"
	(handle-update-buddy self (next-toc-arg)
			     (string= "T" (next-toc-arg))
			     (parse-integer (next-toc-arg))
			     (parse-integer (next-toc-arg))
			     (parse-integer (next-toc-arg))
			     (next-toc-arg)))
       ("ERROR"
	(let ((code (parse-integer (next-toc-arg)))
	      (args (rest-toc-args)))
	  (setf (aim-connection-last-error self) (cons code args))
	  (handle-toc-error self code args)))
       ("EVILED"
	(handle-warned self (parse-integer (next-toc-arg)) (next-toc-arg)))
       ("CHAT_JOIN"
	(handle-chat-join self (next-toc-arg) (next-toc-arg)))
       ("CHAT_IN"
	(handle-chat-in self (next-toc-arg) (next-toc-arg)
			(string= "T" (next-toc-arg)) (rest-toc-string)))
       ("CHAT_UPDATE_BUDDY"
	(handle-chat-update-buddy self (next-toc-arg) (string= "T" (next-toc-arg))
				  (rest-toc-args)))
       ("CHAT_INVITE"
	(handle-chat-invite self (next-toc-arg) (next-toc-arg) (next-toc-arg)
			    (rest-toc-string)))
       ("CHAT_LEFT"
	(handle-chat-left self (next-toc-arg)))
       ("GOTO_URL"
	(handle-goto-url self (next-toc-arg) (rest-toc-string)))
       ("PAUSE"
	(handle-pause self))
       (otherwise
	(warn "Unhandled AIM TOC command ~S" string))))))


;; ------------------------------------------------
;; Actions
;; ------------------------------------------------

(defmethod do-send-im ((self aim-connection) screen-name message &key (auto-p NIL))
  (send-toc self "toc_send_im ~A ~A~A"
	    (normalize-string screen-name)
	    (encode-string message)
	    (if auto-p " auto" "")))

(defmethod do-add-buddies ((self aim-connection) buddies)
  (send-toc self "toc_add_buddy~{ ~A~}" (mapcar #'normalize-string buddies)))

(defmethod do-remove-buddies ((self aim-connection) buddies)
  (send-toc self "toc_remove_buddy~{ ~A~}" (mapcar #'normalize-string buddies)))

(defmethod do-add-permits ((self aim-connection) permits)
  (send-toc self "toc_add_permit~{ ~A~}" (mapcar #'normalize-string permits)))

(defmethod do-add-denies ((self aim-connection) denies)
  (send-toc self "toc_add_deny~{ ~A~}" (mapcar #'normalize-string denies)))

(defmethod do-warn ((self aim-connection) screen-name anonymous-p)
  (send-toc self "toc_evil ~A ~A"
	    (normalize-string screen-name)
	    (if anonymous-p "anon" "norm")))

(defmethod do-set-idle-time ((self aim-connection) seconds)
  (send-toc self "toc_set_idle ~S" seconds))

(defmethod do-set-away-message ((self aim-connection) message)
  (if message
    (send-toc self "toc_set_away ~A" (encode-string message))
    (send-toc self "toc_set_away")))

(defmethod do-get-info ((self aim-connection) user)
  (send-toc self "toc_get_info ~A" (normalize-string user)))

(defmethod do-set-info ((self aim-connection) info)
  (send-toc self "toc_set_info ~A" (encode-string info)))

(defmethod do-chat-invite ((self aim-connection) room invitation buddies)
  (send-toc self "toc_chat_invite ~A ~A~{ ~A~}"
	    (normalize-string room)
	    (encode-string invitation)
	    (mapcar #'normalize-string buddies)))

(defmethod do-chat-accept ((self aim-connection) id)
  (send-toc self "toc_chat_accept ~A" id))

(defmethod do-chat-leave ((self aim-connection) id)
  (send-toc self "toc_chat_leave ~A" id))

(defmethod do-chat-whisper ((self aim-connection) room user message)
  (send-toc self "toc_chat_whisper ~A ~A ~A"
	    room (normalize-string user) (encode-string message)))

(defmethod do-chat-send ((self aim-connection) room message)
  (send-toc self "toc_chat_send ~A ~A"
	    room (encode-string message)))

(defmethod do-chat-join ((self aim-connection) room)
  ;; The docs says it's always 4...
  (let ((exchange 4))
    (send-toc self "toc_chat_join ~A ~A" exchange room)))

(defmethod do-set-config ((self aim-connection) config)
  (send-toc self "toc_set_config \"~A\"" config))

(defmethod do-get-dir ((self aim-connection) user)
  (send-toc self "toc_get_dir ~A" (encode-string user)))

(defmethod do-set-dir ((self aim-connection) info)
  (send-toc self "toc_set_dir ~A" info))

(defmethod do-dir-search ((self aim-connection) info)
  (send-toc self "toc_dir_search ~A" info))

;; Should only be called in response to receving FLAP signon from
;; server.
(defmethod send-flap-sign-on ((self aim-connection))
  (let ((normalized-name (normalize-string (aim-connection-username self))))
    (write-flap (aim-connection-stream self) :sign-on
		(with-output-to-string (s)
		  (write-word2 0 s)
		  (write-byte2 0 s)
		  (write-byte2 1 s)
		  (write-word2 1 s)
		  (write-word2 (length normalized-name) s)
		  (write-string normalized-name s)))))

(defmethod send-toc-sign-on ((self aim-connection))
  (with-slots (login-host login-port username password language agent)
      self
    (send-toc self "toc_signon ~A ~A ~A ~A ~A ~A"
	      login-host login-port (normalize-string username)
	      password (encode-string language)
	      (encode-string agent))))



(defmethod send-toc ((self aim-connection) fmt &rest args)
  (let ((msg (apply #'format nil fmt args)))
    (write-toc (aim-connection-stream self) msg :type :data)))


;; --------------------
;; Reading and Writing TOC and FLAPs from and to streams.

(defun write-toc (stream string &key (type :data))
  (write-flap stream type (format nil "~A~A" string (code-char 0))))


(defvar *debug-flap* NIL)

(defun read-flap (stream)
  ;; Assume any errors here mean we were disconnected.  A somewhat
  ;; dangerous assumption, really.
  (handler-case
   (progn
     (assert (eql (read-char stream) #\*))
     (let* ((frame-type (%read-byte stream))
	    (sequence-number (read-word stream))
	    (data-length (read-word stream)))
       (let ((s (with-output-to-string (s)
				       (dotimes (i data-length)
					 (write-char (code-char (%read-byte stream)) s)))))
	 (when *debug-flap*
	   (format *debug-io* "~&<-- * [~S] ~s byte frame, type ~S: ~S"
		   sequence-number data-length (code-frame-type frame-type) s))
	 (values s (code-frame-type frame-type) sequence-number))))
   (error (e)
     (error 'disconnect-error :original-error e))))

(defun write-flap (stream type payload)
  (let ((len (length payload)))
    (let ((sequence-number (next-sequence-number)))
      (when *debug-flap*
	(format *debug-io* "~&--> * [~S] ~S byte frame, type ~S: ~S"
		sequence-number len type payload))
      (let ((string (with-output-to-string (s)
		      (write-char #\* s)
		      (write-byte2 (frame-type-code type) s)
		      (write-word2 sequence-number s)
		      (write-word2 len s)
		      (princ payload s))))
	;; Assume any errors here mean we were disconnected.  A somewhat
	;; dangerous assumption, really.
	(handler-case
	 (%send-string stream string)
	 (error (e)
	   (error 'disconnect-error :original-error e)))))))

(defvar *sequence-number* (random 65536))
(defun next-sequence-number ()
  (mod (incf *sequence-number*) 65536))


(define-condition disconnect-error (error)
  ((original-error :reader original-error :initarg :original-error))
  (:report (lambda (condition stream)
	     (format stream "~A" (original-error condition)))))

(defun code-frame-type (code)
  (ecase code
    (1 :sign-on)
    (2 :data)
    (3 :error)
    (4 :sign-off)
    (5 :keep-alive)))

(defun frame-type-code (type)
  (ecase type
    (:sign-on 1)
    (:data 2)
    (:error 3)
    (:sign-off 4)
    (:keep-alive 5)))

(defun write-word2 (integer stream)
  (write-byte2 (ash integer -8) stream)
  (write-byte2 (logand integer 255) stream))

(defun write-byte2 (integer stream)
  (write-char (code-char integer) stream))

(defun read-word (stream &optional (eof-error-p T) eof-value)
  (let ((byte1 (%read-byte stream eof-error-p :eof)))
    (if (eq byte1 :eof)
      eof-value
      (let ((byte2 (%read-byte stream eof-error-p :eof)))
	(if (eq byte2 :eof)
	  eof-value
	  (+ (* byte1 65536) byte2))))))

(defun %read-byte (stream &optional (eof-error-p T) eof-value)
  (let ((char (read-char stream eof-error-p eof-value)))
    (unless (and (not eof-error-p) (eq char eof-value))
      (setf char (char-code char)))
    char))
    
(defun %send-string (stream string)
  (format stream "~A" string)
  (finish-output stream))


;; --------------------
;; String utilities

(defun encode-string (string)
  (with-output-to-string (s)
    (write-char #\" s)
    (dotimes (i (length string))
      (let ((char (char string i)))
	(when (member char '(#\$ #\{ #\} #\[ #\] #\( #\) #\" #\\))
	  (write-char #\\ s))
	(write-char char s)))
    (write-char #\" s)))


(defvar *roast-string* "Tic/Toc")

(defun roast-string (string &optional (roaster *roast-string*))
  (with-output-to-string (s)
    (let ((rlen (length roaster)))
      (write-string "0x" s)
      (dotimes (i (length string))
	(format s "~2,'0X"
		(logxor (char-code (char string i))
			(char-code (char roaster (mod i rlen)))))))))

(defun normalize-string (string)
  (remove #\space (string-downcase string)))



#|

;; AOL enforces a limit on the rate at which messages can be sent;
;; it's easy for a bot that talks to multiple people simultaneously to
;; go over the "server speed limit".

(defclass throttled-aim-connection (aim-connection)
  ((max-send-rate :accessor aim-connection-max-send-rate :initform nil
		  :initarg :max-send-rate)
   (regulator-process :accessor regulator-process :initform nil)
   (toc-queue :accessor toc-queue :initform (make-instance 'util:synched-queue))))

    
(defmethod send-toc ((self throttled-aim-connection) fmt &rest args)
  (let ((msg (apply #'format nil fmt args)))
    (util:q-add (toc-queue self) msg)))


(defmethod toc-queue-regulator ((self throttled-aim-connection))
  (flet ((wait-for-toc-in-queue (queue)
	   (process-wait "Waiting for queue"
			 #'(lambda ()
			     (not (util:q-empty-p queue))))))
    (loop
      (wait-for-toc-in-queue (toc-queue self))
      (write-toc (aim-connection-stream self)
		 (util:q-head (toc-queue self)))
      (sleep (/ 1.0 (aim-connection-max-send-rate self))))))


(defmethod close-aim-connection :around ((self throttled-aim-connection))
  (call-next-method)
  (when (regulator-process self)
    (process-kill (regulator-process self))))

(defmethod open-aim-connection :after ((self throttled-aim-connection))
  (setf (regulator-process self)
	(process-run-function "AIM throttler"
			      #'toc-queue-regulator
			      self)))
|#

#|

;; One way to run the AIM connection in a different process.

(defclass async-aim-connection (aim-connection)
  ((handler-proc :accessor aim-connection-handler-proc :initform nil)))

(defmethod open-aim-connection :after ((self async-aim-connection))
  (setf (aim-connection-handler-proc self) (make-aim-handler-process self)))
  
(defmethod close-aim-connection :before ((self async-aim-connection))
  (when (aim-connection-handler-proc self)
    (process-kill (aim-connection-handler-proc self))
    (setf (aim-connection-handler-proc self) nil)))

(defvar *process-number* 0)

(defmethod make-aim-handler-process ((self async-aim-connection))
  (process-run-function (format nil "AIM Handler ~S" (incf *process-number*))
			'handler-process-loop self))

(defmethod handler-process-loop ((self async-aim-connection))
  (if (not (aim-connection-auto-reconnect-p self))
    (receive-events self)
    (let ((continue-p T))
      (do ()
	  ((not continue-p))
	(handler-case
	 (receive-events self)
	 (disconnect-error (e)
	   (warn "AIM connection got the following error: ~A" e)
	   (setf continue-p (handle-disconnection self)))))
      (close (aim-connection-stream self))
      (setf (aim-connection-stream self) nil))))

|#