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 000000000000..3d4a3510ea05
--- /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))
+           (conn (ldap:new-ldap :host (ldap:host *ldap*)
+                                :port (ldap:port *ldap*)
+                                :user dn
+                                :pass password))
+           (code-sym (nth-value 1 (unwind-protect (ldap:bind conn)
+                                    (ldap:unbind conn)))))
+      (when (equalp code-sym 'trivial-ldap:success)
+        user))))