diff options
Diffstat (limited to 'lisp/core')
| -rw-r--r-- | lisp/core/coreutils.lisp | 156 | ||||
| -rw-r--r-- | lisp/core/html.lisp | 270 | ||||
| -rw-r--r-- | lisp/core/httputils.lisp | 74 |
3 files changed, 500 insertions, 0 deletions
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")) |