moved everything under lisp/

3 files changed, 154 insertions, 0 deletions

diff --git a/lisp/entity/entity.lisp b/lisp/entity/entity.lisp
new file mode 100644
index 0000000..ea665e2
--- /dev/null
+++ b/lisp/entity/entity.lisp
@@ -0,0 +1,44 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :ldapadmin)
+
+(defclass entity ()
+  ()
+  (:documentation "Superclass for all entity objects. An entity object
+is one that represents a single tuple from a data source, like a SQL
+table or LDAP record. In this case we're dealing with LDAP records."))
+
+(defmacro with-entity-slots-to-list ((entity slot) &body body)
+  "Iterates over all the slots of `entity' and builds an alist based
+on those slots. `slot' is the iterator."
+  `(remove-if #'null (mapcar (lambda (slot)
+                               (when (slot-is-field-p slot)
+                                 ,@body))
+                             (org-ckons-core::map-slot-names ,entity))))
+
+(defmethod attribute-value-list ((entity entity) &optional (keep-nulls nil))
+  (with-entity-slots-to-list (entity slot)
+    (when (or keep-nulls
+              (and (not keep-nulls)
+                   (not (org-ckons-core::null-or-empty-p (slot-value entity slot)))))
+      `(,slot . ,(slot-value entity slot)))))
+
+(defmethod get-slots-regex ((entity entity) regex)
+  (sort (remove-if-not (lambda (x) (org-ckons-core::match-it regex (symbol-name x)))
+                       (org-ckons-core::map-slot-names entity))
+        (lambda (x y) (string< (symbol-name x) (symbol-name y)))))
+
+(defmethod intersect-slots ((entity entity) slots)
+  (let ((intersect-slots ()))
+    (loop for class-slot in (org-ckons-core::map-slot-names entity) do
+         (let ((class-slot-string (org-ckons-core::parse-symbol class-slot)))
+           (loop for arg-slot in slots do
+                (let ((arg-slot-string (org-ckons-core::parse-symbol arg-slot)))
+                  (when (string-equal class-slot-string arg-slot-string)
+                    (push class-slot intersect-slots))))))
+    (nreverse intersect-slots)))
+
+(defun slot-is-field-p (slot)
+  (let ((name (symbol-name slot)))
+    (and (equal name (ppcre:regex-replace "^\\*" name "")))))
diff --git a/lisp/entity/generics.lisp b/lisp/entity/generics.lisp
new file mode 100644
index 0000000..510c7db
--- /dev/null
+++ b/lisp/entity/generics.lisp
@@ -0,0 +1,35 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :ldapadmin)
+
+(defgeneric attribute-value-list (entity &optional keep-nulls)
+  (:documentation "Builds an alist of attribute/value pairs."))
+
+(defgeneric get-slots-regex (entity regex)
+  (:documentation "Gets an alphabetically sorted list of `entity'
+slots whose names match `regex'."))
+
+(defgeneric intersect-slots (entity slots)
+  (:documentation "Since the built-in `intersect' function does not
+take package name prefixes into account, and since
+`org-ckons-core::map-slot-names' returns slot names prefixed with the
+package name, this method was written to intersect lists ignoring
+package prefixes."))
+
+(defgeneric get-cn (ldap-user)
+  (:documentation "Generates the CN of an `ldap-user'. `trivial-ldap'
+does not fetch `cn' so we have to assemble it ourselves."))
+
+(defgeneric get-user-dn (ldap-user ldap)
+  (:documentation "Generates the full DN of an `ldap-user'."))
+
+(defgeneric modify-ldap-user (ldap-user ldap)
+  (:documentation "Writes the data in `ldap-user' to the LDAP
+server."))
+
+(defgeneric delete-ldap-user (ldap-user ldap)
+  (:documentation "Deletes an `ldap-user' from LDAP."))
+
+(defgeneric add-ldap-user (ldap-user ldap)
+  (:documentation "Adds an `ldap-user' to LDAP."))
diff --git a/lisp/entity/ldap-user.lisp b/lisp/entity/ldap-user.lisp
new file mode 100644
index 0000000..282592b
--- /dev/null
+++ b/lisp/entity/ldap-user.lisp
@@ -0,0 +1,75 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :ldapadmin)
+
+(defclass ldap-user (entity)
+  ((givenname :initarg :givenname
+              :initform nil
+              :accessor givenname)
+   (sn :initarg :sn
+       :initform nil
+       :accessor sn)
+   (mail :initarg :mail
+         :initform nil
+         :accessor mail)
+   (postaladdress :initarg :postaladdress
+                  :initform nil
+                  :accessor postaladdress)
+   (postalcode :initarg :postalcode
+               :initform nil
+               :accessor postalcode)
+   (st :initarg :st
+       :initform nil
+       :accessor st)
+   (l :initarg :l
+      :initform nil
+      :accessor l)
+   (telephonenumber :initarg :telephonenumber
+                    :initform nil
+                    :accessor telephonenumber)
+   (mobile :initarg :mobile
+           :initform nil
+           :accessor mobile)
+   (businesscategory :initarg :businesscategory
+                     :initform nil
+                     :accessor businesscategory))
+  (:documentation "A single inetOrgPerson entry from LDAP."))
+
+(defmethod get-cn ((ldap-user ldap-user))
+  (format nil "~a ~a" (givenname ldap-user) (sn ldap-user)))
+
+(defmethod get-user-dn ((ldap-user ldap-user) (ldap ldap))
+  (format nil "cn=~a ~a,ou=people,~a" (givenname ldap-user) (sn ldap-user) (base-dn ldap)))
+
+(defmethod modify-ldap-user ((ldap-user ldap-user) (ldap ldap))
+  (let* ((existing-user (get-ldap-user ldap (get-cn ldap-user)))
+         (existing-attrs (attribute-value-list existing-user t))
+         (new-attrs (attribute-value-list ldap-user))
+         (ldap-entry (ldap:new-entry (get-user-dn ldap-user ldap) :attrs existing-attrs))
+         (change-attrs (remove-if #'null
+                                  (mapcar (lambda (attr)
+                                            (let ((new-attr (assoc (car attr) new-attrs)))
+                                              (cond ((and (org-ckons-core::null-or-empty-p (cdr attr))
+                                                          (not (org-ckons-core::null-or-empty-p (cdr new-attr))))
+                                                     `(ldap:add ,(car attr) ,(cdr new-attr)))
+                                                    ((and (not (org-ckons-core::null-or-empty-p (cdr attr)))
+                                                          (org-ckons-core::null-or-empty-p (cdr new-attr)))
+                                                     `(ldap:delete ,(car attr) ,(cdr attr)))
+                                                    ((and (not (org-ckons-core::null-or-empty-p (cdr attr)))
+                                                          (not (org-ckons-core::null-or-empty-p (cdr new-attr)))
+                                                          (not (string= (cdr attr) (cdr new-attr))))
+                                                     `(ldap:replace ,(car attr) ,(cdr new-attr))))))
+                                          existing-attrs))))
+    (ldap:modify (connection ldap) (get-user-dn ldap-user ldap) change-attrs)))
+
+(defmethod delete-ldap-user ((ldap-user ldap-user) (ldap ldap))
+  (let* ((existing-user (get-ldap-user ldap (get-cn ldap-user)))
+         (existing-attrs (attribute-value-list existing-user))
+         (ldap-entry (ldap:new-entry (get-user-dn ldap-user ldap) :attrs existing-attrs)))
+    (ldap:delete ldap-entry (connection ldap))))
+
+(defmethod add-ldap-user ((ldap-user ldap-user) (ldap ldap))
+  (let* ((new-attrs (attribute-value-list ldap-user))
+         (new-entry (ldap:new-entry (get-user-dn ldap-user ldap) :attrs (org-ckons-core::add-to-list new-attrs '((objectclass . (inetorgperson)))))))
+    (ldap:add new-entry (connection ldap))))