From: Christophe Rhodes <csr21@cantab.net>
Date: Mon, 16 Dec 2013 09:05:12 +0000 (+0000)
Subject: accept-header parsing
X-Git-Tag: els2014-submission~23
X-Git-Url: http://christophe.rhodes.io/gitweb/?a=commitdiff_plain;h=de2944d5e7a9c5f1b7ee3c32c12cbda71832f6fe;p=specializable.git

accept-header parsing

INSERT routine to insert (and possibly modify the q of) a node

Parser using cl-ppcre, which will win few prizes for robustness but at
least gets the header as sent by Chromium on my computer right...
---

diff --git a/accept-specializer.lisp b/accept-specializer.lisp
index 4ebe091..67d9d36 100644
--- a/accept-specializer.lisp
+++ b/accept-specializer.lisp
@@ -78,6 +78,39 @@
         (and type-node (accept-node-q type-node))
         (accept-node-q accept-tree))))
 
+(defun insert (range q tree)
+  (labels ((ensure-node (range tree)
+             (cond
+               ((null range) tree)
+               (t (ensure-node (cdr range)
+                               (or (find (car range) (accept-node-children tree)
+                                         :key #'accept-node-name :test #'string=)
+                                   (car (push
+                                         (make-accept-node :name (car range))
+                                         (accept-node-children tree)))))))))
+    (let ((node (ensure-node range tree)))
+      ;; we could choose different behaviour here
+      (setf (accept-node-q node) q))
+    tree))
+
+(defun parse-accept-string (string)
+  (flet ((whitespacep (x)
+           (member x '(#\Space #\Tab))))
+    (let ((string (remove-if #'whitespacep string))
+          (result (make-accept-node :name nil)))
+      (cl-ppcre:do-register-groups (type subtype qp q)
+          ;; not desperately error-proof
+          ("([a-z]*|\\*)/([a-z]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
+        (if qp
+            (setf q (float (+ (digit-char-p (char q 0))
+                              (/ (parse-integer q :start 2)
+                                 (expt 10 (- (length q) 2))))))
+            (setf q 1.0))
+        (let ((range (and (string/= type "*")
+                          (cons type (and (string/= subtype "*")
+                                          (list subtype))))))
+          (insert range q result))))))
+
 (defclass accept-generic-function (specializable-generic-function)
   ()
   (:metaclass sb-mop:funcallable-standard-class))