Possibly Cool domain names

;;;; -*- mode: lisp -*- ;;; Pre-loading initialization (eval-when (:compile-toplevel :load-toplevel :execute) (load "/usr/local/lib/sbcl/asdf/asdf")) (eval-when (:compile-toplevel :load-toplevel :execute) (push "/home/azimuth/.sbcl/systems/" asdf:*central-registry*) (asdf:oos 'asdf:load-op :cgi-utils) (asdf:oos 'asdf:load-op :local-time) (asdf:oos 'asdf:load-op :sb-bsd-sockets)) ;;; Configuration (defparameter +created-domains-count+ 10 "Number of created domains shown on a web page at once.") (defparameter +log-path+ #p"/home/azimuth/public_html/code/domain_files/domain_log.txt") (defparameter +words-path+ #p"/home/azimuth/public_html/code/domain_files/words.lisp") ;;; HTTP headers must always be output first (format t "Content-type: text/html~c~%~c~%" #\return #\return) ;;; Randomize random numbers (setf *random-state* (make-random-state t)) ;;; Variables to contain the word lists (defvar *nouns* nil) (defvar *adjectives* nil) (defvar *prefixes* nil) ;;; We may have more than one person attempting to access files at ;;; the same time. During writing, this can cause malfunction. This ;;; uses a lock file to ensure exclusivity (defmacro with-lock-wait ((path) &body body) (let ((lock-path (gensym)) (lock-file (gensym))) `(let ((,lock-path (format nil "~a.lock" (namestring ,path)))) (unwind-protect (progn (loop for ,lock-file = (open ,lock-path :direction :output :if-exists nil :if-does-not-exist :create) until ,lock-file do (sleep 0.1) finally (close ,lock-file)) ,@body) (ignore-errors (delete-file ,lock-path)))))) (defun load-word-file (path) "Load the word file at PATH into the global variables" (setf *nouns* nil *adjectives* nil *prefixes* nil) (let ((tuples (with-lock-wait (path) (with-open-file (inf path :direction :input) (read inf))))) (dolist (tuple tuples) (ecase (first tuple) (noun (push (second tuple) *nouns*)) (adjective (push (second tuple) *adjectives*)) (prefix (push (second tuple) *prefixes*)))))) (defun write-word-file (path) "Write the words in the global variables to the word file at PATH" (with-lock-wait (path) (with-open-file (ouf path :direction :output :if-exists :supersede :if-does-not-exist :create) (format ouf "(~{~s~^~%~})~%" (append (mapcar (lambda (word) (list 'noun word)) *nouns*) (mapcar (lambda (word) (list 'adjective word)) *adjectives*) (mapcar (lambda (word) (list 'prefix word)) *prefixes*)))))) ;;; Output header (defun output-html-header () "Outputs the initial section of the page." (format t " Possibly Cool domain names

(Possibly) Cool domain names

")) (defun output-html-footer () "Output the last bits of the html page" (format t "~%")) (defun syslog (action word) (with-lock-wait (+log-path+) (with-open-file (ouf +log-path+ :direction :output :if-exists :append :if-does-not-exist :create) (format ouf "~a :: ~a :: ~a ~a~%" (local-time:format-timestring nil (local-time:now) nil nil 3 3 #\- #\: #\space) (http:http-getenv "REMOTE_ADDR") action word)))) (defun add-word (word category) (cond ((< (length word) 1) (format t "

(no word entered)

~%")) ((notevery #'alpha-char-p word) (format t "

(~a is not valid)

~%" word)) ((or (find word *nouns* :test #'string=) (find word *adjectives* :test #'string=) (find word *prefixes* :test #'string=)) (format t "

(~a is already in the database)

~%" word)) ((eql category 'noun) (push word *nouns*) (write-word-file +words-path+) (syslog "addnoun" word) (format t "

(~a added to nouns)

" word)) ((eql category 'adjective) (push word *adjectives*) (write-word-file +words-path+) (syslog "addadj" word) (format t "

(~a added to adjectives)

" word)) ((eql category 'prefix) (push word *prefixes*) (write-word-file +words-path+) (syslog "addprefix" word) (format t "

(~a added to prefixes)

" word)))) (defun remove-word (word) (cond ((< (length word) 1) (format t "

(no word entered)

~%")) ((notevery #'alpha-char-p word) (format t "

(~a is not valid)

~%" word)) ((find word *nouns* :test #'string=) (setf *nouns* (delete word *nouns* :test #'string=)) (write-word-file +words-path+) (syslog "delnoun" word) (format t "

(~a removed from nouns)

~%" word)) ((find word *adjectives* :test #'string=) (setf *adjectives* (delete word *adjectives* :test #'string=)) (write-word-file +words-path+) (syslog "deladj" word) (format t "

(~a removed from adjectives)

~%" word)) ((find word *prefixes* :test #'string=) (setf *prefixes* (delete word *prefixes* :test #'string=)) (write-word-file +words-path+) (syslog "delprefix" word) (format t "

(~a removed from prefixes)

~%" word)))) (defun handle-html-params (action raw-word) "Handles CGI parameters, notably the adding of words to the database." (let* ((word (string-downcase (if (> (length raw-word) 30) (subseq raw-word 0 30) raw-word)))) (cond ((string= action "Remove") (remove-word word)) ((string= action "Add Noun") (add-word word 'noun)) ((string= action "Add Adjective") (add-word word 'adjective)) ((string= action "Add Prefix") (add-word word 'prefix))))) (defun random-elt (sequence) "Returns a random element from SEQUENCE." (when (car sequence) (nth (random (length sequence)) sequence))) (defun create-domain () "Returns a string with a randomly generated domain name." (let ((separator nil) ; (when (< (random 10) 3) "-")) (selector (random 60))) (concatenate 'string (cond ((< selector 20) ;; noun-noun (let ((noun1-idx (random (length *nouns*))) (noun2-idx (random (1- (length *nouns*))))) (when (>= noun2-idx noun1-idx) (incf noun2-idx)) (format nil "~a~@[~a~]~a" (nth noun1-idx *nouns*) separator (nth noun2-idx *nouns*)))) ((< selector 40) ;; adjective-noun (format nil "~a~@[~a~]~a" (random-elt *adjectives*) separator (random-elt *nouns*))) ((< selector 50) ;; prefix-noun (format nil "~a~@[~a~]~a" (random-elt *prefixes*) separator (random-elt *nouns*))) (t ;; prefix-adjective (format nil "~a~@[~a~]~a" (random-elt *prefixes*) separator (random-elt *adjectives*)))) ".com"))) (defun domain-exists-p (name) (handler-case (sb-bsd-sockets:get-host-by-name name) (sb-bsd-sockets:host-not-found-error () nil) (sb-bsd-sockets::no-address-error () (progn t)) (sb-bsd-sockets:try-again-error () nil))) (defun create-unused-domain () (loop for name = (create-domain) while (domain-exists-p name) finally (return name))) ;;; Output words (defun output-html-domains (count) "Outputs the html to produce COUNT number of randomly generated domains." (format t "

") (format t "whois" domain) (format t " ~a" domain) (format t "

~%")) (defun output-html-form (admin-p) "Output the form at the end of the page. The word adding fields won't be displayed if ADMIN-P is NIL." (format t "

~%")) ;;; Execution starts here (defun display-html-page (admin action raw-word) "Main display function" (load-word-file +words-path+) (output-html-header) (let ((admin-p (string= admin "yes"))) (handle-html-params action raw-word) (format t "

~%") (multiple-value-bind (count-per slop) (floor +created-domains-count+ 2) (output-html-domains count-per) (format t "	") (output-html-domains (+ count-per slop))) (format t "
~%") (output-html-form admin-p) (format t "

~%")) (output-html-footer)) (defun check-single-word (word) (load-word-file +words-path+) (dolist (listed-word (append *nouns* *adjectives* *prefixes*)) (let ((domain (format nil "~a~a.com" listed-word word))) (unless (domain-exists-p domain) (format t "~a~%" domain))))) (when (http:http-getenv "REMOTE_ADDR") (display-html-page (http:http-query-parameter "admin") (http:http-query-parameter "action") (http:http-query-parameter "word")))