diff options
Diffstat (limited to 'lisp')
30 files changed, 1645 insertions, 0 deletions
diff --git a/lisp/condition/condition.lisp b/lisp/condition/condition.lisp new file mode 100644 index 0000000..9fb353a --- /dev/null +++ b/lisp/condition/condition.lisp @@ -0,0 +1,7 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(define-condition handled-error (error) + ((text :initarg :text :reader text))) diff --git a/lisp/core/core.lisp b/lisp/core/core.lisp new file mode 100644 index 0000000..e42b1d2 --- /dev/null +++ b/lisp/core/core.lisp @@ -0,0 +1,8 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(defpackage :ldapadmin + (:use :cl :cl-log :hunchentoot) + (:export :ldapadmin)) + +(in-package :ldapadmin) 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)))) diff --git a/lisp/ldap/generics.lisp b/lisp/ldap/generics.lisp new file mode 100644 index 0000000..ed8a839 --- /dev/null +++ b/lisp/ldap/generics.lisp @@ -0,0 +1,18 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defgeneric disconnect (ldap) + (:documentation "")) + +(defgeneric get-ldap-users (ldap search-base) + (:documentation "Calls `with-ldap-iterate' to iterate over all LDAP +users returned with the search `search-base', wrapping each entry in +an `ldap-user' object. Returns a list of these objects. `ldap' is a +free variable that must be present for `with-ldap-iterate'.")) + +(defgeneric get-ldap-user (ldap cn) + (:documentation "Calls `with-ldap-users' with a search filter and +returns the first entry.")) + diff --git a/lisp/ldap/ldap.lisp b/lisp/ldap/ldap.lisp new file mode 100644 index 0000000..b7ec502 --- /dev/null +++ b/lisp/ldap/ldap.lisp @@ -0,0 +1,130 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass ldap () + ((ldap-host :initarg :ldap-host + :initform nil + :accessor ldap-host) + (sslflag :initarg :sslflag + :initform nil + :accessor sslflag) + (username :initarg :username + :initform nil + :accessor username) + (password :initarg :password + :initform nil + :accessor password) + (base-dn :initarg :base-dn + :initform nil + :accessor base-dn) + (debug-mode :initarg :debug-mode + :initform nil + :accessor debug-mode) + (config :initarg :config + :initform nil + :accessor config) + (connection :initarg :connection + :initform nil + :accessor connection)) + (:documentation "Used to provide an object-oriented interface to the +LDAP options in the webapp config file.")) + +(defmethod initialize-instance :after ((ldap ldap) &key config) + "Parses the LDAP config from the options.lisp file into a new `ldap' +object." + (let ((conf (car config))) + (setf (ldap-host ldap) (getf conf :ldap-host)) + (setf (sslflag ldap) (getf conf :sslflag)) + (setf (username ldap) (getf conf :username)) + (setf (password ldap) (getf conf :password)) + (setf (base-dn ldap) (getf conf :base-dn)) + (setf (debug-mode ldap) (getf conf :debug-mode)) + (setf (config ldap) conf) + (setf (connection ldap) (apply #'ldap:new-ldap + `(:host ,(ldap-host ldap) + :sslflag ,(sslflag ldap) + :user ,(username ldap) + :pass ,(password ldap) + :base ,(base-dn ldap) + :reuse-connection ,'ldap:rebind + :debug ,(debug-mode ldap)))))) + +(defmethod disconnect ((ldap ldap)) + (ldap:unbind (connection ldap))) + +(defmacro with-ldap ((ldap-name) &body body) + "Convenience macro for instantiating an `ldap' instance and using it +in an `unwind-protect'." + `(let ((,ldap-name (make-instance 'ldap :config `(,(ldap *webapp*))))) + (unwind-protect + (progn + ,@body) + (disconnect ,ldap-name)))) + +(defmacro with-ldap-iterate ((ldap-entry search-base) &body body) + "Runs an ldapsearch and executes `body' over each result. The +variable `ldap-entry' is bound to the iterator of the +`ldap:dosearch'. You may use it in your `body'." + `(progn + (ldap:bind (connection ldap)) + (ldap:dosearch (,ldap-entry (ldap:search (connection ldap) ,search-base)) + ,@body))) + +(defmethod get-ldap-users ((ldap ldap) search-base) + (let ((ldap-users ())) + (with-ldap-iterate (ldap-entry search-base) + (let ((ldap-user (populate-ldap-user ldap-entry))) + (push ldap-user ldap-users))) + (nreverse ldap-users))) + +(defmethod search-ldap-users ((ldap ldap) search-terms) + (get-ldap-users ldap (format nil + "(&(objectclass=inetOrgPerson)(!(cn=Manager))(!(uid=root))(!(uid=nobody))~a)" + (build-search-base search-terms)))) + +(defmethod get-ldap-user ((ldap ldap) cn) + (car (search-ldap-users ldap `((:cn ,cn))))) + +(defun check-ldap-password (config dn password) + "Uses ldapwhoami to check the userPassword of a given +binddn. Returns `t' if the password is valid, `nil' otherwise." + (= 0 (uffi:run-shell-command (format nil + "ldapwhoami -x -H ~a://~a -D 'cn=~a,~a' -w ~a" + (if (getf config :sslflag) "ldaps" "ldap") + (getf config :ldap-host) + dn + (getf config :base-dn) + password)))) + +(defun populate-ldap-user (ldap-entry) + "Copies the data from a single LDAP entry as produced by +`with-ldap-iterate' into a new `ldap-user' object." + (let* ((ldap-user (make-instance 'ldap-user)) + (valid-attribute-names (intersect-slots ldap-user (mapcar (lambda (pair) + (car pair)) + (ldap:attrs ldap-entry))))) + (loop for name-value in (ldap:attrs ldap-entry) do + (let ((name (intern (symbol-name (car name-value)) (find-package (string-upcase "ldapadmin")))) + (value (cadr name-value))) + (when (find name + valid-attribute-names + :test (lambda (x y) + (string-equal (symbol-name x) (symbol-name y)))) + (setf (slot-value ldap-user name) value)))) + ldap-user)) + +(defun build-search-base (search-terms) + "Converts a plist like `((:givenname \"Carlos\") (:sn +\"Konstanski\"))' to an LDAP search base fragment like +\"(givenname=Carlos)(sn=Konstanski)\". Any `nil' or empty-string +values are ignored." + (org-ckons-core::reduce-to-char-separated-string (mapcar (lambda (term) + (when (not (org-ckons-core::null-or-empty-p (cadr term))) + (format nil + "(~a=~a)" + (symbol-name (car term)) + (cadr term)))) + search-terms) + "")) diff --git a/lisp/ldapadmin.asd b/lisp/ldapadmin.asd new file mode 100644 index 0000000..08f3210 --- /dev/null +++ b/lisp/ldapadmin.asd @@ -0,0 +1,67 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :cl) + +(defpackage :ldapadmin-system (:use :cl :asdf)) +(in-package :ldapadmin-system) + +(defmacro do-defsystem (&key name version maintainer author description long-description depends-on components) + `(defsystem ,name + :name ,name + :version ,version + :maintainer ,maintainer + :author ,author + :description ,description + :long-description ,long-description + :depends-on ,(eval depends-on) + :components ,components)) + +(defparameter *quicklisp-packages* '(net-telent-date cl-ppcre uffi hunchentoot cl-log ironclad trivial-ldap)) +(defparameter *asdf-packages* '(org-ckons-core org-ckons-http org-ckons-json)) +(defparameter *all-packages* (append *quicklisp-packages* *asdf-packages*)) + +(loop for pkg in *quicklisp-packages* do + (ql:quickload (symbol-name pkg))) + +(do-defsystem :name "ldapadmin" + :version "2" + :maintainer "Carlos Konstanski <me@ckons.org>" + :author "Carlos Konstanski <me@ckons.org>" + :description "ldapadmin" + :long-description "ldapadmin is a web application written in Common Lisp, based on the Hunchentoot web server. It is a web UI frontend for LDAP." + :depends-on *all-packages* + :components ((:module core + :components ((:file "core"))) + (:module condition + :depends-on (core) + :components ((:file "condition"))) + (:module ldap + :depends-on (condition) + :components ((:file "generics") + (:file "ldap" :depends-on ("generics")))) + (:module entity + :depends-on (ldap) + :components ((:file "generics") + (:file "entity" :depends-on ("generics")) + (:file "ldap-user" :depends-on ("entity")))) + (:module service + :depends-on (entity) + :components ((:file "base-service") + (:file "rest-service" :depends-on ("base-service")) + (:file "auth-service" :depends-on ("rest-service")) + (:file "generic-form" :depends-on ("rest-service")) + (:file "menu-service" :depends-on ("base-service")) + (:file "home-service" :depends-on ("rest-service")) + (:file "login-service" :depends-on ("generic-form")) + (:file "logout-service" :depends-on ("rest-service")) + (:file "inetorg-view-service" :depends-on ("auth-service" "generic-form")) + (:file "inetorg-modify-service" :depends-on ("auth-service" "generic-form")) + (:file "inetorg-delete-service" :depends-on ("auth-service" "generic-form")) + (:file "inetorg-add-service" :depends-on ("auth-service" "generic-form")))) + (:module webapps + :depends-on (service) + :components ((:file "webapp-loader") + (:module ldapadmin + :depends-on ("webapp-loader") + :components ((:file "site"))))))) diff --git a/lisp/service/auth-service.lisp b/lisp/service/auth-service.lisp new file mode 100644 index 0000000..0a84264 --- /dev/null +++ b/lisp/service/auth-service.lisp @@ -0,0 +1,30 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass auth-service (rest-service) + () + (:documentation "")) + +(defmethod initialize-instance :after ((auth-service auth-service) &key) + (when (not (string= (session-value :permissions) "admin")) + (setf (location auth-service) "/home") + (setf (errormsg auth-service) "You are not authorized to access this resource."))) + +(defmacro with-auth ((instance auth-service) &body body) + `(let ((,instance (make-instance ',auth-service))) + (when (string= (session-value :permissions) "admin") + ,@body) + (when (location-p ,instance) + (setf (session-value :message) nil) + (setf (session-value :errormsg) nil)) + (org-ckons-json::objects-to-json `(,,instance)))) + +(defmacro with-noauth ((instance rest-service) &body body) + `(let ((,instance (make-instance ',rest-service))) + ,@body + (when (location-p ,instance) + (setf (session-value :message) nil) + (setf (session-value :errormsg) nil)) + (org-ckons-json::objects-to-json `(,,instance)))) diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp new file mode 100644 index 0000000..7eb8fb3 --- /dev/null +++ b/lisp/service/base-service.lisp @@ -0,0 +1,8 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass base-service () + () + (:documentation "")) diff --git a/lisp/service/generic-form.lisp b/lisp/service/generic-form.lisp new file mode 100644 index 0000000..6e0c821 --- /dev/null +++ b/lisp/service/generic-form.lisp @@ -0,0 +1,87 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass generic-form (base-service) + ((name :initarg :name + :initform nil + :accessor name) + (http-method :initarg :http-method + :initform "POST" + :accessor http-method) + (action :initarg :action + :initform nil + :accessor action) + (required-p :initarg :required-p + :initform nil + :accessor required-p) + (form-fields :initarg :form-fields + :initform nil + :accessor form-fields)) + (:documentation "")) + +(defclass form-field (base-service) + ((name :initarg :name + :initform nil + :accessor name) + (label :initarg :label + :initform nil + :accessor label) + (value :initarg :value + :initform nil + :accessor value) + (checked :initarg :checked + :initform nil + :accessor checked) + (field-type :initarg :field-type + :initform nil + :accessor field-type) + (required :initarg :required + :initform nil + :accessor required) + (dismiss :initarg :dismiss + :initform nil + :accessor dismiss) + (options :initarg :options + :initform nil + :accessor options) + (onclick :initarg :onclick + :initform nil + :accessor onclick) + (onchange :initarg :onchange + :initform nil + :accessor onchange)) + (:documentation "")) + +(defclass option (base-service) + ((label :initarg :label + :initform nil + :accessor label) + (value :initarg :value + :initform nil + :accessor value)) + (:documentation "")) + +(defun make-form (name action required-p fields) + (make-instance 'generic-form + :name name + :action action + :required-p required-p + :form-fields (mapcar (lambda (field) + (make-instance 'form-field + :name (getf field :name) + :label (getf field :label) + :value (getf field :value) + :checked (getf field :checked) + :field-type (getf field :field-type) + :required (getf field :required) + :dismiss (getf field :dismiss) + :options (mapcar (lambda (option) + (make-instance 'option + :label (getf option :label) + :value (getf option :value))) + (getf field :options)) + :onclick (getf field :onclick) + :onchange (getf field :onchange))) + fields))) diff --git a/lisp/service/home-service.lisp b/lisp/service/home-service.lisp new file mode 100644 index 0000000..b914cae --- /dev/null +++ b/lisp/service/home-service.lisp @@ -0,0 +1,18 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass home-service (rest-service) + ((content :initarg :content + :initform nil + :accessor content)) + (:documentation "")) + +(defmethod initialize-instance :after ((home-service home-service) &key) + (setf (content home-service) (format nil "Welcome to the ~a website" (title *webapp*)))) + +(defun home-json (&optional message errormsg) + (with-noauth (instance home-service) + (when message (setf (message instance) message)) + (when errormsg (setf (errormsg instance) errormsg)))) diff --git a/lisp/service/inetorg-add-service.lisp b/lisp/service/inetorg-add-service.lisp new file mode 100644 index 0000000..a58a10d --- /dev/null +++ b/lisp/service/inetorg-add-service.lisp @@ -0,0 +1,55 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass inetorg-add-service (auth-service) + ((form :initarg :form + :initform nil + :accessor form) + (title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defmethod initialize-instance :after ((inetorg-add-service inetorg-add-service) &key) + (setf (title inetorg-add-service) "Add InetOrg Entry") + (setf (form inetorg-add-service) (make-form "inetorg-add-form" + nil + t + '((:name "add-givenname" :label "givenName" :field-type "text" :required "required") + (:name "add-sn" :label "sn" :field-type "text" :required "required") + (:name "add-mail" :label "mail" :field-type "text") + (:name "add-postaladdress" :label "postalAddress" :field-type "text") + (:name "add-postalcode" :label "postalCode" :field-type "text") + (:name "add-st" :label "st" :field-type "text") + (:name "add-l" :label "l" :field-type "text") + (:name "add-telephonenumber" :label "telephoneNumber" :field-type "text") + (:name "add-mobile" :label "mobile" :field-type "text") + (:name "add-businesscategory" :label "businessCategory" :field-type "text") + (:label "Create InetOrg Entry" :field-type "button" :onclick "on_inetorg_add_submit_clicked()"))))) + +(defun inetorg-add-json () + (with-auth (instance inetorg-add-service) + t)) + +(defclass inetorg-add-submit-service (auth-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun inetorg-add-submit-json (givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory) + (with-auth (instance inetorg-add-submit-service) + (with-ldap (ldap) + (let ((ldap-user (make-instance 'ldap-user + :givenname givenname + :sn sn + :mail mail + :postaladdress postaladdress + :postalcode postalcode + :st st + :l l + :telephonenumber telephonenumber + :mobile mobile + :businesscategory businesscategory))) + (add-ldap-user ldap-user ldap) + (setf (session-value :message) "InetOrg entry created successfully."))))) diff --git a/lisp/service/inetorg-delete-service.lisp b/lisp/service/inetorg-delete-service.lisp new file mode 100644 index 0000000..7c27480 --- /dev/null +++ b/lisp/service/inetorg-delete-service.lisp @@ -0,0 +1,26 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass inetorg-delete-service (auth-service) + ((cn :initarg :cn + :initform nil + :accessor cn) + (location-p :initform nil)) + (:documentation "")) + +(defun inetorg-delete-json (cn) + (with-auth (instance inetorg-delete-service) + (setf (cn instance) cn))) + +(defclass inetorg-delete-submit-service (auth-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun inetorg-delete-submit-json (cn) + (with-auth (instance inetorg-delete-submit-service) + (with-ldap (ldap) + (let ((ldap-user (get-ldap-user ldap cn))) + (delete-ldap-user ldap-user ldap) + (setf (session-value :message) "InetOrg entry deleted successfully."))))) diff --git a/lisp/service/inetorg-modify-service.lisp b/lisp/service/inetorg-modify-service.lisp new file mode 100644 index 0000000..89e5b9b --- /dev/null +++ b/lisp/service/inetorg-modify-service.lisp @@ -0,0 +1,59 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass inetorg-modify-service (auth-service) + ((form :initarg :form + :initform nil + :accessor form) + (ldap-user-values :initarg :ldap-user-values + :initform nil + :accessor ldap-user-values) + (title :initarg :title + :initform nil + :accessor title) + (location-p :initform nil)) + (:documentation "")) + +(defmethod initialize-instance :after ((inetorg-modify-service inetorg-modify-service) &key) + (setf (form inetorg-modify-service) (make-form "inetorg-modify-form" + nil + t + `((:name "modify-givenname" :label "givenName" :field-type "text") + (:name "modify-sn" :label "sn" :field-type "text") + (:name "modify-mail" :label "mail" :field-type "text") + (:name "modify-postaladdress" :label "postalAddress" :field-type "text") + (:name "modify-postalcode" :label "postalCode" :field-type "text") + (:name "modify-st" :label "st" :field-type "text") + (:name "modify-l" :label "l" :field-type "text") + (:name "modify-telephonenumber" :label "telephoneNumber" :field-type "text") + (:name "modify-mobile" :label "mobile" :field-type "text") + (:name "modify-businesscategory" :label "businessCategory" :field-type "text") + (:label "Modify InetOrg Entry" :field-type "button" :onclick "on_inetorg_modify_submit_clicked()"))))) + +(defun inetorg-modify-json (cn) + (with-auth (instance inetorg-modify-service) + (with-ldap (ldap) + (setf (ldap-user-values instance) (get-ldap-user ldap cn))))) + +(defclass inetorg-modify-submit-service (auth-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun inetorg-modify-submit-json (givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory) + (with-auth (instance inetorg-modify-submit-service) + (with-ldap (ldap) + (let ((ldap-user (make-instance 'ldap-user + :givenname givenname + :sn sn + :mail mail + :postaladdress postaladdress + :postalcode postalcode + :st st + :l l + :telephonenumber telephonenumber + :mobile mobile + :businesscategory businesscategory))) + (modify-ldap-user ldap-user ldap) + (setf (session-value :message) "InetOrg entry saved successfully."))))) diff --git a/lisp/service/inetorg-view-service.lisp b/lisp/service/inetorg-view-service.lisp new file mode 100644 index 0000000..379b1b0 --- /dev/null +++ b/lisp/service/inetorg-view-service.lisp @@ -0,0 +1,70 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass inetorg-view-service (auth-service) + ((title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defun inetorg-view-json (&optional message errormsg) + (with-auth (instance inetorg-view-service) + (when message (setf (message instance) message)) + (when errormsg (setf (errormsg instance) errormsg)) + (setf (title instance) "Use the form to filter the InetOrg results."))) + +(defclass inetorg-view-search-service (auth-service) + ((form :initarg :form + :initform nil + :accessor form) + (title :initarg :title + :initform nil + :accessor title) + (location-p :initform nil)) + (:documentation "")) + +(defmethod initialize-instance :after ((inetorg-view-search-service inetorg-view-search-service) &key) + (setf (form inetorg-view-search-service) (make-form "inetorg-view-search-form" + nil + t + '((:name "view-givenname" :label "givenName" :field-type "text") + (:name "view-sn" :label "sn" :field-type "text") + (:name "view-mail" :label "mail" :field-type "text") + (:name "view-postaladdress" :label "postalAddress" :field-type "text") + (:name "view-postalcode" :label "postalCode" :field-type "text") + (:name "view-st" :label "st" :field-type "text") + (:name "view-l" :label "l" :field-type "text") + (:name "view-telephonenumber" :label "telephoneNumber" :field-type "text") + (:name "view-mobile" :label "mobile" :field-type "text") + (:name "view-businesscategory" :label "businessCategory" :field-type "text") + (:label "Search InetOrg Entries" :field-type "button" :onclick "on_inetorg_view_search_clicked()"))))) + +(defun inetorg-view-search-json () + (with-auth (instance inetorg-view-search-service) + nil)) + +(defclass inetorg-view-results-service (auth-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defun inetorg-view-results-json (givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory) + (with-auth (instance inetorg-view-results-service) + (with-ldap (ldap) + (setf (results instance) + (sort (search-ldap-users ldap + `((:givenname ,givenname) + (:sn ,sn) + (:mail ,mail) + (:postaladdress ,postaladdress) + (:postalcode ,postalcode) + (:st ,st) + (:l ,l) + (:telephonenumber ,telephonenumber) + (:mobile ,mobile) + (:businesscategory ,businesscategory))) + (lambda (x y) (string< (get-cn x) (get-cn y)))))))) diff --git a/lisp/service/login-service.lisp b/lisp/service/login-service.lisp new file mode 100644 index 0000000..82b647c --- /dev/null +++ b/lisp/service/login-service.lisp @@ -0,0 +1,43 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass login-service (rest-service) + ((form :initarg :form + :initform nil + :accessor form) + (title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defmethod initialize-instance :after ((login-service login-service) &key) + (setf (title login-service) "Login") + (setf (form login-service) (make-form "login-form" + nil + t + '((:name "dn" :label "DN" :field-type "text" :required "required") + (:name "password" :label "Password" :field-type "password" :required "required") + (:label "Login" :field-type "button" :onclick "on_login_submit_clicked()"))))) + +(defun login-json () + (with-noauth (instance login-service) + t)) + +(defclass login-authenticate-service (rest-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun login-authenticate-json (dn password) + (with-noauth (instance login-authenticate-service) + (cond ((check-ldap-password (ldap *webapp*) dn password) + (setf (session-value :permissions) "admin") + (setf (session-value :message) "Successfully logged in.") + (setf (session-value :errormsg) nil)) + (t + (setf (session-value :message) nil) + (setf (session-value :errormsg) "Login failed."))) + (setf (message instance) (session-value :message)) + (setf (errormsg instance) (session-value :errormsg)))) + diff --git a/lisp/service/logout-service.lisp b/lisp/service/logout-service.lisp new file mode 100644 index 0000000..59a9968 --- /dev/null +++ b/lisp/service/logout-service.lisp @@ -0,0 +1,14 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass logout-service (rest-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun logout-json () + (with-noauth (instance logout-service) + (setf (session-value :permissions) "anonymous") + (setf (location instance) "/home") + (setf (message instance) "You are now logged out."))) diff --git a/lisp/service/menu-service.lisp b/lisp/service/menu-service.lisp new file mode 100644 index 0000000..728b8e5 --- /dev/null +++ b/lisp/service/menu-service.lisp @@ -0,0 +1,55 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defparameter *menu-config* '((:id "a_menu_home" :label "Home" :handler "/home" :permissions "t") + (:id "a_menu_login" :label "Login" :handler "/login" :permissions "anonymous") + (:id "a_menu_logout" :label "Logout" :handler "/logout" :permissions "admin") + (:id "a_menu_inetorg_view" :label "View InetOrg Entries" :handler "/inetorg/view" :permissions "admin") + (:id "a_menu_inetorg_add" :label "Add InetOrg Entry" :handler "/inetorg/add" :permissions "admin"))) + +(defclass menuitem () + ((id :initarg :id + :initform nil + :accessor id) + (label :initarg :label + :initform nil + :accessor label) + (handler :initarg :handler + :initform nil + :accessor handler) + (permissions :initarg :permissions + :initform nil + :accessor permissions) + (children :initarg :children + :initform nil + :accessor children)) + (:documentation "")) + +(defclass menu-service (base-service) + ((menuitems :initarg :menuitems + :initform nil + :accessor menuitems) + (location-p :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defmethod initialize-instance :after ((menu-service menu-service) &key) + (setf (menuitems menu-service) + (mapcar (lambda (x) + (make-instance 'menuitem + :id (getf x :id) + :label (getf x :label) + :handler (getf x :handler))) + (remove-if 'null (mapcar (lambda (x) + (when (find-if (lambda (y) + (string= (getf x :permissions) y)) + `("t" ,(session-value :permissions))) + x)) + *menu-config*))))) + +(defun menu-json () + (with-noauth (instance menu-service) + t)) diff --git a/lisp/service/rest-service.lisp b/lisp/service/rest-service.lisp new file mode 100644 index 0000000..ff66dd4 --- /dev/null +++ b/lisp/service/rest-service.lisp @@ -0,0 +1,36 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defclass rest-service (base-service) + ((location :initarg :location + :initform nil + :accessor location) + (location-p :initarg :location-p + :initform t + :accessor location-p) + (message :initarg :message + :initform nil + :accessor message) + (errormsg :initarg :errormsg + :initform nil + :accessor errormsg)) + (:documentation "")) + +(defmethod initialize-instance :after ((rest-service rest-service) &key) + (when (location-p rest-service) + (if (message rest-service) + (setf (session-value :message) (message rest-service)) + (setf (message rest-service) (session-value :message))) + (if (errormsg rest-service) + (setf (session-value :errormsg) (errormsg rest-service)) + (setf (errormsg rest-service) (session-value :errormsg))) + (when (null (location rest-service)) + (setf (location rest-service) (type-to-path rest-service))))) + +(defun location-json (&optional (location "/home")) + (format nil "{\"location\":\"~a\"}" location)) + +(defun type-to-path (rest-type) + (concatenate 'string "/" (ppcre:regex-replace "-service" (string-downcase (type-of rest-type)) "/"))) diff --git a/lisp/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore b/lisp/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore new file mode 100644 index 0000000..a1cd79c --- /dev/null +++ b/lisp/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore @@ -0,0 +1,15 @@ +target +classes +resources +checkouts +pom.xml +pom.xml.asc +*.jar +*.class +.lein-* +.nrepl-port +.hgignore +.hg +profiles.clj +figwheel_server.log +.rebel_readline_history diff --git a/lisp/webapps/ldapadmin/clojurescript/ldapadmin/README.md b/lisp/webapps/ldapadmin/clojurescript/ldapadmin/README.md new file mode 100644 index 0000000..53ca866 --- /dev/null +++ b/lisp/webapps/ldapadmin/clojurescript/ldapadmin/README.md @@ -0,0 +1,14 @@ +# ldapadmin + +A Clojure library designed to ... well, that part is up to you. + +## Usage + +FIXME + +## License + +Copyright © 2017 FIXME + +Distributed under the Eclipse Public License either version 1.0 or (at +your option) any later version. diff --git a/lisp/webapps/ldapadmin/clojurescript/ldapadmin/project.clj b/lisp/webapps/ldapadmin/clojurescript/ldapadmin/project.clj new file mode 100644 index 0000000..001af8b --- /dev/null +++ b/lisp/webapps/ldapadmin/clojurescript/ldapadmin/project.clj @@ -0,0 +1,13 @@ +(defproject ldapadmin "0.1.0-SNAPSHOT" + :description "An LDAP adminitration utility written in SBCL on the + server-side and ClojureScript on the client-side. This is the + client-side component." + :url "FIXME" + :license "public domain" + :dependencies [[org.clojure/clojure "LATEST"] + [org.clojure/clojurescript "LATEST"] + [cljs-ajax "LATEST"] + [prismatic/dommy "LATEST"] + [hiccups "LATEST"]] + :plugins [[lein-cljsbuild "LATEST"]] + :clean-targets ^{:protect false} [:target-path "out" "resources/public/cljs"]) diff --git a/lisp/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs b/lisp/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs new file mode 100644 index 0000000..d3f0374 --- /dev/null +++ b/lisp/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs @@ -0,0 +1,447 @@ +(ns ldapadmin.core + (:require-macros [hiccups.core :as hiccups :refer [html]]) + (:require [ajax.core :refer [GET POST]] + [dommy.core :as dommy] + [hiccups.runtime :as hiccupsrt] + [clojure.string :as str] + [org-ckons-cljs.notifications.core :as ck-notifications] + [org-ckons-cljs.form.core :as ck-form])) + +;; declarations + +(enable-console-print!) +(def jquery (js* "$")) + +(declare notifications) +(declare auth-notifications) +(declare template-menu) +(declare handler-menu) +(declare render-menu) +(declare template-home) +(declare handler-home) +(declare render-home) +(declare template-login) +(declare handler-login) +(declare render-login) +(declare on-login-submit-clicked) +(declare handler-login-authenticate) +(declare render-login-authenticate) +(declare handler-logout) +(declare render-logout) +(declare template-inetorg-view) +(declare handler-inetorg-view) +(declare render-inetorg-view) +(declare on-inetorg-view-search-clicked) +(declare template-inetorg-view-search) +(declare handler-inetorg-view-search) +(declare render-inetorg-view-search) +(declare template-inetorg-view-results) +(declare handler-inetorg-view-results) +(declare render-inetorg-view-results) +(declare on-inetorg-modify-clicked) +(declare template-inetorg-modify) +(declare handler-inetorg-modify) +(declare render-inetorg-modify) +(declare on-inetorg-modify-submit-clicked) +(declare handler-inetorg-modify-submit) +(declare render-inetorg-modify-submit) +(declare on-inetorg-delete-clicked) +(declare template-inetorg-delete) +(declare handler-inetorg-delete) +(declare render-inetorg-delete) +(declare on-inetorg-delete-submit-clicked) +(declare handler-inetorg-delete-submit) +(declare render-inetorg-delete-submit) +(declare template-inetorg-add) +(declare handler-inetorg-add) +(declare render-inetorg-add) +(declare on-inetorg-add-submit-clicked) +(declare handler-inetorg-add-submit) +(declare render-inetorg-add-submit) +(declare on-menu-clicked) +(declare handler-location) +(declare goto-location) + +;; notifications + +(defn notifications [jsonobj] + (ck-notifications/maybe-message jsonobj) + (ck-notifications/maybe-error jsonobj)) + +(defn auth-notifications [jsonobj] + (cond (empty? (get jsonobj "errormsg")) + (notifications jsonobj) + :else + (do + (render-home "" (get jsonobj "errormsg")) + (render-menu)))) + +;; menu + +(hiccups/defhtml template-menu [menuitems] + [:ul {:class "nav nav-pills"} + (for [menuitem menuitems] + [:li {:class "nav-item"} + [:a {:class (cond (= (str/upper-case (get menuitem "handler")) + (str/upper-case (dommy/html (dommy/sel1 :#location)))) + "nav-link active" + :else + "nav-link") + :id (get menuitem "id") + :onclick (str (namespace ::x) ".on_menu_clicked('" (get menuitem "handler") "')")} + (get menuitem "label")]])]) + +(defn handler-menu [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#menu) (template-menu (get jsonobj "menuitems"))))) + +(defn render-menu [] + (GET "/menu" {:handler handler-menu})) + +;; home + +(hiccups/defhtml template-home [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "content")]) + +(defn handler-home [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-home jsonobj)))) + +(defn render-home + ([] + (GET "/home" {:handler handler-home})) + ([message errormsg] + (POST "/home" {:format :raw + :params {:message message + :errormsg errormsg} + :handler handler-home}))) + +;; login + +(hiccups/defhtml template-login [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "title")] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x)) + [:div {:style "text-align: center"}]) + +(defn handler-login [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-login jsonobj)))) + +(defn render-login [] + (GET "/login" {:handler handler-login})) + +;; login-authenticate + +(defn on-login-submit-clicked [] + (when (-> (jquery "#login-form") + (.get "0") + (.checkValidity)) + (render-login-authenticate))) + +(defn handler-login-authenticate [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (cond (get jsonobj "errormsg") + (goto-location "/login") + (get jsonobj "message") + (do + (dommy/set-html! (dommy/sel1 :#location) "/inetorg/view") + (render-inetorg-view) + (render-menu))))) + +(defn render-login-authenticate [] + (POST "/login/authenticate" {:format :raw + :params {:dn (dommy/value (dommy/sel1 :#dn)) + :password (dommy/value (dommy/sel1 :#password))} + :handler handler-login-authenticate})) + +;; logout + +(defn handler-logout [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (render-home (get jsonobj "message") "") + (dommy/set-html! (dommy/sel1 :#location) "/home") + (render-menu))) + +(defn render-logout [] + (GET "/logout" {:handler handler-logout})) + +;; inetorg-view + +(hiccups/defhtml template-inetorg-view [jsonobj] + [:h3 {:style "text-align: center"} (get jsonobj "title")] + [:div {:id "search"}] + [:div {:id "results"}] + [:div {:id "modify" + :class "modal fade" + :role "dialog"} + [:div {:class "modal-dialog modal-lg"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"] + [:h4 "Modify InetOrg Entry"]] + [:div {:id "modify-body" + :class "modal-body" + :style "height: 510px;"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]] + [:div {:id "delete" + :class "modal fade" + :role "dialog"} + [:div {:class "modal-dialog"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"] + [:h4 "Delete InetOrg Entry"]] + [:div {:id "delete-body" + :class "modal-body"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]]) + +(defn handler-inetorg-view [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-inetorg-view jsonobj)) + (render-inetorg-view-search))) + +(defn render-inetorg-view [] + (GET "/inetorg/view" {:handler handler-inetorg-view})) + +;; inetorg-view-search + +(defn on-inetorg-view-search-clicked [] + (when (-> (jquery "#inetorg-view-search-form") + (.get "0") + (.checkValidity)) + (render-inetorg-view-results))) + +(hiccups/defhtml template-inetorg-view-search [jsonobj] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-inetorg-view-search [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#search) (template-inetorg-view-search jsonobj)) + (render-inetorg-view-results))) + +(defn render-inetorg-view-search [] + (GET "/inetorg/view/search" {:handler handler-inetorg-view-search})) + +;; inetorg-view-results + +(hiccups/defhtml template-inetorg-view-results [jsonobj] + [:table {:class "table table-hover"} + [:thead + [:tr + [:th "givenName"] + [:th "sn"] + [:th "mail"] + [:th "postalAddress"] + [:th "postalCode"] + [:th "st"] + [:th "l"] + [:th "telephoneNumber"] + [:th "mobile"] + [:th "businessCategory"] + [:th "Del"]]] + [:tbody + (for [ldap-user (get jsonobj "results")] + (let* [cn (str (get ldap-user "givenname") " " (get ldap-user "sn")) + onclick (str (namespace ::x) ".on_inetorg_modify_clicked('" cn "')")] + [:tr + [:td {:onclick onclick} (get ldap-user "givenname")] + [:td {:onclick onclick} (get ldap-user "sn")] + [:td {:onclick onclick} (get ldap-user "mail")] + [:td {:onclick onclick} (get ldap-user "postaladdress")] + [:td {:onclick onclick} (get ldap-user "postalcode")] + [:td {:onclick onclick} (get ldap-user "st")] + [:td {:onclick onclick} (get ldap-user "l")] + [:td {:onclick onclick} (get ldap-user "telephonenumber")] + [:td {:onclick onclick} (get ldap-user "mobile")] + [:td {:onclick onclick} (get ldap-user "businesscategory")] + [:td [:img {:src "/static/images/edit-delete.png" + :onclick (str (namespace ::x) ".on_inetorg_delete_clicked('" cn "')")}]]]))]]) + +(defn handler-inetorg-view-results [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#results) (template-inetorg-view-results jsonobj)))) + +(defn render-inetorg-view-results [] + (POST "/inetorg/view/results" {:format :raw + :params {:givenname (dommy/value (dommy/sel1 :#view-givenname)) + :sn (dommy/value (dommy/sel1 :#view-sn)) + :mail (dommy/value (dommy/sel1 :#view-mail)) + :postaladdress (dommy/value (dommy/sel1 :#view-postaladdress)) + :postalcode (dommy/value (dommy/sel1 :#view-postalcode)) + :st (dommy/value (dommy/sel1 :#view-st)) + :l (dommy/value (dommy/sel1 :#view-l)) + :telephonenumber (dommy/value (dommy/sel1 :#view-telephonenumber)) + :mobile (dommy/value (dommy/sel1 :#view-mobile)) + :businesscategory (dommy/value (dommy/sel1 :#view-businesscategory))} + :handler handler-inetorg-view-results})) + +;; inetorg-modify + +(defn on-inetorg-modify-clicked [cn] + (render-inetorg-modify cn)) + +(hiccups/defhtml template-inetorg-modify [jsonobj] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-inetorg-modify [response] + (let [jsonobj (js->clj (js/JSON.parse response)) + jquery (js* "$")] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#modify-body) (template-inetorg-modify jsonobj)) + (doseq [[name value] (get jsonobj "ldapUserValues")] + (dommy/set-value! (dommy/sel1 (keyword (str "#modify-" name))) value)) + (.modal (jquery "#modify")))) + +(defn render-inetorg-modify [cn] + (POST "/inetorg/modify" {:format :raw + :params {:cn cn} + :handler handler-inetorg-modify})) + +;; inetorg-modify-submit + +(defn on-inetorg-modify-submit-clicked [] + (.modal (jquery "#modify") "hide") + (render-inetorg-modify-submit)) + +(defn handler-inetorg-modify-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/inetorg/view"))) + +(defn render-inetorg-modify-submit [] + (POST "/inetorg/modify/submit" {:format :raw + :params {:givenname (dommy/value (dommy/sel1 :#modify-givenname)) + :sn (dommy/value (dommy/sel1 :#modify-sn)) + :mail (dommy/value (dommy/sel1 :#modify-mail)) + :postaladdress (dommy/value (dommy/sel1 :#modify-postaladdress)) + :postalcode (dommy/value (dommy/sel1 :#modify-postalcode)) + :st (dommy/value (dommy/sel1 :#modify-st)) + :l (dommy/value (dommy/sel1 :#modify-l)) + :telephonenumber (dommy/value (dommy/sel1 :#modify-telephonenumber)) + :mobile (dommy/value (dommy/sel1 :#modify-mobile)) + :businesscategory (dommy/value (dommy/sel1 :#modify-businesscategory))} + :handler handler-inetorg-modify-submit})) + +;; inetrog-delete + +(defn on-inetorg-delete-clicked [cn] + (render-inetorg-delete cn)) + +(hiccups/defhtml template-inetorg-delete [jsonobj] + [:p (str "Are you sure you want to delete the InetOrg entry: " (get jsonobj "cn"))] + [:p "This action cannot be undone."] + [:button {:type "button" + :data-dismiss "modal" + :onclick (str (namespace ::x) ".on_inetorg_delete_submit_clicked('" (get jsonobj "cn") "')")} + "Delete InetOrg Entry"]) + +(defn handler-inetorg-delete [response] + (let [jsonobj (js->clj (js/JSON.parse response)) + jquery (js* "$")] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#delete-body) (template-inetorg-delete jsonobj)) + (.modal (jquery "#delete")))) + +(defn render-inetorg-delete [cn] + (POST "/inetorg/delete" {:format :raw + :params {:cn cn} + :handler handler-inetorg-delete})) + +;; inetrog-delete-submit + +(defn on-inetorg-delete-submit-clicked [cn] + (render-inetorg-delete-submit cn)) + +(defn handler-inetorg-delete-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (on-menu-clicked "/inetorg/view"))) + +(defn render-inetorg-delete-submit [cn] + (POST "/inetorg/delete/submit" {:format :raw + :params {:cn cn} + :handler handler-inetorg-delete-submit})) + +;; inetrog-add + +(hiccups/defhtml template-inetorg-add [jsonobj] + (ck-form/template-generic-form (get jsonobj "form") (namespace ::x))) + +(defn handler-inetorg-add [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-inetorg-add jsonobj)))) + +(defn render-inetorg-add [] + (GET "/inetorg/add" {:handler handler-inetorg-add})) + +;; inetorg-add-submit + +(defn on-inetorg-add-submit-clicked [] + (when (-> (jquery "#inetorg-add-form") + (.get "0") + (.checkValidity)) + (render-inetorg-add-submit))) + +(defn handler-inetorg-add-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (notifications jsonobj) + (on-menu-clicked "/inetorg/view"))) + +(defn render-inetorg-add-submit [] + (POST "/inetorg/add/submit" {:format :raw + :params {:givenname (dommy/value (dommy/sel1 :#add-givenname)) + :sn (dommy/value (dommy/sel1 :#add-sn)) + :mail (dommy/value (dommy/sel1 :#add-mail)) + :postaladdress (dommy/value (dommy/sel1 :#add-postaladdress)) + :postalcode (dommy/value (dommy/sel1 :#add-postalcode)) + :st (dommy/value (dommy/sel1 :#add-st)) + :l (dommy/value (dommy/sel1 :#add-l)) + :telephonenumber (dommy/value (dommy/sel1 :#add-telephonenumber)) + :mobile (dommy/value (dommy/sel1 :#add-mobile)) + :businesscategory (dommy/value (dommy/sel1 :#add-businesscategory))} + :handler handler-inetorg-add-submit})) + +;; location + +(defn on-menu-clicked [handler] + (dommy/set-html! (dommy/sel1 :#location) handler) + (render-menu) + (cond (= handler "/home") (render-home) + (= handler "/login") (render-login) + (= handler "/login/authenticate") (render-login-authenticate) + (= handler "/logout") (render-logout) + (= handler "/inetorg/view") (render-inetorg-view) + (= handler "/inetorg/add") (render-inetorg-add))) + +(defn handler-location [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (on-menu-clicked (get jsonobj "location")) + (notifications jsonobj))) + +(defn goto-location [location] + (POST "/location" {:format :raw + :params {:location location} + :handler handler-location})) diff --git a/lisp/webapps/ldapadmin/conf/.gitignore b/lisp/webapps/ldapadmin/conf/.gitignore new file mode 100644 index 0000000..14fa7a6 --- /dev/null +++ b/lisp/webapps/ldapadmin/conf/.gitignore @@ -0,0 +1 @@ +options.lisp diff --git a/lisp/webapps/ldapadmin/conf/options.lisp.example b/lisp/webapps/ldapadmin/conf/options.lisp.example new file mode 100644 index 0000000..89f0a37 --- /dev/null +++ b/lisp/webapps/ldapadmin/conf/options.lisp.example @@ -0,0 +1,11 @@ +((:name "ldapadmin" + :url "ldapadmin.tld" + :document-root "ldapadmin" + :title "LDAP Administration Tool" + :meta-description "LDAP Administration Tool" + :ldap (:ldap-host "ldap.tld" + :sslflag nil + :username "cn=Manager,dc=tld" + :password "Welcome1" + :base-dn "dc=tld" + :debug-mode t))) diff --git a/lisp/webapps/ldapadmin/site.lisp b/lisp/webapps/ldapadmin/site.lisp new file mode 100644 index 0000000..5b5163a --- /dev/null +++ b/lisp/webapps/ldapadmin/site.lisp @@ -0,0 +1,101 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defmacro .base (&optional (onload-fn "goto_location('/home')")) + `(org-ckons-http::html5 + `(html + (head + ((meta :name "viewport" :content "width=device-width, initial-scale=1")) + ((meta :charset "utf-8")) + ((title) ,(title *webapp*)) + ,@(mapcar (lambda (css) + `((link :rel "stylesheet" :href ,(getf css :href) :integrity ,(getf css :integrity) :crossorigin ,(getf css :crossorigin)))) + '((:href "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0/css/bootstrap.min.css" :integrity "sha384-Gn5384xqQ1aoWXA+058RXPxPg6fy4IWvTNh0E263XmFcJlSAwiGgFAW/dAiS6JXm" :crossorigin "anonymous") + (:href "https://stackpath.bootstrapcdn.com/bootswatch/4.5.2/darkly/bootstrap.min.css" :integrity "sha384-nNK9n28pDUDDgIiIqZ/MiyO3F4/9vsMtReZK39klb/MtkZI3/LtjSjlmyVPS3KdN" :crossorigin "anonymous"))) + ,@(mapcar (lambda (js) + `((script :type "text/javascript" :src ,(getf js :src) :integrity ,(getf js :integrity) :crossorigin ,(getf js :crossorigin)))) + '((:src "https://code.jquery.com/jquery-3.2.1.slim.min.js" :integrity "sha384-KJ3o2DKtIkvYIK3UENzmM7KCkRr/rE9/Qpg6aAZGJwFDMVNA/GpGFF93hXpG5KkN" :crossorigin "anonymous") + (:src "https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.12.9/umd/popper.min.js" :integrity "sha384-ApNbgh9B+Y1QKtv3Rn7W3mgPxhU9K/ScQsAP7hUibX39j7fakFPskvXusvfa0b4Q" :crossorigin "anonymous") + (:src "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0/js/bootstrap.min.js" :integrity "sha384-JZR6Spejh4U02d8jOt6vLEHfe/JQGiRRSQQxSfFWpi1MquVdAyjUar5+76PVCmYl" :crossorigin "anonymous"))) + ((script :type "text/javascript" :src "/static/js/cljs/main.js"))) + ((body :onload ,(format nil "ldapadmin.core.~a" ,onload-fn)) + ((div :class "container-fluid") + ((div :class "row") + ((div :class "col") " ") + ((div :class "col") + ((div :class "page-header") + ((h2 :align "center") ,(title *webapp*)))) + ((div :class "col") " ")) + ((div :id "menu" :class "well")) + ((div :id "location" :style "display: none")) + ((div :id "errormsg")) + ((div :id "message")) + ((div :id "body"))))))) + +(defmacro .location () + `(location-json location)) + +(defmacro .home-get () + `(home-json)) + +(defmacro .home-post () + `(home-json message errormsg)) + +(defmacro .menu () + `(menu-json)) + +(defmacro .login () + `(login-json)) + +(defmacro .login-authenticate () + `(login-authenticate-json dn password)) + +(defmacro .logout () + `(logout-json)) + +(defmacro .inetorg-view () + `(inetorg-view-json)) + +(defmacro .inetorg-view-search () + `(inetorg-view-search-json)) + +(defmacro .inetorg-view-results () + `(inetorg-view-results-json givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory)) + +(defmacro .inetorg-modify () + `(inetorg-modify-json cn)) + +(defmacro .inetorg-modify-submit () + `(inetorg-modify-submit-json givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory)) + +(defmacro .inetorg-delete () + `(inetorg-delete-json cn)) + +(defmacro .inetorg-delete-submit () + `(inetorg-delete-submit-json cn)) + +(defmacro .inetorg-add () + `(inetorg-add-json)) + +(defmacro .inetorg-add-submit () + `(inetorg-add-submit-json givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory)) + +(define-endpoint :get "/" () .base) +(define-endpoint :post "/location" ((location :parameter-type 'string)) .location) +(define-endpoint :get "/home" () .home-get) +(define-endpoint :post "/home" ((message :parameter-type 'string) (errormsg :parameter-type 'string)) .home-post) +(define-endpoint :get "/menu" () .menu) +(define-endpoint :get "/login" () .login) +(define-endpoint :post "/login/authenticate" ((dn :parameter-type 'string) (password :parameter-type 'string)) .login-authenticate) +(define-endpoint :get "/logout" () .logout) +(define-endpoint :get "/inetorg/view" () .inetorg-view) +(define-endpoint :get "/inetorg/view/search" () .inetorg-view-search) +(define-endpoint :post "/inetorg/view/results" ((givenname :parameter-type 'string) (sn :parameter-type 'string) (mail :parameter-type 'string) (postaladdress :parameter-type 'string) (postalcode :parameter-type 'string) (st :parameter-type 'string) (l :parameter-type 'string) (telephonenumber :parameter-type 'string) (mobile :parameter-type 'string) (businesscategory :parameter-type 'string)) .inetorg-view-results) +(define-endpoint :post "/inetorg/modify" ((cn :parameter-type 'string)) .inetorg-modify) +(define-endpoint :post "/inetorg/modify/submit" ((givenname :parameter-type 'string) (sn :parameter-type 'string) (mail :parameter-type 'string) (postaladdress :parameter-type 'string) (postalcode :parameter-type 'string) (st :parameter-type 'string) (l :parameter-type 'string) (telephonenumber :parameter-type 'string) (mobile :parameter-type 'string) (businesscategory :parameter-type 'string)) .inetorg-modify-submit) +(define-endpoint :post "/inetorg/delete" ((cn :parameter-type 'string)) .inetorg-delete) +(define-endpoint :post "/inetorg/delete/submit" ((cn :parameter-type 'string)) .inetorg-delete-submit) +(define-endpoint :get "/inetorg/add" () .inetorg-add) +(define-endpoint :post "/inetorg/add/submit" ((givenname :parameter-type 'string) (sn :parameter-type 'string) (mail :parameter-type 'string) (postaladdress :parameter-type 'string) (postalcode :parameter-type 'string) (st :parameter-type 'string) (l :parameter-type 'string) (telephonenumber :parameter-type 'string) (mobile :parameter-type 'string) (businesscategory :parameter-type 'string)) .inetorg-add-submit) diff --git a/lisp/webapps/ldapadmin/static/images/edit-delete.png b/lisp/webapps/ldapadmin/static/images/edit-delete.png Binary files differnew file mode 100644 index 0000000..b0de61d --- /dev/null +++ b/lisp/webapps/ldapadmin/static/images/edit-delete.png diff --git a/lisp/webapps/ldapadmin/static/js/cljs b/lisp/webapps/ldapadmin/static/js/cljs new file mode 120000 index 0000000..349848d --- /dev/null +++ b/lisp/webapps/ldapadmin/static/js/cljs @@ -0,0 +1 @@ +../../clojurescript/ldapadmin/resources/public/cljs
\ No newline at end of file diff --git a/lisp/webapps/webapp-loader.lisp b/lisp/webapps/webapp-loader.lisp new file mode 100644 index 0000000..555d493 --- /dev/null +++ b/lisp/webapps/webapp-loader.lisp @@ -0,0 +1,157 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :ldapadmin) + +(defvar *acceptor* nil) +(defvar *dispatch-table* '(#'dispatch-easy-handlers #'default-dispatcher)) +(defvar *webapps* (make-hash-table :test 'equal)) +(defvar *webapp* nil) +(defparameter *port* 3006) +(defparameter *session-timeout* 14400) +(defparameter *server-root* (namestring (asdf:system-relative-pathname (intern (package-name #.*package*)) "./")) + "The location of the web server root on the filesystem.") + +(defclass webapp () + ((name :initarg :name + :initform nil + :accessor name + :documentation "The name of the webapp as used in the code. A +string used as the key to any webapp config lookup.") + (url :initarg :url + :initform nil + :accessor url + :documentation "The domain portion of the URL to the +root of the webapp.") + (document-root :initarg :document-root + :initform nil + :accessor document-root + :documentation "The absolute filesystem path to +the webapp's top-level directory, which is inside the webapps +folder.") + (title :initarg :title + :initform nil + :accessor title + :documentation "The default title that shows up in +the browser title bar.") + (meta-description :initarg :meta-description + :initform nil + :accessor meta-description + :documentation "The text that goes into the META DESCRIPTION +tag, and anywhere else we want to put this text so that it will show +up in Google.") + (ldap :initarg :ldap + :initform nil + :accessor ldap)) + (:documentation "")) + +(defgeneric get-site-file-path (webapp) + (:documentation "Builds a full filesystem path to a webapp's site +file.")) + +(defmethod get-site-file-path ((webapp webapp)) + (format nil "~a/site" (document-root webapp))) + +(defgeneric get-pages-file-paths (webapp) + (:documentation "")) + +(defmethod get-pages-file-paths ((webapp webapp)) + (mapcar (lambda (pages-file) + (ppcre:regex-replace-all "\\.lisp$" (format nil "~a" pages-file) "")) + (remove-if (lambda (x) (equal x "shared")) + (org-ckons-core::shell-wrapper (format nil "find '~a' -maxdepth 1 -type f -iname 'pages*.lisp' |sort" (document-root webapp)))))) + +(defun make-server-path (relative-path) + "Makes a relative filesystem path into a full one, using +`*server-root*' as the base." + (make-document-root-path *server-root* relative-path)) + +(defun make-document-root-path (document-root relative-path) + "Makes a relative filesystem path into a full one, using +`document-root' as the base." + (concatenate 'string document-root relative-path)) + +(defun make-webapp-path (relative-path) + "Makes an absolute filesystem path to a location in the webapps +folder." + (concatenate 'string *server-root* "webapps/" relative-path)) + +(defun get-options-files () + (mapcar (lambda (webapp-directory) + (format nil "~a/conf/options.lisp" webapp-directory)) + (remove-if (lambda (x) (or (org-ckons-core::match-it "webapps/$" x) + (org-ckons-core::match-it "webapps/shared$" x) + (org-ckons-core::match-it "webapps/CVS$" x) + (org-ckons-core::match-it "webapps/\\.$" x) + (org-ckons-core::match-it "webapps/\\.\\.$" x))) + (org-ckons-core::shell-wrapper (format nil "find '~a' -maxdepth 1 -type d |sort" (make-webapp-path "")))))) + +(defun set-webapp (webapp) + "Sets a `webapp' object in `*webapps*'. The lookup key is the +webapp name. If a webapp already exists under this key, it gets +overwritten with the new one." + (setf (gethash (name webapp) *webapps*) webapp)) + +(defun get-webapp (key) + "Gets the webapp object." + (gethash key *webapps*)) + +(defun generate-sessionid () + "Generates a unique random string to seed the +`*session-secret*'. The string is a SHA256 hash." + (let ((entropic-value (make-array '(32) :element-type '(unsigned-byte 8)))) + (with-open-file (urandom-file "/dev/urandom" :direction :input :element-type '(unsigned-byte 8)) + (loop for i from 0 to 31 do + (setf (elt entropic-value i) (read-byte urandom-file)))) + (let ((digest (ironclad:make-digest 'ironclad:sha256))) + (ironclad:update-digest digest entropic-value) + (ironclad:byte-array-to-hex-string (ironclad:produce-digest digest))))) + +(defun populate-webapps () + (loop for options-file in (get-options-files) do + (with-open-file (input options-file :direction :input) + (let* ((form (car (read input)))) + (set-webapp (make-instance 'webapp + :name (getf form :name) + :url (getf form :url) + :document-root (make-webapp-path (getf form :document-root)) + :title (getf form :title) + :meta-description (getf form :meta-description) + :ldap (getf form :ldap))))))) + +(defun ldapadmin () + "Call this to start the server." + (when (null *acceptor*) + (let ((package (string-downcase (package-name *package*)))) + (populate-webapps) + (setf (log-manager) (make-instance 'log-manager :message-class 'formatted-message)) + (start-messenger 'text-file-messenger :filename (format nil "/var/log/lisp/~a.log" package)) + (setf *session-secret* (generate-sessionid)) + (populate-webapps) + (setf *acceptor* (start (make-instance 'easy-acceptor + :port *port* + :document-root (make-server-path (format nil "webapps/~a/" package)) + :name (format nil "~a-acceptor" package))))))) + +(defmacro with-request-wrapper (uri page-function) + ;; Assigning package outside the backquote is necessary because + ;; *package* resolves incorrectly to common-lisp-user inside the + ;; backquote. + (let ((package (string-downcase (package-name *package*)))) + `(let ((*webapp* (get-webapp ,package))) + (org-ckons-core::logger (format nil "Page request URI: [~a]" ,uri)) + (unless *session* + (start-session) + (setf (session-max-time *session*) *session-timeout*) + (setf (session-value :permissions) "anonymous")) + (,page-function)))) + +(defmacro define-endpoint (request-type uri var-list page-function) + "Does the grunt work of creating an `easy-handler' for each page you +wish to publish." + (let ((name (gensym))) + `(progn + (org-ckons-core::logger (format nil "Publishing page. URL = [~a]" ,uri)) + (define-easy-handler (,name :uri ,uri :default-request-type ,request-type) + ,var-list + (with-request-wrapper ,uri ,page-function))))) |
