Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
188 lines (172 sloc) 9.07 KB
;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; -*-
;;; Copyright (C) 2013 Anton Vodonosov (
;;; See for details.
(defpackage :openid-demo
(:use :cl)
(:export :start))
(in-package :openid-demo)
(defun src-rel-path (subpath)
(asdf:system-relative-pathname :openid-demo subpath))
(defclass demo-acceptor (hunchentoot:easy-acceptor)
((relying-party :type cl-openid:relying-party
:initarg :relying-party
:accessor relying-party
:initform (error ":relying-party is required"))))
(defun cur-user ()
"Returns either NIL or a plist containing various
user account attributes, as created by MAKE-ACCOUNT."
(and hunchentoot:*session*
(hunchentoot:session-value 'cur-user)))
(hunchentoot:define-easy-handler (home :uri "/")
(format nil
<head><title>CL OpenID Demo</title></head>
<table border=\"0\" cellspacing=\"10\">
<td style=\"vertical-align:top;\">
<img src=\"\"/></td>
<td style=\"vertical-align:top; padding-top: 40px\">
Hello friend! You are authenticated as: ~:[<code>NIL</code>~;
~:*<pre><code>(~{~(~S~) ~S~^~% ~})</code></pre>~]</td>
<td style=\"vertical-align:top; padding-top: 40px;\">
<a href=\"/login\" style=\"margin-left: 10ex\"><b>(re)login</b></a></td></tr>
(push (hunchentoot:create-folder-dispatcher-and-handler "/jquery-openid/"
(src-rel-path "jquery-openid/"))
(hunchentoot:define-easy-handler (login :uri "/login")
(if openid_identifier ;; form submited, initiate authentication
;; We can request not only user identity, but also additional
;; attributes as email, first/last names, country, language, etc.
;; This may be done via OpenID extensions:
;; OpenID Simple Registration Extension or OpenID Attribute Exchange Extension.
;; We use both extensions, for sure, as different providers may support
;; one extension but not another.
(let ((attr-exchange '( "" "fetch_request" "" "" "" "" ""
;; choose the attributes you want to request
;; in the followin comma separated list: "email,language,country,firstname,lastname"
;; attributes that we want but do not require may be requested
;; as if_available, although for example Google doesn't support
;; if_available today (see,
;; section "Attribute exchange extension" for the list of what google support)
;; ""
(simple-reg '(:openid.ns.sreg ""
:openid.sreg.optional "nickname,email,fullname,dob,gender,postcode,country,language,timezone")))
(cl-openid:initiate-authentication (relying-party hunchentoot:*acceptor*)
:extra-parameters (append attr-exchange
;; else - render the form
(format nil
<title>OpenID Login</title>
<script type=\"text/javascript\" src=\"\"></script>
<script type=\"text/javascript\" src=\"/jquery-openid/jquery.openid.js\"></script>
<link href=\"/jquery-openid/openid.css\" rel=\"stylesheet\" type=\"text/css\">
(alexandria:read-file-into-string (src-rel-path "jquery-openid/login-form.html")))))
(defun make-account (open-id-identity response-message)
"Unify attributes representation of the two extensions:
OpenID Simple Registration Extension or OpenID Attribute Exchange Extension.
RESPONSE-MESSAGE is an assoc-list representing OpenID provider response."
(flet ((val (key)
(cdr (assoc key response-message :test #'string=))))
(list :claimed-id open-id-identity
:email (or (val "") (val ""))
:nickname (val "openid.sreg.nickname")
:fullname (or (val "openid.sreg.fullname")
(and (val "openid.ext1.value.firstname")
(val "openid.ext1.value.lastname")
(format nil "~A ~A"
(val "openid.ext1.value.firstname")
(val "openid.ext1.value.lastname"))))
:firstname (val "openid.ext1.value.firstname")
:lastname (val "openid.ext1.value.lastname")
:birthday (val "openid.sreg.dob")
:country (or (val "") (val ""))
:language (or (val "openid.sreg.language") (val "openid.ext1.value.language"))
:timezone (val "openid.sreg.timezone")
:postcode (val "openid.sreg.postcode")))
;; Note,
;; Simple Registration Extension defines only 9 attributes,
;; we use all of them - those starting with openid.sreg.
;; OpenID Attribute Exchange is an extensible framework, many attributes
;; are defined here:
;; In our example we only use the attributes supported by Google
(hunchentoot:define-easy-handler (openid-rp :uri "/openid-rp")
(let* (;; hunchentoot GET paremeters have the same
;; representation as open-id message: an alist
(message (hunchentoot:get-parameters hunchentoot:*request*))
(absolute-reply-uri (puri:merge-uris (hunchentoot:request-uri hunchentoot:*request*)
(cl-openid:root-uri (relying-party hunchentoot:*acceptor*))))
(format t "response message: ~% ~{~s~^~% ~}~%" message)
(setf (values user-id-url authproc)
(cl-openid:handle-indirect-response (relying-party hunchentoot:*acceptor*)
(cl-openid:openid-assertion-error (e)
(RETURN-FROM openid-rp (format nil "Error: ~A ~A"
(cl-openid:code e)
(t (e) (RETURN-FROM openid-rp (format nil "Error: ~A" e))))
(if user-id-url
;; todo for cl-openid: return user ID as a string instead puri:uri
(setf user-id-url (princ-to-string user-id-url))
(setf (hunchentoot:session-value 'cur-user)
(make-account user-id-url message))
(hunchentoot:REDIRECT "/"))
;; else:
"Access denied")))
(defun make-relying-party (public-host public-port)
(let ((host-port (format nil "~A:~A" public-host public-port)))
(make-instance 'cl-openid:relying-party
:root-uri (puri:uri (format nil
:realm (puri:uri (format nil "http://~A"
;; todo for cl-openid: allow the URIs to be just strings
(defun start (&key port public-host (public-port port))
PORT is the TCP port we open socket at.
PUBLIC-HOST is the host name through wich user's browser access our application;
you can use \"localhost\" during development.
PUPLIC-PORT is the port on wich user's browser access our application
(may be different from PORT for exmaple at Heroku)."
(hunchentoot:start (make-instance 'demo-acceptor
:port port
:relying-party (make-relying-party public-host public-port))))