/src/core/parameters.lisp

 1
 2(in-package :oauth)
 3
 4(export '(parameter sort-parameters normalized-parameters))
 5
 6;; the cache allows us to call NORMALIZED-PARAMETERS repeatedly
 7;; without excessive processing penalty.
 8(defvar *parameters-cache* (tg:make-weak-hash-table :test #'eq :weakness :key)
 9  "Per-request cache for parameters in OAuth requests.")
10
11(defvar *signature-cache* (tg:make-weak-hash-table :test #'eq :weakness :key)
12  ;; this is much more simple than maintaining multiple caches
13  ;; for different parameter list flavors.
14  "Per-request cache for signatures in OAuth requests.")
15
16(defun sort-parameters (parameters)
17  "Sort PARAMETERS according to the OAuth spec. This is a destructive operation."
18  (assert (not (assoc "oauth_signature" parameters :test #'equal)))
19  (sort parameters #'string< :key (lambda (x)
20                                    "Sort by key and value."
21                                    (concatenate 'string (princ-to-string (car x))
22                                                 (princ-to-string (cdr x))))))
23
24(defun normalized-parameters (&key remove-duplicates-p)
25  "Collect request parameters and remove those excluded by the standard. See 9.1.1.
26  Note: REMOVE-DUPLICATES-P has no effect right now."
27  (declare (ignorable remove-duplicates-p))
28  (or (gethash (request) *parameters-cache*)
29      (let ((parameters (append (remove "realm" (auth-parameters)
30                                        :key #'car :test #'equalp) ; TODO: http auth header parameters
31                                (post-parameters)
32                                (get-parameters))))
33        ;; save the signature, we might need it later
34        (setf (gethash (request) *signature-cache*)
35              (cdr (assoc "oauth_signature" parameters :test #'equal)))
36        (let* ((parameters (remove "oauth_signature" parameters
37                                   :key #'car :test #'equal))
38               (sorted-parameters (sort-parameters parameters)))
39          (setf (gethash (request) *parameters-cache*) sorted-parameters)
40          sorted-parameters
41          #+(or) ; disabled for now because it makes caching slightly more complex.
42                 ; we just don't support elimination of duplicates right now.
43          (if remove-duplicates-p
44            (remove-duplicates sorted-parameters :key #'car :test #'string-equal :from-end t)
45            sorted-parameters)))))
46
47(defun parameter (name &key (test #'equal))
48  "Note: OAuth parameters are case-sensitive per section 5.
49  The case of user-supplied parameters is not restricted."
50  (cdr (assoc name (normalized-parameters) :test test)))
51
52(defun oauth-parameter-p (parameter)
53  "Return T if PARAMETER starts with \"oauth_\". PARAMETER is a
54string denoting the parameter name."
55  (equal
56    (subseq (car (ensure-list parameter)) 0 (min 6 (length parameter)))
57    "oauth_" ))
58
59(defun remove-oauth-parameters (parameters)
60  (remove-if #'oauth-parameter-p parameters :key #'car))
61