;;;; cl-phantasmagoria.lisp
;;;Requires:
;;; #:cl-ppcre #:usocket
;;;(in-package #:cl-phantasmagoria)
(defvar *threads* (list))
(defvar *last-post* 0)
(defvar *port* 8070)
(defvar *domain* "localhost")
(defun create-server ()
(let ((socket (usocket:socket-listen "127.0.0.1" *port* :reuse-address t)))
(unwind-protect
(loop for connection = (usocket:socket-accept socket :element-type 'character)
do (unwind-protect
(progn
(gopher-respond connection)
(force-output (usocket:socket-stream connection)))
(progn
(when connection
(usocket:socket-close connection)))))
(when socket usocket:socket-close socket))))
(defun add-thread (name)
(push (list (incf *last-post*) name "") *threads*))
(defun filter-posts (lambda)
(delete-if lambda *threads*))
(defun blank-from (cutoff postno)
(setf (third (assoc postno *threads*))
(subseq (third (assoc postno *threads*))
0
(nth-value
0
(cl-ppcre:scan
cutoff
(third (assoc postno *threads*)))))))
(defun append-to-thread (thrno words)
(setf (third (assoc thrno *threads*))
(format nil "~a~%~%~a:~%~a~%"
(third (assoc thrno *threads*))
(incf *last-post*)
words)))
(defun print-gophermap (stream)
(format stream "phantasmagoria~%~%")
(format stream "~a~a ~a ~a ~a~%"
7 "add thread" "add thread" *domain* *port*)
(format stream "~a~a ~a ~a ~a~%"
7 "respond thread" "respond thread" *domain* *port*)
(dolist (s *threads*)
(format stream "0~a: ~a ~a ~a ~a~%"
(first s) (second s) (first s) *domain* *port*)))
(defun print-thread (thrno stream)
(format stream "phantasmagoria~%~a: ~a~%~a"
thrno
(second (assoc thrno *threads*))
(third (assoc thrno *threads*))))
(defun gopher-respond (connection)
"lynx
gopher://localhost:8070/1/"
(let* ((safety 0)
(terms (mapcar
(lambda (x) (coerce x 'string))
(loop
for done = nil
collect
(loop
for y = (read-char (usocket:socket-stream connection))
do (when (char= y #\return) (setf done t))
do (when (> (incf safety) 400)
(setf done t)
(return))
while (not (or (char= y #\tab) (char= y #\return)))
collect y)
while (not done)))))
(cond ((and (= 1 (length terms))
(string= "/" (car terms)))
(print-gophermap (usocket:socket-stream connection)))
((and (= 1 (length terms))
(assoc (parse-integer (first terms))
*threads*))
(print-thread (parse-integer (first terms))
(usocket:socket-stream connection)))
((and (= 2 (length terms))
(string= "add thread" (car terms)))
(add-thread (second terms))
(print-thread *last-post* (usocket:socket-stream connection)))
((and (= 2 (length terms))
(string= "respond thread" (car terms)))
(let* ((idx (parse-integer (subseq
(second terms)
0
(nth-value
0
(cl-ppcre:scan
'(:POSITIVE-LOOKAHEAD ":")
(second terms)))))))
(append-to-thread idx
(second terms))
(print-thread idx
(usocket:socket-stream connection))))
(t (error ":-(")))))
