initail commit

1 files changed, 156 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)))