;;;; 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 ":-(")))))