anchor.diff: -;;;; Hunchensocket - websocket.lisp Hunchentoot-based WebSocket (draft) implementation
  -;;;; Copyright (C) 2011  Alexander Kahl <e-user@fsfe.org>
  -;;;; This file is part of Hunchensocket.
  -;;;; Redistribution and use in source and binary forms, with or without
  -;;;; modification, are permitted provided that the following conditions
  -;;;; are met:
  -;;;; 
  +;;;; Hunchensocket - websocket.lisp
  +;;;;
  +;;;; Hunchentoot-based WebSocket (draft) implementation Copyright (C)
  +;;;; 2011 Alexander Kahl <e-user@fsfe.org>
  +;;;; 2014 Joao Tavora
  +;;;;
  +;;;; This file is part of Hunchensocket.  Redistribution and use in
  +;;;; source and binary forms, with or without modification, are
  +;;;; permitted provided that the following conditions are met:
  +;;;;
   ;;;;   * Redistributions of source code must retain the above copyright
   ;;;;     notice, this list of conditions and the following disclaimer.
  -;;;; 
  +;;;;
   ;;;;   * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
   ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
   ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  
positive.code: (defvar *websocket-socket* nil
    "The currently active WebSocket socket")
  
  (defparameter *websocket-handlers* nil
    "List of handler closures that will be queried for new connections")
  
  (defclass websocket-request (request)
    ((handler :accessor websocket-request-handler
              :initform nil
              :documentation "Message handler of the current request"))
    (:documentation "Subclass of the regular Hunchentoot request"))
  
  (defclass websocket-reply (reply) ()
    (:documentation "Subclass of the regular Hunchentoot reply (used only for dispatching)"))
  
  (defmethod initialize-instance :after ((reply websocket-reply) &rest initargs &key &allow-other-keys)
    "initialize-instance :after websocket-reply &rest initargs &key &allow-other-keys => side effect
  
  Set the reply's external format to Unix EOL / UTF-8 explicitly."
    (declare (ignore initargs))
    (setf (reply-external-format reply) (make-external-format :utf8 :eol-style :lf)))
  
  (defclass websocket-acceptor (acceptor)
    ((websocket-timeout :initarg :websocket-timeout
                        :accessor websocket-timeout
                        :initform 60
                        :documentation "Custom WebSocket timeout overriding the default usocket one"))
    (:default-initargs :request-class 'websocket-request :reply-class 'websocket-reply)
    (:documentation "Special WebSocket acceptor to be used in place of the regular Hunchentoot one"))
  
  (defclass websocket-ssl-acceptor (websocket-acceptor ssl-acceptor) ()
    (:documentation "Special WebSocket SSL acceptor"))
  
negative.code:   ((key :initarg :key :reader websocket-illegal-key-of
          :initform (required-argument :key)
          :documentation "Original, spurious key argument"))
    (:documentation "Signalled if client sends erroneous handshake key"))
  
  (define-condition websocket-illegal-frame-type (condition)
    ((type :initarg :type :reader websocket-illegal-frame-type-of
           :initform (required-argument :type)
           :documentation "Spurious frame type received"))
    (:documentation "Signal if client sends spurious frame type"))
  
  (defun read-bytes-array (stream number)
    "Read NUMBER bytes from Chunga STREAM into array and return it."
    (let ((result (make-array number :element-type '(unsigned-byte 8))))
      (dotimes (index number result)
        (setf (aref result index)
              (char-int (read-char* stream t))))))
  
  (defun read-key3 (request)
    "Read eight bytes from REQUEST's content stream and return them as a byte
  array."
    (read-bytes-array (content-stream request) 8))
  
  (defun digest-key (key)
    "Evaluates to MD5 digest of KEY sequence."
    (digest-sequence :md5 key))
  
  (defun websocket-uri (request host &optional ssl)
    "Form WebSocket URL (ws:// or wss://) URL."
    (format nil "~:[ws~;wss~]://~a~a" ssl host (script-name request)))
  
  (defun websocket-send-term (&optional
                                (stream *websocket-stream*)
                                (mutex *websocket-stream-mutex*))
    "Send the magic WebSocket termination sequence across STREAM."
    (with-lock-held (mutex)
      (write-sequence +websocket-terminator+ stream)
      (force-output stream)))
  
  (defun websocket-send-message (message &optional
                                           (stream *websocket-stream*)
                                           (mutex *websocket-stream-mutex*))
    "Encode MESSAGE as UTF-8 bytes and send it across STREAM in a proper frame."
    (when (> (length message) 0) ; empty message would send terminator
      (log-message* :debug "Going to send websocket message ~a" message)
      (with-lock-held (mutex)
  