/src/core/request-adapter.lisp

  1(in-package :oauth)
  2
  3;;; server-specific request abstraction layer
  4;;;
  5;;; defaults to Hunchentoot
  6
  7(export '(request-adapter
  8          make-request-adapter
  9          *request-adapter*
 10          make-hunchentoot-request-adapter
 11          init-default-request-adapter
 12          *request*
 13          request
 14          request-method
 15          request-uri
 16          abort-request
 17          auth-parameters
 18          post-parameters
 19          get-parameters)) ; TODO move to package.lisp
 20
 21
 22#.`(defstruct request-adapter ; TODO: make this a standard-class, too
 23     "An adapter for server-specific parts of OAuth.
 24The return value of REQUEST-OBJECT-FN must be comparable with EQ."
 25     ,@(loop for slotname in '(request-object-fn
 26                               request-method-fn
 27                               request-uri-fn
 28                               abort-request-fn
 29                               auth-parameters-fn
 30                               post-parameters-fn
 31                               get-parameters-fn)
 32           collect `(,slotname nil :type (or function symbol null))))
 33
 34(defun make-hunchentoot-request-adapter ()
 35  (make-request-adapter :request-object-fn (lambda () hunchentoot:*request*)
 36                        :request-uri-fn (lambda (request)
 37                                          (let* ((http-host (split-sequence #\: (hunchentoot:host request)))
 38                                                 (hostname (first http-host))
 39                                                 (port (second http-host)))
 40                                            (make-instance 'puri:uri
 41                                                           :scheme (etypecase hunchentoot:*acceptor*
 42                                                                     (hunchentoot:ssl-acceptor :https)
 43                                                                     (hunchentoot:acceptor :http))
 44                                                           :host hostname
 45                                                           :port port
 46                                                           :path (hunchentoot:script-name* request))))
 47                        :request-method-fn 'hunchentoot:request-method*
 48                        :abort-request-fn 'hunchentoot:abort-request-handler
 49                        :auth-parameters-fn (lambda (request) (declare (ignore request)) nil) ; TODO
 50                        :post-parameters-fn 'hunchentoot:post-parameters*
 51                        :get-parameters-fn 'hunchentoot:get-parameters*))
 52                                              
 53
 54(defvar *request-adapter* nil
 55  "Set this variable to an instance of REQUEST-ADAPTER tailored to
 56  your web server.")
 57
 58(defun init-default-request-adapter ()
 59  (setf *request-adapter* (make-hunchentoot-request-adapter)))
 60
 61(init-default-request-adapter)
 62
 63(defvar *request* nil
 64  "User-supplied request override. Only if you know what you're doing.")
 65
 66(defun request ()
 67  (or *request* ; allow request object override
 68      (funcall (request-adapter-request-object-fn *request-adapter*))))
 69
 70(defun request-method (&optional (request (request)))
 71  (let* ((result (funcall (request-adapter-request-method-fn *request-adapter*) request))
 72         (normalized-result (etypecase result
 73                              (keyword result)
 74                              (symbol (intern (symbol-name result) :keyword))
 75                              (string (intern result :keyword)))))
 76    (assert (member normalized-result '(:get :post :put :delete :head :trace :options :connect)))
 77    result))
 78
 79(defun request-uri (&optional (request (request)))
 80  "Return the request uri including protocol, host, port
 81and path. Other parts like the query string are optional and
 82will be ignored. The result type is (or string puri:uri)."
 83  ;; TODO: cache this
 84  (let ((result (funcall (request-adapter-request-uri-fn *request-adapter*) request)))
 85    (check-type result (or string puri:uri))
 86    result))
 87
 88;; TODO: assertions/type checks for the following functions
 89  
 90(defun auth-parameters (&optional (request (request)))
 91  (funcall (request-adapter-auth-parameters-fn *request-adapter*) request))
 92
 93(defun post-parameters (&optional (request (request)))
 94  (funcall (request-adapter-post-parameters-fn *request-adapter*) request))
 95
 96(defun get-parameters (&optional (request (request)))
 97  (funcall (request-adapter-get-parameters-fn *request-adapter*) request))
 98
 99
100(defun abort-request (result)
101  "Return the string RESULT immediately from the request handler."
102  (funcall (request-adapter-abort-request-fn *request-adapter*) result))
103