Thursday, 3 January 2008

A login widget for Weblocks

Update: Thanks to some comments from readers, I've made an updated version. Please see the code here. Specifically, the concept of the auth-provider and the auth-login-fields have gone the way of the dodo and been merged into a singular auth-method.

In this earlier post, I abused the Weblocks dataform object to implement a widget for creating a new user.

I have since been heads down coding but last night, I teased the login/authentication logic apart from the rest of my app and I have created a login widget that should be usable as a component. The main concept is the concept of an authentication provider, called the auth-provider. This is the part that the application writer fills in. Here is a sample:


;;; Not always just user/login :-)
(def-auth-login-fields my-auth-login-fields
((site
:initarg :site
:accessor my-auth-login-fields-site
:type string ; Weblocks types
:initform nil)
(login
:initarg :login
:accessor my-auth-login-fields-login
:type string
:initform nil)
(password
:initarg :password
:accessor my-auth-login-fields-password
:type password
:initform nil)))

;;; In this instance, only a tag but could have state.
(defclass my-auth-provider ()
())

;;; Helper function
(defun make-my-auth-provider ()
(make-instance 'my-auth-provider))

;;; The meat of it - return a generalized boolean. The result of this method is returned
;;; to the user
(defmethod auth-provider-authenticate ((map my-auth-provider) (fields my-auth-login-fields))
(user-find-match (site-find (my-auth-login-fields-site fields))
(my-auth-login-fields-login fields)
(my-auth-login-fields-password fields)))

;;; The auth-provider and auth-login-fields are intimately connected.
(defmethod auth-provider-make-fields ((map my-auth-provider))
(make-instance 'my-auth-login-fields :auth-provider map))

To use the login widget:

(defmacro current-user ()
`(hunchentoot:session-value 'current-user))

(defun init-user-session (comp)
(with-flow (composite-widgets comp)
;; The value returned here is whatever was returned by
;; auth-provider-authenticate. The widget does not return
;; until auth-provider-authenticate returns not nil.
(setf (current-user)
(yield (make-instance 'login
:auth-provider (make-my-auth-provider))))
(unless (current-user)
(error "Um... User wasn't returned? This world is crazy. Atleast I still have my Lisp."))
...

Here is some code you should be able to copy-and-paste (you still need to write an auth-provider.) Let me know if you think there are improvements to be made. I'd like to submit this to Slava when I get a round tuit.

(defwidget login (weblocks:composite)
((auth-provider
:accessor login-auth-provider
:initarg :auth-provider)))

(defwidget login-form (weblocks:dataform)
())

(defmethod initialize-instance :after ((self login)
&rest args
&key auth-provider
(login-title "Login")
&allow-other-keys)
(declare (ignore args))
(let ((fields (auth-provider-make-fields auth-provider)))
(setf (widget-name self) "login-composite")
(setf (composite-widgets self)
(list (lambda () (with-html (:h1 (str login-title))))
(make-instance 'login-form
:name 'loginform
:data fields
:ui-state :form
:allow-close-p nil
:on-success
(lambda (&rest args)
(declare (ignore args))
(answer self (slot-value fields 'result))))))))

(defclass auth-login-fields ()
((auth-provider
:accessor auth-login-fields-auth-provider
:initarg :auth-provider)
(result)))

(defun authenticate (provider fields)
(let ((result (auth-provider-authenticate provider fields)))
(if result
(progn
(tbnl:log-message* "Successful authentication")
(setf (slot-value fields 'result) result)
(values t nil))
(progn
(tbnl:log-message* "Failed authentication: ~A" fields)
(values nil '((foo "Authentication failed")))))))

;;; Weblocks hooks
(defmethod weblocks:update-object-from-request :around ((fields auth-login-fields)
&rest args)
(multiple-value-bind (success failed-slots)
(call-next-method)
(if success
(authenticate (auth-login-fields-auth-provider fields) fields)
(values success failed-slots))))

(defmethod weblocks:render-form-controls ((obj auth-login-fields)
&rest keys
&key action
&allow-other-keys)
(with-html
(:div :class "submit"
(render-button *submit-control-name* :value "Login"))))


(defmethod weblocks:dataform-submit-action ((obj login-form) data &rest args)
(apply #'weblocks:update-object-from-request data :persist-object-p nil args))

;;; AUTH-PROVIDER GENERIC

(defgeneric auth-provider-authenticate (auth-provider fields)
(:documentation "Return a generalized boolean to indicate
whether the fields provided authenticate a user."))

(defgeneric auth-provider-make-fields (auth-provider)
(:documentation "Return the fields that auth-provider needs
to authenticate users. This is in the form of a new CLOS object instance.

The types of the fields should be specified to be one of the weblocks
types (see weblocks/src/types/*.lisp)"))

(defmacro def-auth-login-fields (name &body body)
"A macro used to define login fields."
`(defclass ,name (auth-login-fields)
,@body))

No comments: