diff options
Diffstat (limited to 'webapps')
| -rw-r--r-- | webapps/ldapadmin/clojurescript/ldapadmin/.gitignore | 13 | ||||
| -rw-r--r-- | webapps/ldapadmin/clojurescript/ldapadmin/README.md | 14 | ||||
| -rw-r--r-- | webapps/ldapadmin/clojurescript/ldapadmin/project.clj | 13 | ||||
| -rw-r--r-- | webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs | 471 | ||||
| -rw-r--r-- | webapps/ldapadmin/conf/.gitignore | 1 | ||||
| -rw-r--r-- | webapps/ldapadmin/conf/options.lisp.example | 11 | ||||
| -rw-r--r-- | webapps/ldapadmin/site.lisp | 97 | ||||
| -rw-r--r-- | webapps/ldapadmin/static/images/edit-delete.png | bin | 0 -> 1121 bytes | |||
| l--------- | webapps/ldapadmin/static/js/cljs | 1 | ||||
| -rw-r--r-- | webapps/webapp-loader.lisp | 163 |
10 files changed, 784 insertions, 0 deletions
diff --git a/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore b/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore new file mode 100644 index 0000000..21dfdd2 --- /dev/null +++ b/webapps/ldapadmin/clojurescript/ldapadmin/.gitignore @@ -0,0 +1,13 @@ +target +classes +checkouts +pom.xml +pom.xml.asc +*.jar +*.class +.lein-* +.nrepl-port +.hgignore +.hg +profiles.clj +figwheel_server.log diff --git a/webapps/ldapadmin/clojurescript/ldapadmin/README.md b/webapps/ldapadmin/clojurescript/ldapadmin/README.md new file mode 100644 index 0000000..53ca866 --- /dev/null +++ b/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/webapps/ldapadmin/clojurescript/ldapadmin/project.clj b/webapps/ldapadmin/clojurescript/ldapadmin/project.clj new file mode 100644 index 0000000..001af8b --- /dev/null +++ b/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/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs b/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs new file mode 100644 index 0000000..fb09c3f --- /dev/null +++ b/webapps/ldapadmin/clojurescript/ldapadmin/src/core.cljs @@ -0,0 +1,471 @@ +(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])) + +;; ========================================================================== ;; +;; declarations + +(enable-console-print!) + +(declare template-message) +(declare maybe-error) +(declare maybe-message) +(declare notifications) +(declare auth-notifications) +(declare template-generic-form) +(declare template-menu) +(declare handler-menu) +(declare render-menu) +(declare template-home) +(declare handler-home) +(declare render-home) +(declare handler-login) +(declare render-login) +(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 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 handler-inetorg-modify) +(declare render-inetorg-modify) +(declare template-inetorg-modify-submit) +(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 template-inetorg-delete-submit) +(declare handler-inetorg-delete-submit) +(declare render-inetorg-delete-submit) +(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) + +;; ========================================================================== ;; +;; notifications + +(hiccups/defhtml template-error [errormsg] + [:div {:class "alert alert-danger"} errormsg]) + +(hiccups/defhtml template-message [message] + [: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) ""))) + +(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) ""))) + +(defn notifications [jsonobj] + (maybe-error jsonobj) + (maybe-message jsonobj)) + +(defn auth-notifications [jsonobj] + (when (get jsonobj "errormsg") + (render-home) + (render-menu))) + +;; ========================================================================== ;; +;; forms + +(hiccups/defhtml template-generic-form + ([jsonobj] + (template-generic-form jsonobj "on_menu_clicked")) + ([jsonobj onclick] + [:form {:name (get jsonobj "name") + :id (get jsonobj "name") + :class "form-horizontal" + :method (get jsonobj "httpMethod")} + (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") + :id (get form-field "name") + :type (get form-field "fieldType") + :class "btn btn-primary" + :data-dismiss "modal" + :onclick (str (namespace ::x) "." onclick "('" (get jsonobj "action") "')")} + (get form-field "label")]] + :else + [:div {:class "form-group"} + [:label {:for (get form-field "name") + :class "control-label col-sm-2"} + (get form-field "label")] + [:div {:class "col-sm-10"} + [:input {:name (get form-field "name") + :id (get form-field "name") + :type (get form-field "fieldType") + :class "form-control"}]]]))])) + +;; ========================================================================== ;; +;; menu + +(hiccups/defhtml template-menu [menuitems] + [:div {:class "row"} + (for [menuitem menuitems] + [:div {:class "col-lg-3"} + [:a {:class "menuitem" + :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 {:align "center"} (get jsonobj "content")]) + +(defn handler-home [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#body) (template-home jsonobj)))) + +(defn render-home [] + (GET "/home" {:handler handler-home})) + +;; ========================================================================== ;; +;; login + +(defn handler-login [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-generic-form jsonobj)))) + +(defn render-login [] + (GET "/login" {:handler handler-login})) + +;; ========================================================================== ;; +;; login-authenticate + +(defn handler-login-authenticate [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (cond (get jsonobj "errormsg") + (render-login) + (get jsonobj "message") + (render-home)) + (render-menu) + (notifications jsonobj))) + +(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) + (render-menu) + (notifications jsonobj))) + +(defn render-logout [] + (GET "/logout" {:handler handler-logout})) + +;; ========================================================================== ;; +;; inetorg-view + +(hiccups/defhtml template-inetorg-view [jsonobj] + [:h3 {:align "center"} (get jsonobj "instructions")] + [: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 [handler] + (render-inetorg-view-results)) + +(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")) + (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 "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 [: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))} + :handler handler-inetorg-view-results})) + +;; ========================================================================== ;; +;; inetorg-modify + +(defn on-inetorg-modify-clicked [cn] + (render-inetorg-modify cn)) + +(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")) + (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 [] + (render-inetorg-modify-submit)) + +(defn handler-inetorg-modify-submit [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (auth-notifications jsonobj) + (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))} + :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) + (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 + +(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")))) + +(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 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))} + :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))) + +(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) diff --git a/webapps/ldapadmin/conf/.gitignore b/webapps/ldapadmin/conf/.gitignore new file mode 100644 index 0000000..14fa7a6 --- /dev/null +++ b/webapps/ldapadmin/conf/.gitignore @@ -0,0 +1 @@ +options.lisp diff --git a/webapps/ldapadmin/conf/options.lisp.example b/webapps/ldapadmin/conf/options.lisp.example new file mode 100644 index 0000000..89f0a37 --- /dev/null +++ b/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/webapps/ldapadmin/site.lisp b/webapps/ldapadmin/site.lisp new file mode 100644 index 0000000..00d91c5 --- /dev/null +++ b/webapps/ldapadmin/site.lisp @@ -0,0 +1,97 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defmacro .base () + `(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 ,css))) + '("https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css"))) + ,@(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 + ((div :class "container-fluid") + ((div :class "page-header") + ((h2 :align "center") ,(title *webapp*))) + ((div :id "menu" :class "well")) + ((div :id "location")) + ((div :id "errormsg")) + ((div :id "message")) + ((div :id "body"))))))) + +;; ========================================================================== ;; + +(defmacro .location () + `(location-json)) + +(defmacro .home () + `(home-json)) + +(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)) + +(defmacro .inetorg-modify () + `(inetorg-modify-json cn)) + +(defmacro .inetorg-modify-submit () + `(inetorg-modify-submit-json givenname sn mail postaladdress postalcode st l telephonenumber mobile)) + +(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)) + +;; ========================================================================== ;; + +(def-page :get "/" () .base) +(def-page :get "/location" () .location) +(def-page :get "/home" () .home) +(def-page :get "/menu" () .menu) +(def-page :get "/login" () .login) +(def-page :post "/login/authenticate" ((dn :parameter-type 'string) (password :parameter-type 'string)) .login-authenticate) +(def-page :get "/logout" () .logout) +(def-page :get "/inetorg/view" () .inetorg-view) +(def-page :get "/inetorg/view/search" () .inetorg-view-search) +(def-page :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)) .inetorg-view-results) +(def-page :post "/inetorg/modify" ((cn :parameter-type 'string)) .inetorg-modify) +(def-page :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)) .inetorg-modify-submit) +(def-page :post "/inetorg/delete" ((cn :parameter-type 'string)) .inetorg-delete) +(def-page :post "/inetorg/delete/submit" ((cn :parameter-type 'string)) .inetorg-delete-submit) +(def-page :get "/inetorg/add" () .inetorg-add) +(def-page :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)) .inetorg-add-submit) diff --git a/webapps/ldapadmin/static/images/edit-delete.png b/webapps/ldapadmin/static/images/edit-delete.png Binary files differnew file mode 100644 index 0000000..b0de61d --- /dev/null +++ b/webapps/ldapadmin/static/images/edit-delete.png diff --git a/webapps/ldapadmin/static/js/cljs b/webapps/ldapadmin/static/js/cljs new file mode 120000 index 0000000..349848d --- /dev/null +++ b/webapps/ldapadmin/static/js/cljs @@ -0,0 +1 @@ +../../clojurescript/ldapadmin/resources/public/cljs
\ No newline at end of file diff --git a/webapps/webapp-loader.lisp b/webapps/webapp-loader.lisp new file mode 100644 index 0000000..de5bf81 --- /dev/null +++ b/webapps/webapp-loader.lisp @@ -0,0 +1,163 @@ +;;; -*- 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) + +;; ========================================================================== ;; + +(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")) + (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." + (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 (match-it "webapps/$" x) + (match-it "webapps/shared$" x) + (match-it "webapps/CVS$" x) + (match-it "webapps/\\.$" x) + (match-it "webapps/\\.\\.$" x))) + (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))) + (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 def-page (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 + (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))))) |
