PageRenderTime 23ms CodeModel.GetById 16ms RepoModel.GetById 1ms app.codeStats 0ms

/src/core/request-adapter.lisp

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