1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
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)))
|
