From 31657f6854edc116946a099be889440fb3e92e53 Mon Sep 17 00:00:00 2001 From: ckonstanski Date: Sat, 27 Nov 2021 10:20:12 -0700 Subject: moved everything under lisp/ --- condition/condition.lisp | 7 - core/core.lisp | 8 - entity/entity.lisp | 44 -- entity/generics.lisp | 35 -- entity/ldap-user.lisp | 75 ---- ldap/generics.lisp | 18 - ldap/ldap.lisp | 130 ------ ldapadmin.asd | 67 --- lisp/condition/condition.lisp | 7 + lisp/core/core.lisp | 8 + lisp/entity/entity.lisp | 44 ++ lisp/entity/generics.lisp | 35 ++ lisp/entity/ldap-user.lisp | 75 ++++ lisp/ldap/generics.lisp | 18 + lisp/ldap/ldap.lisp | 130 ++++++ lisp/ldapadmin.asd | 67 +++ lisp/service/auth-service.lisp | 30 ++ lisp/service/base-service.lisp | 8 + lisp/service/generic-form.lisp | 87 ++++ lisp/service/home-service.lisp | 18 + lisp/service/inetorg-add-service.lisp | 55 +++ lisp/service/inetorg-delete-service.lisp | 26 ++ lisp/service/inetorg-modify-service.lisp | 59 +++ lisp/service/inetorg-view-service.lisp | 70 ++++ lisp/service/login-service.lisp | 43 ++ lisp/service/logout-service.lisp | 14 + lisp/service/menu-service.lisp | 55 +++ lisp/service/rest-service.lisp | 36 ++ .../ldapadmin/clojurescript/ldapadmin/.gitignore | 15 + .../ldapadmin/clojurescript/ldapadmin/README.md | 14 + .../ldapadmin/clojurescript/ldapadmin/project.clj | 13 + .../clojurescript/ldapadmin/src/core.cljs | 447 +++++++++++++++++++++ lisp/webapps/ldapadmin/conf/.gitignore | 1 + lisp/webapps/ldapadmin/conf/options.lisp.example | 11 + lisp/webapps/ldapadmin/site.lisp | 101 +++++ .../ldapadmin/static/images/edit-delete.png | Bin 0 -> 1121 bytes lisp/webapps/ldapadmin/static/js/cljs | 1 + lisp/webapps/webapp-loader.lisp | 157 ++++++++ service/auth-service.lisp | 30 -- service/base-service.lisp | 8 - service/generic-form.lisp | 87 ---- service/home-service.lisp | 18 - service/inetorg-add-service.lisp | 55 --- service/inetorg-delete-service.lisp | 26 -- service/inetorg-modify-service.lisp | 59 --- service/inetorg-view-service.lisp | 70 ---- service/login-service.lisp | 43 -- service/logout-service.lisp | 14 - service/menu-service.lisp | 55 --- service/rest-service.lisp | 36 -- .../ldapadmin/clojurescript/ldapadmin/.gitignore | 15 - .../ldapadmin/clojurescript/ldapadmin/README.md | 14 - .../clojurescript/ldapadmin/checkouts/.gitignore | 1 - .../ldapadmin/clojurescript/ldapadmin/project.clj | 13 - .../clojurescript/ldapadmin/src/core.cljs | 447 --------------------- webapps/ldapadmin/conf/.gitignore | 1 - webapps/ldapadmin/conf/options.lisp.example | 11 - webapps/ldapadmin/site.lisp | 101 ----- webapps/ldapadmin/static/images/edit-delete.png | Bin 1121 -> 0 bytes webapps/ldapadmin/static/js/cljs | 1 - webapps/webapp-loader.lisp | 157 -------- 61 files changed, 1645 insertions(+), 1646 deletions(-) delete mode 100644 condition/condition.lisp delete mode 100644 core/core.lisp delete mode 100644 entity/entity.lisp delete mode 100644 entity/generics.lisp delete mode 100644 entity/ldap-user.lisp delete mode 100644 ldap/generics.lisp delete mode 100644 ldap/ldap.lisp delete mode 100644 ldapadmin.asd create mode 100644 lisp/condition/condition.lisp create mode 100644 lisp/core/core.lisp create mode 100644 lisp/entity/entity.lisp create mode 100644 lisp/entity/generics.lisp create mode 100644 lisp/entity/ldap-user.lisp create mode 100644 lisp/ldap/generics.lisp create mode 100644 lisp/ldap/ldap.lisp create mode 100644 lisp/ldapadmin.asd create mode 100644 lisp/service/auth-service.lisp create mode 100644 lisp/service/base-service.lisp create mode 100644 lisp/service/generic-form.lisp create mode 100644 lisp/service/home-service.lisp create mode 100644 lisp/service/inetorg-add-service.lisp create mode 100644 lisp/service/inetorg-delete-service.lisp create mode 100644 lisp/service/inetorg-modify-service.lisp create mode 100644 lisp/service/inetorg-view-service.lisp create mode 100644 lisp/service/login-service.lisp create mode 100644 lisp/service/logout-service.lisp create mode 100644 lisp/service/menu-service.lisp create mode 100644 lisp/service/rest-service.lisp create mode 100644 lisp/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore create mode 100644 lisp/webapps/ldapadmin/clojurescript/ldapadmin/README.md create mode 100644 lisp/webapps/ldapadmin/clojurescript/ldapadmin/project.clj create mode 100644 lisp/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs create mode 100644 lisp/webapps/ldapadmin/conf/.gitignore create mode 100644 lisp/webapps/ldapadmin/conf/options.lisp.example create mode 100644 lisp/webapps/ldapadmin/site.lisp create mode 100644 lisp/webapps/ldapadmin/static/images/edit-delete.png create mode 120000 lisp/webapps/ldapadmin/static/js/cljs create mode 100644 lisp/webapps/webapp-loader.lisp delete mode 100644 service/auth-service.lisp delete mode 100644 service/base-service.lisp delete mode 100644 service/generic-form.lisp delete mode 100644 service/home-service.lisp delete mode 100644 service/inetorg-add-service.lisp delete mode 100644 service/inetorg-delete-service.lisp delete mode 100644 service/inetorg-modify-service.lisp delete mode 100644 service/inetorg-view-service.lisp delete mode 100644 service/login-service.lisp delete mode 100644 service/logout-service.lisp delete mode 100644 service/menu-service.lisp delete mode 100644 service/rest-service.lisp delete mode 100644 webapps/ldapadmin/clojurescript/ldapadmin/.gitignore delete mode 100644 webapps/ldapadmin/clojurescript/ldapadmin/README.md delete mode 100644 webapps/ldapadmin/clojurescript/ldapadmin/checkouts/.gitignore delete mode 100644 webapps/ldapadmin/clojurescript/ldapadmin/project.clj delete mode 100644 webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs delete mode 100644 webapps/ldapadmin/conf/.gitignore delete mode 100644 webapps/ldapadmin/conf/options.lisp.example delete mode 100644 webapps/ldapadmin/site.lisp delete mode 100644 webapps/ldapadmin/static/images/edit-delete.png delete mode 120000 webapps/ldapadmin/static/js/cljs delete mode 100644 webapps/webapp-loader.lisp diff --git a/condition/condition.lisp b/condition/condition.lisp deleted file mode 100644 index 9fb353a..0000000 --- a/condition/condition.lisp +++ /dev/null @@ -1,7 +0,0 @@ -;;; -*- 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/core/core.lisp b/core/core.lisp deleted file mode 100644 index e42b1d2..0000000 --- a/core/core.lisp +++ /dev/null @@ -1,8 +0,0 @@ -;;; -*- 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/entity/entity.lisp b/entity/entity.lisp deleted file mode 100644 index ea665e2..0000000 --- a/entity/entity.lisp +++ /dev/null @@ -1,44 +0,0 @@ -;;; -*- 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/entity/generics.lisp b/entity/generics.lisp deleted file mode 100644 index 510c7db..0000000 --- a/entity/generics.lisp +++ /dev/null @@ -1,35 +0,0 @@ -;;; -*- 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/entity/ldap-user.lisp b/entity/ldap-user.lisp deleted file mode 100644 index 282592b..0000000 --- a/entity/ldap-user.lisp +++ /dev/null @@ -1,75 +0,0 @@ -;;; -*- 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/ldap/generics.lisp b/ldap/generics.lisp deleted file mode 100644 index ed8a839..0000000 --- a/ldap/generics.lisp +++ /dev/null @@ -1,18 +0,0 @@ -;;; -*- 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/ldap/ldap.lisp b/ldap/ldap.lisp deleted file mode 100644 index b7ec502..0000000 --- a/ldap/ldap.lisp +++ /dev/null @@ -1,130 +0,0 @@ -;;; -*- 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/ldapadmin.asd b/ldapadmin.asd deleted file mode 100644 index 08f3210..0000000 --- a/ldapadmin.asd +++ /dev/null @@ -1,67 +0,0 @@ -;;; -*- 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 " - :author "Carlos Konstanski " - :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/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 " + :author "Carlos Konstanski " + :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 new file mode 100644 index 0000000..b0de61d Binary files /dev/null and b/lisp/webapps/ldapadmin/static/images/edit-delete.png differ 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))))) diff --git a/service/auth-service.lisp b/service/auth-service.lisp deleted file mode 100644 index 0a84264..0000000 --- a/service/auth-service.lisp +++ /dev/null @@ -1,30 +0,0 @@ -;;; -*- 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/service/base-service.lisp b/service/base-service.lisp deleted file mode 100644 index 7eb8fb3..0000000 --- a/service/base-service.lisp +++ /dev/null @@ -1,8 +0,0 @@ -;;; -*- 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/service/generic-form.lisp b/service/generic-form.lisp deleted file mode 100644 index 6e0c821..0000000 --- a/service/generic-form.lisp +++ /dev/null @@ -1,87 +0,0 @@ -;;; -*- 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/service/home-service.lisp b/service/home-service.lisp deleted file mode 100644 index b914cae..0000000 --- a/service/home-service.lisp +++ /dev/null @@ -1,18 +0,0 @@ -;;; -*- 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/service/inetorg-add-service.lisp b/service/inetorg-add-service.lisp deleted file mode 100644 index a58a10d..0000000 --- a/service/inetorg-add-service.lisp +++ /dev/null @@ -1,55 +0,0 @@ -;;; -*- 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/service/inetorg-delete-service.lisp b/service/inetorg-delete-service.lisp deleted file mode 100644 index 7c27480..0000000 --- a/service/inetorg-delete-service.lisp +++ /dev/null @@ -1,26 +0,0 @@ -;;; -*- 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/service/inetorg-modify-service.lisp b/service/inetorg-modify-service.lisp deleted file mode 100644 index 89e5b9b..0000000 --- a/service/inetorg-modify-service.lisp +++ /dev/null @@ -1,59 +0,0 @@ -;;; -*- 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/service/inetorg-view-service.lisp b/service/inetorg-view-service.lisp deleted file mode 100644 index 379b1b0..0000000 --- a/service/inetorg-view-service.lisp +++ /dev/null @@ -1,70 +0,0 @@ -;;; -*- 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/service/login-service.lisp b/service/login-service.lisp deleted file mode 100644 index 82b647c..0000000 --- a/service/login-service.lisp +++ /dev/null @@ -1,43 +0,0 @@ -;;; -*- 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/service/logout-service.lisp b/service/logout-service.lisp deleted file mode 100644 index 59a9968..0000000 --- a/service/logout-service.lisp +++ /dev/null @@ -1,14 +0,0 @@ -;;; -*- 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/service/menu-service.lisp b/service/menu-service.lisp deleted file mode 100644 index 728b8e5..0000000 --- a/service/menu-service.lisp +++ /dev/null @@ -1,55 +0,0 @@ -;;; -*- 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/service/rest-service.lisp b/service/rest-service.lisp deleted file mode 100644 index ff66dd4..0000000 --- a/service/rest-service.lisp +++ /dev/null @@ -1,36 +0,0 @@ -;;; -*- 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/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore b/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore deleted file mode 100644 index a1cd79c..0000000 --- a/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore +++ /dev/null @@ -1,15 +0,0 @@ -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/webapps/ldapadmin/clojurescript/ldapadmin/README.md b/webapps/ldapadmin/clojurescript/ldapadmin/README.md deleted file mode 100644 index 53ca866..0000000 --- a/webapps/ldapadmin/clojurescript/ldapadmin/README.md +++ /dev/null @@ -1,14 +0,0 @@ -# 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/webapps/ldapadmin/clojurescript/ldapadmin/checkouts/.gitignore b/webapps/ldapadmin/clojurescript/ldapadmin/checkouts/.gitignore deleted file mode 100644 index 72e8ffc..0000000 --- a/webapps/ldapadmin/clojurescript/ldapadmin/checkouts/.gitignore +++ /dev/null @@ -1 +0,0 @@ -* diff --git a/webapps/ldapadmin/clojurescript/ldapadmin/project.clj b/webapps/ldapadmin/clojurescript/ldapadmin/project.clj deleted file mode 100644 index 001af8b..0000000 --- a/webapps/ldapadmin/clojurescript/ldapadmin/project.clj +++ /dev/null @@ -1,13 +0,0 @@ -(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/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs b/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs deleted file mode 100644 index d3f0374..0000000 --- a/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs +++ /dev/null @@ -1,447 +0,0 @@ -(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/webapps/ldapadmin/conf/.gitignore b/webapps/ldapadmin/conf/.gitignore deleted file mode 100644 index 14fa7a6..0000000 --- a/webapps/ldapadmin/conf/.gitignore +++ /dev/null @@ -1 +0,0 @@ -options.lisp diff --git a/webapps/ldapadmin/conf/options.lisp.example b/webapps/ldapadmin/conf/options.lisp.example deleted file mode 100644 index 89f0a37..0000000 --- a/webapps/ldapadmin/conf/options.lisp.example +++ /dev/null @@ -1,11 +0,0 @@ -((: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/webapps/ldapadmin/site.lisp b/webapps/ldapadmin/site.lisp deleted file mode 100644 index 5b5163a..0000000 --- a/webapps/ldapadmin/site.lisp +++ /dev/null @@ -1,101 +0,0 @@ -;;; -*- 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/webapps/ldapadmin/static/images/edit-delete.png b/webapps/ldapadmin/static/images/edit-delete.png deleted file mode 100644 index b0de61d..0000000 Binary files a/webapps/ldapadmin/static/images/edit-delete.png and /dev/null differ diff --git a/webapps/ldapadmin/static/js/cljs b/webapps/ldapadmin/static/js/cljs deleted file mode 120000 index 349848d..0000000 --- a/webapps/ldapadmin/static/js/cljs +++ /dev/null @@ -1 +0,0 @@ -../../clojurescript/ldapadmin/resources/public/cljs \ No newline at end of file diff --git a/webapps/webapp-loader.lisp b/webapps/webapp-loader.lisp deleted file mode 100644 index 555d493..0000000 --- a/webapps/webapp-loader.lisp +++ /dev/null @@ -1,157 +0,0 @@ -;;; -*- 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))))) -- cgit v1.3