moved everything under lisp/

12 files changed, 501 insertions, 0 deletions

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)) "/")))