Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
103 lines (88 sloc) 3.74 KB
(defpackage #:firephp
(:use :cl)
(:documentation
"FirePHP protocol server implementation"))
(in-package :firephp)
(export '(send-message fb descr *escape-html-p*))
(defun split-into-chunks (sequence &optional (size 1))
(let ((list (copy-seq sequence)))
(loop while list collect
(if (< (length list) size)
(prog1
list
(setf list nil))
(prog1
(subseq list 0 size)
(setf list (subseq list size)))))))
(defun send-header (name value)
(setf (hunchentoot:header-out name) value))
(defun get-last-message-index ()
(let ((value (hunchentoot:header-out :x-wf-1-index)))
(if value (parse-integer value)
0)))
(defun send-message (message &rest args &key (type :dump) (label nil))
(unless (boundp 'hunchentoot:*reply*)
(warn "It seems like hunchentoot is not started, trying to send message ~A" message)
(return-from send-message))
(let*
((dump (equal type :dump))
(structure-index (if dump 2 1))
(message-index (1+ (get-last-message-index)))
(firephp-version "0.3"))
(send-header "X-Wf-Protocol-1" "http://meta.wildfirehq.org/Protocol/JsonStream/0.2")
(send-header "X-Wf-1-Plugin-1" (format nil "http://meta.firephp.org/Wildfire/Plugin/FirePHP/Library-FirePHPCore/~a" firephp-version))
(if dump
(progn
(send-header "X-Wf-1-Structure-2" "http://meta.firephp.org/Wildfire/Structure/FirePHP/Dump/0.1")
(if label
(setf message (format nil "{\"~A\":~A}" label (json:encode-json-to-string message)))
(setf message (json:encode-json-to-string message))))
(progn
(send-header "X-Wf-1-Structure-1" "http://meta.firephp.org/Wildfire/Structure/FirePHP/FirebugConsole/0.1")
(loop for i in (list :type) do
(when (getf args i)
(setf (getf args i) (string-upcase (getf args i)))))
(setf message
(format nil "[~A,~A]"
(json:encode-json-alist-to-string
(loop for (key value) on args :by #'cddr
collect (cons (string-capitalize key) value)))
(json:encode-json-to-string message)))))
(let* ((chunks (split-into-chunks message 5000))
(chunks-length (length chunks)))
(loop for i in chunks
for j from 0 do
(if (> chunks-length 2)
(send-header (format nil "X-Wf-1-~d-1-~d" structure-index message-index)
(format nil "~a|~a|~a"
(if (zerop j) (length message) "")
i
(if (< j (- chunks-length 2)) "\\" "")))
(send-header (format nil "X-Wf-1-~d-1-~d" structure-index message-index)
(format nil "~a|~a|~a" (length i) i "")))
(incf message-index 1)))
(send-header "X-Wf-1-Index" (write-to-string (- message-index 1)))))
(defvar *escape-html-p* t)
(defun maybe-escape-html (str)
(if *escape-html-p*
(hunchentoot:escape-for-html str)
str))
(defun fb (&rest args)
"Simple debug function applies to any arguments and just displays them"
(send-message
(format nil "~{#~d ~A~^~[<br/>~;~%~]~}"
(loop for i from 1
for j in (mapcar #'maybe-escape-html (mapcar #'prin1-to-string args))
append (list i j (if *escape-html-p* 0 1)))) :type :log))
(defun descr (&rest args)
(send-message
(ppcre:regex-replace-all
(string #\Newline)
(maybe-escape-html
(with-output-to-string (s)
(loop for i in args do
(describe i s))))
(if *escape-html-p*
"<br/>"
(string #\Newline)))
:type :log))