close #20 user_setup_url automatic generation
Mon Jul 11 16:43:11 PDT 2011 Anton Vodonosov <avodonosov@yandex.ru>
* close #20 user_setup_url automatic generation
diff -rN -u old-cl-openid/README.html new-cl-openid/README.html
--- old-cl-openid/README.html 2014-07-31 04:34:44.000000000 -0700
+++ new-cl-openid/README.html 2014-07-31 04:34:44.000000000 -0700
@@ -7,7 +7,7 @@
<title>CL-OpenID</title>
<meta http-equiv="Content-Type" content="text/html;charset=utf-8"/>
<meta name="generator" content="Org-mode"/>
-<meta name="generated" content="2011-06-12 03:59:37 "/>
+<meta name="generated" content="2011-07-12 02:39:44 "/>
<meta name="author" content="Maciej Pasternacki"/>
<meta name="description" content=""/>
<meta name="keywords" content=""/>
@@ -152,16 +152,15 @@
<li><a href="#sec-3_2_4">3.2.4 Function <code>CANCEL-RESPONSE-URI</code> <i>op</i> <i>message</i> ⇒ <i>uri</i> </a></li>
<li><a href="#sec-3_2_5">3.2.5 Function <code>SUCCESSFUL-RESPONSE-URI</code> <i>op</i> <i>auth-request-message</i> ⇒ <i>uri</i> </a></li>
<li><a href="#sec-3_2_6">3.2.6 Generic <code>HANDLE-CHECKID-IMMEDIATE</code> <i>op message</i> ⇒ <i>generalized-boolean</i> </a></li>
-<li><a href="#sec-3_2_7">3.2.7 Generic <code>USER-SETUP-URL</code> <i>op message</i> ⇒ <i>uri</i> </a></li>
-<li><a href="#sec-3_2_8">3.2.8 Generic <code>HANDLE-CHECKID-SETUP</code> <i>op message</i> ⇒ <i>response values</i> </a></li>
-<li><a href="#sec-3_2_9">3.2.9 Protocol messages </a>
-<ul>
-<li><a href="#sec-3_2_9_1">3.2.9.1 Function <code>MAKE-MESSAGE</code> <i>&amp;rest parameters</i> ⇒ <i>message</i> </a></li>
-<li><a href="#sec-3_2_9_2">3.2.9.2 Function <code>COPY-MESSAGE</code> <i>message &amp;rest parameters</i> ⇒ <i>message</i> </a></li>
-<li><a href="#sec-3_2_9_3">3.2.9.3 Function <code>IN-NS</code> <i>message &amp;optional namespace</i> ⇒ <i>message</i> </a></li>
-<li><a href="#sec-3_2_9_4">3.2.9.4 Function <code>MESSAGE-FIELD</code> <i>message field-name</i> ⇒ <i>value</i> </a></li>
-<li><a href="#sec-3_2_9_5">3.2.9.5 Function <code>MESSAGE-V2-P</code> <i>message</i> ⇒ <i>boolean</i> </a></li>
-<li><a href="#sec-3_2_9_6">3.2.9.6 Function <code>AUTH-REQUEST-REALM</code> <i>auth-request-message</i> ⇒ <i>string</i> </a></li>
+<li><a href="#sec-3_2_7">3.2.7 Generic <code>HANDLE-CHECKID-SETUP</code> <i>op message</i> ⇒ <i>response values</i> </a></li>
+<li><a href="#sec-3_2_8">3.2.8 Protocol messages </a>
+<ul>
+<li><a href="#sec-3_2_8_1">3.2.8.1 Function <code>MAKE-MESSAGE</code> <i>&amp;rest parameters</i> ⇒ <i>message</i> </a></li>
+<li><a href="#sec-3_2_8_2">3.2.8.2 Function <code>COPY-MESSAGE</code> <i>message &amp;rest parameters</i> ⇒ <i>message</i> </a></li>
+<li><a href="#sec-3_2_8_3">3.2.8.3 Function <code>IN-NS</code> <i>message &amp;optional namespace</i> ⇒ <i>message</i> </a></li>
+<li><a href="#sec-3_2_8_4">3.2.8.4 Function <code>MESSAGE-FIELD</code> <i>message field-name</i> ⇒ <i>value</i> </a></li>
+<li><a href="#sec-3_2_8_5">3.2.8.5 Function <code>MESSAGE-V2-P</code> <i>message</i> ⇒ <i>boolean</i> </a></li>
+<li><a href="#sec-3_2_8_6">3.2.8.6 Function <code>AUTH-REQUEST-REALM</code> <i>auth-request-message</i> ⇒ <i>string</i> </a></li>
</ul>
</li>
</ul>
@@ -745,30 +744,9 @@
</div>
<div id="outline-container-3_2_7" class="outline-4">
-<h4 id="sec-3_2_7"><span class="section-number-4">3.2.7</span> Generic <code>USER-SETUP-URL</code> <i>op message</i> ⇒ <i>uri</i> </h4>
+<h4 id="sec-3_2_7"><span class="section-number-4">3.2.7</span> Generic <code>HANDLE-CHECKID-SETUP</code> <i>op message</i> ⇒ <i>response values</i> </h4>
<div class="outline-text-4" id="text-3_2_7">
-<p>URI for user setup to return on failed immediate request.
-</p>
-<p>
-When NIL is returned, no user_setup_url is sent in setup_needed
-responses.
-</p>
-<p>
-This generic should be specialized on concrete Provider classes to
-provide entry point to user authentication dialogue.
-</p>
-<p>
-Default method always returns NIL.
-</p>
-</div>
-
-</div>
-
-<div id="outline-container-3_2_8" class="outline-4">
-<h4 id="sec-3_2_8"><span class="section-number-4">3.2.8</span> Generic <code>HANDLE-CHECKID-SETUP</code> <i>op message</i> ⇒ <i>response values</i> </h4>
-<div class="outline-text-4" id="text-3_2_8">
-
<p>Handles checkid_setup requests.
</p>
<p>
@@ -790,9 +768,9 @@
</div>
-<div id="outline-container-3_2_9" class="outline-4">
-<h4 id="sec-3_2_9"><span class="section-number-4">3.2.9</span> Protocol messages </h4>
-<div class="outline-text-4" id="text-3_2_9">
+<div id="outline-container-3_2_8" class="outline-4">
+<h4 id="sec-3_2_8"><span class="section-number-4">3.2.8</span> Protocol messages </h4>
+<div class="outline-text-4" id="text-3_2_8">
<p>Messages passed between OpenID Provider and the Relying Party are
composed of key-value pairs. Natural Lisp representation of
@@ -803,9 +781,9 @@
</div>
-<div id="outline-container-3_2_9_1" class="outline-5">
-<h5 id="sec-3_2_9_1"><span class="section-number-5">3.2.9.1</span> Function <code>MAKE-MESSAGE</code> <i>&amp;rest parameters</i> ⇒ <i>message</i> </h5>
-<div class="outline-text-5" id="text-3_2_9_1">
+<div id="outline-container-3_2_8_1" class="outline-5">
+<h5 id="sec-3_2_8_1"><span class="section-number-5">3.2.8.1</span> Function <code>MAKE-MESSAGE</code> <i>&amp;rest parameters</i> ⇒ <i>message</i> </h5>
+<div class="outline-text-5" id="text-3_2_8_1">
<p>Make new message from arbitrary keyword parameters.
</p>
@@ -827,9 +805,9 @@
</div>
-<div id="outline-container-3_2_9_2" class="outline-5">
-<h5 id="sec-3_2_9_2"><span class="section-number-5">3.2.9.2</span> Function <code>COPY-MESSAGE</code> <i>message &amp;rest parameters</i> ⇒ <i>message</i> </h5>
-<div class="outline-text-5" id="text-3_2_9_2">
+<div id="outline-container-3_2_8_2" class="outline-5">
+<h5 id="sec-3_2_8_2"><span class="section-number-5">3.2.8.2</span> Function <code>COPY-MESSAGE</code> <i>message &amp;rest parameters</i> ⇒ <i>message</i> </h5>
+<div class="outline-text-5" id="text-3_2_8_2">
<p>Create a copy of MESSAGE, updating PARAMETERS provided as keyword parameters.
</p>
@@ -842,9 +820,9 @@
</div>
-<div id="outline-container-3_2_9_3" class="outline-5">
-<h5 id="sec-3_2_9_3"><span class="section-number-5">3.2.9.3</span> Function <code>IN-NS</code> <i>message &amp;optional namespace</i> ⇒ <i>message</i> </h5>
-<div class="outline-text-5" id="text-3_2_9_3">
+<div id="outline-container-3_2_8_3" class="outline-5">
+<h5 id="sec-3_2_8_3"><span class="section-number-5">3.2.8.3</span> Function <code>IN-NS</code> <i>message &amp;optional namespace</i> ⇒ <i>message</i> </h5>
+<div class="outline-text-5" id="text-3_2_8_3">
<p>Add openid.namespace <i>namespace</i> to <i>message</i>.
</p>
@@ -855,9 +833,9 @@
</div>
-<div id="outline-container-3_2_9_4" class="outline-5">
-<h5 id="sec-3_2_9_4"><span class="section-number-5">3.2.9.4</span> Function <code>MESSAGE-FIELD</code> <i>message field-name</i> ⇒ <i>value</i> </h5>
-<div class="outline-text-5" id="text-3_2_9_4">
+<div id="outline-container-3_2_8_4" class="outline-5">
+<h5 id="sec-3_2_8_4"><span class="section-number-5">3.2.8.4</span> Function <code>MESSAGE-FIELD</code> <i>message field-name</i> ⇒ <i>value</i> </h5>
+<div class="outline-text-5" id="text-3_2_8_4">
<p>Get value of <i>field-name</i> field from <i>message</i>.
</p>
@@ -865,9 +843,9 @@
</div>
-<div id="outline-container-3_2_9_5" class="outline-5">
-<h5 id="sec-3_2_9_5"><span class="section-number-5">3.2.9.5</span> Function <code>MESSAGE-V2-P</code> <i>message</i> ⇒ <i>boolean</i> </h5>
-<div class="outline-text-5" id="text-3_2_9_5">
+<div id="outline-container-3_2_8_5" class="outline-5">
+<h5 id="sec-3_2_8_5"><span class="section-number-5">3.2.8.5</span> Function <code>MESSAGE-V2-P</code> <i>message</i> ⇒ <i>boolean</i> </h5>
+<div class="outline-text-5" id="text-3_2_8_5">
<p>True if <i>message</i> is an OpenID v2 message (namespace check).
</p>
@@ -875,9 +853,9 @@
</div>
-<div id="outline-container-3_2_9_6" class="outline-5">
-<h5 id="sec-3_2_9_6"><span class="section-number-5">3.2.9.6</span> Function <code>AUTH-REQUEST-REALM</code> <i>auth-request-message</i> ⇒ <i>string</i> </h5>
-<div class="outline-text-5" id="text-3_2_9_6">
+<div id="outline-container-3_2_8_6" class="outline-5">
+<h5 id="sec-3_2_8_6"><span class="section-number-5">3.2.8.6</span> Function <code>AUTH-REQUEST-REALM</code> <i>auth-request-message</i> ⇒ <i>string</i> </h5>
+<div class="outline-text-5" id="text-3_2_8_6">
<p>Returns the realm of the OpenID authentication
request <i>auth-request-message</i>.
@@ -892,7 +870,7 @@
<div id="postamble">
<p class="author"> Author: Maciej Pasternacki
</p>
-<p class="date"> Date: 2011-06-12 03:59:37 </p>
+<p class="date"> Date: 2011-07-12 02:39:44 </p>
<p class="creator">HTML generated by org-mode 6.36c in emacs 23</p>
</div>
</div>
diff -rN -u old-cl-openid/README.org new-cl-openid/README.org
--- old-cl-openid/README.org 2014-07-31 04:34:44.000000000 -0700
+++ new-cl-openid/README.org 2014-07-31 04:34:44.000000000 -0700
@@ -252,17 +252,6 @@
Default method always fails.
-*** Generic =USER-SETUP-URL= /op message/ ⇒ /uri/
- URI for user setup to return on failed immediate request.
-
- When NIL is returned, no user_setup_url is sent in setup_needed
- responses.
-
- This generic should be specialized on concrete Provider classes to
- provide entry point to user authentication dialogue.
-
- Default method always returns NIL.
-
*** Generic =HANDLE-CHECKID-SETUP= /op message/ ⇒ /response values/
Handles checkid_setup requests.
diff -rN -u old-cl-openid/cl-openid.asd new-cl-openid/cl-openid.asd
--- old-cl-openid/cl-openid.asd 2014-07-31 04:34:44.000000000 -0700
+++ new-cl-openid/cl-openid.asd 2014-07-31 04:34:44.000000000 -0700
@@ -57,7 +57,7 @@
(:file "authproc" :depends-on ("suite"))
(:file "relying-party" :depends-on ("suite"))
(:file "provider" :depends-on ("suite")))))
- :depends-on (#:cl-openid #:fiveam))
+ :depends-on (#:cl-openid #:fiveam #:flexi-streams))
(defmethod perform ((op asdf:test-op)
(system (eql (find-system :cl-openid))))
diff -rN -u old-cl-openid/src/package.lisp new-cl-openid/src/package.lisp
--- old-cl-openid/src/package.lisp 2014-07-31 04:34:44.000000000 -0700
+++ new-cl-openid/src/package.lisp 2014-07-31 04:34:44.000000000 -0700
@@ -25,7 +25,7 @@
;; OP class
#:openid-provider #:endpoint-uri
;; OP API
- #:handle-openid-provider-request #:handle-checkid-setup #:handle-checkid-immediate #:user-setup-url
+ #:handle-openid-provider-request #:handle-checkid-setup #:handle-checkid-immediate
;; OP responses
#:successful-response-uri #:cancel-response-uri #:+indirect-response-code+
;; Message API
diff -rN -u old-cl-openid/src/provider.lisp new-cl-openid/src/provider.lisp
--- old-cl-openid/src/provider.lisp 2014-07-31 04:34:44.000000000 -0700
+++ new-cl-openid/src/provider.lisp 2014-07-31 04:34:44.000000000 -0700
@@ -133,15 +133,33 @@
(indirect-response (message-field auth-request-message "openid.return_to")
(successful-response-message op auth-request-message))))
-;;; Setup needed message generation
-(defgeneric user-setup-url (op message)
- (:documentation "URI for user setup to return on failed immediate request.
+;;; Setup needed message generation.
-This generic should be specialized on concrete Provider classes to
-provide entry point to user authentication dialogue.")
- (:method (op message)
- (declare (ignore op message))
- nil))
+;; For backward compatibility with OpenID 1.1
+;; we need to provide the openid.user_setup_url response
+;; parameter when replying to a failed immediate
+;; authentication requests.
+;;
+;; See OpenID Authentication 1.1, Sections
+;; 4.2.2.2. Sent on Failed Assertion and 4.2.3. Extra Notes
+;; for the description of this response parameter.
+;; And OpenID Authentication 2.0 - Final,
+;; Section 14.2. Implementing OpenID Authentication 1.1 Compatibility
+;; requiring us to implement it.
+;;
+;; In our implementation the openid.user_setup_url is just an URI
+;; representing checkid_setup authentication request to the
+;; same provider.
+(defun user-setup-url (op message)
+ "Returns the value to be passed in the openid.user_setup_url
+parameter of a response to a failed immediate authentication request.
+OP is the OpenID Provider. MESSAGE is the original authentication
+request. In case the MESSAGE is a request of OpenID version 2,
+returns NIL."
+ (declare (ignore op))
+ (when (not (message-v2-p message))
+ (indirect-message-uri (endpoint-uri op)
+ (copy-message message :openid.mode "checkid_setup"))))
(define-constant +setup-needed-response-message+
(in-ns (make-message :openid.mode "setup_needed")))
diff -rN -u old-cl-openid/t/provider.lisp new-cl-openid/t/provider.lisp
--- old-cl-openid/t/provider.lisp 2014-07-31 04:34:44.000000000 -0700
+++ new-cl-openid/t/provider.lisp 2014-07-31 04:34:44.000000000 -0700
@@ -95,3 +95,198 @@
:assoc-type assoc-type
:allow-unencrypted-association-p nil))))
+
+;; Test openid-provider; the implementations of generic
+;; functions which should be redefined by a derived class
+;; are slots here, so that we don't need to define new
+;; class for every test case where we need to hook into
+;; the functions.
+(defclass test-openid-provider (openid-provider)
+ ((handle-checkid-setup-impl :type (or function null)
+ :initarg :handle-checkid-setup-impl
+ :initform nil)
+ (handle-checkid-immediate-impl :type (or function null)
+ :initarg :handle-checkid-immediate-impl
+ :initform nil)))
+
+(defmethod handle-checkid-setup ((op test-openid-provider) message)
+ (with-slots ((impl handle-checkid-setup-impl)) op
+ (if impl
+ (funcall impl op message)
+ (call-next-method))))
+
+(defmethod handle-checkid-immediate ((op test-openid-provider) message)
+ (with-slots ((impl handle-checkid-immediate-impl)) op
+ (if impl
+ (funcall impl op message)
+ (call-next-method))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Some utils code
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun split (char string)
+ "Returns a list of substrings of string
+divided by ONE character CHAR each.
+Note: Two consecutive CHARs will be seen as
+if there were an empty string between them."
+ (loop for i = 0 then (1+ j)
+ as j = (position char string :start i)
+ collect (subseq string i j)
+ while j))
+
+;; -------------------------------------------------------------------------- ;;
+;; UrlDecoding
+;;
+;; copy/pasted from hunchentoot.
+;; It's bad we don't have a reusable library for just url-decoding/encoding.
+;; Maybe move it to a separate library some day...
+;; call the main functions encode-uri-component decode-uri-component then.
+;; -------------------------------------------------------------------------- ;;
+
+(defmacro upgrade-vector (vector new-type &key converter)
+ "Returns a vector with the same length and the same elements as
+VECTOR \(a variable holding a vector) but having element type
+NEW-TYPE. If CONVERTER is not NIL, it should designate a function
+which will be applied to each element of VECTOR before the result is
+stored in the new vector. The resulting vector will have a fill
+pointer set to its end.
+
+The macro also uses SETQ to store the new vector in VECTOR."
+ `(setq ,vector
+ (loop with length = (length ,vector)
+ with new-vector = (make-array length
+ :element-type ,new-type
+ :fill-pointer length)
+ for i below length
+ do (setf (aref new-vector i) ,(if converter
+ `(funcall ,converter (aref ,vector i))
+ `(aref ,vector i)))
+ finally (return new-vector))))
+
+(defun url-decode (string &optional (external-format :utf-8))
+ "Decodes a URL-encoded STRING which is assumed to be encoded using
+the external format EXTERNAL-FORMAT."
+ (when (zerop (length string))
+ (return-from url-decode ""))
+ (let ((vector (make-array (length string) :element-type '(unsigned-byte 8) :fill-pointer 0))
+ (i 0)
+ unicodep)
+ (loop
+ (unless (< i (length string))
+ (return))
+ (let ((char (aref string i)))
+ (labels ((decode-hex (length)
+ (prog1
+ (parse-integer string :start i :end (+ i length) :radix 16)
+ (incf i length)))
+ (push-integer (integer)
+ (vector-push integer vector))
+ (peek ()
+ (aref string i))
+ (advance ()
+ (setq char (peek))
+ (incf i)))
+ (cond
+ ((char= #\% char)
+ (advance)
+ (cond
+ ((char= #\u (peek))
+ (unless unicodep
+ (setq unicodep t)
+ (upgrade-vector vector '(integer 0 65535)))
+ (advance)
+ (push-integer (decode-hex 4)))
+ (t
+ (push-integer (decode-hex 2)))))
+ (t
+ (push-integer (char-code (case char
+ ((#\+) #\Space)
+ (otherwise char))))
+ (advance))))))
+ (cond (unicodep
+ (upgrade-vector vector 'character :converter #'code-char))
+ (t (flex:octets-to-string vector :external-format external-format)))))
+
+
+;; -------------------------------------------------------------------------------- ;;
+;; end of UrlDecoding
+;; -------------------------------------------------------------------------------- ;;
+
+;; Helper function to parse key-vals of the URL parameters.
+;; Again, copy/pasted from hunchentoot.
+(defun form-url-encoded-list-to-alist (form-url-encoded-list
+ &optional (external-format :utf-8))
+ "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
+alist. Both names and values are url-decoded while doing this.
+FORM-URL-ENCODED-LIST is something like (\"key=value\" \"key2=value2\")."
+ (mapcar #'(lambda (entry)
+ (destructuring-bind (name &optional value)
+ ;;(split "=" entry :limit 2) ;; it's the original hunchentoot code
+ ;; but our SPLIT is simpler, there is no :LIMIT 2 argument
+ ;; (and we are not copy/pasting the SPLIT from hunchentoot
+ ;; because we don't want to depend on ppcre
+ (split #\= entry)
+ (cons (string-trim " " (url-decode name external-format))
+ (url-decode (or value "") external-format))))
+ form-url-encoded-list))
+
+(defun uri-query-to-params-alist (uri-query-string)
+ (form-url-encoded-list-to-alist (split #\& uri-query-string)))
+
+(defun uri-params-alist (uri)
+ "URI may be as string or PURI:URI"
+ (uri-query-to-params-alist (puri:uri-query (puri:uri uri))))
+
+(defun uri-param (uri param-name)
+ "URI may be a string or PURI:URI"
+ (cdr (assoc param-name (uri-params-alist uri)
+ :test #'string=)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; end of the utils
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test user-setup-url
+ (let* (;; make a customized instance of the TEST-OPENID-PROVIDER
+ ;; which returns a special value from handle-checkid-setup.
+ (op (make-instance 'test-openid-provider
+ :endpoint-uri "http://test-endpoint-uri.com/"
+ :handle-checkid-setup-impl (lambda (&rest ignored)
+ (declare (ignore ignored))
+ "handle-checkid-setup-called"))))
+
+ ;; Now request checkid-immediate from that provider
+ ;; receive negative response and retrieve
+ ;; the openid.user_setup_url response parameter.
+ ;;
+ ;; This response parameter should be a valid checkid_setup request
+ ;; to the same provider.
+ ;;
+ ;; Test it by querying the provider and ensuring the
+ ;; handle-openid-provider-requeest returns the value we return
+ ;; from handle-checkid-setup, which means our checkid-setup was called.
+ (let ((immediate-p t)
+ (claimed-id "test-claimed-id")
+ (op-local-id "test-op-local-id")
+ (return-to "test-return-to")
+ (protocol-version-major 1)
+ (realm "test-realm"))
+ (let* ((msg (make-message
+ :openid.mode "checkid_immediate"
+ :openid.claimed_id claimed-id
+ :openid.identity (or op-local-id claimed-id)
+ :openid.return_to return-to
+ (if (= 2 protocol-version-major)
+ :openid.realm ; OpenID 1.x compat: trust_root instead of realm
+ :openid.trust_root) realm))
+ (reply-uri (handle-openid-provider-request op
+ msg
+ :allow-unencrypted-association-p t))
+ (setup-url (uri-param reply-uri "openid.user_setup_url"))
+ (new-request-msg (uri-params-alist setup-url)))
+
+ (is (string= "handle-checkid-setup-called"
+ (cl-openid:handle-openid-provider-request op
+ new-request-msg
+ :allow-unencrypted-association-p t)))))))