about summary refs log tree commit diff
path: root/web/panettone/src/authentication.lisp
diff options
context:
space:
mode:
authorGriffin Smith <grfn@gws.fyi>2020-08-28T22·49-0400
committerglittershark <grfn@gws.fyi>2020-08-31T23·03+0000
commit21690c644bc503e4c8cc55df00b398ab81fd7444 (patch)
tree9d80b320d7c9300b8fea204e203de187fde5ce01 /web/panettone/src/authentication.lisp
parent2bc564bd0dfc886cc27d14271a8423c9a266482c (diff)
fix(panettone): Automatically reconnect to ldap r/1746
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>
Diffstat (limited to 'web/panettone/src/authentication.lisp')
-rw-r--r--web/panettone/src/authentication.lisp68
1 files changed, 52 insertions, 16 deletions
diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp
index e4f893f88330..20510257539f 100644
--- a/web/panettone/src/authentication.lisp
+++ b/web/panettone/src/authentication.lisp
@@ -6,13 +6,46 @@
 (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* (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)
   (apply
@@ -28,15 +61,16 @@
 
 (defun find-user/ldap (username)
   (check-type username (simple-array character (*)))
-  (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*))
+  (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 (*)))
@@ -44,14 +78,16 @@
     (ldap-entry->user ldap-entry)))
 
 (defun find-user-by-dn (dn)
-  (ldap:search *ldap* `(= objectClass organizationalPerson)
-               :base dn
-               :scope 'ldap:base)
-  (when-let ((ldap-entry (ldap:next-search-result *ldap*)))
-    (ldap-entry->user ldap-entry)))
+  (with-ldap ()
+    (progn
+      (ldap:search *ldap* `(= objectClass organizationalPerson)
+                   :base dn
+                   :scope 'ldap:base)
+      (when-let ((ldap-entry (ldap:next-search-result *ldap*)))
+        (ldap-entry->user ldap-entry)))))
 
 (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)