diff options
36 files changed, 2418 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..696753b --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*~ +*swp +*.fasl diff --git a/condition/condition.lisp b/condition/condition.lisp new file mode 100644 index 0000000..e8abc85 --- /dev/null +++ b/condition/condition.lisp @@ -0,0 +1,9 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(define-condition handled-error (error) + ((text :initarg :text :reader text))) diff --git a/core/coreutils.lisp b/core/coreutils.lisp new file mode 100644 index 0000000..72f213c --- /dev/null +++ b/core/coreutils.lisp @@ -0,0 +1,190 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(defpackage #:ldapadmin + (:use #:cl #:cl-log #:hunchentoot) + (:export #:ldapadmin)) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(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))) + syms) + ,@body)) + +(defmacro once-only ((&rest names) &body body) + (let ((gensyms (loop for n in names collect (gensym)))) + `(let (,@(loop for g in gensyms collect `(,g (gensym)))) + `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) + ,@body))))) + +(defun logger (output) + "Logs output to the cl-log log file." + (log-message :info (format nil "~a: ~a" (net.telent.date:universal-time-to-rfc2822-date (get-universal-time)) output))) + +(defun string-to-list (my-string) + "Converts a sequence to a list \(or whatever the sequence is a +string representation of\)." + (with-input-from-string (stream my-string) + (read stream))) + +(defmacro add-to-list (output-list &rest value-to-add) + "Wraps the SETF...APPEND idiom in a smaller package." + `(setf ,output-list (append ,output-list ,@value-to-add))) + +(defun parse-symbol (my-symbol) + (let ((symbol-parts (ppcre:split "::" (symbol-name my-symbol)))) + (if (= (length symbol-parts) 1) + (car symbol-parts) + (cadr symbol-parts)))) + +(defun flatten (mylist) + (cond ((atom mylist) mylist) + ((listp (car mylist)) + (append (flatten (car mylist)) (flatten (cdr mylist)))) + (t (append (list (car mylist)) (flatten (cdr mylist)))))) + +(defun match-it (regex field) + "Wraps a PCRE search in a smaller package." + (cl-ppcre:all-matches-as-strings regex field)) + +(defun cast-float (string-rep) + "Tries to return the float representation of `string-rep'. If +`string-rep' cannot be parsed as a float, returns `nil'." + (let ((read-value (read-from-string string-rep))) + (cond ((floatp read-value) read-value) + ((integerp read-value) (float read-value)) + (t nil)))) + +(defun pretty-print (raw-string &optional textbox-p) + "Filters `nil' string values, returning ` ' instead. But if +`textbox-p' is t, it returns an empty string instead of ` '." + (let ((trimmed-string (when raw-string (string-trim '(#\Space #\Tab) raw-string)))) + (if (and trimmed-string (> (length trimmed-string) 0)) + (format nil "~a" (ppcre:regex-replace-all "\"" trimmed-string """)) + (if textbox-p "" " ")))) + +(defun strip-milliseconds (sql-datetime) + (subseq sql-datetime 0 (position #\. sql-datetime))) + +#+sbcl +(defun map-slot-names (instance) + "Returns a list of the names of all the slots of any class instance +using reflection. The returned values are symbols. Only works with +SBCL." + (mapcar #'sb-mop:slot-definition-name + (sb-mop:class-slots (class-of instance)))) + +(defun make-document-root-path (document-root relative-path) + "Makes a relative filesystem path into a full one, using +`document-root' as the base." + (concatenate 'string document-root relative-path)) + +(defun make-server-path (relative-path) + "Makes a relative filesystem path into a full one, using +`*server-root*' as the base." + (make-document-root-path *server-root* relative-path)) + +(defun null-or-empty-p (sequence) + (or (null sequence) (equal (length sequence) 0))) + +(defun xml-escape (mystring) + (setf mystring (ppcre:regex-replace-all "<" mystring "<")) + (setf mystring (ppcre:regex-replace-all ">" mystring ">")) + (setf mystring (ppcre:regex-replace-all "&" mystring "&")) + (setf mystring (ppcre:regex-replace-all "\"" mystring """)) + (setf mystring (ppcre:regex-replace-all "'" mystring "'")) + mystring) + +(defun xml-unescape (mystring) + (setf mystring (ppcre:regex-replace-all "<" mystring "<")) + (setf mystring (ppcre:regex-replace-all ">" mystring ">")) + (setf mystring (ppcre:regex-replace-all "&" mystring "&")) + (setf mystring (ppcre:regex-replace-all """ mystring "\"")) + (setf mystring (ppcre:regex-replace-all "'" mystring "'")) + mystring) + +(defun trim-last-char (mystring) + (if (null-or-empty-p mystring) + "" + (subseq mystring 0 (- (length mystring) 1)))) + +(defun string-to-real (string-rep) + "Converts a string representation of a number to a rational +representation. For some reason, the lisp community calls rational +numbers `real'. If you pass this method garbage, you will get 0. It +always returns a number." + (if (null-or-empty-p string-rep) + 0 + (let* ((string-parts (ppcre:split "\\." (string-trim '(#\Space #\Tab) string-rep))) + (integer-portion (parse-integer (car string-parts) :junk-allowed t)) + (fractional-portion-string (second string-parts)) + (fractional-divisor 1)) + (multiple-value-bind (fractional-portion fractional-portion-length) + (if (> (length fractional-portion-string) 0) + (parse-integer fractional-portion-string :junk-allowed t) + (values nil 0)) + (when (null integer-portion) + (setf integer-portion 0)) + (when (null fractional-portion) + (setf fractional-portion 0)) + (when (not (= fractional-portion 0)) + (setf fractional-divisor (expt 10 fractional-portion-length))) + (if (>= integer-portion 0) + (+ integer-portion (/ fractional-portion fractional-divisor)) + (- integer-portion (/ fractional-portion fractional-divisor))))))) + +(defun real-to-string (real-rep &key (places 2)) + "Converts a rational representaion of a number into a string +representation, rounded to `places' decimal places." + (when real-rep + (if (= places 0) + (format nil "~a" (parse-integer (format nil "~,2f" real-rep) :junk-allowed t)) + (format nil + (format nil "~~,~af" places) + (coerce real-rep 'long-float))))) + +(defun double-to-real (double-rep &key (places 2)) + "Converts a double to a real. It does this by converting the double +to a string, and then the string to a real. Decimal place truncation +happens when converting to a string." + (string-to-real (real-to-string double-rep :places places))) + +(defun pad-with-zeros (string-rep places) + "Left-pads a string representaion of a number with leading zeros to +make it the specified length." + (loop for i from (+ (length string-rep) 1) to places do + (setf string-rep (format nil "0~a" string-rep))) + string-rep) + +(defun shell-wrapper (command) + "Calls a shell command and returns the output as a list, where each +atom of the list is a string that contains one line of the output." + (let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t))) + (with-output-to-string (stream output) + (uffi:run-shell-command command :output stream)) + (loop for line in (ppcre:split #\Newline output) + collect line))) + +(defun reduce-to-char-separated-string (mylist char) + (format nil "~a" (reduce (lambda (&optional x y) + (cond ((and x y) (format nil "~a~a~a" x char y)) + ((and x (not y)) (format nil "~a" x)) + ((and (not x) y) (format nil "~a" y)) + (t ""))) + mylist))) + +(defun reduce-to-comma-separated-string (mylist) + (reduce-to-char-separated-string mylist ",")) + +(defun reduce-to-newline-separated-string (mylist) + (reduce-to-char-separated-string mylist #\Newline)) diff --git a/core/html.lisp b/core/html.lisp new file mode 100644 index 0000000..c76e9cb --- /dev/null +++ b/core/html.lisp @@ -0,0 +1,324 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +;; Lifted directly from araneida. + +(in-package :ldapadmin) + +;;; XXX fix this, it's not correct +(defun html-reserved-p (c) + (member c '(#\< #\" #\> #\&))) + +(defun html-escape (html-string) + (apply #'concatenate 'string + (loop for c across html-string + if (html-reserved-p c) + collect (format nil "&#~A;" (char-code c)) + else if (eql c #\Newline) collect "<br>" + else collect (string c)))) + +(defun s. (&rest args) + "Concatenate ARGS as strings" + (declare (optimize (speed 3))) + (let ((*print-pretty* nil)) + (with-output-to-string (out) + (dolist (arg args) + (princ arg out))))) + +(defun html-escape-tag (tag attrs content) + (declare (ignore tag attrs)) + (s. (mapcar #'html-escape content))) + +(setf (get 'escape 'html-converter) #'html-escape-tag) +(setf (get 'null 'html-converter) #'princ-to-string) + +(macrolet ((html-attr-body () + `(with-output-to-string (o) + (loop for (att val . rest) on attr by #'cddr do + (cond + #+parenscript((and (symbolp att) (equal (symbol-name 'css) (symbol-name att))) + (progn + (princ " " o) + (princ "style=\"" o) + (princ (val-printer (parenscript::css-inline-func val)) o) + (princ "\"" o))) + ((symbolp att) + (progn + (princ " " o) + (princ (symbol-name att) o) + (princ "=\"" o) + (princ (val-printer val) o) + (princ "\"" o))) + (t + (error "attribute ~S is not a symbol in attribute list ~S" att attr))))))) + (defun html-attr (attr) + (macrolet ((val-printer (val) + val)) + (html-attr-body))) + (defun html-attr-escaped (attr) + (macrolet ((val-printer (val) + `(html-escape ,val))) + (html-attr-body)))) + +(defun empty-element-p (tag) + (member (intern (symbol-name tag) #.*package*) '())) + +(defmacro defhtmltag (tag (attributes-var content-var) &body body) + "Define a custom HTML tag +Useful for custom phrases, or even special constructs. + +Example: +(defhtmltag coffee (attr content) + (declare (ignore attr content)) + \"c|_|\") + +So, saying +(span \"Nice hot \" (coffee)) + +Would produce: +<span>Nice hot c|_|</span> + +More in-depth use would be something such as: +(even-odd-list + (li \"one\") + (li \"two\") + (li \"three\")) + +Turning into: +(ul + ((li :class \"odd\") \"one\") + ((li :class \"even\") \"two\") + ((li :class \"odd\") \"odd\")) + +Your custom tag is expected to return either a string or +an html construct like you'd pass to HTML-STREAM." + (with-gensyms (throw-away) + `(setf (get ',tag :html-converter) + (lambda (,throw-away ,attributes-var ,content-var) + (declare (ignore ,throw-away)) + (funcall + (lambda (,attributes-var ,content-var) + ,@body) + ,attributes-var ,content-var))))) + +(defun htmlp (html) + "Returns t if html is a legal HTML list. +NB: HTML and friends print out a superset of legal html lists. + +'(ul (li \"yes\") (li \"no\")) is legal +3 is not + +But HTML will print both of them" + (and (consp html) + (not (stringp (car html))))) + +(defmacro destructure-html ((tag-sym attrs-sym content-sym) html &body body) + "Destructure an HTML construct. +(destructure-html (tag attrs content) '((span :class \"strange\") \"A strange span!\") + (format t \"<~A ~{~A~}>~{~A~}</~A>\" tag attrs content tag)) +If the construct is invalid, it will cause an error" + (once-only (html) + `(if (htmlp ,html) + (let ((,tag-sym (if (consp (car ,html)) + (caar ,html) + (car ,html))) + (,attrs-sym (if (consp (car ,html)) + (cdar ,html) + nil)) + (,content-sym (cdr ,html))) + ,@body)))) + +; I admit, this is a rather goofy way to write this. There's just so much code they have in common +; and this lets me modify them rather easily. +(macrolet ((html-body () + `(ret-block + (cond ((htmlp things) + (destructure-html (tag attrs content) things + (let ((special-effect (get tag :html-converter))) + (if special-effect + (if (not (functionp special-effect)) + (error "Tag ~A has :html-converter set, but NOT as a function." tag) + (call-self stream (funcall special-effect tag attrs content) inline-elements)) + (cond ((equal (symbol-name 'comment) (symbol-name tag)) + (printing + (format-out "<!-- ~{~A ~}~%" attrs) + (iter-list (c content) + (call-self stream c inline-elements)) + (format-out " -->~%"))) + #+parenscript + ((equal (symbol-name 'css) (symbol-name tag)) + (printing + (format-out "<style type=\"text/css\">~%") + (format-out "<!--~%") + (iter-list (c content) + (format-out (parenscript::css-rule-to-string (parenscript::make-css-rule (car c) (cdr c))))) + (format-out "~%-->") + (format-out "</style>"))) + #+parenscript + ((equal (symbol-name 'js-script) (symbol-name tag)) + (printing + (format-out "<script type=\"text/javascript\">~%") + (format-out "// <![CDATA[~%") + (format-out (parenscript:js* (cons 'progn content))) + (format-out "~%// ]]>~%"))) + ((not (empty-element-p tag)) + (printing + (format-out "<~A~A>" (symbol-name tag) (attr-printer attrs)) + (iter-list (c content) + (call-self stream c inline-elements)) + (format-out "</~A>~:[~;~%~]" + (symbol-name tag) + (not (member tag inline-elements))))) + (t + (format-out "<~A~A>" (symbol-name tag) (attr-printer attrs)))))))) + ((consp things) + (iter-list (thing things) (format-out "~A" thing))) + ((functionp things) + (call-function things stream)) + ((keywordp things) + (format-out "<~A>" (symbol-name things))) + (t + (format-out "~A" (thing-printer things))))))) + + ;; stream forms first + (macrolet ((ret-block (output-block) + `(progn + ,output-block + t)) + (iter-list ((item list) func) + `(dolist (,item ,list) + ,func)) + (printing (&body list) + `(progn + ,@list)) + (format-out (&rest args) + `(format stream ,@args)) + (call-function (things stream) + `(funcall ,things ,stream))) + + (defun html-stream (stream things &optional inline-elements) + "Format supplied argument as HTML. Argument may be a string +\(returned unchanged\) or a list of \(tag content\) where tag may be +\(tagname attrs\). \(\(a :href \"/ \"\) \"home\"\) is formatted as +you'd expect it to be. INLINE-ELEMENTS is a list of elements not to +print a newline after. Returns T unless broken, so can be the last +form in a handler For special effects, set the HTML-CONVERTER property +of a symbol for a tag to a function. It will be called with arguments +\(TAG ATTRS CONTENT\) and should return a string to be interpolated at +that point." + (declare (optimize (speed 3)) + (type stream stream)) + (macrolet ((attr-printer (attrs) + `(html-attr ,attrs)) + (call-self (stream things &optional inline-elements) + `(html-stream ,stream ,things ,inline-elements)) + (thing-printer (things) + `(princ-to-string things))) + (html-body))) + + (defun html-escaped-stream (stream things &optional inline-elements) + "Format supplied argument as HTML, escaping properly. +Just like html-stream except certain things are now html-escaped. +Content - in '\(p \"foo\"\) \"foo\" is the content - is escaped, as +well as the values of attributes. Please note that this CAN result in +double escaping if calling code also escapes. For special effects, +set the HTML-CONVERTER property of a symbol for a tag to a function. +It will be called with arguments \(TAG ATTRS CONTENT\) and should +return a string to be interpolated at that point. NB that the attrs +and content will be passed in *unescaped*" + (declare (optimize (speed 3)) + (type stream stream)) + (macrolet ((attr-printer (attrs) + `(html-attr-escaped ,attrs)) + (call-self (stream things &optional inline-elements) + `(html-escaped-stream ,stream ,things ,inline-elements)) + (thing-printer (things) + `(html-escape (princ-to-string ,things)))) + (html-body)))) + + ;; now for the string forms + (macrolet ((ret-block (output-block) + output-block) + (iter-list ((item list) func) + `(apply #'concatenate 'string (mapcar (lambda (,item) ,func) ,list))) + (printing (&body list) + `(concatenate 'string + ,@list)) + (format-out (&rest args) + `(format nil ,@args)) + (call-function (things stream) + (declare (ignore stream)) + `(funcall ,things))) + + (defun html (things &optional inline-elements) + "Format supplied argument as HTML. Argument may be a string +\(returned unchanged\) or a list of \(tag content\) where tag may be +\(tagname attrs\). \(\(a :href \"/\"\) \"home\"\) is formatted as +you'd expect it to be. For special effects, set the HTML-CONVERTER +property of a symbol for a tag to a function. It will be called with +arguments \(TAG ATTRS CONTENT\) and should return a string to be +interpolated at that point." + (declare (optimize (speed 3))) + (macrolet ((attr-printer (attrs) + `(html-attr ,attrs)) + (call-self (stream things &optional inline-elements) + `(html ,things ,inline-elements)) + (thing-printer (things) + `(princ-to-string ,things))) + (html-body))))) + +(defun html5 (things &optional inline-elements) + (format nil "<!DOCTYPE html>~%~a" (html things inline-elements))) + +#|| +(search-html-tree '((string> ht :element) t (= p :element)) '((html) ((body) ((p) "foo") ((p) "bar") ((div :title "titl") "blah")))) +||# + +(defun search-html-tree (search-terms tree) + (labels ((node-matches (term tree) + (or (eql term t) + (destructuring-bind (op content name) term + (let ((r-op (if (eql op '=) 'equal op))) + (if (eql name :element) + (funcall r-op content (caar tree)) + (funcall r-op content (getf (cdar tree) name)))))))) + (cond ((eql (cdr search-terms) nil) + (and (node-matches (car search-terms) tree) tree)) + ((null tree) nil) + ((node-matches (car search-terms) tree) + (remove-if #'null + (mapcar (lambda (tr) + (search-html-tree (cdr search-terms) tr)) + (cdr tree))))))) + + +#+parenscript +(defmacro css-file (request &rest rules) + "Sends CSS as a file in response to request, as specified by rules. + For example: + (defmethod handle-request-response ((handler my-handler) method request) + (css-file request + (* :border \"1px solid black\") + (div.bl0rg :font-family \"serif\") + ((\"a:active\" \"a:hoover\") :color \"black\" :size \"200%\"))) + See the documentation for Parenscript for more info on the CSS rules themselves." + `(progn + (request-send-headers ,request :content-type "text/css") + ,@(mapcar (lambda (rule) + `(princ (parenscript::css-rule-to-string (parenscript::css-rule ,@rule)) (request-stream ,request))) + rules) + t)) + +#+parenscript +(defmacro js-file (request &rest body) + "Sends Javascript as a file in response to request, as specified by the javascript body. + For example: + (defmethod handle-request-response ((handler my-handler) method request) + (js-file request + (defun hello () + (alert \"Hello, World!\")))) + See the documentation for Parenscript for more info on how to do Javascript." + `(progn + (request-send-headers ,request :content-type "text/javascript") + (princ (parenscript:js ,@body) (request-stream ,request)) + t)) diff --git a/core/httputils.lisp b/core/httputils.lisp new file mode 100644 index 0000000..fbd5c36 --- /dev/null +++ b/core/httputils.lisp @@ -0,0 +1,66 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +(defmacro with-cookie-jar (&rest body) + `(let ((cookie-jar (make-instance 'drakma:cookie-jar))) + ,@body)) + +(defun drakma-request (url + cookie-jar + &key + (method :get) + (content-type "application/x-www-form-urlencoded") + (content nil) + (user-agent :firefox) + (redirect t) + (auto-referer t) + (additional-headers nil) + (connection-timeout 20) + (proxy nil) + (proxy-basic-authorization nil) + (basic-authorization nil)) + (drakma:http-request url + :cookie-jar cookie-jar + :method method + :content-type content-type + :content content + :user-agent user-agent + :redirect redirect + :auto-referer auto-referer + :connection-timeout connection-timeout + :additional-headers additional-headers + :proxy proxy + :proxy-basic-authorization proxy-basic-authorization + :basic-authorization basic-authorization + :close t)) + +(defun escape-url (url) + (let ((escaped-url url)) + (setf escaped-url (ppcre:regex-replace-all "%" escaped-url "%25")) + (setf escaped-url (ppcre:regex-replace-all "\\?" escaped-url "%3F")) + (setf escaped-url (ppcre:regex-replace-all "#" escaped-url "%23")) + (setf escaped-url (ppcre:regex-replace-all "/" escaped-url "%2F")) + (setf escaped-url (ppcre:regex-replace-all "'" escaped-url "%27")) + (setf escaped-url (ppcre:regex-replace-all " " escaped-url "%20")) + (setf escaped-url (ppcre:regex-replace-all "\\(" escaped-url "%28")) + (setf escaped-url (ppcre:regex-replace-all "\\)" escaped-url "%29")) + (setf escaped-url (ppcre:regex-replace-all ":" escaped-url "%3A")) + escaped-url)) + +(defun unescape-url (url) + (let ((unescaped-url url)) + (setf unescaped-url (ppcre:regex-replace-all "%25" unescaped-url "%")) + (setf unescaped-url (ppcre:regex-replace-all "%3F" unescaped-url "?")) + (setf unescaped-url (ppcre:regex-replace-all "%23" unescaped-url "#")) + (setf unescaped-url (ppcre:regex-replace-all "%2F" unescaped-url "/")) + (setf unescaped-url (ppcre:regex-replace-all "%27" unescaped-url "'")) + (setf unescaped-url (ppcre:regex-replace-all "%20" unescaped-url " ")) + (setf unescaped-url (ppcre:regex-replace-all "%28" unescaped-url "(")) + (setf unescaped-url (ppcre:regex-replace-all "%29" unescaped-url ")")) + (setf unescaped-url (ppcre:regex-replace-all "%3A" unescaped-url ":")) + unescaped-url)) + +(defun newlines-to-backslash-n (body) + (cl-ppcre:regex-replace-all #\Newline body "\\\\n")) diff --git a/entity/entity.lisp b/entity/entity.lisp new file mode 100644 index 0000000..92635b4 --- /dev/null +++ b/entity/entity.lisp @@ -0,0 +1,46 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defclass entity () + () + (:documentation "Superclass for all entity objects. An entity object +is one that represents a single tuple from a data source, like a SQL +table or LDAP record. In this case we're dealing with LDAP records.")) + +(defmacro with-entity-slots-to-list ((entity slot) &body body) + "Iterates over all the slots of `entity' and builds an alist based +on those slots. `slot' is the iterator." + `(remove-if #'null (mapcar (lambda (slot) + (when (slot-is-field-p slot) + ,@body)) + (map-slot-names ,entity)))) + +(defmethod attribute-value-list ((entity entity) &optional (keep-nulls nil)) + (with-entity-slots-to-list (entity slot) + (when (or keep-nulls + (and (not keep-nulls) + (not (null-or-empty-p (slot-value entity slot))))) + `(,slot . ,(slot-value entity slot))))) + +(defmethod get-slots-regex ((entity entity) regex) + (sort (remove-if-not (lambda (x) (match-it regex (symbol-name x))) + (map-slot-names entity)) + (lambda (x y) (string< (symbol-name x) (symbol-name y))))) + +(defmethod intersect-slots ((entity entity) slots) + (let ((intersect-slots ())) + (loop for class-slot in (map-slot-names entity) do + (let ((class-slot-string (parse-symbol class-slot))) + (loop for arg-slot in slots do + (let ((arg-slot-string (parse-symbol arg-slot))) + (when (string-equal class-slot-string arg-slot-string) + (push class-slot intersect-slots)))))) + (nreverse intersect-slots))) + +(defun slot-is-field-p (slot) + (let ((name (symbol-name slot))) + (and (equal name (ppcre:regex-replace "^\\*" name ""))))) diff --git a/entity/generics.lisp b/entity/generics.lisp new file mode 100644 index 0000000..613d6ca --- /dev/null +++ b/entity/generics.lisp @@ -0,0 +1,36 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defgeneric attribute-value-list (entity &optional keep-nulls) + (:documentation "Builds an alist of attribute/value pairs.")) + +(defgeneric get-slots-regex (entity regex) + (:documentation "Gets an alphabetically sorted list of `entity' +slots whose names match `regex'.")) + +(defgeneric intersect-slots (entity slots) + (:documentation "Since the built-in `intersect' function does not +take package name prefixes into account, and since `map-slot-names' +returns slot names prefixed with the package name, this method was +written to intersect lists ignoring package prefixes.")) + +(defgeneric get-cn (ldap-user) + (:documentation "Generates the CN of an `ldap-user'. `trivial-ldap' +does not fetch `cn' so we have to assemble it ourselves.")) + +(defgeneric get-user-dn (ldap-user ldap) + (:documentation "Generates the full DN of an `ldap-user'.")) + +(defgeneric modify-ldap-user (ldap-user ldap) + (:documentation "Writes the data in `ldap-user' to the LDAP +server.")) + +(defgeneric delete-ldap-user (ldap-user ldap) + (:documentation "Deletes an `ldap-user' from LDAP.")) + +(defgeneric add-ldap-user (ldap-user ldap) + (:documentation "Adds an `ldap-user' to LDAP.")) diff --git a/entity/ldap-user.lisp b/entity/ldap-user.lisp new file mode 100644 index 0000000..aa0d64c --- /dev/null +++ b/entity/ldap-user.lisp @@ -0,0 +1,74 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defclass ldap-user (entity) + ((givenname :initarg :givenname + :initform nil + :accessor givenname) + (sn :initarg :sn + :initform nil + :accessor sn) + (mail :initarg :mail + :initform nil + :accessor mail) + (postaladdress :initarg :postaladdress + :initform nil + :accessor postaladdress) + (postalcode :initarg :postalcode + :initform nil + :accessor postalcode) + (st :initarg :st + :initform nil + :accessor st) + (l :initarg :l + :initform nil + :accessor l) + (telephonenumber :initarg :telephonenumber + :initform nil + :accessor telephonenumber) + (mobile :initarg :mobile + :initform nil + :accessor mobile)) + (:documentation "A single inetOrgPerson entry from LDAP.")) + +(defmethod get-cn ((ldap-user ldap-user)) + (format nil "~a ~a" (givenname ldap-user) (sn ldap-user))) + +(defmethod get-user-dn ((ldap-user ldap-user) (ldap ldap)) + (format nil "cn=~a ~a,ou=people,~a" (givenname ldap-user) (sn ldap-user) (base-dn ldap))) + +(defmethod modify-ldap-user ((ldap-user ldap-user) (ldap ldap)) + (let* ((existing-user (get-ldap-user ldap (get-cn ldap-user))) + (existing-attrs (attribute-value-list existing-user t)) + (new-attrs (attribute-value-list ldap-user)) + (ldap-entry (ldap:new-entry (get-user-dn ldap-user ldap) :attrs existing-attrs)) + (change-attrs (remove-if #'null + (mapcar (lambda (attr) + (let ((new-attr (assoc (car attr) new-attrs))) + (cond ((and (null-or-empty-p (cdr attr)) + (not (null-or-empty-p (cdr new-attr)))) + `(ldap:add ,(car attr) ,(cdr new-attr))) + ((and (not (null-or-empty-p (cdr attr))) + (null-or-empty-p (cdr new-attr))) + `(ldap:delete ,(car attr) ,(cdr attr))) + ((and (not (null-or-empty-p (cdr attr))) + (not (null-or-empty-p (cdr new-attr))) + (not (string= (cdr attr) (cdr new-attr)))) + `(ldap:replace ,(car attr) ,(cdr new-attr)))))) + existing-attrs)))) + (ldap:modify (connection ldap) (get-user-dn ldap-user ldap) change-attrs))) + +(defmethod delete-ldap-user ((ldap-user ldap-user) (ldap ldap)) + (let* ((existing-user (get-ldap-user ldap (get-cn ldap-user))) + (existing-attrs (attribute-value-list existing-user)) + (ldap-entry (ldap:new-entry (get-user-dn ldap-user ldap) :attrs existing-attrs))) + (ldap:delete ldap-entry (connection ldap)))) + +(defmethod add-ldap-user ((ldap-user ldap-user) (ldap ldap)) + (let* ((new-attrs (attribute-value-list ldap-user)) + (new-entry (ldap:new-entry (get-user-dn ldap-user ldap) :attrs (add-to-list new-attrs '((objectclass . (inetorgperson))))))) + (ldap:add new-entry (connection ldap)))) diff --git a/file/file-utils.lisp b/file/file-utils.lisp new file mode 100644 index 0000000..20a61ee --- /dev/null +++ b/file/file-utils.lisp @@ -0,0 +1,112 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(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." + (compile-file filename) + (load filename)) + +(defun write-pid-file () + (shell-wrapper (format nil "echo ~a >~a/~a.pid" (sb-posix:getpid) (sb-posix:getenv "HOME") (string-downcase (package-name *package*))))) + +(defun file-to-list (infile) + "Reads `infile' and returns a list, where each atom is a single +line of the file. `infile' can be a string or a pathname +object." + (let ((infile-list ())) + (with-open-file (filehandle infile :if-does-not-exist nil) + (if (streamp filehandle) + (progn + (loop for line = (read-line filehandle nil) + while line do + (push line infile-list)) + (nreverse infile-list)) + nil)))) + +(defun parse-csv-line (line) + "Parses a single line of CSV input into a list of string fields." + (let ((quoted-string-mode nil) + (line-list ()) + (field-collector "")) + (loop for this-char across (ppcre:regex-replace-all #\Return line "") do + (cond ((equal this-char #\") + (setf quoted-string-mode (not quoted-string-mode))) + ((and (equal this-char #\,) (not quoted-string-mode)) + (push field-collector line-list) + (setf field-collector "")) + (t + (setf field-collector (format nil "~a~a" field-collector this-char))))) + ;; get the field after the last comma + (push field-collector line-list) + (nreverse line-list))) + +(defmacro dofile ((line filename) &body body) + "Wrapper for the common task of opening a file and reading it one +line at a time." + (let ((stream (gensym))) + `(with-open-file (,stream ,filename) + (loop for ,line = (read-line ,stream nil nil) + while ,line do ,@body)))) + +(defun mkdir (path) + (uffi:run-shell-command (format nil "mkdir -p ~a" path))) + +(defun copy-file (source destination) + "Copies file from `source' to `destination'. If the destination +directory does not exist, it will be created." + (when (and (file-exists-p source) + (file-p source) + (not (null-or-empty-p destination))) + (let ((destination-parts (nreverse (remove-if #'null-or-empty-p (ppcre:split "/" destination)))) + (destination-file "") + (destination-directory "")) + (setf destination-file (pop destination-parts)) + (loop for part in (nreverse destination-parts) do + (setf destination-directory (format nil "~a/~a" destination-directory part))) + (mkdir destination-directory) + (uffi:run-shell-command (format nil "cp '~a' '~a'" source destination))))) + +(defun purge-old-files (directory-path) + "Deletes everything out of a directory that is older than 8 hours +old." + (uffi:run-shell-command (format nil "find ~a/* -mmin 480 |xargs rm -rf" directory-path))) + +(defun purge-files-regex (directory-path regex) + "Deletes everything out of a directory whose name matches the +`regex'." + (uffi:run-shell-command (format nil "find ~a/* -regex '~a' |xargs rm -rf" directory-path regex))) + +(defun file-exists-p (file-path) + (equal (car (shell-wrapper (format nil "if test -f '~a'; then echo 0; else echo 1; fi" file-path))) "0")) + +(defun file-mtime (file-path) + (let ((output (car (shell-wrapper (format nil "ls --full-time '~a' |awk '{ print $6,$7 }' |awk -F. '{ print $1; }'" file-path))))) + (if (not (match-it "^\\d\\d\\d\\d-\\d\\d-\\d\\d \\d\\d:\\d\\d:\\d\\d$" output)) + (error 'handled-error :text (format nil "Error in `file-mtime': ~a" output)) + output))) + +(defun directory-p (absolute-path) + (if (car (shell-wrapper (format nil "file '~a' |grep 'directory'" absolute-path))) t nil)) + +(defun symlink-p (absolute-path) + (if (car (shell-wrapper (format nil "file '~a' |grep 'symbolic link'" absolute-path))) t nil)) + +(defun file-p (absolute-path) + (if (or (directory-p absolute-path) (symlink-p absolute-path)) nil t)) + +(defun path-contained-p (root-path path-to-check) + "Returns `(,root-path) if `path-to-check' is contained within `root-path', +`nil' otherwise." + (match-it root-path path-to-check)) + +(defun find-files (working-dir base-dir pattern) + (shell-wrapper (format nil + "pushd ~a >/dev/null 2>&1 ; find ~a -iname '~a' ; popd >/dev/null 2>&1" + working-dir + base-dir + pattern))) diff --git a/json/json-utils.lisp b/json/json-utils.lisp new file mode 100644 index 0000000..6467cbb --- /dev/null +++ b/json/json-utils.lisp @@ -0,0 +1,76 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defun json-to-object (object-type json-obj) + (remove-if-not (lambda (x) + (let ((found-value nil)) + (loop for slot in (map-slot-names x) do + (when (slot-value x slot) + (setf found-value t))) + found-value)) + (mapcar (lambda (obj) + (let ((object (make-instance object-type))) + (loop for slot in (map-slot-names object) do + (let ((symb (intern (symbol-name slot) :keyword))) + (setf (slot-value object slot) + (cdr (find-if (lambda (param) (eq (car param) symb)) obj))))) + 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) + (eq (class-name superclass) 'base-service)) + (sb-mop:class-direct-superclasses (class-of object))))))) + (list-of-lists-p (object) + (and (listp object) + (find-if (lambda (y) (not (null y))) + (mapcar (lambda (x) + (listp x)) + object)))) + (list-of-objects-p (object) + (and (listp object) + (find-if (lambda (y) (not (null y))) + (mapcar (lambda (x) + (objectp x)) + object)))) + (map-slots (object) + (remove-if 'null (mapcar (lambda (slot) + (let ((symb (intern (symbol-name slot) :keyword)) + (value (slot-value object slot))) + (when value + (cons symb (cond ((or (equal value (json:json-bool t)) + (equal value (json:json-bool nil))) + value) + ((list-of-lists-p value) + (listify value)) + ((list-of-objects-p value) + (if explicit-encoder-p + (error "Can't do list-of-objects with the explicit encoder.") + (listify value))) + ((listp value) + (map 'vector #'identity value)) + ((objectp value) + (if explicit-encoder-p + (cons :object (map-slots value)) + (map-slots value))) + (t + value)))))) + (map-slot-names object)))) + (listify (list-of-objects) + (mapcar (lambda (object) + (map-slots object)) + list-of-objects))) + (let ((listobj (listify list-of-objects))) + (reduce-to-comma-separated-string (mapcar (lambda (alist) + (if explicit-encoder-p + (json:with-explicit-encoder + (json:encode-json-to-string (cons :object alist))) + (json:encode-json-alist-to-string alist))) + listobj))))) diff --git a/ldap/generics.lisp b/ldap/generics.lisp new file mode 100644 index 0000000..e3b0956 --- /dev/null +++ b/ldap/generics.lisp @@ -0,0 +1,20 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defgeneric disconnect (ldap) + (:documentation "")) + +(defgeneric get-ldap-users (ldap search-base) + (:documentation "Calls `with-ldap-iterate' to iterate over all LDAP +users returned with the search `search-base', wrapping each entry in +an `ldap-user' object. Returns a list of these objects. `ldap' is a +free variable that must be present for `with-ldap-iterate'.")) + +(defgeneric get-ldap-user (ldap cn) + (:documentation "Calls `with-ldap-users' with a search filter and +returns the first entry.")) + diff --git a/ldap/ldap.lisp b/ldap/ldap.lisp new file mode 100644 index 0000000..8a9f0ad --- /dev/null +++ b/ldap/ldap.lisp @@ -0,0 +1,132 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defclass ldap () + ((ldap-host :initarg :ldap-host + :initform nil + :accessor ldap-host) + (sslflag :initarg :sslflag + :initform nil + :accessor sslflag) + (username :initarg :username + :initform nil + :accessor username) + (password :initarg :password + :initform nil + :accessor password) + (base-dn :initarg :base-dn + :initform nil + :accessor base-dn) + (debug-mode :initarg :debug-mode + :initform nil + :accessor debug-mode) + (config :initarg :config + :initform nil + :accessor config) + (connection :initarg :connection + :initform nil + :accessor connection)) + (:documentation "Used to provide an object-oriented interface to the +LDAP options in the webapp config file.")) + +(defmethod initialize-instance :after ((ldap ldap) &key config) + "Parses the LDAP config from the options.lisp file into a new `ldap' +object." + (let ((conf (car config))) + (setf (ldap-host ldap) (getf conf :ldap-host)) + (setf (sslflag ldap) (getf conf :sslflag)) + (setf (username ldap) (getf conf :username)) + (setf (password ldap) (getf conf :password)) + (setf (base-dn ldap) (getf conf :base-dn)) + (setf (debug-mode ldap) (getf conf :debug-mode)) + (setf (config ldap) conf) + (setf (connection ldap) (apply #'ldap:new-ldap + `(:host ,(ldap-host ldap) + :sslflag ,(sslflag ldap) + :user ,(username ldap) + :pass ,(password ldap) + :base ,(base-dn ldap) + :reuse-connection ,'ldap:rebind + :debug ,(debug-mode ldap)))))) + +(defmethod disconnect ((ldap ldap)) + (ldap:unbind (connection ldap))) + +(defmacro with-ldap ((ldap-name) &body body) + "Convenience macro for instantiating an `ldap' instance and using it +in an `unwind-protect'." + `(let ((,ldap-name (make-instance 'ldap :config `(,(ldap *webapp*))))) + (unwind-protect + (progn + ,@body) + (disconnect ,ldap-name)))) + +(defmacro with-ldap-iterate ((ldap-entry search-base) &body body) + "Runs an ldapsearch and executes `body' over each result. The +variable `ldap-entry' is bound to the iterator of the +`ldap:dosearch'. You may use it in your `body'." + `(progn + (ldap:bind (connection ldap)) + (ldap:dosearch (,ldap-entry (ldap:search (connection ldap) ,search-base)) + ,@body))) + +(defmethod get-ldap-users ((ldap ldap) search-base) + (let ((ldap-users ())) + (with-ldap-iterate (ldap-entry search-base) + (let ((ldap-user (populate-ldap-user ldap-entry))) + (push ldap-user ldap-users))) + (nreverse ldap-users))) + +(defmethod search-ldap-users ((ldap ldap) search-terms) + (get-ldap-users ldap (format nil + "(&(objectclass=inetOrgPerson)(!(cn=Manager))(!(uid=root))(!(uid=nobody))~a)" + (build-search-base search-terms)))) + +(defmethod get-ldap-user ((ldap ldap) cn) + (car (search-ldap-users ldap `((:cn ,cn))))) + +(defun check-ldap-password (config dn password) + "Uses ldapwhoami to check the userPassword of a given +binddn. Returns `t' if the password is valid, `nil' otherwise." + (= 0 (uffi:run-shell-command (format nil + "ldapwhoami -x -H ~a://~a -D 'cn=~a,~a' -w ~a" + (if (getf config :sslflag) "ldaps" "ldap") + (getf config :ldap-host) + dn + (getf config :base-dn) + password)))) + +(defun populate-ldap-user (ldap-entry) + "Copies the data from a single LDAP entry as produced by +`with-ldap-iterate' into a new `ldap-user' object." + (let* ((ldap-user (make-instance 'ldap-user)) + (valid-attribute-names (intersect-slots ldap-user (mapcar (lambda (pair) + (car pair)) + (ldap:attrs ldap-entry))))) + (loop for name-value in (ldap:attrs ldap-entry) do + (let ((name (intern (symbol-name (car name-value)) (find-package (string-upcase "ldapadmin")))) + (value (cadr name-value))) + (when (find name + valid-attribute-names + :test (lambda (x y) + (string-equal (symbol-name x) (symbol-name y)))) + (setf (slot-value ldap-user name) value)))) + ldap-user)) + +(defun build-search-base (search-terms) + "Converts a plist like `((:givenname \"Carlos\") (:sn +\"Konstanski\"))' to an LDAP search base fragment like +\"(givenname=Carlos)(sn=Konstanski)\". Any `nil' or empty-string +values are ignored." + (reduce-to-char-separated-string (mapcar (lambda (term) + (when (not (null-or-empty-p (cadr term))) + (format nil + "(~a=~a)" + (symbol-name (car term)) + (cadr term)))) + search-terms) + "")) diff --git a/ldapadmin.asd b/ldapadmin.asd new file mode 100644 index 0000000..9202bbb --- /dev/null +++ b/ldapadmin.asd @@ -0,0 +1,85 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:cl) + +;; ========================================================================== ;; + +(defpackage #:ldapadmin-system (:use #:cl #:asdf)) +(in-package #:ldapadmin-system) + +;; ========================================================================== ;; + +(defmacro do-defsystem (&key name version maintainer author description long-description depends-on components) + `(defsystem ,name + :name ,name + :version ,version + :maintainer ,maintainer + :author ,author + :description ,description + :long-description ,long-description + :depends-on ,(eval depends-on) + :components ,components)) + +;; ========================================================================== ;; + +(defparameter *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>" + :author "Carlos Konstanski <ckonstanski@pippiandcarlos.com>" + :description "ldapadmin" + :long-description "ldapadmin is a web application written in Common Lisp, based on the Hunchentoot web server. Its purpose is to be an administrative frontend to an openldap server." + :depends-on *asdf-packages* + :components ((:module core + :components ((:file "coreutils") + (:file "httputils" :depends-on ("coreutils")) + (:file "html" :depends-on ("coreutils")))) + (:module condition + :depends-on (core) + :components ((:file "condition"))) + (:module file + :depends-on (condition) + :components ((:file "file-utils"))) + (:module json + :depends-on (condition) + :components ((:file "json-utils"))) + (:module ldap + :depends-on (json) + :components ((:file "generics") + (:file "ldap" :depends-on ("generics")))) + (:module entity + :depends-on (ldap) + :components ((:file "generics") + (:file "entity" :depends-on ("generics")) + (:file "ldap-user" :depends-on ("entity")))) + (:module service + :depends-on (entity) + :components ((:file "base-service") + (:file "rest-service" :depends-on ("base-service")) + (:file "auth-service" :depends-on ("rest-service")) + (:file "generic-form" :depends-on ("rest-service")) + (:file "menu" :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")))) + (:module webapps + :depends-on (service) + :components ((:file "webapp-loader") + (:module ldapadmin + :depends-on ("webapp-loader") + :components ((:file "site") + (:file "pages-auth" :depends-on ("site")))))))) diff --git a/service/auth-service.lisp b/service/auth-service.lisp new file mode 100644 index 0000000..0d0e8a0 --- /dev/null +++ b/service/auth-service.lisp @@ -0,0 +1,21 @@ +;;; -*- 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 form-class) &body body) + `(let ((,instance (make-instance ',form-class))) + (when (null (errormsg ,instance)) + ,@body) + (objects-to-json `(,,instance)))) diff --git a/service/base-service.lisp b/service/base-service.lisp new file mode 100644 index 0000000..0f65b82 --- /dev/null +++ b/service/base-service.lisp @@ -0,0 +1,10 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defclass base-service () + () + (:documentation "")) diff --git a/service/generic-form.lisp b/service/generic-form.lisp new file mode 100644 index 0000000..1fb9867 --- /dev/null +++ b/service/generic-form.lisp @@ -0,0 +1,45 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; + +(defclass generic-form (rest-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) + (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) + (field-type :initarg :field-type + :initform nil + :accessor field-type)) + (: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)))) diff --git a/service/home.lisp b/service/home.lisp new file mode 100644 index 0000000..488b86f --- /dev/null +++ b/service/home.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 (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.lisp b/service/inetorg-add.lisp new file mode 100644 index 0000000..a55f72d --- /dev/null +++ b/service/inetorg-add.lisp @@ -0,0 +1,54 @@ +;;; -*- 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-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) + (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))) + (add-ldap-user ldap-user ldap) + (setf (message instance) "InetOrg entry created successfully."))))) diff --git a/service/inetorg-delete.lisp b/service/inetorg-delete.lisp new file mode 100644 index 0000000..d01db5d --- /dev/null +++ b/service/inetorg-delete.lisp @@ -0,0 +1,34 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:ldapadmin) + +;; ========================================================================== ;; +;; inetorg-delete + +(defclass inetorg-delete (auth-service) + ((cn :initarg :cn + :initform nil + :accessor cn) + (location-p :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defun inetorg-delete-json (cn) + (with-auth (instance inetorg-delete) + (setf (cn instance) cn))) + +;; ========================================================================== ;; +;; inetorg-delete-submit + +(defclass inetorg-delete-submit (auth-service) + () + (:documentation "")) + +(defun inetorg-delete-submit-json (cn) + (with-auth (instance inetorg-delete-submit) + (with-ldap (ldap) + (let ((ldap-user (get-ldap-user ldap cn))) + (delete-ldap-user ldap-user ldap) + (setf (message instance) "InetOrg entry deleted successfully."))))) diff --git a/service/inetorg-modify.lisp b/service/inetorg-modify.lisp new file mode 100644 index 0000000..e1f5577 --- /dev/null +++ b/service/inetorg-modify.lisp @@ -0,0 +1,58 @@ +;;; -*- 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-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) + (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))) + (modify-ldap-user ldap-user ldap) + (setf (message instance) "InetOrg entry saved successfully."))))) diff --git a/service/inetorg-view.lisp b/service/inetorg-view.lisp new file mode 100644 index 0000000..08e7914 --- /dev/null +++ b/service/inetorg-view.lisp @@ -0,0 +1,70 @@ +;;; -*- 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-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) + (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))) + (lambda (x y) (string< (get-cn x) (get-cn y)))))))) diff --git a/service/login-authenticate.lisp b/service/login-authenticate.lisp new file mode 100644 index 0000000..5b657a0 --- /dev/null +++ b/service/login-authenticate.lisp @@ -0,0 +1,24 @@ +;;; -*- 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.lisp b/service/login.lisp new file mode 100644 index 0000000..6d005d7 --- /dev/null +++ b/service/login.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 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.lisp b/service/logout.lisp new file mode 100644 index 0000000..219e7e2 --- /dev/null +++ b/service/logout.lisp @@ -0,0 +1,19 @@ +;;; -*- 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.lisp new file mode 100644 index 0000000..069cb11 --- /dev/null +++ b/service/menu.lisp @@ -0,0 +1,57 @@ +;;; -*- 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" :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") + (:id "a_menu_inetorg_view" :label "View InetOrg Entries" :url "/inetorg/view" :handler "/inetorg/view" :permission "admin") + (:id "a_menu_inetorg_add" :label "Add InetOrg Entry" :url "/inetorg/add" :handler "/inetorg/add" :permission "admin"))) + +(defclass menuitem () + ((id :initarg :id + :initform nil + :accessor id) + (label :initarg :label + :initform nil + :accessor label) + (url :initarg :url + :initform nil + :accessor url) + (handler :initarg :handler + :initform nil + :accessor handler) + (permissions :initarg :permissions + :initform nil + :accessor permissions) + (children :initarg :children + :initform nil + :accessor children)) + (:documentation "")) + +(defclass menu (base-service) + ((menuitems :initarg :menuitems + :initform nil + :accessor menuitems)) + (:documentation "")) + +(defmethod initialize-instance :after ((menu menu) &key) + (setf (menuitems menu) + (mapcar (lambda (x) + (make-instance 'menuitem + :id (getf x :id) + :label (getf x :label) + :url (getf x :url) + :handler (getf x :handler))) + (remove-if 'null (mapcar (lambda (x) + (when (find-if (lambda (y) + (string= (getf x :permission) y)) + `("t" ,(session-value :permissions))) + x)) + *menu-config*))))) + +(defun menu-json () + (objects-to-json `(,(make-instance 'menu)))) diff --git a/service/rest-service.lisp b/service/rest-service.lisp new file mode 100644 index 0000000..693463f --- /dev/null +++ b/service/rest-service.lisp @@ -0,0 +1,33 @@ +;;; -*- 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) + (errormsg :initarg :errormsg + :initform nil + :accessor errormsg) + (message :initarg :message + :initform nil + :accessor message)) + (:documentation "")) + +(defmethod initialize-instance :after ((rest-service rest-service) &key) + (when (and (location-p rest-service) (null (location rest-service))) + (setf (location rest-service) (type-to-path rest-service)) + (setf (session-value :location) (location rest-service)))) + +(defun location-json () + (let ((location (if (session-value :location) (session-value :location) "/home"))) + (format nil "{\"location\":\"~a\"}" location))) + +(defun type-to-path (rest-type) + (concatenate 'string "/" (ppcre:regex-replace "-" (string-downcase (type-of rest-type)) "/"))) 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))))) |
