diff options
33 files changed, 549 insertions, 466 deletions
diff --git a/condition/condition.lisp b/condition/condition.lisp index e8abc85..4b576bc 100644 --- a/condition/condition.lisp +++ b/condition/condition.lisp @@ -3,7 +3,5 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (define-condition handled-error (error) ((text :initarg :text :reader text))) diff --git a/core/coreutils.lisp b/core/coreutils.lisp index 72f213c..8279766 100644 --- a/core/coreutils.lisp +++ b/core/coreutils.lisp @@ -7,13 +7,9 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defparameter *server-root* (namestring (asdf:system-relative-pathname (intern (package-name *package*)) "./")) "The location of the web server root on the filesystem.") -;; ========================================================================== ;; - (defmacro with-gensyms (syms &body body) `(let ,(mapcar #'(lambda (s) `(,s (gensym))) diff --git a/entity/entity.lisp b/entity/entity.lisp index 92635b4..c7f9842 100644 --- a/entity/entity.lisp +++ b/entity/entity.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defclass entity () () (:documentation "Superclass for all entity objects. An entity object diff --git a/entity/generics.lisp b/entity/generics.lisp index 613d6ca..e2a050a 100644 --- a/entity/generics.lisp +++ b/entity/generics.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defgeneric attribute-value-list (entity &optional keep-nulls) (:documentation "Builds an alist of attribute/value pairs.")) diff --git a/entity/ldap-user.lisp b/entity/ldap-user.lisp index 32837a2..f8d8a1c 100644 --- a/entity/ldap-user.lisp +++ b/entity/ldap-user.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defclass ldap-user (entity) ((givenname :initarg :givenname :initform nil diff --git a/file/file-utils.lisp b/file/file-utils.lisp index 20a61ee..cafdf17 100644 --- a/file/file-utils.lisp +++ b/file/file-utils.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defun compile-and-load (filename) "Compiles and then loads a file. `filename' should not have an extension, such as .fasl or .lisp." diff --git a/json/json-utils.lisp b/json/json-utils.lisp index 6467cbb..90262ef 100644 --- a/json/json-utils.lisp +++ b/json/json-utils.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defun json-to-object (object-type json-obj) (remove-if-not (lambda (x) (let ((found-value nil)) @@ -21,8 +19,6 @@ object)) json-obj))) -;; ========================================================================== ;; - (defun objects-to-json (list-of-objects &optional (explicit-encoder-p nil)) (labels ((objectp (object) (not (eq () (remove-if 'null (mapcar (lambda (superclass) diff --git a/ldap/generics.lisp b/ldap/generics.lisp index e3b0956..8378a23 100644 --- a/ldap/generics.lisp +++ b/ldap/generics.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defgeneric disconnect (ldap) (:documentation "")) diff --git a/ldap/ldap.lisp b/ldap/ldap.lisp index 8a9f0ad..0c16414 100644 --- a/ldap/ldap.lisp +++ b/ldap/ldap.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defclass ldap () ((ldap-host :initarg :ldap-host :initform nil diff --git a/ldapadmin.asd b/ldapadmin.asd index f2de66e..5d6b331 100644 --- a/ldapadmin.asd +++ b/ldapadmin.asd @@ -3,13 +3,9 @@ (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 @@ -21,17 +17,11 @@ :depends-on ,(eval depends-on) :components ,components)) -;; ========================================================================== ;; - (defparameter *asdf-packages* '(net-telent-date cl-ppcre uffi hunchentoot cl-log ironclad cl-json drakma trivial-ldap)) -;; ========================================================================== ;; - (loop for pkg in *asdf-packages* do (ql:quickload (symbol-name pkg))) -;; ========================================================================== ;; - (do-defsystem :name "ldapadmin" :version "1.00.000" :maintainer "Carlos Konstanski <ckonstanski@pippiandcarlos.com>" @@ -67,15 +57,14 @@ (:file "rest-service" :depends-on ("base-service")) (:file "auth-service" :depends-on ("rest-service")) (:file "generic-form" :depends-on ("rest-service")) - (:file "menu" :depends-on ("base-service")) - (:file "home" :depends-on ("rest-service")) - (:file "login" :depends-on ("generic-form")) - (:file "login-authenticate" :depends-on ("rest-service")) - (:file "logout" :depends-on ("rest-service")) - (:file "inetorg-view" :depends-on ("auth-service" "generic-form")) - (:file "inetorg-modify" :depends-on ("auth-service" "generic-form")) - (:file "inetorg-delete" :depends-on ("auth-service" "generic-form")) - (:file "inetorg-add" :depends-on ("auth-service" "generic-form")))) + (: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") diff --git a/service/auth-service.lisp b/service/auth-service.lisp index 0d0e8a0..2cdc7bf 100644 --- a/service/auth-service.lisp +++ b/service/auth-service.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defclass auth-service (rest-service) () (:documentation "")) diff --git a/service/base-service.lisp b/service/base-service.lisp index 0f65b82..bc110a3 100644 --- a/service/base-service.lisp +++ b/service/base-service.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defclass base-service () () (:documentation "")) diff --git a/service/generic-form.lisp b/service/generic-form.lisp index 1fb9867..e48d653 100644 --- a/service/generic-form.lisp +++ b/service/generic-form.lisp @@ -3,9 +3,7 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - -(defclass generic-form (rest-service) +(defclass generic-form (base-service) ((name :initarg :name :initform nil :accessor name) @@ -15,6 +13,9 @@ (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)) @@ -27,19 +28,60 @@ (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)) + :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 "")) -(defmacro define-generic-form-constructor ((form-class name action) fields) - `(defmethod initialize-instance :after ((,form-class ,form-class) &key) - (setf (name ,form-class) ,name) - (setf (action ,form-class) ,action) - (setf (form-fields ,form-class) - (mapcar (lambda (form) - (make-instance 'form-field - :name (getf form :name) - :label (getf form :label) - :field-type (getf form :field-type))) - ,fields)))) +(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 new file mode 100644 index 0000000..fd96b36 --- /dev/null +++ b/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) + (objects-to-json `(,(make-instance 'home-service + :message message + :errormsg errormsg)))) diff --git a/service/home.lisp b/service/home.lisp deleted file mode 100644 index 488b86f..0000000 --- a/service/home.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 (rest-service) - ((content :initarg :content - :initform nil - :accessor content)) - (:documentation "")) - -(defmethod initialize-instance :after ((home home) &key) - (setf (content home) (concatenate 'string "Welcome to the " (title *webapp*)))) - -(defun home-json () - (objects-to-json `(,(make-instance 'home)))) diff --git a/service/inetorg-add-service.lisp b/service/inetorg-add-service.lisp new file mode 100644 index 0000000..9647060 --- /dev/null +++ b/service/inetorg-add-service.lisp @@ -0,0 +1,57 @@ +;;; -*- 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 :initarg :location-p + :initform nil + :accessor location-p)) + (: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 (message instance) "InetOrg entry created successfully."))))) diff --git a/service/inetorg-add.lisp b/service/inetorg-add.lisp deleted file mode 100644 index c094375..0000000 --- a/service/inetorg-add.lisp +++ /dev/null @@ -1,56 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -(declaim (optimize (speed 0) (safety 3) (debug 3))) - -(in-package #:ldapadmin) - -;; ========================================================================== ;; -;; inetorg-add - -(defclass inetorg-add (auth-service generic-form) - ((instructions :initarg :instructions - :initform nil - :accessor instructions)) - (:documentation "")) - -(define-generic-form-constructor (inetorg-add "inetorg-add-form" "/inetorg/add/submit") - '((:name "add-givenname" :label "givenName" :field-type "text") - (:name "add-sn" :label "sn" :field-type "text") - (: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") - (:name "add-submit" :label "Create InetOrg Entry" :field-type "button"))) - -(defun inetorg-add-json () - (with-auth (instance inetorg-add) - (setf (instructions instance) "Use the form to add a new InetOrg entry."))) - -;; ========================================================================== ;; -;; inetorg-add-submit - -(defclass inetorg-add-submit (auth-service) - ((location-p :initarg :location-p - :initform nil - :accessor location-p)) - (:documentation "")) - -(defun inetorg-add-submit-json (givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory) - (with-auth (instance inetorg-add-submit) - (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 (message instance) "InetOrg entry created successfully."))))) diff --git a/service/inetorg-delete.lisp b/service/inetorg-delete-service.lisp index d01db5d..1bcac65 100644 --- a/service/inetorg-delete.lisp +++ b/service/inetorg-delete-service.lisp @@ -3,9 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; -;; inetorg-delete - (defclass inetorg-delete (auth-service) ((cn :initarg :cn :initform nil @@ -19,9 +16,6 @@ (with-auth (instance inetorg-delete) (setf (cn instance) cn))) -;; ========================================================================== ;; -;; inetorg-delete-submit - (defclass inetorg-delete-submit (auth-service) () (:documentation "")) diff --git a/service/inetorg-modify-service.lisp b/service/inetorg-modify-service.lisp new file mode 100644 index 0000000..293c43b --- /dev/null +++ b/service/inetorg-modify-service.lisp @@ -0,0 +1,60 @@ +;;; -*- 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) + (title :initarg :title + :initform nil + :accessor title) + (location-p :initarg :location-p + :initform nil + :accessor location-p)) + (: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" :value ) + (: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"))) + +(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 (auth-service) + ((location-p :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defun inetorg-modify-submit-json (givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory) + (with-auth (instance inetorg-modify-submit) + (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 (message instance) "InetOrg entry saved successfully."))))) diff --git a/service/inetorg-modify.lisp b/service/inetorg-modify.lisp deleted file mode 100644 index a8b5b21..0000000 --- a/service/inetorg-modify.lisp +++ /dev/null @@ -1,60 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -(declaim (optimize (speed 0) (safety 3) (debug 3))) - -(in-package #:ldapadmin) - -;; ========================================================================== ;; -;; inetorg-modify - -(defclass inetorg-modify (auth-service generic-form) - ((ldap-user-values :initarg :ldap-user-values - :initform nil - :accessor ldap-user-values) - (location-p :initarg :location-p - :initform nil - :accessor location-p)) - (:documentation "")) - -(define-generic-form-constructor (inetorg-modify "inetorg-modify-form" "/inetorg/modify/submit") - '((: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") - (:name "modify-submit" :label "Modify InetOrg Entry" :field-type "button"))) - -(defun inetorg-modify-json (cn) - (with-auth (instance inetorg-modify) - (with-ldap (ldap) - (setf (ldap-user-values instance) (get-ldap-user ldap cn))))) - -;; ========================================================================== ;; -;; inetorg-modify-submit - -(defclass inetorg-modify-submit (auth-service) - ((location-p :initarg :location-p - :initform nil - :accessor location-p)) - (:documentation "")) - -(defun inetorg-modify-submit-json (givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory) - (with-auth (instance inetorg-modify-submit) - (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 (message instance) "InetOrg entry saved successfully."))))) diff --git a/service/inetorg-view-service.lisp b/service/inetorg-view-service.lisp new file mode 100644 index 0000000..5cbd0c6 --- /dev/null +++ b/service/inetorg-view-service.lisp @@ -0,0 +1,72 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +(defclass inetorg-view (auth-service) + ((title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defun inetorg-view-json () + (with-auth (instance inetorg-view) + (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 :initarg :location-p + :initform nil + :accessor location-p)) + (: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 (auth-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initarg :location-p + :initform nil + :accessor location-p)) + (: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/inetorg-view.lisp b/service/inetorg-view.lisp deleted file mode 100644 index f5bf2f2..0000000 --- a/service/inetorg-view.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -(declaim (optimize (speed 0) (safety 3) (debug 3))) - -(in-package #:ldapadmin) - -;; ========================================================================== ;; -;; inetorg-view - -(defclass inetorg-view (auth-service) - ((instructions :initarg :instructions - :initform nil - :accessor instructions)) - (:documentation "")) - -(defun inetorg-view-json () - (with-auth (instance inetorg-view) - (setf (instructions instance) "Use the form to filter the InetOrg results."))) - -;; ========================================================================== ;; -;; inetorg-view-search - -(defclass inetorg-view-search (auth-service generic-form) - ((location-p :initarg :location-p - :initform nil - :accessor location-p)) - (:documentation "")) - -(define-generic-form-constructor (inetorg-view-search "inetorg-view-search-form" "/inetorg/view/results") - '((: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") - (:name "view-submit" :label "Search InetOrg Entries" :field-type "button"))) - -(defun inetorg-view-search-json () - (with-auth (instance inetorg-view-search) - nil)) - -;; ========================================================================== ;; -;; inetorg-view-results - -(defclass inetorg-view-results (auth-service) - ((results :initarg :results - :initform nil - :accessor results) - (location-p :initarg :location-p - :initform nil - :accessor location-p)) - (:documentation "")) - -(defun inetorg-view-results-json (givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory) - (with-auth (instance inetorg-view-results) - (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-authenticate.lisp b/service/login-authenticate.lisp deleted file mode 100644 index 5b657a0..0000000 --- a/service/login-authenticate.lisp +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -(declaim (optimize (speed 0) (safety 3) (debug 3))) - -(in-package #:ldapadmin) - -;; ========================================================================== ;; - -(defclass login-authenticate (rest-service) - ((location-p :initarg :location-p - :initform nil - :accessor location-p)) - (:documentation "")) - -(defmethod initialize-instance :after ((login-authenticate login-authenticate) &key auth-result) - (if auth-result - (setf (message login-authenticate) "Successfully logged in.") - (setf (errormsg login-authenticate) "Login failed."))) - -(defun login-authenticate-json (dn password) - (let ((auth-result nil)) - (when (check-ldap-password (ldap *webapp*) dn password) - (setf (session-value :permissions) "admin") - (setf auth-result t)) - (objects-to-json `(,(make-instance 'login-authenticate :auth-result auth-result))))) diff --git a/service/login-service.lisp b/service/login-service.lisp new file mode 100644 index 0000000..8de0ec5 --- /dev/null +++ b/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 () + (objects-to-json `(,(make-instance 'login-service)))) + +(defclass login-authenticate-service (rest-service) + ((location-p :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defmethod initialize-instance :after ((login-authenticate-service login-authenticate-service) &key auth-result) + (if auth-result + (setf (message login-authenticate-service) "Successfully logged in.") + (setf (errormsg login-authenticate-service) "Login failed."))) + +(defun login-authenticate-json (username pwd) + (let ((auth-result nil)) + (when (check-ldap-password (ldap *webapp*) dn password) + (setf (session-value :permissions) "admin") + (setf auth-result t)) + (objects-to-json `(,(make-instance 'login-authenticate-service :auth-result auth-result))))) diff --git a/service/login.lisp b/service/login.lisp deleted file mode 100644 index 6d005d7..0000000 --- a/service/login.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 login (generic-form) - () - (:documentation "")) - -(define-generic-form-constructor (login "login-form" "/login/authenticate") - '((:name "dn" :label "DN" :field-type "text") - (:name "password" :label "Password" :field-type "password") - (:name "submit" :label "Login" :field-type "button"))) - -(defun login-json () - (objects-to-json `(,(make-instance 'login)))) diff --git a/service/logout-service.lisp b/service/logout-service.lisp new file mode 100644 index 0000000..d6aef8f --- /dev/null +++ b/service/logout-service.lisp @@ -0,0 +1,17 @@ +;;; -*- 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 :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defmethod initialize-instance :after ((logout-service logout-service) &key) + (setf (message logout-service) "You are now logged out.")) + +(defun logout-json () + (set-user (make-default-user)) + (objects-to-json `(,(make-instance 'logout-service)))) diff --git a/service/logout.lisp b/service/logout.lisp deleted file mode 100644 index 219e7e2..0000000 --- a/service/logout.lisp +++ /dev/null @@ -1,19 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -(declaim (optimize (speed 0) (safety 3) (debug 3))) - -(in-package #:ldapadmin) - -;; ========================================================================== ;; - -(defclass logout (rest-service) - ((location-p :initarg :location-p - :initform nil - :accessor location-p)) - (:documentation "")) - -(defmethod initialize-instance :after ((logout logout) &key) - (setf (message logout) "You are now logged out.")) - -(defun logout-json () - (setf (session-value :permissions) "anonymous") - (objects-to-json `(,(make-instance 'logout)))) diff --git a/service/menu.lisp b/service/menu-service.lisp index 069cb11..25cad07 100644 --- a/service/menu.lisp +++ b/service/menu-service.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defparameter *menu-config* '((:id "a_menu_home" :label "Home" :url "/home" :handler "/home" :permission "t") (:id "a_menu_login" :label "Login" :url "/login" :handler "/login" :permission "anonymous") (:id "a_menu_logout" :label "Logout" :url "/logout" :handler "/logout" :permission "admin") diff --git a/service/rest-service.lisp b/service/rest-service.lisp index 693463f..b34817f 100644 --- a/service/rest-service.lisp +++ b/service/rest-service.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defclass rest-service (base-service) ((location :initarg :location :initform nil diff --git a/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore b/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore index c754477..a1cd79c 100644 --- a/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore +++ b/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore @@ -12,3 +12,4 @@ pom.xml.asc .hg profiles.clj figwheel_server.log +.rebel_readline_history diff --git a/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs b/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs index 268da39..e7ef977 100644 --- a/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs +++ b/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs @@ -4,7 +4,6 @@ [dommy.core :as dommy] [hiccups.runtime :as hiccupsrt])) -;; ========================================================================== ;; ;; declarations (enable-console-print!) @@ -21,8 +20,10 @@ (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) @@ -31,15 +32,17 @@ (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 on-inetorg-modify-clicked) (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 template-inetorg-modify-submit) +(declare on-inetorg-modify-submit-clicked) (declare handler-inetorg-modify-submit) (declare render-inetorg-modify-submit) (declare on-inetorg-delete-clicked) @@ -47,20 +50,20 @@ (declare handler-inetorg-delete) (declare render-inetorg-delete) (declare on-inetorg-delete-submit-clicked) -(declare template-inetorg-delete-submit) (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 template-location) (declare on-menu-clicked) (declare handler-location) (declare goto-location) -;; ========================================================================== ;; +(def jquery (js* "$")) + ;; notifications (hiccups/defhtml template-error [errormsg] @@ -70,68 +73,145 @@ [:div {:class "alert alert-success"} message]) (defn maybe-error [jsonobj] - (cond (get jsonobj "errormsg") - (dommy/set-html! (dommy/sel1 :#errormsg) - (template-error (get jsonobj "errormsg"))) - :else - (dommy/set-html! (dommy/sel1 :#errormsg) ""))) + (let [errormsg (get jsonobj "errormsg")] + (cond (or (= nil errormsg) (= "" errormsg)) + (dommy/set-style! (dommy/sel1 :#errormsg) :display "none") + :else + (do + (dommy/set-style! (dommy/sel1 :#errormsg) :display "block") + (dommy/set-html! (dommy/sel1 :#errormsg) + (template-error errormsg)))))) (defn maybe-message [jsonobj] - (cond (get jsonobj "message") - (dommy/set-html! (dommy/sel1 :#message) - (template-message (get jsonobj "message"))) - :else - (dommy/set-html! (dommy/sel1 :#message) ""))) + (let [message (get jsonobj "message")] + (cond (or (= nil message) (= "" message)) + (dommy/set-style! (dommy/sel1 :#message) :display "none") + :else + (do + (dommy/set-style! (dommy/sel1 :#message) :display "block") + (dommy/set-html! (dommy/sel1 :#message) + (template-message message)))))) (defn notifications [jsonobj] (maybe-error jsonobj) (maybe-message jsonobj)) (defn auth-notifications [jsonobj] - (when (get jsonobj "errormsg") - (render-home) - (render-menu))) + (cond (get jsonobj "errormsg") + (do + (render-home "" (get jsonobj "errormsg")) + (render-menu)) + :else + (maybe-message jsonobj))) -;; ========================================================================== ;; ;; forms (hiccups/defhtml template-generic-form - ([jsonobj] - (template-generic-form jsonobj "on_menu_clicked")) - ([jsonobj onclick] + [:div {:id "form-errormsg"}] [:form {:name (get jsonobj "name") :id (get jsonobj "name") - :class "form-horizontal" - :method (get jsonobj "httpMethod")} + :method (get jsonobj "httpMethod") + :action (when (get jsonobj "action") + (str "javascript:" (namespace ::x) "." (get jsonobj "action")))} (for [form-field (get jsonobj "formFields")] (cond (= (get form-field "fieldType") "button") - [:div {:class "col-sm-offset-2 col-sm-10"} - [:button {:name (get form-field "name") + [:div {:class "form-group row"} + [:div {:class "offset-sm-2 col-sm-10"} + [:button {:class "btn btn-primary" + :data-dismiss (get jsonobj "dismiss") + :type (cond (get form-field "onclick") "button" :else "submit") + :onclick (when (get form-field "onclick") + (str (namespace ::x) "." (get form-field "onclick")))} + (get form-field "label")]]] + (= (get form-field "fieldType") "hidden") + [:input {:name (get form-field "name") + :id (get form-field "name") + :value (get form-field "value") + :type (get form-field "fieldType")}] + (= (get form-field "fieldType") "checkbox") + [:div {:class "form-check"} + [:input {:type "checkbox" + :class "form-check-input" + :id (get form-field "name") + :value (get form-field "value") + :checked (get form-field "checked") + :required (get form-field "required")}] + (when (get form-field "label") + [:label {:class "form-check-label" + :for (get form-field "name")} + (get form-field "label")])] + (= (get form-field "fieldType") "select") + [:div {:class "form-group"} + [:label {:for (get form-field "name")} + (get form-field "label")] + [:select {:class "form-control" + :name (get form-field "name") + :id (get form-field "name") + :required (get form-field "required") + :onchange (when (get form-field "onchange") + (str (namespace ::x) "." (get form-field "onchange")))} + (for [option (get form-field "options")] + [:option {:value (get option "value") + :selected (when (= (get option "value") (get form-field "value")) + "selected")} + (get option "label")])]] + (= (get form-field "fieldType") "textarea") + [:div {:class "form-group row"} + (when (get form-field "label") + [:label {:for (get form-field "name") + :class "col-form-label col-sm-2" + :style "text-align: right"} + (get form-field "label")]) + [:div {:class "col-sm-10"} + [:textarea {:name (get form-field "name") + :id (get form-field "name") + :rows "10" + :cols "68"} + (get form-field "value")]]] + (= (get form-field "fieldType") "datetime-local") + [:div {:class "form-group row"} + (when (get form-field "label") + [:label {:for (get form-field "name") + :class "col-form-label col-sm-2" + :style "text-align: right"} + (get form-field "label")]) + [:div {:class "col-sm-10"} + [:input {:name (get form-field "name") :id (get form-field "name") + :value (get form-field "value") :type (get form-field "fieldType") - :class "btn btn-primary" - :data-dismiss "modal" - :onclick (str (namespace ::x) "." onclick "('" (get jsonobj "action") "')")} - (get form-field "label")]] + :class "form-control" + :required (get form-field "required") + :min "2018-01-01T00:00" + :max "2020:12-31T23:59"}]]] :else - [:div {:class "form-group"} - [:label {:for (get form-field "name") - :class "control-label col-sm-2"} - (get form-field "label")] + [:div {:class "form-group row"} + (when (get form-field "label") + [:label {:for (get form-field "name") + :class "col-form-label col-sm-2" + :style "text-align: right"} + (get form-field "label")]) [:div {:class "col-sm-10"} [:input {:name (get form-field "name") :id (get form-field "name") + :value (get form-field "value") :type (get form-field "fieldType") - :class "form-control"}]]]))])) + :class "form-control" + :required (get form-field "required")}]]]))] + (when (get jsonobj "requiredP") + [:div "* Required"])) -;; ========================================================================== ;; ;; menu (hiccups/defhtml template-menu [menuitems] - [:div {:class "row"} + [:ul {:class "nav nav-pills"} (for [menuitem menuitems] - [:div {:class "col-lg-3"} - [:a {:class "menuitem" + [:li {:class "nav-item"} + [:a {:class (cond (= (clojure.string/upper-case (get menuitem "handler")) + (clojure.string/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")]])]) @@ -143,70 +223,86 @@ (defn render-menu [] (GET "/menu" {:handler handler-menu})) -;; ========================================================================== ;; ;; home (hiccups/defhtml template-home [jsonobj] - [:h3 {:align "center"} (get jsonobj "content")]) + [: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})) + ([] + (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")] + (template-generic-form (get jsonobj "form")) + [: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-generic-form 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") - (render-login) + (do + (notifications jsonobj) + (render-login)) (get jsonobj "message") - (render-home)) - (render-menu) - (notifications jsonobj))) + (do + (dommy/set-html! (dommy/sel1 :#location) "/home") + (render-home (get jsonobj "message") ""))) + (render-menu))) (defn render-login-authenticate [] (POST "/login/authenticate" {:format :raw - :params {:dn (dommy/value (dommy/sel1 :#dn)) - :password (dommy/value (dommy/sel1 :#password))} + :params {:username (dommy/value (dommy/sel1 :#username)) + :pwd (dommy/value (dommy/sel1 :#pwd))} :handler handler-login-authenticate})) -;; ========================================================================== ;; ;; logout (defn handler-logout [response] (let [jsonobj (js->clj (js/JSON.parse response))] - (render-home) - (render-menu) - (notifications jsonobj))) + (render-home"You are now logged out" "") + (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 {:align "center"} (get jsonobj "instructions")] + [:h3 {:style "text-align: center"} (get jsonobj "instructions")] [:div {:id "search"}] [:div {:id "results"}] [:div {:id "modify" :class "modal fade" - :role "dialog"} + :role "dialog"} [:div {:class "modal-dialog modal-lg"} [:div {:class "modal-content"} [:div {:class "modal-header"} @@ -253,22 +349,26 @@ (defn render-inetorg-view [] (GET "/inetorg/view" {:handler handler-inetorg-view})) -;; ========================================================================== ;; ;; inetorg-view-search -(defn on-inetorg-view-search-clicked [handler] - (render-inetorg-view-results)) +(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] + (template-generic-form (get jsonobj "form"))) (defn handler-inetorg-view-search [response] (let [jsonobj (js->clj (js/JSON.parse response))] (auth-notifications jsonobj) - (dommy/set-html! (dommy/sel1 :#search) (template-generic-form jsonobj "on_inetorg_view_search_clicked")) + (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] @@ -323,17 +423,22 @@ :businesscategory (dommy/value (dommy/sel1 :#view-businesscategory))} :handler handler-inetorg-view-results})) -;; ========================================================================== ;; ;; inetorg-modify (defn on-inetorg-modify-clicked [cn] - (render-inetorg-modify cn)) + (when (-> (jquery "#inetorg-modify-form") + (.get "0") + (.checkValidity)) + (render-inetorg-modify cn)) + +(hiccups/defhtml template-inetorg-modify [jsonobj] + (template-generic-form (get jsonobj "form"))) (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-generic-form jsonobj "on_inetorg_modify_submit_clicked")) + (dommy/set-html! (dommy/sel1 :#modify-body) (template-inetrog-modify jsonobj)) (doseq [[name value] (get jsonobj "ldapUserValues")] (dommy/set-value! (dommy/sel1 (keyword (str "#modify-" name))) value)) (.modal (jquery "#modify")))) @@ -343,7 +448,6 @@ :params {:cn cn} :handler handler-inetorg-modify})) -;; ========================================================================== ;; ;; inetorg-modify-submit (defn on-inetorg-modify-submit-clicked [] @@ -369,7 +473,6 @@ :businesscategory (dommy/value (dommy/sel1 :#modify-businesscategory))} :handler handler-inetorg-modify-submit})) -;; ========================================================================== ;; ;; inetrog-delete (defn on-inetorg-delete-clicked [cn] @@ -395,7 +498,6 @@ :params {:cn cn} :handler handler-inetorg-delete})) -;; ========================================================================== ;; ;; inetrog-delete-submit (defn on-inetorg-delete-submit-clicked [cn] @@ -412,22 +514,26 @@ :params {:cn cn} :handler handler-inetorg-delete-submit})) -;; ========================================================================== ;; ;; inetrog-add +(hiccups/defhtml template-inetorg-add [jsonobj] + (template-generic-form (get jsonobj "form"))) + (defn handler-inetorg-add [response] (let [jsonobj (js->clj (js/JSON.parse response))] (auth-notifications jsonobj) - (dommy/set-html! (dommy/sel1 :#body) (template-generic-form jsonobj "on_inetorg_add_submit_clicked")))) + (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 [handler] - (render-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))] @@ -449,28 +555,24 @@ :businesscategory (dommy/value (dommy/sel1 :#add-businesscategory))} :handler handler-inetorg-add-submit})) -;; ========================================================================== ;; ;; location -(hiccups/defhtml template-location [location] - [:h3 {:align "center"} location]) - (defn on-menu-clicked [handler] - (dommy/set-html! (dommy/sel1 :#location) (clojure.string/upper-case (template-location handler))) - (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))) + (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")) - (render-menu) (notifications jsonobj))) (defn goto-location [] - (GET "/location" {:handler handler-location})) - -(set! (.-onload js/window) goto-location) + (POST "/location" {:format :raw + :params {:location location} + :handler handler-location})) diff --git a/webapps/ldapadmin/site.lisp b/webapps/ldapadmin/site.lisp index f010186..126c479 100644 --- a/webapps/ldapadmin/site.lisp +++ b/webapps/ldapadmin/site.lisp @@ -3,9 +3,7 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - -(defmacro .base () +(defmacro .base (&optional (onload-fn "goto_location('/home')")) `(html5 `(html (head @@ -13,31 +11,37 @@ ((meta :charset "utf-8")) ((title) ,(title *webapp*)) ,@(mapcar (lambda (css) - `((link :rel "stylesheet" :href ,css))) - '("https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.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"))) ,@(mapcar (lambda (js) - `((script :type "text/javascript" :src ,js))) - '("https://ajax.googleapis.com/ajax/libs/jquery/3.2.0/jquery.min.js" - "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js" - "/static/js/cljs/main.js")) - (body + `((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 "hworch.core.~a" ,onload-fn)) ((div :class "container-fluid") - ((div :class "page-header") - ((h2 :align "center") ,(title *webapp*))) + ((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")) + ((div :id "location" :style "display: none")) ((div :id "errormsg")) ((div :id "message")) ((div :id "body"))))))) -;; ========================================================================== ;; - (defmacro .location () - `(location-json)) + `(location-json location)) -(defmacro .home () +(defmacro .home-get () `(home-json)) +(defmacro .home-post () + `(home-json message errormsg)) + (defmacro .menu () `(menu-json)) @@ -77,11 +81,10 @@ (defmacro .inetorg-add-submit () `(inetorg-add-submit-json givenname sn mail postaladdress postalcode st l telephonenumber mobile businesscategory)) -;; ========================================================================== ;; - (define-endpoint :get "/" () .base) -(define-endpoint :get "/location" () .location) -(define-endpoint :get "/home" () .home) +(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) diff --git a/webapps/webapp-loader.lisp b/webapps/webapp-loader.lisp index c29da1f..83f1979 100644 --- a/webapps/webapp-loader.lisp +++ b/webapps/webapp-loader.lisp @@ -3,8 +3,6 @@ (in-package #:ldapadmin) -;; ========================================================================== ;; - (defvar *acceptor* nil) (defvar *dispatch-table* '(#'dispatch-easy-handlers #'default-dispatcher)) (defvar *webapps* (make-hash-table :test 'equal)) @@ -12,8 +10,6 @@ (defparameter *port* 3006) (defparameter *session-timeout* 14400) -;; ========================================================================== ;; - (defclass webapp () ((name :initarg :name :initform nil @@ -47,8 +43,6 @@ up in Google.") :accessor ldap)) (:documentation "")) -;; ========================================================================== ;; - (defgeneric get-site-file-path (webapp) (:documentation "Builds a full filesystem path to a webapp's site file.")) @@ -65,8 +59,6 @@ file.")) (remove-if (lambda (x) (equal x "shared")) (shell-wrapper (format nil "find '~a' -maxdepth 1 -type f -iname 'pages*.lisp' |sort" (document-root webapp)))))) -;; ========================================================================== ;; - (defun make-webapp-path (relative-path) "Makes an absolute filesystem path to a location in the webapps folder." @@ -92,8 +84,6 @@ overwritten with the new one." "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." @@ -105,8 +95,6 @@ overwritten with the new one." (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) @@ -119,8 +107,6 @@ overwritten with the new one." :meta-description (getf form :meta-description) :ldap (getf form :ldap))))))) -;; ========================================================================== ;; - (defun ldapadmin () "Call this to start the server." (when (null *acceptor*) @@ -135,8 +121,6 @@ overwritten with the new one." :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 @@ -150,8 +134,6 @@ overwritten with the new one." (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." |