diff options
Diffstat (limited to 'lisp')
30 files changed, 2385 insertions, 0 deletions
diff --git a/lisp/condition/condition.lisp b/lisp/condition/condition.lisp new file mode 100644 index 0000000..391b5c7 --- /dev/null +++ b/lisp/condition/condition.lisp @@ -0,0 +1,7 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(define-condition unauth-error (error) + ((text :initarg :text :reader text))) diff --git a/lisp/core/coreutils.lisp b/lisp/core/coreutils.lisp new file mode 100644 index 0000000..8e74766 --- /dev/null +++ b/lisp/core/coreutils.lisp @@ -0,0 +1,156 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(defpackage :dns-admin + (:use :cl :hunchentoot :cl-log) + (:export :dns-admin)) + +(in-package #:dns-admin) + +(require :sb-introspect) + +(defparameter *server-root* (namestring (asdf:system-relative-pathname (intern (package-name #.*package*)) "./")) + "The location of the web server root on the filesystem.") + +(defvar *sendmail-debug* nil + "If non-`nil', email will be sent to the address contained in this +variable instead of the recipient supplied in the call to +`sendmail'.") + +;; needed for html.lisp +(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))))) + +(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))) + +(defmacro format-list (format-string &body body) + `(format nil ,format-string ,@body)) + +(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 logger (output) + "Logs output to the cl-log log file. Also writes a timestamp to +standard output, which is very useful for correlating the log file and +the dribble file." + (let ((timestamp (net.telent.date:universal-time-to-rfc2822-date (get-universal-time)))) + (format t "LOG TIMESTAMP: ~a~%" timestamp) + (log-message :info (format nil "~a: ~a" timestamp 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))) + +(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 pretty-print (raw-string &optional textbox-p) + "If `raw-string' is `nil', ` ' is returned. But if `textbox-p' +is `t', it returns an empty string instead of ` '." + (let ((trimmed-string (if raw-string (string-trim '(#\Space #\Tab) raw-string) nil))) + (if (and trimmed-string (> (length trimmed-string) 0)) + (format nil "~a" trimmed-string) + (if textbox-p "" " ")))) + +#+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 trim-last-char (mystring) + (if (null-or-empty-p mystring) + "" + (subseq mystring 0 (- (length mystring) 1)))) + +(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 "~a" real-rep) :junk-allowed t)) + (format nil + (format nil "~~,~af" places) + (coerce real-rep 'long-float))))) + +(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)) + (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)) + +(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))) + +(defmacro sendmail (mail-server from to subject message &key display-name reply-to html-message authentication attachments) + "Wrapper around `cl-smtp:send-email'. `attachments' needs to be a +list of `cl-smtp:attachment' objects if non-nil." + `(cl-smtp:send-email ,mail-server + ,from + ,(if *sendmail-debug* *sendmail-debug* to) + ,(if *sendmail-debug* (format nil "DEBUG ~a" subject) subject) + ,message + ,@(when display-name `(:display-name ,display-name)) + ,@(when reply-to `(:reply-to ,reply-to)) + ,@(when html-message `(:html-message ,html-message)) + ,@(when authentication `(:authentication ,authentication)) + ,@(when attachments `(:attachments ,attachments)))) + +(defun report-error (message) + (if *catch-errors-p* + (logger message) + (error message))) diff --git a/lisp/core/html.lisp b/lisp/core/html.lisp new file mode 100644 index 0000000..dc83e18 --- /dev/null +++ b/lisp/core/html.lisp @@ -0,0 +1,270 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +;; Lifted directly from araneida. + +(in-package :dns-admin) + +;;; 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 + ((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 " -->~%"))) + ((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))))))) diff --git a/lisp/core/httputils.lisp b/lisp/core/httputils.lisp new file mode 100644 index 0000000..f131511 --- /dev/null +++ b/lisp/core/httputils.lisp @@ -0,0 +1,74 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defmacro with-cookie-jar (&body body) + ;; VZWQP-573: chunga cannot handle the infoblox cookies + ;;`(let ((cookie-jar (make-instance 'drakma:cookie-jar))) + `(let (cookie-jar) + ,@body)) + +(defun drakma-request (url + cookie-jar + &key + (protocol :HTTP/1.1) + (method :get) + (content-type "application/x-www-form-urlencoded") + (user-agent :firefox) + (content nil) + (parameters nil) + (redirect t) + (auto-referer t) + (additional-headers nil) + (connection-timeout 120) + (verify nil) + (proxy nil) + (proxy-basic-authorization nil) + (basic-authorization nil)) + (drakma:http-request url + :cookie-jar cookie-jar + :protocol protocol + :method method + :content-type content-type + :parameters parameters + :content content + :user-agent user-agent + :redirect redirect + :auto-referer auto-referer + :connection-timeout connection-timeout + :additional-headers additional-headers + :verify verify + :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/lisp/dns-admin.asd b/lisp/dns-admin.asd new file mode 100644 index 0000000..15f783b --- /dev/null +++ b/lisp/dns-admin.asd @@ -0,0 +1,65 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:cl) + +(defpackage #:dns-admin-system (:use #:cl #:asdf)) +(in-package #:dns-admin-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 cl-smtp)) + +(loop for pkg in *asdf-packages* do + (ql:quickload (symbol-name pkg))) + +(do-defsystem :name "dns-admin" + :version "1" + :maintainer "Carlos Konstanski <carlos.konstanski@verizonwireless.com>" + :author "Carlos Konstanski <carlos.konstanski@verizonwireless.com>" + :description "dns-admin" + :long-description "dns-admin is a web application written in Common Lisp based on the Hunchentoot web server. The client-side code is written in ClojureScript. Its purpose is to be a DNS administration tool." + :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 (core condition) + :components ((:file "file-utils"))) + (:module json + :depends-on (condition) + :components ((:file "json-utils"))) + (:module dns + :depends-on (json) + :components ((:file "dns"))) + (:module entity + :depends-on (dns) + :components ((:file "generics") + (:file "entity" :depends-on ("generics")) + (:file "dns-record" :depends-on ("entity")))) + (:module service + :depends-on (entity) + :components ((:file "base-service") + (:file "rest-service" :depends-on ("base-service")) + (:file "generic-form" :depends-on ("rest-service")) + (:file "dns-service" :depends-on ("rest-service")))) + (:module webapps + :depends-on (service) + :components ((:file "generics") + (:file "webapp-loader" :depends-on ("generics")) + (:module dns-admin + :depends-on ("webapp-loader") + :components ((:file "site"))))))) diff --git a/lisp/dns/dns.lisp b/lisp/dns/dns.lisp new file mode 100644 index 0000000..f0dfeda --- /dev/null +++ b/lisp/dns/dns.lisp @@ -0,0 +1,53 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass dns () + ((label :initarg :label + :initform nil + :accessor label) + (backend-type :initarg :backend-type + :initform nil + :accessor backend-type)) + (:documentation "")) + +(defclass dns-infoblox (dns) + ((url :initarg :url + :initform nil + :accessor url) + (username :initarg :username + :initform nil + :accessor username) + (password :initarg :password + :initform nil + :accessor password)) + (:documentation "Used to provide an object-oriented interface to the +DNS options in the webapp config file.")) + +(defclass dns-nsupdate (dns) + ((hostname :initarg :hostname + :initform nil + :accessor hostname) + (forward-zone :initarg :forward-zone + :initform nil + :accessor forward-zone) + (reverse-zone :initarg :reverse-zone + :initform nil + :accessor reverse-zone) + (dnssec-key :initarg :dnssec-key + :initform nil + :accessor dnssec-key + :documentation "This is a filepath, not the actual contents of the key.")) + (:documentation "")) + +(defmethod initialize-instance :after ((dns dns) &key config) + (loop for slot in (map-slot-names dns) do + (setf (slot-value dns slot) (getf config (intern (symbol-name slot) :keyword))))) + +(defmacro with-dns ((dns-name) &body body) + (let ((package (package-name #.*package*))) + `(let* ((config (dns *webapp*)) + (dns-class (intern (string-upcase (concatenate 'string "dns-" (getf config :backend-type))) (find-package ,package))) + (,dns-name (make-instance dns-class :config config))) + ,@body))) diff --git a/lisp/entity/dns-record.lisp b/lisp/entity/dns-record.lisp new file mode 100644 index 0000000..7fa2f4a --- /dev/null +++ b/lisp/entity/dns-record.lisp @@ -0,0 +1,168 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass dns-record (entity) + ((*recordtype :initarg :*recordtype + :initform nil + :accessor *recordtype) + (name :initarg :name + :initform nil + :accessor name)) + (:documentation "Base class for DNS records.")) + +(defclass dns-record-infoblox (dns-record) + ((--ref :initarg :--ref + :initform nil + :accessor --ref) + (ttl :initarg :ttl + :initform nil + :accessor ttl)) + (:documentation "Base class for DNS records of type infoblox.")) + +(defclass dns-record-infoblox-a (dns-record-infoblox) + ((ipv-4-addr :initarg :ipv-4-addr + :initform nil + :accessor ipv-4-addr)) + (:documentation "DNS A record of type infoblox.")) + +(defclass dns-record-infoblox-aaaa (dns-record-infoblox) + ((ipv-6-addr :initarg :ipv-6-addr + :initform nil + :accessor ipv-6-addr)) + (:documentation "DNS AAAA record of type infoblox.")) + +(defclass dns-record-infoblox-cname (dns-record-infoblox) + ((canonical :initarg :canonical + :initform nil + :accessor canonical)) + (:documentation "DNS CNAME record of type infoblox.")) + +(defclass dns-record-infoblox-ptr (dns-record-infoblox) + ((ptrdname :initarg :ptrdname + :initform nil + :accessor ptrdname) + (ipv-4-addr :initarg :ipv-4-addr + :initform nil + :accessor ipv-4-addr)) + (:documentation "DNS PTR record of type infoblox.")) + +(defun sanitize-dns-filter-param (param) + (cond ((intersection `(,param) '("" "null" "undefined") :test 'string=) nil) + (t param))) + +(defmethod slot-to-param ((dns-record dns-record-infoblox) slot) + (cond ((eq slot '*recordtype) 'recordtype) + ((eq slot '--ref) 'ref) + ((eq slot 'ipv-4-addr) 'ipv4addr) + ((eq slot 'ipv-6-addr) 'ipv6addr) + (t slot))) + +(defmethod param-to-slot ((dns-record dns-record-infoblox) param) + (cond ((eq param 'recordtype) '*recordtype) + ((eq param 'ref) '--ref) + ((eq param 'ipv4addr) 'ipv-4-addr) + ((eq param 'ipv6addr) 'ipv-6-addr) + (t param))) + +(defmethod make-dns-record ((dns dns) recordtype) + (let* ((package (package-name #.*package*)) + (dns-record-class (intern (string-upcase (format nil "dns-record-~a-~a" (backend-type dns) recordtype)) (find-package package)))) + (make-instance dns-record-class :*recordtype recordtype))) + +(defmethod intersect-dns-record-function-args ((dns-record dns-record) func-symbol) + (intersection (sb-introspect:function-lambda-list func-symbol) + (mapcar (lambda (slot) + (slot-to-param dns-record slot)) + (map-slot-names dns-record)))) + +(defmethod search-filter-satisfied-p ((dns-record dns-record) rec) + (not (position nil (mapcar (lambda (slot) + (let ((slot-has-value-p (and (slot-value dns-record slot)))) + (or (not slot-has-value-p) + (and slot-has-value-p + (match-it (slot-value dns-record slot) (slot-value rec slot)))))) + (remove-if 'null (mapcar (lambda (s) + (when (slot-is-field-p s) s)) + (map-slot-names dns-record))))))) + +(defmacro define-dns-impl ((method-name action) &body macro-body) + ;; dig @127.0.0.1 +dnssec ckons.org AXFR + (let ((endpoint (gensym))) + `(progn + (defgeneric ,method-name (dns dns-record-infoblox)) + (defmethod ,method-name ((dns dns) (dns-record dns-record-infoblox)) + (let ((,endpoint (format nil + "~a/~a?_return_as_object=1~a" + (url dns) + (if (intersection `(,,action) '(:get :post)) + (format nil "record:~a" (*recordtype dns-record)) + (--ref dns-record)) + (if (and (eq (type-of dns-record) 'dns-record-infoblox-ptr) + (not (eq ,action :delete))) + "&_return_fields=name,ptrdname,ipv4addr,ipv6addr" + ""))) + (parameters (if (slot-value dns-record 'ttl) + `(("use_ttl" . t) ("ttl" . ,(ttl dns-record))) + (remove-if 'null (mapcar (lambda (slot) + (when (and (not (eq ,action :get)) + (not (eq slot '--ref)) + (slot-is-field-p slot) + (slot-value dns-record slot)) + `(,(string-downcase (symbol-name (slot-to-param dns-record slot))) . ,(slot-value dns-record slot)))) + (map-slot-names dns-record)))))) + (when (not (eq ,action :get)) + (setf parameters (alist-to-json parameters))) + (multiple-value-bind (body status-code headers uri stream must-close reason) + (apply #'drakma-request `(,,endpoint + nil + :method ,,action + ,@(when (not (eq ,action :get)) `(:content-type "application/json")) + ,@(if (eq ,action :get) + `(:parameters ,parameters) + `(:content ,parameters)) + :basic-authorization (,(session-value :username) ,(session-value :pwd)))) + (declare (ignore headers uri stream must-close reason)) + (cond ((or (= status-code 401) (= status-code 403)) + (hunchentoot:require-authorization (name *webapp*))) + ((< status-code 300) + ,@macro-body) + (t + (format nil "Error response from infoblox.~%Method = [~a]~%Endpoint = [~a]~%Parameters = [~a]~%Response = [~a]" ',method-name ,endpoint parameters (flexi-streams:octets-to-string body :external-format :utf-8)))))))))) + +(defmethod get-dns-records ((dns dns) recordtype ref name ipv4addr ipv6addr canonical ptrdname) + (declare (special recordtype ref name ipv4addr ipv6addr canonical ptrdname)) + (let ((dns-record (make-dns-record dns recordtype))) + (loop for param in (intersect-dns-record-function-args dns-record 'get-dns-records) do + (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param)))) + (get-dns-records-impl dns dns-record))) + +(define-dns-impl (get-dns-records-impl :get) + (remove-if 'null (mapcar (lambda (rec) + (when (search-filter-satisfied-p dns-record rec) rec)) + (json-to-object (type-of dns-record) (cdar (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))))))) + +(defmethod add-dns-record ((dns dns) (dns-record dns-record)) + (add-dns-record-impl dns dns-record)) + +(define-dns-impl (add-dns-record-impl :post) + (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))) + +(defmethod modify-dns-record ((dns dns) (dns-record dns-record)) + (modify-dns-record-impl dns dns-record)) + +(define-dns-impl (modify-dns-record-impl :put) + (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))) + +(defmethod modify-dns-record-ttl ((dns dns) (dns-record dns-record)) + (modify-dns-record-ttl-impl dns dns-record)) + +(define-dns-impl (modify-dns-record-ttl-impl :put) + (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))) + +(defmethod delete-dns-record ((dns dns) (dns-record dns-record)) + (delete-dns-record-impl dns dns-record)) + +(define-dns-impl (delete-dns-record-impl :delete) + (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))) diff --git a/lisp/entity/entity.lisp b/lisp/entity/entity.lisp new file mode 100644 index 0000000..cf342cf --- /dev/null +++ b/lisp/entity/entity.lisp @@ -0,0 +1,44 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(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 DNS record.")) + +(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 (x) + (when (slot-is-field-p x) + ,@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/lisp/entity/generics.lisp b/lisp/entity/generics.lisp new file mode 100644 index 0000000..d4929d3 --- /dev/null +++ b/lisp/entity/generics.lisp @@ -0,0 +1,51 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(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 slot-to-param (dns-record-infoblox slot) + (:documentation "")) + +(defgeneric param-to-slot (dns-record-infoblox param) + (:documentation "")) + +(defgeneric make-dns-record (dns recordtype) + (:documentation "")) + +(defgeneric intersect-dns-record-function-args (dns-record func-symbol) + (:documentation "")) + +(defgeneric intersect-dns-record-function-args (dns-record func-symbol) + (:documentation "")) + +(defgeneric search-filter-satisfied-p (dns-record rec) + (:documentation "")) + +(defgeneric get-dns-records (dns recordtype ref name ipv4addr ipv6addr canonical ptrdname) + + (:documentation "")) + +(defgeneric add-dns-record (dns dns-record) + (:documentation "")) + +(defgeneric modify-dns-record (dns dns-record) + (:documentation "")) + +(defgeneric modify-dns-record-ttl (dns dns-record) + (:documentation "")) + +(defgeneric delete-dns-record (dns dns-record) + (:documentation "")) diff --git a/lisp/file/file-utils.lisp b/lisp/file/file-utils.lisp new file mode 100644 index 0000000..1d463fd --- /dev/null +++ b/lisp/file/file-utils.lisp @@ -0,0 +1,31 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(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 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)))) + +(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)))) diff --git a/lisp/json/json-utils.lisp b/lisp/json/json-utils.lisp new file mode 100644 index 0000000..03f2748 --- /dev/null +++ b/lisp/json/json-utils.lisp @@ -0,0 +1,75 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defun alist-to-json (alist &key explicit-encoder-p) + (if explicit-encoder-p + (json:with-explicit-encoder + (json:encode-json-to-string (cons :object alist))) + (json:encode-json-alist-to-string alist))) + +(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 &key explicit-encoder-p) + (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) + (alist-to-json alist :explicit-encoder-p explicit-encoder-p)) + listobj))))) diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp new file mode 100644 index 0000000..3f945cf --- /dev/null +++ b/lisp/service/base-service.lisp @@ -0,0 +1,8 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass base-service () + () + (:documentation "")) diff --git a/lisp/service/dns-service.lisp b/lisp/service/dns-service.lisp new file mode 100644 index 0000000..5783574 --- /dev/null +++ b/lisp/service/dns-service.lisp @@ -0,0 +1,223 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass dns-service (rest-service) + ((title :initarg :title + :initform nil + :accessor title) + (form :initarg :form + :initform nil + :accessor form)) + (:documentation "")) + +(defclass dns-search-service (dns-service) + ((location-p :initarg :location-p + :initform nil + :accessor location-p) + (form :initarg :form + :initform nil + :accessor form) + (results :initarg :results + :initform nil + :accessor results)) + (:documentation "")) + +(defclass dns-login-service (dns-search-service) + () + (:documentation "")) + +(defclass dns-headers-service (rest-service) + ((location-p :initarg :location-p + :initform nil + :accessor location-p) + (headers :initarg :headers + :initform nil + :accessor headers)) + (:documentation "")) + +(defclass dns-add-service (dns-search-service) + () + (:documentation "")) + +(defclass dns-modify-service (dns-search-service) + () + (:documentation "")) + +(defclass dns-ttl-service (dns-search-service) + () + (:documentation "")) + +(defun make-dns-form (form-name action button-label &key required-p recordtype ref name ipv4addr ipv6addr canonical ptrdname) + (make-form form-name + nil + required-p + `((:name "ref" :label "Ref" :field-type ,(if required-p "hidden" "text") ,@(when (sanitize-dns-filter-param ref) `(:value ,ref)) ,@(when required-p '(:required "required"))) + (:name "name" :label ,(format nil "Name~a" (if required-p " *" "")) :field-type "text" ,@(when (sanitize-dns-filter-param name) `(:value ,name)) ,@(when required-p '(:required "required"))) + ,@(cond ((string= recordtype "a") + `((:name "ipv4addr" :label ,(format nil "IPv4 Address~a" (if required-p " *" "")) :field-type "text" ,@(when ipv4addr `(:value ,ipv4addr)) ,@(when required-p '(:required "required"))))) + ((string= recordtype "aaaa") + `((:name "ipv6addr" :label ,(format nil "IPv6 Address~a" (if required-p " *" "")) :field-type "text" ,@(when ipv6addr `(:value ,ipv6addr)) ,@(when required-p '(:required "required"))))) + ((string= recordtype "cname") + `((:name "canonical" :label ,(format nil "Canonical~a" (if required-p " *" "")) :field-type "text" ,@(when (sanitize-dns-filter-param canonical) `(:value ,canonical)) ,@(when required-p '(:required "required"))))) + ((string= recordtype "ptr") + `((:name "ptrdname" :label ,(format nil "PTR Dname~a" (if required-p " *" "")) :field-type "text" ,@(when (sanitize-dns-filter-param ptrdname) `(:value ,ptrdname)) ,@(when required-p '(:required "required"))) + (:name "ipv4addr" :label ,(format nil "IPv4 Address~a" (if required-p " *" "")) :field-type "text" ,@(when ipv4addr `(:value ,ipv4addr)) ,@(when required-p '(:required "required")))))) + (:label ,button-label :field-type "button" :onclick ,action)))) + +(defun make-ttl-form (form-name action button-label &key required-p ref) + (make-form form-name + nil + required-p + `((:name "ref" :label "Ref" :field-type ,(if required-p "hidden" "text") ,@(when (sanitize-dns-filter-param ref) `(:value ,ref)) ,@(when required-p '(:required "required"))) + (:name "ttl" :label ,(format nil "TTL~a" (if required-p " *" "")) :field-type "text" ,@(when required-p '(:required "required"))) + (:label ,button-label :field-type "button" :onclick ,action)))) + +(defun handle-dns () + (with-service (instance dns-service) + (setf (title instance) "Select Record Type") + (setf (form instance) (make-form "dns-select-recordtype-form" + nil + nil + '((:name "recordtype" + :field-type "select" + :required "required" + :onchange "on_dns_select_recordtype_changed()" + :options ((:label "A" :value "a") + (:label "AAAA" :value "aaaa") + (:label "CNAME" :value "cname") + (:label "PTR" :value "ptr")))))))) + +(defun handle-dns-login-get () + (with-service (instance dns-login-service) + (setf (title instance) (cond ((string= (getf (dns *webapp*) :backend-type) "infoblox") + "Provide Infoblox Credentials") + ((string= (getf (dns *webapp*) :backend-type) "nsupdate") + "Provide Path to nsupdate Keyfile"))) + (setf (form instance) (make-form "dns-login-get-form" + nil + t + (cond ((string= (getf (dns *webapp*) :backend-type) "infoblox") + '((:name "username" :label "Username *" :field-type "text" :required "required") + (:name "pwd" :label "Password *" :field-type "password" :required "required") + (:label "Login" :field-type "button" :onclick "on_dns_login_get_clicked()"))) + ((string= (getf (dns *webapp*) :backend-type) "nsupdate") + '((:name "keypath" :label "Key Path *" :field-type "text" :required "required") + (:label "Login" :field-type "button" :onclick "on_dns_login_get_clicked()")))))))) + +(defun handle-dns-login-post (username pwd keypath) + (declare (special username pwd keypath)) + (with-service (instance dns-search-service) + (loop for param in (sb-introspect:function-lambda-list 'handle-dns-login-post) do + (when (symbol-value param) + (setf (session-value (intern (symbol-name param) :keyword)) (symbol-value param)))) + (setf (message instance) "Credentials accepted."))) + +(defun handle-dns-headers (recordtype) + (with-service (instance dns-headers-service) + (with-dns (dns) + (let ((dns-record (make-dns-record dns recordtype))) + (setf (headers instance) (mapcar (lambda (slot) + (slot-to-param dns-record slot)) + (map-slot-names dns-record))))))) + +(defun handle-dns-api-search-get (recordtype) + (with-service (instance dns-search-service) + (setf (title instance) (format nil "Filter ~a Records" (string-upcase recordtype))) + (setf (form instance) (make-dns-form "dns-api-search-get-form" + "on_dns_api_search_get_clicked()" + "Search" + :recordtype recordtype)))) + +(defun handle-dns-api-search-post (recordtype ref name ipv4addr ipv6addr canonical ptrdname) + (with-service (instance dns-search-service) + (with-dns (dns) + (let ((results (get-dns-records dns recordtype ref name ipv4addr ipv6addr canonical ptrdname))) + (cond ((eq results 'unauth-error) + (setf (authmsg instance) "Authentication failed")) + ((not (listp results)) + (setf (errormsg instance) results)) + (t + (setf (results instance) results))))))) + +(defun handle-dns-api-add-get (recordtype) + (with-service (instance dns-add-service) + (setf (title instance) (format nil "DNS - Add a(n) ~a Record" (string-upcase recordtype))) + (setf (form instance) (make-dns-form "dns-api-add-get-form" + "on_dns_api_add_get_clicked()" + "Add" + :required-p t + :recordtype recordtype)))) + +(defun handle-dns-api-add-post (recordtype name ipv4addr ipv6addr canonical ptrdname) + (declare (special recordtype name ipv4addr ipv6addr canonical ptrdname)) + (with-service (instance dns-add-service) + (with-dns (dns) + (let ((dns-record (make-dns-record dns recordtype))) + (loop for param in (intersect-dns-record-function-args dns-record 'handle-dns-api-add-post) do + (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param)))) + (let ((results (add-dns-record dns dns-record))) + (if results + (setf (message instance) (format nil "Record added successfully. _ref: ~a" results)) + (setf (errormsg instance) (format nil "Error while adding record.")))))))) + +(defun handle-dns-api-modify-get (recordtype ref name ipv4addr ipv6addr canonical ptrdname) + (with-service (instance dns-add-service) + (setf (title instance) (format nil "DNS - Modify a(n) ~a Record" (string-upcase recordtype))) + (setf (form instance) (make-dns-form "dns-api-modify-get-form" + "on_dns_api_modify_get_clicked()" + "Modify" + :required-p t + :recordtype recordtype + :ref ref + :name name + :ipv4addr ipv4addr + :ipv6addr ipv6addr + :canonical canonical + :ptrdname ptrdname)))) + +(defun handle-dns-api-modify-post (recordtype ref name ipv4addr ipv6addr canonical ptrdname) + (declare (special recordtype ref name ipv4addr ipv6addr canonical ptrdname)) + (with-service (instance dns-modify-service) + (with-dns (dns) + (let ((dns-record (make-dns-record dns recordtype))) + (loop for param in (intersect-dns-record-function-args dns-record 'handle-dns-api-modify-post) do + (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param)))) + (let ((results (modify-dns-record dns dns-record))) + (if results + (setf (message instance) (format nil "Record modified successfully. _ref: ~a" results)) + (setf (errormsg instance) (format nil "Error while modifying record.")))))))) + +(defun handle-dns-api-delete-post (recordtype ref) + (declare (special recordtype ref)) + (with-service (instance dns-add-service) + (with-dns (dns) + (let ((dns-record (make-dns-record dns recordtype))) + (loop for param in (intersect-dns-record-function-args dns-record 'handle-dns-api-delete-post) do + (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param)))) + (let ((results (delete-dns-record dns dns-record))) + (if results + (setf (message instance) "Record deleted successfully.") + (setf (errormsg instance) (format nil "Error while deleting record.")))))))) + +(defun handle-dns-api-ttl-get (recordtype ref name) + (with-service (instance dns-ttl-service) + (setf (title instance) (format nil "DNS - Set the TTL on ~a" name)) + (setf (form instance) (make-ttl-form "dns-api-ttl-get-form" + "on_dns_api_ttl_get_clicked()" + "Modify TTL" + :required-p t + :ref ref)))) + +(defun handle-dns-api-ttl-post (recordtype ref ttl) + (declare (special recordtype ref ttl)) + (with-service (instance dns-ttl-service) + (with-dns (dns) + (let ((dns-record (make-dns-record dns recordtype))) + (loop for param in (intersect-dns-record-function-args dns-record 'handle-dns-api-ttl-post) do + (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param)))) + (let ((results (modify-dns-record-ttl dns dns-record))) + (if results + (setf (message instance) "Record modified successfully.") + (setf (errormsg instance) (format nil "Error while TTLing record.")))))))) diff --git a/lisp/service/generic-form.lisp b/lisp/service/generic-form.lisp new file mode 100644 index 0000000..a3eeec4 --- /dev/null +++ b/lisp/service/generic-form.lisp @@ -0,0 +1,87 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass generic-form (base-service) + ((name :initarg :name + :initform nil + :accessor name) + (http-method :initarg :http-method + :initform "POST" + :accessor http-method) + (action :initarg :action + :initform nil + :accessor action) + (required-p :initarg :required-p + :initform nil + :accessor required-p) + (form-fields :initarg :form-fields + :initform nil + :accessor form-fields)) + (:documentation "")) + +(defclass form-field (base-service) + ((name :initarg :name + :initform nil + :accessor name) + (label :initarg :label + :initform nil + :accessor label) + (value :initarg :value + :initform nil + :accessor value) + (checked :initarg :checked + :initform nil + :accessor checked) + (field-type :initarg :field-type + :initform nil + :accessor field-type) + (required :initarg :required + :initform nil + :accessor required) + (dismiss :initarg :dismiss + :initform nil + :accessor dismiss) + (options :initarg :options + :initform nil + :accessor options) + (onclick :initarg :onclick + :initform nil + :accessor onclick) + (onchange :initarg :onchange + :initform nil + :accessor onchange)) + (:documentation "")) + +(defclass option (base-service) + ((label :initarg :label + :initform nil + :accessor label) + (value :initarg :value + :initform nil + :accessor value)) + (:documentation "")) + +(defun make-form (name action required-p fields) + (make-instance 'generic-form + :name name + :action action + :required-p required-p + :form-fields (mapcar (lambda (field) + (make-instance 'form-field + :name (getf field :name) + :label (getf field :label) + :value (getf field :value) + :checked (getf field :checked) + :field-type (getf field :field-type) + :required (getf field :required) + :dismiss (getf field :dismiss) + :options (mapcar (lambda (option) + (make-instance 'option + :label (getf option :label) + :value (getf option :value))) + (getf field :options)) + :onclick (getf field :onclick) + :onchange (getf field :onchange))) + fields))) diff --git a/lisp/service/login-service.lisp b/lisp/service/login-service.lisp new file mode 100644 index 0000000..251f899 --- /dev/null +++ b/lisp/service/login-service.lisp @@ -0,0 +1,48 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass login-service (rest-service) + ((form :initarg :form + :initform nil + :accessor form) + (title :initarg :title + :initform nil + :accessor title)) + (:documentation "")) + +(defmethod initialize-instance :after ((login-service login-service) &key) + (cond ((string= (backend (dns *webapp*)) "infoblox") + (setf (title login-service) "Supply the Infoblox username, password and domain.") + (setf (form login-service) (make-form "login-form" + nil + t + '((:name "username" :label "Username *" :field-type "text" :required "required") + (:name "pwd" :label "Password *" :field-type "password" :required "required") + (:name "domain" :label "Domain *" :field-type "text" :required "required") + (:label "Login" :field-type "button" :onclick "on_login_submit_clicked()"))))) + +(defun login-json () + (objects-to-json `(,(make-instance 'login-service)))) + +(defclass login-authenticate-service (rest-service) + ((location-p :initarg :location-p + :initform nil + :accessor location-p)) + (:documentation "")) + +(defmethod initialize-instance :after ((login-authenticate-service login-authenticate-service) &key auth-result) + (if auth-result + (setf (message login-authenticate-service) "Successfully logged in.") + (setf (errormsg login-authenticate-service) "Login failed."))) + +(defun login-authenticate-json (username password domain) + (let ((auth-result nil)) + (when (and (intersection `(,username) (valid-users *webapp*) :test 'string=) + (check-ldap-password (ldap *webapp*) username password)) + (setf (session-value :username) username) + (setf (session-value :pwd) pwd) + (setf (session-value :domain) domain) + (setf auth-result t)) + (objects-to-json `(,(make-instance 'login-authenticate-service :auth-result auth-result))))) diff --git a/lisp/service/rest-service.lisp b/lisp/service/rest-service.lisp new file mode 100644 index 0000000..ea374b8 --- /dev/null +++ b/lisp/service/rest-service.lisp @@ -0,0 +1,37 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass rest-service (base-service) + ((location :initarg :location + :initform nil + :accessor location) + (location-p :initarg :location-p + :initform t + :accessor location-p) + (authmsg :initarg :authmsg + :initform nil + :accessor authmsg) + (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)))) + +(defun handle-location (&optional (location "/home")) + (format nil "{\"location\":\"~a\"}" location)) + +(defun type-to-path (rest-type) + (concatenate 'string "/" (ppcre:regex-replace-all "-" (ppcre:regex-replace "-service$" (string-downcase (type-of rest-type)) "") "/"))) + +(defmacro with-service ((instance rest-service) &body body) + `(let ((,instance (make-instance ',rest-service))) + ,@body + (objects-to-json `(,,instance)))) diff --git a/lisp/webapps/dns-admin/clojurescript/dnsadmin/.gitignore b/lisp/webapps/dns-admin/clojurescript/dnsadmin/.gitignore new file mode 100644 index 0000000..c754477 --- /dev/null +++ b/lisp/webapps/dns-admin/clojurescript/dnsadmin/.gitignore @@ -0,0 +1,14 @@ +target +classes +resources +checkouts +pom.xml +pom.xml.asc +*.jar +*.class +.lein-* +.nrepl-port +.hgignore +.hg +profiles.clj +figwheel_server.log diff --git a/lisp/webapps/dns-admin/clojurescript/dnsadmin/README.md b/lisp/webapps/dns-admin/clojurescript/dnsadmin/README.md new file mode 100644 index 0000000..549a339 --- /dev/null +++ b/lisp/webapps/dns-admin/clojurescript/dnsadmin/README.md @@ -0,0 +1,14 @@ +# dns-admin + +A Clojure library designed to ... well, that part is up to you. + +## Usage + +FIXME + +## License + +Copyright © 2017 FIXME + +Distributed under the Eclipse Public License either version 1.0 or (at +your option) any later version. diff --git a/lisp/webapps/dns-admin/clojurescript/dnsadmin/project.clj b/lisp/webapps/dns-admin/clojurescript/dnsadmin/project.clj new file mode 100644 index 0000000..79940e3 --- /dev/null +++ b/lisp/webapps/dns-admin/clojurescript/dnsadmin/project.clj @@ -0,0 +1,11 @@ +(defproject dnsadmin "0.1.0-SNAPSHOT" + :description "FIXME" + :url "FIXME" + :license "public domain" + :dependencies [[org.clojure/clojure "LATEST"] + [org.clojure/clojurescript "LATEST"] + [cljs-ajax "LATEST"] + [prismatic/dommy "LATEST"] + [hiccups "LATEST"]] + :plugins [[lein-cljsbuild "LATEST"]] + :clean-targets ^{:protect false} [:target-path "out" "resources/public/cljs"]) diff --git a/lisp/webapps/dns-admin/clojurescript/dnsadmin/src/core.cljs b/lisp/webapps/dns-admin/clojurescript/dnsadmin/src/core.cljs new file mode 100644 index 0000000..8b760de --- /dev/null +++ b/lisp/webapps/dns-admin/clojurescript/dnsadmin/src/core.cljs @@ -0,0 +1,673 @@ +(ns dnsadmin.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 null-or-empty-p) +(declare reduce-checkboxes) +(declare template-message) +(declare maybe-errormsg) +(declare maybe-message) +(declare notifications) +(declare auth-notifications) +(declare template-generic-form) +(declare template-dns) +(declare handler-dns) +(declare render-dns) +(declare navigate-to) +(declare handler-location) +(declare goto-location) +(declare reset-app) +(declare template-dns-login-get) +(declare handler-dns-login-get) +(declare render-dns-login-get) +(declare on-dns-login-get-clicked) +(declare handler-dns-login-post) +(declare render-dns-login-post) +(declare template-dns-headers) +(declare handler-dns-headers) +(declare render-dns-headers) +(declare on-dns-select-recordtype-changed) +(declare template-dns-api-search-get) +(declare handler-dns-api-search-get) +(declare render-dns-api-search-get) +(declare on-dns-api-search-get-clicked) +(declare template-dns-api-search-post-loading) +(declare template-dns-api-search-post) +(declare handler-dns-api-search-post) +(declare render-dns-api-search-post) +(declare on-dns-api-add-clicked) +(declare template-dns-api-add-get) +(declare handler-dns-api-add-get) +(declare render-dns-api-add-get) +(declare on-dns-add-get-clicked) +(declare handler-dns-api-add-post) +(declare render-dns-api-add-post) +(declare on-dns-modify-api-clicked) +(declare template-dns-api-modify-get) +(declare handler-dns-api-modify-get) +(declare render-dns-api-modify-get) +(declare on-dns-api-modify-post-clicked) +(declare handler-dns-api-modify-post) +(declare render-dns-api-modify-post) +(declare on-dns-api-delete-clicked) +(declare handler-dns-api-delete-post) +(declare render-dns-api-delete-post) +(declare on-dns-api-ttl-clicked) +(declare template-dns-api-ttl-get) +(declare handler-dns-api-ttl-get) +(declare render-dns-api-ttl-get) +(declare on-dns-api-ttl-post-clicked) +(declare handler-dns-api-ttl-post) +(declare render-dns-api-ttl-post) + +(def jquery (js* "$")) + +(defn null-or-empty-p [arg] + (or (not arg) + (= arg ""))) + +(defn reduce-checkboxes [selector] + "Reduces the names of all checked checkboxes to a pipe-separated + list. Assumes that the checkboxes are named via the convention + `chk_something-more'. The important thing is the underscore + separating the throwaway prefix and the remaining useful + bit. `selector' will likely be something like: [id^='chk_']" + (reduce (fn [x y] + (cond (and x y) (str x "|" y) + (and x (not y)) x + (and (not x) y) y + :else "")) + (map (fn [elem] + (let [this (jquery (str "#" (dommy/attr elem :id)))] + (when (-> this (.prop "checked")) + (second (clojure.string/split (-> this (.prop "id")) "_"))))) + (.toArray (jquery selector))))) + +;; notifications + +(hiccups/defhtml template-authmsg [authmsg] + [:div {:class "alert alert-danger"} authmsg]) + +(hiccups/defhtml template-errormsg [errormsg] + [:div {:class "alert alert-danger"} errormsg]) + +(hiccups/defhtml template-message [message] + [:div {:class "alert alert-success"} message]) + +(defn maybe-authmsg [jsonobj] + (let [authmsg (get jsonobj "authmsg")] + (cond (null-or-empty-p authmsg) + (do + (dommy/set-style! (dommy/sel1 :#authmsg) :display "none") + (dommy/set-html! (dommy/sel1 :#authmsg) "") + true) + :else + (do + (dommy/set-style! (dommy/sel1 :#authmsg) :display "block") + (dommy/set-html! (dommy/sel1 :#authmsg) + (template-authmsg authmsg)) + false)))) + +(defn maybe-errormsg [jsonobj] + (let [errormsg (get jsonobj "errormsg")] + (cond (null-or-empty-p errormsg) + (do + (dommy/set-style! (dommy/sel1 :#errormsg) :display "none") + (dommy/set-html! (dommy/sel1 :#errormsg) "") + true) + :else + (do + (dommy/set-style! (dommy/sel1 :#errormsg) :display "block") + (dommy/set-html! (dommy/sel1 :#errormsg) + (template-errormsg errormsg)) + false)))) + +(defn maybe-message [jsonobj] + (let [message (get jsonobj "message")] + (cond (null-or-empty-p message) + (do + (dommy/set-style! (dommy/sel1 :#message) :display "none") + (dommy/set-html! (dommy/sel1 :#message) "")) + :else + (do + (dommy/set-style! (dommy/sel1 :#message) :display "block") + (dommy/set-html! (dommy/sel1 :#message) + (template-message message)))) + true)) + +(defn notifications [jsonobj] + (let [authmsg-result (maybe-authmsg jsonobj) + errormsg-result (maybe-errormsg jsonobj) + message-result (maybe-message jsonobj)] + (and authmsg-result errormsg-result message-result))) + +(defn auth-notifications [jsonobj] + (let [result (notifications jsonobj)] + (cond (get jsonobj "authmsg") + (render-dns-login-get)) + result)) + +;; forms + +(hiccups/defhtml template-generic-form [jsonobj] + [:div {:id "form-errormsg"}] + [:form {:name (get jsonobj "name") + :id (get jsonobj "name") + :method (get jsonobj "httpMethod") + :action (when (get jsonobj "action") + (str "javascript:" (namespace ::x) "." (get jsonobj "action")))} + (for [form-field (get jsonobj "formFields")] + (cond (= (get form-field "fieldType") "button") + [:div {:class "form-group row"} + [:div {:class "offset-sm-2 col-sm-10"} + [:button {:class "btn btn-primary" + :data-dismiss (get jsonobj "dismiss") + :type (cond (get form-field "onclick") "button" :else "submit") + :onclick (when (get form-field "onclick") + (str (namespace ::x) "." (get form-field "onclick")))} + (get form-field "label")]]] + (= (get form-field "fieldType") "hidden") + [:input {:name (get form-field "name") + :id (get form-field "name") + :value (get form-field "value") + :type (get form-field "fieldType")}] + (= (get form-field "fieldType") "checkbox") + [:div {:class "form-check"} + [:input {:type "checkbox" + :class "form-check-input" + :name (get form-field "name") + :id (get form-field "name") + :value (get form-field "value") + :checked (get form-field "checked") + :required (get form-field "required")}] + [:label {:class "form-check-label" + :for (get form-field "name")} + (get form-field "label")]] + (= (get form-field "fieldType") "radio") + [:div {:class "form-check"} + [:input {:type "radio" + :class "form-check-input" + :name (get form-field "name") + :id (get form-field "name") + :value (get form-field "value") + :checked (get form-field "checked") + :required (get form-field "required")}] + [:label {:class "form-check-label" + :for (get form-field "name")} + (get form-field "label")]] + (= (get form-field "fieldType") "select") + [:div {:class "form-group"} + [:label {:for (get form-field "name")} + (get form-field "label")] + [:select {:class "form-control" + :name (get form-field "name") + :id (get form-field "name") + :required (get form-field "required") + :onchange (when (get form-field "onchange") + (str (namespace ::x) "." (get form-field "onchange")))} + (for [option (get form-field "options")] + [:option {:value (get option "value")} + (get option "label")])]] + :else + [:div {:class "form-group row"} + [:label {:for (get form-field "name") + :class "col-form-label col-sm-2" + :style "text-align: right"} + (get form-field "label")] + [:div {:class "col-sm-10"} + [:input {:name (get form-field "name") + :id (get form-field "name") + :value (get form-field "value") + :type (get form-field "fieldType") + :class "form-control" + :required (get form-field "required")}]]]))] + (when (get jsonobj "requiredP") + [:div "* Required"])) + +;; dns + +(hiccups/defhtml template-dns [jsonobj] + [:div {:class "container-fluid"} + [:div {:class "row"} + [:div {:class "col-2"} + [:h4 (get jsonobj "title")] + (template-generic-form (get jsonobj "form")) + [:div {:id "search"}]] + [:div {:class "col"} + [:div {:style "text-align: right"} + [:button {:class "btn btn-primary" + :type "button" + :onclick (str (namespace ::x) ".on_dns_api_add_clicked()")} + "Add New Record"]] + [:div {:id "results"}]]]] + [:div {:id "add" + :class "modal fade" + :role "dialog"} + [:div {:class "modal-dialog modal-lg"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:h5 {:class "modal-title"} "DNS - Add"] + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"]] + [:div {:id "add-body" + :class "modal-body" + :style "height: 460px;"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]] + [:div {:id "modify" + :class "modal fade" + :role "dialog"} + [:div {:class "modal-dialog modal-lg"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:h5 {:class "modal-title"} "DNS - Modify"] + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"]] + [:div {:id "modify-body" + :class "modal-body" + :style "height: 460px;"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]] + [:div {:id "ttl" + :class "modal fade" + :role "dialog"} + [:div {:class "modal-dialog modal-lg"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:h5 {:class "modal-title"} "DNS - TTL"] + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"]] + [:div {:id "ttl-body" + :class "modal-body" + :style "height: 200px;"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]] + [:div {:id "login" + :class "modal fade" + :role "dialog"} + [:div {:class "modal-dialog modal-lg"} + [:div {:class "modal-content"} + [:div {:class "modal-header"} + [:h5 {:class "modal-title"} "DNS - Authentication"] + [:button {:type "button" + :class "close" + :data-dismiss "modal"} + "×"]] + [:div {:id "login-body" + :class "modal-body" + :style "height: 460px;"}] + [:div {:class "modal-footer"} + [:button {:type "submit" + :class "btn btn-danger btn-default" + :data-dismiss "modal"} + [:span {:class "glyphicon glyphicon-remove"}] + "Cancel"]]]]]) + +(defn handler-dns [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-dns jsonobj)) + (render-dns-api-search-get) + (render-dns-headers)))) + +(defn render-dns [] + (GET "/dns" {:handler handler-dns})) + +;; location + +(defn navigate-to [handler] + (dommy/set-html! (dommy/sel1 :#location) handler) + (cond (= handler "/dns") (render-dns))) + +(defn handler-location [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (navigate-to (get jsonobj "location")) + (notifications jsonobj))) + +(defn goto-location [location] + (POST "/location" {:format :raw + :params {:location location} + :handler handler-location})) + +(defn reset-app [] + (set! (.-location js/document) "/")) + +;; dns-login-get + +(hiccups/defhtml template-dns-login-get [jsonobj] + [:h5 (get jsonobj "title")] + (template-generic-form (get jsonobj "form"))) + +(defn handler-dns-login-get [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#login-body) (template-dns-login-get jsonobj)) + (.modal (jquery "#login")))) + +(defn render-dns-login-get [] + (GET "/dns/login" {:handler handler-dns-login-get})) + +(defn on-dns-login-get-clicked [] + (when (-> (jquery "#dns-login-get-form") + (.get "0") + (.checkValidity)) + (.modal (jquery "#login") "hide") + (apply render-dns-login-post + (map (fn [field] + (when (jquery (str "#dns-login-get-form input[id=" field "]")) + (.val (jquery (str "#dns-login-get-form input[id=" field "]"))))) + ["username" "pwd" "keypath"])))) + +;; dns-login-post + +(defn handler-dns-login-post [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (render-dns-api-search-post)))) + +(defn render-dns-login-post [username pwd keypath] + (POST "/dns/login/post" {:format :raw + :params {:username username + :pwd pwd + :keypath keypath} + :handler handler-dns-login-post})) + +;; dns-headers + +(hiccups/defhtml template-dns-headers [jsonobj] + [:table {:class "table table-hover"} + [:thead + [:tr + (for [header (remove (fn [x] (= x "ttl")) (get jsonobj "headers"))] + [:th header]) + [:th "TTL"] + [:th "Del"]]]]) + +(defn handler-dns-headers [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#results) (template-dns-headers jsonobj))))) + +(defn render-dns-headers [] + (POST "/dns/headers" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype))} + :handler handler-dns-headers})) + +;; dns-api-search-get + +(defn on-dns-select-recordtype-changed [] + (render-dns-api-search-get) + (render-dns-headers)) + +(hiccups/defhtml template-dns-api-search-get [jsonobj] + [:h4 (get jsonobj "title")] + (template-generic-form (get jsonobj "form"))) + +(defn handler-dns-api-search-get [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#search) (template-dns-api-search-get jsonobj))))) + +(defn render-dns-api-search-get [] + (POST "/dns/api/search" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype))} + :handler handler-dns-api-search-get})) + +(defn on-dns-api-search-get-clicked [] + (when (-> (jquery "#dns-api-search-get-form") + (.get "0") + (.checkValidity)) + (dommy/set-html! (dommy/sel1 :#results) (template-dns-api-search-post-loading)) + (render-dns-api-search-post))) + +;; dns-api-search-post + +(hiccups/defhtml template-dns-api-search-post-loading [] + [:h5 "Loading..."]) + +(hiccups/defhtml template-dns-api-search-post [jsonobj] + (let [results (get jsonobj "results") + keys (remove (fn [x] (or (= x "Recordtype") (= x "ttl"))) (keys (first results)))] + [:table {:class "table table-hover"} + [:thead + [:tr + (for [key keys] + [:th key]) + [:th "TTL"] + [:th "Del"]]] + [:tbody + (for [rec results] + (let [onclick (str (namespace ::x) ".on_dns_api_modify_clicked('" (get rec "_ref") "','" (get rec "name") "','" (get rec "ipv4Addr") "','" (get rec "ipv6Addr") "','" (get rec "canonical") "','" (get rec "ptrdname") "')")] + [:tr + (for [key keys] + [:td {:onclick onclick} (get rec key)]) + [:td [:img {:src "/static/images/clock.png" + :onclick (str (namespace ::x) ".on_dns_api_ttl_clicked('" (get rec "_ref") "','" (get rec "name") "')")}]] + [:td [:img {:src "/static/images/delete.png" + :onclick (str (namespace ::x) ".on_dns_api_delete_clicked('" (get rec "_ref") "','" (get rec "name") "')")}]]]))]])) + +(defn handler-dns-api-search-post [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#results) (template-dns-api-search-post jsonobj))))) + +(defn render-dns-api-search-post [] + (let [fields ["ref" "name" "ipv4addr" "ipv6addr" "canonical" "ptrdname"] + params (merge {:recordtype (dommy/value (dommy/sel1 :#recordtype))} + (into {} (map vector + (map (fn [field] + (keyword field)) + fields) + (map (fn [field] + (when (jquery (str "#dns-api-search-get-form input[id=" field "]")) + (let [val (.val (jquery (str "#dns-api-search-get-form input[id=" field "]")))] + (cond (null-or-empty-p val) nil + :else val)))) + fields))))] + (POST "/dns/api/search/post" {:format :raw + :params params + :handler handler-dns-api-search-post}))) + +;; dns-api-add-get + +(defn on-dns-api-add-clicked [] + (render-dns-api-add-get)) + +(hiccups/defhtml template-dns-api-add-get [jsonobj] + [:h5 (get jsonobj "title")] + (template-generic-form (get jsonobj "form"))) + +(defn handler-dns-api-add-get [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#add-body) (template-dns-api-add-get jsonobj)) + (.modal (jquery "#add"))))) + +(defn render-dns-api-add-get [] + (POST "/dns/api/add" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype))} + :handler handler-dns-api-add-get})) + +(defn on-dns-api-add-get-clicked [] + (when (-> (jquery "#dns-api-add-get-form") + (.get "0") + (.checkValidity)) + (cond (and (= (dommy/value (dommy/sel1 :#recordtype)) "a") + (let [ipv4addr (when (jquery "#dns-api-add-get-form input[id=ipv4addr]") + (.val (jquery "#dns-api-add-get-form input[id=ipv4addr]"))) + ipv6addr (when (jquery "#dns-api-add-get-form input[id=ipv6addr]") + (.val (jquery "#dns-api-add-get-form input[id=ipv6addr]")))] + (and (null-or-empty-p ipv4addr) + (null-or-empty-p ipv6addr)))) + (js/alert "One or both of the following fields must be populated: IPv4 Address, IPv6 Address") + :else + (do + (.modal (jquery "#add") "hide") + (dommy/set-html! (dommy/sel1 :#results) (template-dns-api-search-post-loading)) + (apply render-dns-api-add-post + (map (fn [field] + (when (jquery (str "#dns-api-add-get-form input[id=" field "]")) + (.val (jquery (str "#dns-api-add-get-form input[id=" field "]"))))) + ["name" "ipv4addr" "ipv6addr" "canonical" "ptrdname"])))))) + +;; dns-api-add-post + +(defn handler-dns-api-add-post [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (render-dns-api-search-post)))) + +(defn render-dns-api-add-post [name ipv4addr ipv6addr canonical ptrdname] + (POST "/dns/api/add/post" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype)) + :name name + :ipv4addr ipv4addr + :ipv6addr ipv6addr + :canonical canonical + :ptrdname ptrdname} + :handler handler-dns-api-add-post})) + +;; dns-api-modify-get + +(defn on-dns-api-modify-clicked [ref name ipv4addr ipv6addr canonical ptrdname] + (render-dns-api-modify-get ref name ipv4addr ipv6addr canonical ptrdname)) + +(hiccups/defhtml template-dns-api-modify-get [jsonobj] + [:h5 (get jsonobj "title")] + (template-generic-form (get jsonobj "form"))) + +(defn handler-dns-api-modify-get [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#modify-body) (template-dns-api-modify-get jsonobj)) + (.modal (jquery "#modify"))))) + +(defn render-dns-api-modify-get [ref name ipv4addr ipv6addr canonical ptrdname] + (POST "/dns/api/modify" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype)) + :ref ref + :name name + :ipv4addr ipv4addr + :ipv6addr ipv6addr + :canonical canonical + :ptrdname ptrdname} + :handler handler-dns-api-modify-get})) + +(defn on-dns-api-modify-get-clicked [ref name ipv4addr ipv6addr canonical ptrdname] + (when (-> (jquery "#dns-api-modify-get-form") + (.get "0") + (.checkValidity)) + (.modal (jquery "#modify") "hide") + (dommy/set-html! (dommy/sel1 :#results) (template-dns-api-search-post-loading)) + (apply render-dns-api-modify-post + (map (fn [field] + (when (jquery (str "#dns-api-modify-get-form input[id=" field "]")) + (.val (jquery (str "#dns-api-modify-get-form input[id=" field "]"))))) + ["ref" "name" "ipv4addr" "ipv6addr" "canonical" "ptrdname"])))) + +;; dns-api-modify-post + +(defn handler-dns-api-modify-post [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (render-dns-api-search-post)))) + +(defn render-dns-api-modify-post [ref name ipv4addr ipv6addr canonical ptrdname] + (POST "/dns/api/modify/post" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype)) + :ref ref + :name name + :ipv4addr ipv4addr + :ipv6addr ipv6addr + :canonical canonical + :ptrdname ptrdname} + :handler handler-dns-api-modify-post})) + +;; dns-api-delete-post + +(defn on-dns-api-delete-clicked [ref name] + (when (js/confirm (str "Are you sure that you want to delete the record for " name "?")) + (dommy/set-html! (dommy/sel1 :#results) (template-dns-api-search-post-loading)) + (render-dns-api-delete-post ref))) + +(defn handler-dns-api-delete-post [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (render-dns-api-search-post)))) + +(defn render-dns-api-delete-post [ref] + (POST "/dns/api/delete/post" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype)) + :ref ref} + :handler handler-dns-api-delete-post})) + +;; dns-api-ttl-get + +(defn on-dns-api-ttl-clicked [ref name] + (render-dns-api-ttl-get ref name)) + +(hiccups/defhtml template-dns-api-ttl-get [jsonobj] + [:h5 (get jsonobj "title")] + (template-generic-form (get jsonobj "form"))) + +(defn handler-dns-api-ttl-get [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#ttl-body) (template-dns-api-ttl-get jsonobj)) + (.modal (jquery "#ttl"))))) + +(defn render-dns-api-ttl-get [ref name] + (POST "/dns/api/ttl" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype)) + :ref ref + :name name} + :handler handler-dns-api-ttl-get})) + +(defn on-dns-api-ttl-get-clicked [ref ttl] + (when (-> (jquery "#dns-api-ttl-get-form") + (.get "0") + (.checkValidity)) + (.modal (jquery "#ttl") "hide") + (dommy/set-html! (dommy/sel1 :#results) (template-dns-api-search-post-loading)) + (apply render-dns-api-ttl-post + (map (fn [field] + (when (jquery (str "#dns-api-ttl-get-form input[id=" field "]")) + (.val (jquery (str "#dns-api-ttl-get-form input[id=" field "]"))))) + ["ref" "ttl"])))) + +;; dns-api-ttl-post + +(defn handler-dns-api-ttl-post [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (when (auth-notifications jsonobj) + (render-dns-api-search-post)))) + +(defn render-dns-api-ttl-post [ref ttl] + (POST "/dns/api/ttl/post" {:format :raw + :params {:recordtype (dommy/value (dommy/sel1 :#recordtype)) + :ref ref + :ttl ttl} + :handler handler-dns-api-ttl-post})) diff --git a/lisp/webapps/dns-admin/conf/options.lisp b/lisp/webapps/dns-admin/conf/options.lisp new file mode 100644 index 0000000..ddc02f2 --- /dev/null +++ b/lisp/webapps/dns-admin/conf/options.lisp @@ -0,0 +1,7 @@ +(:name "dns-admin" + :document-root "dns-admin" + :title "DNS Administration" + :meta-description "A website for administering DNS. Supports nsupdate and infoblox." + :dns (:label "CDS Infoblox" + :backend-type "infoblox" + :url "https://cdsinfdnsgm.nnodns.com/wapi/v2.6")) diff --git a/lisp/webapps/dns-admin/conf/options.lisp.example b/lisp/webapps/dns-admin/conf/options.lisp.example new file mode 100644 index 0000000..ddc02f2 --- /dev/null +++ b/lisp/webapps/dns-admin/conf/options.lisp.example @@ -0,0 +1,7 @@ +(:name "dns-admin" + :document-root "dns-admin" + :title "DNS Administration" + :meta-description "A website for administering DNS. Supports nsupdate and infoblox." + :dns (:label "CDS Infoblox" + :backend-type "infoblox" + :url "https://cdsinfdnsgm.nnodns.com/wapi/v2.6")) diff --git a/lisp/webapps/dns-admin/site.lisp b/lisp/webapps/dns-admin/site.lisp new file mode 100644 index 0000000..996eeea --- /dev/null +++ b/lisp/webapps/dns-admin/site.lisp @@ -0,0 +1,103 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defmacro .base (&optional (onload-fn "goto_location('/dns')")) + `(html5 + `(html + (head + ((meta :name "viewport" :content "width=device-width, initial-scale=1")) + ((meta :charset "utf-8")) + ((title) ,(title *webapp*)) + ,@(mapcar (lambda (css) + `((link :rel "stylesheet" :href ,(getf css :href) :integrity ,(getf css :integrity) :crossorigin ,(getf css :crossorigin)))) + '((:href "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0/css/bootstrap.min.css" :integrity "sha384-Gn5384xqQ1aoWXA+058RXPxPg6fy4IWvTNh0E263XmFcJlSAwiGgFAW/dAiS6JXm" :crossorigin "anonymous"))) + ,@(mapcar (lambda (js) + `((script :type "text/javascript" :src ,(getf js :src) :integrity ,(getf js :integrity) :crossorigin ,(getf js :crossorigin)))) + '((:src "https://code.jquery.com/jquery-3.2.1.slim.min.js" :integrity "sha384-KJ3o2DKtIkvYIK3UENzmM7KCkRr/rE9/Qpg6aAZGJwFDMVNA/GpGFF93hXpG5KkN" :crossorigin "anonymous") + (:src "https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.12.9/umd/popper.min.js" :integrity "sha384-ApNbgh9B+Y1QKtv3Rn7W3mgPxhU9K/ScQsAP7hUibX39j7fakFPskvXusvfa0b4Q" :crossorigin "anonymous") + (:src "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0/js/bootstrap.min.js" :integrity "sha384-JZR6Spejh4U02d8jOt6vLEHfe/JQGiRRSQQxSfFWpi1MquVdAyjUar5+76PVCmYl" :crossorigin "anonymous"))) + ((script :type "text/javascript" :src "/static/js/cljs/main.js"))) + ((body :onload ,(format nil "dnsadmin.core.~a" ,onload-fn)) + ((div :class "container-fluid") + ((div :class "row" :style "padding: 20px") + ((div :class "col") + ((div :class "page-header") + ((h2 :align "center") ,(title *webapp*)))))) + ((div :id "location" :style "display: none")) + ((div :id "authmsg")) + ((div :id "errormsg")) + ((div :id "message")) + ((div :id "body")) + ((div :id "infoblox-creds" :class "modal fade" :role "dialog") + ((div :class "modal-dialog modal-lg") + ((div :class "modal-content") + ((div :class "modal-header") + ((h5 :class "modal-title") "Infoblox - Connection Parameters") + ((button :type "button" :class "close" :data-dismiss "modal") "×")) + ((div :id "infoblox-creds-body" :class "modal-body" :style "height: 460px;")) + ((div :class "modal-footer") + ((button :type "submit" :class "btn btn-danger btn-default" :data-dismiss "modal") + ((span :class "glyphicon glyphicon-remove") "Cancel")))))))))) + +(defmacro .location () + `(handle-location location)) + +(defmacro .dns () + `(handle-dns)) + +(defmacro .dns-headers () + `(handle-dns-headers recordtype)) + +(defmacro .dns-login-get () + `(handle-dns-login-get)) + +(defmacro .dns-login-post () + `(handle-dns-login-post username pwd keypath)) + +(defmacro .dns-api-search-get () + `(handle-dns-api-search-get recordtype)) + +(defmacro .dns-api-search-post () + `(handle-dns-api-search-post recordtype ref name ipv4addr ipv6addr canonical ptrdname)) + +(defmacro .dns-api-add-get () + `(handle-dns-api-add-get recordtype)) + +(defmacro .dns-api-add-post () + `(handle-dns-api-add-post recordtype name ipv4addr ipv6addr canonical ptrdname)) + +(defmacro .dns-api-modify-get () + `(handle-dns-api-modify-get recordtype ref name ipv4addr ipv6addr canonical ptrdname)) + +(defmacro .dns-api-modify-post () + `(handle-dns-api-modify-post recordtype ref name ipv4addr ipv6addr canonical ptrdname)) + +(defmacro .dns-api-delete-post () + `(handle-dns-api-delete-post recordtype ref)) + +(defmacro .dns-api-ttl-get () + `(handle-dns-api-ttl-get recordtype ref name)) + +(defmacro .dns-api-ttl-post () + `(handle-dns-api-ttl-post recordtype ref ttl)) + +;; hunchentoot fails to differentiate between :get and :post to the +;; same URL. So we work around it in the URLs but fix it in the +;; downstream macro and function names. +(define-endpoint :get "/" () .base) +(define-endpoint :post "/location" ((location :parameter-type 'string)) .location) +(define-endpoint :get "/dns" () .dns) +(define-endpoint :post "/dns/headers" ((recordtype :parameter-type 'string)) .dns-headers) +(define-endpoint :get "/dns/login" () .dns-login-get) +(define-endpoint :post "/dns/login/post" ((username :parameter-type 'string) (pwd :parameter-type 'string) (keypath :parameter-type 'string)) .dns-login-post) +(define-endpoint :post "/dns/api/search" ((recordtype :parameter-type 'string)) .dns-api-search-get) +(define-endpoint :post "/dns/api/search/post" ((recordtype :parameter-type 'string) (ref :parameter-type 'string) (name :parameter-type 'string) (ipv4addr :parameter-type 'string) (ipv6addr :parameter-type 'string) (canonical :parameter-type 'string) (ptrdname :parameter-type 'string)) .dns-api-search-post) +(define-endpoint :post "/dns/api/add" ((recordtype :parameter-type 'string)) .dns-api-add-get) +(define-endpoint :post "/dns/api/add/post" ((recordtype :parameter-type 'string) (name :parameter-type 'string) (ipv4addr :parameter-type 'string) (ipv6addr :parameter-type 'string) (canonical :parameter-type 'string) (ptrdname :parameter-type 'string)) .dns-api-add-post) +(define-endpoint :post "/dns/api/modify" ((recordtype :parameter-type 'string) (ref :parameter-type 'string) (name :parameter-type 'string) (ipv4addr :parameter-type 'string) (ipv6addr :parameter-type 'string) (canonical :parameter-type 'string) (ptrdname :parameter-type 'string)) .dns-api-modify-get) +(define-endpoint :post "/dns/api/modify/post" ((recordtype :parameter-type 'string) (ref :parameter-type 'string) (name :parameter-type 'string) (ipv4addr :parameter-type 'string) (ipv6addr :parameter-type 'string) (canonical :parameter-type 'string) (ptrdname :parameter-type 'string)) .dns-api-modify-post) +(define-endpoint :post "/dns/api/delete/post" ((recordtype :parameter-type 'string) (ref :parameter-type 'string)) .dns-api-delete-post) +(define-endpoint :post "/dns/api/ttl" ((recordtype :parameter-type 'string) (ref :parameter-type 'string) (name :parameter-type 'string)) .dns-api-ttl-get) +(define-endpoint :post "/dns/api/ttl/post" ((recordtype :parameter-type 'string) (ref :parameter-type 'string) (ttl :parameter-type 'string)) .dns-api-ttl-post) diff --git a/lisp/webapps/dns-admin/static/images/add.png b/lisp/webapps/dns-admin/static/images/add.png Binary files differnew file mode 100644 index 0000000..1055df8 --- /dev/null +++ b/lisp/webapps/dns-admin/static/images/add.png diff --git a/lisp/webapps/dns-admin/static/images/clock.png b/lisp/webapps/dns-admin/static/images/clock.png Binary files differnew file mode 100644 index 0000000..66a95a7 --- /dev/null +++ b/lisp/webapps/dns-admin/static/images/clock.png diff --git a/lisp/webapps/dns-admin/static/images/delete.png b/lisp/webapps/dns-admin/static/images/delete.png Binary files differnew file mode 100644 index 0000000..b0de61d --- /dev/null +++ b/lisp/webapps/dns-admin/static/images/delete.png diff --git a/lisp/webapps/dns-admin/static/images/edit.png b/lisp/webapps/dns-admin/static/images/edit.png Binary files differnew file mode 100644 index 0000000..550dacd --- /dev/null +++ b/lisp/webapps/dns-admin/static/images/edit.png diff --git a/lisp/webapps/dns-admin/static/js/cljs b/lisp/webapps/dns-admin/static/js/cljs new file mode 120000 index 0000000..c6964c8 --- /dev/null +++ b/lisp/webapps/dns-admin/static/js/cljs @@ -0,0 +1 @@ +../../clojurescript/dnsadmin/resources/public/cljs
\ No newline at end of file diff --git a/lisp/webapps/generics.lisp b/lisp/webapps/generics.lisp new file mode 100644 index 0000000..4ddba12 --- /dev/null +++ b/lisp/webapps/generics.lisp @@ -0,0 +1,12 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defgeneric get-site-file-path (webapp) + (:documentation "Builds a full filesystem path to a webapp's site +file.")) + +(defgeneric get-pages-file-paths (webapp) + (:documentation "")) + diff --git a/lisp/webapps/webapp-loader.lisp b/lisp/webapps/webapp-loader.lisp new file mode 100644 index 0000000..c3f64fc --- /dev/null +++ b/lisp/webapps/webapp-loader.lisp @@ -0,0 +1,146 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defvar *acceptor* nil) +(defvar *dispatch-table* '(#'dispatch-easy-handlers #'default-dispatcher)) +(defvar *webapps* (make-hash-table :test 'equal)) +(defvar *webapp* nil) +(defvar *uri* nil) +(defvar *header-register* nil) +(defvar *sessionid* nil) +(defvar *session-timeout* (* 4 60 60)) +(defparameter *port* 3000) +(defparameter *conf-file* "/etc/dns-admin/conf.lisp") +(defparameter *creds-file* "/etc/dns-admin/creds.lisp") + +(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.") + (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.") + (proxy :initarg :proxy + :initform nil + :accessor proxy) + (dns :initarg :dns + :initform nil + :accessor dns)) + (:documentation "")) + +(defmethod get-site-file-path ((webapp webapp)) + (format nil "~a/site" (document-root webapp))) + +(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 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 stored under the key `key'." + (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 () + (with-open-file (input *conf-file* :direction :input) + (let ((form (read input))) + (set-webapp (make-instance 'webapp + :name (getf form :name) + :document-root (make-webapp-path (getf form :document-root)) + :title (getf form :title) + :meta-description (getf form :meta-description) + :proxy (getf form :proxy) + :dns (getf form :dns)))))) + +(defun read-creds-file () + "Reads the data stored in the credentials file at location +`*creds-file*'." + (when (probe-file *creds-file*) + (with-open-file (input *creds-file* :direction :input) + (read input)))) + +(defun dns-admin () + "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 &rest args) + (let ((package (string-downcase (package-name #.*package*)))) + `(let ((*webapp* (get-webapp ,package))) + (logger (format nil "Page request URI: [~a]" ,uri)) + (multiple-value-bind (basic-auth-username basic-auth-pwd) + (hunchentoot:authorization) + (if (or (null-or-empty-p basic-auth-username) + (null-or-empty-p basic-auth-pwd)) + (hunchentoot:require-authorization (name *webapp*)) + (progn + (unless *session* + (start-session) + (setf (session-max-time *session*) *session-timeout*) + (setf (session-value :username) basic-auth-username) + (setf (session-value :pwd) basic-auth-pwd) + (let ((creds (read-creds-file))) + (loop while creds do + (let ((key (pop creds)) + (val (pop creds))) + (setf (session-value key *session*) val))))) + (,page-function ,@args))))))) + +(defmacro define-endpoint (request-type uri var-list page-function &rest args) + "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 ,@args))))) |
