fix(panettone): Automatically reconnect to ldap

Wrap all ldap access in a macro that automatically reconnects and
retries operations that fail due to a connection error, to handle the
case where the ldap server restarts while we still have an open
connection.

Fixes: #44
Change-Id: I4859cf509106e480f97fed17e7f08e0eea909352
Reviewed-on: https://cl.tvl.fyi/c/depot/+/1871
Tested-by: BuildkiteCI
Reviewed-by: eta <eta@theta.eu.org>
This commit is contained in:
Griffin Smith 2020-08-28 18:49:29 -04:00 committed by glittershark
parent 2bc564bd0d
commit 21690c644b
3 changed files with 55 additions and 17 deletions

View file

@ -6,13 +6,46 @@
(defvar *ldap* nil (defvar *ldap* nil
"The ldap connection") "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 () (defclass/std user ()
((cn dn mail displayname :type string))) ((cn dn mail displayname :type string)))
(defun connect-ldap (&key (defun connect-ldap (&key
(host "localhost") (host "localhost")
(port 389)) (port 389))
(setq *ldap* (ldap:new-ldap :host host :port port))) (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) (defun ldap-entry->user (entry)
(apply (apply
@ -28,6 +61,7 @@
(defun find-user/ldap (username) (defun find-user/ldap (username)
(check-type username (simple-array character (*))) (check-type username (simple-array character (*)))
(with-ldap ()
(ldap:search (ldap:search
*ldap* *ldap*
`(and (= objectClass organizationalPerson) `(and (= objectClass organizationalPerson)
@ -36,7 +70,7 @@
(= dn ,username))) (= dn ,username)))
;; TODO(grfn): make this configurable ;; TODO(grfn): make this configurable
:base "ou=users,dc=tvl,dc=fyi") :base "ou=users,dc=tvl,dc=fyi")
(ldap:next-search-result *ldap*)) (ldap:next-search-result *ldap*)))
(defun find-user (username) (defun find-user (username)
(check-type username (simple-array character (*))) (check-type username (simple-array character (*)))
@ -44,14 +78,16 @@
(ldap-entry->user ldap-entry))) (ldap-entry->user ldap-entry)))
(defun find-user-by-dn (dn) (defun find-user-by-dn (dn)
(with-ldap ()
(progn
(ldap:search *ldap* `(= objectClass organizationalPerson) (ldap:search *ldap* `(= objectClass organizationalPerson)
:base dn :base dn
:scope 'ldap:base) :scope 'ldap:base)
(when-let ((ldap-entry (ldap:next-search-result *ldap*))) (when-let ((ldap-entry (ldap:next-search-result *ldap*)))
(ldap-entry->user ldap-entry))) (ldap-entry->user ldap-entry)))))
(comment (comment
(user-by-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi") (find-user-by-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
) )
(defun authenticate-user (user-or-username password) (defun authenticate-user (user-or-username password)

View file

@ -11,7 +11,7 @@
(:nicknames :authn) (:nicknames :authn)
(:use :cl :panettone.util :klatre) (:use :cl :panettone.util :klatre)
(:import-from :defclass-std :defclass/std) (:import-from :defclass-std :defclass/std)
(:import-from :alexandria :when-let) (:import-from :alexandria :when-let :with-gensyms)
(:export (:export
:*user* :*ldap* :*user* :*ldap*
:user :cn :dn :mail :displayname :user :cn :dn :mail :displayname

View file

@ -571,6 +571,8 @@
(comment (comment
(setq hunchentoot:*catch-errors-p* nil) (setq hunchentoot:*catch-errors-p* nil)
;; to setup an ssh tunnel to ldap+cheddar for development:
;; ssh -NL 3899:localhost:389 -L 4238:localhost:4238 whitby.tvl.fyi
(start-panettone :port 6161 (start-panettone :port 6161
:ldap-port 3899 :ldap-port 3899
:session-secret "session-secret") :session-secret "session-secret")