diff options
Diffstat (limited to 'entity')
| -rw-r--r-- | entity/entity.lisp | 46 | ||||
| -rw-r--r-- | entity/generics.lisp | 36 | ||||
| -rw-r--r-- | entity/ldap-user.lisp | 74 |
3 files changed, 156 insertions, 0 deletions
diff --git a/entity/entity.lisp b/entity/entity.lisp new file mode 100644 index 0000000..92635b4 --- /dev/null +++ b/entity/entity.lisp @@ -0,0 +1,46 @@ +;;; -*- 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)) + (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 (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) (match-it regex (symbol-name x))) + (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 (map-slot-names entity) do + (let ((class-slot-string (parse-symbol class-slot))) + (loop for arg-slot in slots do + (let ((arg-slot-string (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/entity/generics.lisp b/entity/generics.lisp new file mode 100644 index 0000000..613d6ca --- /dev/null +++ b/entity/generics.lisp @@ -0,0 +1,36 @@ +;;; -*- 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 `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/entity/ldap-user.lisp b/entity/ldap-user.lisp new file mode 100644 index 0000000..aa0d64c --- /dev/null +++ b/entity/ldap-user.lisp @@ -0,0 +1,74 @@ +;;; -*- 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)) + (: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 (null-or-empty-p (cdr attr)) + (not (null-or-empty-p (cdr new-attr)))) + `(ldap:add ,(car attr) ,(cdr new-attr))) + ((and (not (null-or-empty-p (cdr attr))) + (null-or-empty-p (cdr new-attr))) + `(ldap:delete ,(car attr) ,(cdr attr))) + ((and (not (null-or-empty-p (cdr attr))) + (not (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 (add-to-list new-attrs '((objectclass . (inetorgperson))))))) + (ldap:add new-entry (connection ldap)))) |