/ examples /
/examples/provider.lisp
  1 (defpackage #:cl-openid.example-provider
  2   (:use #:common-lisp #:cl-openid #:puri #:hunchentoot))
  3 
  4 (in-package #:cl-openid.example-provider)
  5 
  6 (defun html (title body &rest body-args)
  7   "Simple HTML formatting."
  8   (format nil "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\"
  9    \"http://www.w3.org/TR/html4/strict.dtd\">
 10 <html><head><title>~A</title></head>
 11 <body>~?</body></html>"
 12           title body body-args))
 13 
 14 ;;; Store handled requests
 15 (defvar *requests* (make-hash-table :test #'equal)
 16   "Handled requests store.
 17 
 18 This hashtable is used to store requests for time of dialogue with
 19 user, between initial checkid_setup request and final decision.")
 20 
 21 (defvar *requests-counter* 0
 22   "Counter for generating unique stored request IDs.")
 23 
 24 (defun store-request
 25     (message &aux (handle (cl-base64:integer-to-base64-string (incf *requests-counter*) :uri t)))
 26   "Store MESSAGE request in *REQUESTS* under new key, return key."
 27   (setf (gethash handle *requests*) message)
 28   handle)
 29 
 30 ;;; Actual provider class.
 31 
 32 ;; To customize OP behaviour and use httpd-specific functions, we need
 33 ;; to create subclass of provided abstract OPENID-PROVIDER class.
 34 (defclass example-op (openid-provider)
 35   ((finish-uri :initarg :finish-uri :reader finish-uri
 36 	       :documentation "URI for setup finalization, filled on instance initialization.")))
 37 
 38 
 39 ;; HANDLE-CHECKID-IMMEDIATE method is called on checkid_immediate
 40 ;; request.  It should examine the request and message, and return
 41 ;; whether to accept or reject the request.  We try to be funny and to
 42 ;; avoid complicating the example too much, and accept every second
 43 ;; request.
 44 (defvar *checkid-immediate-counter* 0)
 45 (defmethod handle-checkid-immediate ((op example-op) message)
 46   "Handle checkid_immediate: accept every second request"
 47   (declare (ignore message))
 48   (oddp (incf *checkid-immediate-counter*)))
 49 
 50 ;; Methods below do reply to OpenID endpoint requests.  They should
 51 ;; return the same values as HANDLE-OPENID-PROVIDER-REQUEST: reply
 52 ;; body and optional HTTP code. If code is a redirect (3xx), body
 53 ;; (first returned value) is actually a redirect URI (URI object or
 54 ;; string).
 55 
 56 ;; HANDLE-CHECKID-SETUP method is called on checkid_setup request.  It
 57 ;; is supposed to handle dialogue with end-user, and is responsible
 58 ;; for storing MESSAGE object for time of the dialogue.
 59 (defmethod handle-checkid-setup
 60     ((op example-op) message
 61      &aux (handle (store-request message)))
 62   "Response for checkid_setup request.
 63 
 64 Presents request details and a simple choice consisting of two links
 65 to FINISH-URI with different parameters."
 66   (values 
 67    (html "Log in?"
 68          "<h2>Message:</h2>
 69 <dl>~:{<dt>~A</dt><dd>~A</dd>~}</dl>
 70 <strong><a href=\"~A\">Log in</a> or <a href=\"~A\">cancel</a>?</strong>"
 71          (mapcar #'(lambda (c)
 72                      (list (car c) (cdr c)))
 73                  message)
 74          (copy-uri (finish-uri op) :query (format nil "handle=~A&allow=1" handle))
 75          (copy-uri (finish-uri op) :query (format nil "handle=~A&deny=1" handle)))
 76    200))
 77   
 78 ;; FINISH-CHECKID-SETUP function is called on request to FINISH-URI,
 79 ;; by user clicking one of links presented in response from
 80 ;; HANDLE-CHECKID-SETUP.  Analyzes request parameters, and returns
 81 ;; an relying party URI to redirect the user's browser to 
 82 ;; (indirect response). The URI parameters tell the relying party
 83 ;; if the authentication was successful or not.
 84 (defun finish-checkid-setup (op &aux
 85                              (handle (get-parameter "handle"))
 86                              (message (gethash handle *requests*))) ; Recover stored message
 87   "Finish checkid setup."
 88   (remhash handle *requests*)		; Message no longer needed
 89   (assert (message-field message "openid.return_to"))
 90   (if (get-parameter "allow") ; Check which of the links was clicked:
 91       (successful-response-uri op message) ; - Allow
 92       (cancel-response-uri op message))    ; - Deny
 93   )
 94 
 95 
 96 ;;; Provider object and Hunchentoot handlers
 97 (defvar *openid-provider* nil
 98   "OpenID Provider object.")
 99 
100 ;; Hunchentoot handles
101 (defun finish-checkid-handle ()
102   (if (not (gethash (get-parameter "handle") *requests*))
103       (html "What exactly do you want?"
104             "<h2>~:[ACCESS GRANTED~;ACCESS DENIED~]</h2>
105 <p>But there is no <code>return_to</code> address, so I can only display this screen to you.</p>"
106             (get-parameter "allow"))
107       (redirect (finish-checkid-setup *openid-provider*))))
108 
109 (defun provider-ht-handle ()
110   (multiple-value-bind (body code)
111       (handle-openid-provider-request *openid-provider*
112                                       (append (post-parameters*)
113                                               (get-parameters*))
114                                       :allow-unencrypted-association-p (ssl-p))
115     (cond
116       ((<= 300 code 399) 			; Redirect, body is actually an URI
117        (redirect body :code code))
118 
119       (t (setf (return-code*) code)	; Set return code
120          body))))
121 
122 ;; Initialization
123 (defun init-provider (base-uri prefix
124                       &aux
125                       (endpoint-uri (merge-uris prefix base-uri))
126                       (finish-prefix (concatenate 'string prefix "finish-setup"))
127                       (finish-uri (merge-uris finish-prefix base-uri)))
128   (setf *openid-provider*
129         (make-instance 'example-op
130                        :endpoint-uri endpoint-uri
131                        :finish-uri finish-uri)
132 
133         *dispatch-table*
134         (nconc (list (create-prefix-dispatcher finish-prefix 'finish-checkid-handle)
135                      (create-prefix-dispatcher prefix 'provider-ht-handle))))
136 
137   ;; Without this, Hunchentoot does not allow sending error response
138   ;; body.
139   (pushnew 400 *approved-return-codes*))
140 
141 ; (init-provider "http://example.com/" "/cl-openid-op/")