From 21690c644bc503e4c8cc55df00b398ab81fd7444 Mon Sep 17 00:00:00 2001
From: Griffin Smith <grfn@gws.fyi>
Date: Fri, 28 Aug 2020 18:49:29 -0400
Subject: 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>
---
 web/panettone/src/authentication.lisp | 68 ++++++++++++++++++++++++++---------
 web/panettone/src/packages.lisp       |  2 +-
 web/panettone/src/panettone.lisp      |  2 ++
 3 files changed, 55 insertions(+), 17 deletions(-)

diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp
index e4f893f883..2051025753 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)
diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp
index 1510df224b..1a8453055f 100644
--- a/web/panettone/src/packages.lisp
+++ b/web/panettone/src/packages.lisp
@@ -11,7 +11,7 @@
   (:nicknames :authn)
   (:use :cl :panettone.util :klatre)
   (:import-from :defclass-std :defclass/std)
-  (:import-from :alexandria :when-let)
+  (:import-from :alexandria :when-let :with-gensyms)
   (:export
    :*user* :*ldap*
    :user :cn :dn :mail :displayname
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
index d4746c7706..cef3572214 100644
--- a/web/panettone/src/panettone.lisp
+++ b/web/panettone/src/panettone.lisp
@@ -571,6 +571,8 @@
 
 (comment
  (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
                   :ldap-port 3899
                   :session-secret "session-secret")
-- 
cgit 1.4.1