fix accept specificity precedence and apply review suggestions

Agent-Logs-Url: https://github.com/cl-sdk/io.github.cl-sdk.wst/sessions/8bd1c9ad-db36-47af-8308-90945d4f986d

Co-authored-by: diasbruno <362368+diasbruno@users.noreply.github.com>

Author: Copilot

request-accept/package.lisp

@@ -15,13 +15,17 @@
 (defconstant +ascii-printable-end+ 126)
 ;; C0 control upper bound (US, 31) used to reject control chars except HTAB.
 (defconstant +ascii-control-end+ 31)
+(defconstant +invalid-media-range-specificity+ -1)
 
-(defparameter *default-response-accept* '(:|text/plain| ("q" "1.0")))
+(defparameter *default-response-accept* '(:|text/plain| ("q" . "1.0")))
 
 (defgeneric respond-with (implementation content request response)
-  (:documentation "Render CONTENT according to IMPLEMENTATION (a selected media type).")
+  (:documentation "Render CONTENT according to IMPLEMENTATION (a selected media type).
+
+The default method returns RESPONSE unchanged.")
   (:method ((implementation t) content request response)
-    content))
+    (declare (ignore implementation content request))
+    response))
 
 (defun %find-response-accept-for-type (response-accepts media-type)
   (if (string-equal media-type "*")
@@ -37,10 +41,12 @@
          (media-type (first mime-sub))
          (media-subtype (second mime-sub)))
     (cond
-      ((and (string-equal "*" media-type)
+      ((and media-type media-subtype
+            (string-equal "*" media-type)
             (string-equal "*" media-subtype))
        (car response-accepts))
-      ((string-equal "*" media-subtype)
+      ((and media-subtype
+            (string-equal "*" media-subtype))
        (%find-response-accept-for-type response-accepts media-type))
       (t
        (find (car request-accept) response-accepts :test #'eq)))))
@@ -129,13 +135,33 @@ REQUEST-ACCEPTS must be ordered by preference (for example, output from
 (defun %process-request-accepts (request-accepts)
   (labels ((get-accept-entry-quality-value (entry)
              (or (find-if (lambda (item) (string-equal (car item) "q"))
-                         entry)
-                '("q" . "1.0"))))
+                          entry)
+                 '("q" . "1.0")))
+           (media-range-specificity (entry)
+             (let* ((parts (split "/" (string (car entry))))
+                    (media-type (first parts))
+                    (media-subtype (second parts)))
+               (cond
+                 ((and media-type media-subtype
+                       (string-equal media-type "*")
+                       (string-equal media-subtype "*"))
+                  0)
+                 ((and media-subtype
+                       (string-equal media-subtype "*"))
+                  1)
+                 ((and media-type media-subtype)
+                  2)
+                 (t
+                  +invalid-media-range-specificity+)))))
     (sort request-accepts
           (lambda (a b)
             (let* ((qa (get-accept-entry-quality-value (cdr a)))
-                   (qb (get-accept-entry-quality-value (cdr b))))
-              (> (serapeum:parse-float (cdr qa)) (serapeum:parse-float (cdr qb))))))))
+                   (qb (get-accept-entry-quality-value (cdr b)))
+                   (qa-value (serapeum:parse-float (cdr qa)))
+                   (qb-value (serapeum:parse-float (cdr qb))))
+              (if (= qa-value qb-value)
+                  (> (media-range-specificity a) (media-range-specificity b))
+                  (> qa-value qb-value)))))))
 
 (defun parse-request-accept (accept-header)
   "Parse an HTTP Accept header into media-range entries.

t/request-accept-tests.lisp

@@ -30,13 +30,33 @@
                  (io.github.cl-sdk.wst.request-accept:parse-request-accept
                   "text/plain; foo"))))
 
+(5am:def-test parse-request-accept-prioritizes-specific-on-equal-quality ()
+  (5am:is (equal '((:|application/json| ("q" . "1.0"))
+                   (:|text/*| ("q" . "1.0")))
+                 (io.github.cl-sdk.wst.request-accept:parse-request-accept
+                  "text/*, application/json"))))
+
 (5am:def-test find-best-response-accept-picks-supported-wildcard-type ()
   (5am:is (equal '(:|text/html| ("q" . "1.0"))
                  (io.github.cl-sdk.wst.request-accept:find-best-response-accept
                   '(:|application/json| :|text/html|)
                   '((:|text/*| ("q" . "1.0"))
                     (:|application/*| ("q" . "0.9")))))))
 
+(5am:def-test find-best-response-accept-prefers-specific-media-type ()
+  (5am:is (equal '(:|application/json| ("q" . "1.0"))
+                 (io.github.cl-sdk.wst.request-accept:find-best-response-accept
+                  '(:|application/json| :|text/html|)
+                  (io.github.cl-sdk.wst.request-accept:parse-request-accept
+                   "text/*, application/json")))))
+
+(5am:def-test find-best-response-accept-ignores-malformed-media-range ()
+  (5am:is (equal '(:|application/json| ("q" . "1.0"))
+                 (io.github.cl-sdk.wst.request-accept:find-best-response-accept
+                  '(:|application/json| :|text/html|)
+                  (io.github.cl-sdk.wst.request-accept:parse-request-accept
+                   "text, application/json")))))
+
 (5am:def-test find-best-response-accept-falls-back-to-any-response-for-star-star ()
   (5am:is (equal '(:|application/json| ("q" . "0.8"))
                  (io.github.cl-sdk.wst.request-accept:find-best-response-accept