diff options
Diffstat (limited to 'web/panettone/src/authentication.lisp')
| -rw-r--r-- | web/panettone/src/authentication.lisp | 115 |
1 files changed, 115 insertions, 0 deletions
diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp new file mode 100644 index 0000000000..c335345020 --- /dev/null +++ b/web/panettone/src/authentication.lisp @@ -0,0 +1,115 @@ +(in-package :panettone.authentication) + +(defvar *user* nil + "The currently logged-in user") + +(defvar *ldap* nil + "The ldap connection") + +(defvar *ldap-host* "localhost" + "The host for the ldap connection") + +(defvar *ldap-port* 389 + "The port for the ldap connection") + +(defclass/std user () + ((cn dn mail displayname :type string))) + +(defun connect-ldap (&key + (host "localhost") + (port 389)) + (setq *ldap-host* host + *ldap-port* port + *ldap* (ldap:new-ldap :host host :port port))) + +(defun reconnect-ldap () + (setq *ldap* (ldap:new-ldap + :host *ldap-host* + :port *ldap-port*))) + +(defmacro with-ldap ((&key (max-tries 1)) &body body) + "Execute BODY in a context where ldap connection errors trigger a reconnect +and a retry" + (with-gensyms (n try retry e) + `(flet + ((,try + (,n) + (flet ((,retry (,e) + (if (>= ,n ,max-tries) + (error ,e) + (progn + (reconnect-ldap) + (,try (1+ ,n)))))) + (handler-case + (progn + ,@body) + (end-of-file (,e) (,retry ,e)) + (trivial-ldap:ldap-connection-error (,e) (,retry ,e)))))) + (,try 0)))) + +(defun ldap-entry->user (entry) + (apply + #'make-instance + 'user + :dn (ldap:dn entry) + (alexandria:mappend + (lambda (field) + (list field (car (ldap:attr-value entry field)))) + (list :mail + :cn + :displayname)))) + +(defun find-user/ldap (username) + (check-type username (simple-array character (*))) + (with-ldap () + (ldap:search + *ldap* + `(and (= objectClass organizationalPerson) + (or + (= cn ,username) + (= dn ,username))) + ;; TODO(grfn): make this configurable + :base "ou=users,dc=tvl,dc=fyi") + (ldap:next-search-result *ldap*))) + +(defun find-user (username) + (check-type username (simple-array character (*))) + (when-let ((ldap-entry (find-user/ldap username))) + (ldap-entry->user ldap-entry))) + +(defun find-user-by-dn (dn) + "Look up the user with the given DN in the LDAP database, returning an +instance of `user'" + (with-ldap () + (let ((have-results + (handler-case + (ldap:search *ldap* `(= objectClass organizationalPerson) + :base dn + :scope 'ldap:base) + ; catch ldap-errors generated by trivial-ldap:parse-ldap-message + ; since this is thrown on conditions which we don't want this + ; function to fail like when there are no search results + (trivial-ldap:ldap-error (e) nil)))) + (when have-results + (when-let ((ldap-entry (ldap:next-search-result *ldap*))) + (ldap-entry->user ldap-entry)))))) + +(comment + (find-user-by-dn "cn=grfn,ou=users,dc=tvl,dc=fyi") + ) + +(defun authenticate-user (user-or-username password) + "Checks the given USER-OR-USERNAME has the given PASSWORD, by making a bind +request against the ldap server at *ldap*. Returns the user if authentication is +successful, `nil' otherwise" + (when-let ((user (if (typep user-or-username 'user) user-or-username + (find-user user-or-username)))) + (let ((dn (dn user))) + (let ((code-sym + (nth-value 1 (ldap:bind + (ldap:new-ldap :host (ldap:host *ldap*) + :port (ldap:port *ldap*) + :user dn + :pass password))))) + (when (equalp code-sym 'trivial-ldap:success) + user))))) |