/ examples /
/examples/relying-party.lisp
  1 (defpackage #:cl-openid.example-rp
  2   (:use #:common-lisp #:cl-openid #:puri #:hunchentoot))
  3 
  4 (in-package #:cl-openid.example-rp)
  5 
  6 
  7 (defvar *relying-party* nil
  8   "A relying party instance, filled when calling INIT-RELYING-PARTY.")
  9 
 10 ;;; Formatting HTML
 11 (defun html (title body &rest body-args)
 12   (format nil "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\"
 13    \"http://www.w3.org/TR/html4/strict.dtd\">
 14 <html><head><title>~A</title></head>
 15 <body>~?</body></html>"
 16           title body body-args))
 17 
 18 (defun alist-to-lol (alist)
 19   "Return ALIST as list-of-lists for pretty formatting"
 20   (mapcar #'(lambda (c)
 21               (list (car c) (cdr c)))
 22           alist))
 23 
 24 (defparameter *login-form*
 25   (html "CL-OpenID login"
 26         "<form method=\"GET\"><fieldset><legend>OpenID Login</legend>
 27 <input type=\"text\" name=\"openid_identifier\" value=\"\" style=\"background-image: url('http://openid.net/wp-content/uploads/2007/10/openid_small_logo.png');background-position: 0px 0px;background-repeat: no-repeat;padding-left: 20px;\">
 28 <input type=\"submit\" name=\"openid_action\" value=\"Login\">
 29 <br><label><input type=\"checkbox\" name=\"checkid_immediate\"> Immediate request</label></form>")
 30   "Initial login form")
 31 
 32 (defun access-denied-screen ()
 33   "Screen displayed on cancel response"
 34   (html "CL-OpenID result"
 35         "<h1 style=\"color: red; text-decoration: blink;\">ACCESS DENIED !!!</h1>
 36 <p><strong>realm:</strong> ~A</p>
 37 <h2>Response:</h2>
 38 <dl>~:{<dt>~A</dt><dd>~A</dd>~}</dl>
 39 <p style=\"text-align:right;\"><a href=\"~A\">return</a><p>"
 40         (realm *relying-party*)
 41         (alist-to-lol (get-parameters*))
 42         (root-uri *relying-party*)))
 43 
 44 (defun access-granted-screen (authproc)
 45   "Screen displayed on successful id_res response."
 46   (html "CL-OpenID result"
 47         "<h1 style=\"color: green; text-decoration: blink;\">ACCESS GRANTED !!!</h1><p>ID: <code>~A</code></p>
 48 <h2>Response:</h2>
 49 <dl>~:{<dt>~A</dt><dd>~A</dd>~}</dl>
 50 <p style=\"text-align:right;\"><a href=\"~A\">return</a><p>"
 51         (escape-for-html (prin1-to-string authproc))
 52         (alist-to-lol (get-parameters*))
 53         (root-uri *relying-party*)))
 54 
 55 (defun assertion-error-screen (err)
 56   "Screen displayed on wrong id_res response."
 57   (html "CL-OpenID assertion error"
 58                 "<h1 style=\"color: red; text-decoration: blink;\">ERROR ERROR ERROR !!!</h1>
 59 <p><strong>~S</strong> ~A</p>
 60 <h2>Response:</h2>
 61 <dl>~:{<dt>~A</dt><dd>~A</dd>~}</dl>
 62 <p style=\"text-align:right;\"><a href=\"~A\">return</a><p>"
 63                 (code err)
 64                 err
 65                 (alist-to-lol (get-parameters*))
 66                 (root-uri *relying-party*)))
 67 
 68 ;;; Actual handler
 69 (defun handle-openid-request ()
 70   "Handle request for an OpenID Relying Party."
 71 
 72   ;; I decided to implement RP on single URI.  It is used for three
 73   ;; different things: for displaying the login form to the user, for
 74   ;; accepting the ID and initiating authentication, and for accepting
 75   ;; indirect reply and displaying result.  We distinguish these
 76   ;; situations by looking at GET parameters:
 77 
 78   (cond
 79     ;; CL-OpenID sends unique handle of authentication process in GET
 80     ;; parameter named +AUTHPROC-HANDLE-PARAMETER+.  If such parameter
 81     ;; is present, this request is an indirect response.
 82     ((get-parameter +authproc-handle-parameter+)
 83      (handler-case
 84 	 (let ((authproc (handle-indirect-response
 85                           *relying-party* (get-parameters*) ; The incoming message alist consists of GET parameters.
 86                           (merge-uris (request-uri*) (root-uri *relying-party*))))) ; Figuring out actual request URI may be more complicated with proxies
 87 	   (if authproc	; On successful id_res, AUTH-PROCESS structure is returned; on cancel response, we get NIL.
 88 	       (access-granted-screen authproc)
 89 	       (access-denied-screen)))
 90        (openid-assertion-error (e) ; On incorrect id_res OPENID-ASSERTION-ERROR is signaled
 91 	 (assertion-error-screen e))))
 92 
 93     ;; If the request is not an indirect response, we check for
 94     ;; openid_identifier parameter, in which our own login form sends
 95     ;; us user's claimed ID, as suggested by OpenID 2.0 specification,
 96     ;; section 7.1 Initiation.
 97     ((get-parameter "openid_identifier")
 98      (redirect            
 99       (initiate-authentication *relying-party* (get-parameter "openid_identifier")
100                                :immediate-p (get-parameter "checkid_immediate"))))
101 
102     ;; When there are no parameters, or there are some unexpected
103     ;; ones, we just assume it is an initial request and show the
104     ;; login form.
105     (t
106      *login-form*)))
107 
108 ;;; Initialization
109 (defun init-relying-party (realm prefix &optional (uri (merge-uris prefix realm)))
110   (setf *relying-party* (make-instance 'relying-party
111                                        :root-uri uri
112                                        :realm (uri realm)))
113 
114   (push (create-prefix-dispatcher prefix 'handle-openid-request)
115         *dispatch-table*))
116 
117 (init-relying-party "http://localhost:4242/" "/cl-openid/")