(defpackage :urlshort
  (:use :common-lisp :woo :spinneret :bordeaux-threads :parenscript))

(defparameter *hash* (make-hash-table :test #'equal))

(defun read-post-body (env)
  (let* ((fstream (flex:make-flexi-stream (getf env :raw-body) :external-format :utf-8)))
    (apply #'concatenate 'string (loop for line = (read-line fstream nil)
				       while line
				       collecting line))))

(defun serve-index (env)
  (cond ((eq (getf env :request-method) :get)
	 (list
	  '200
	  '(:content-type "text/html")
	  (list (with-html-string
		  (:html
		   (:head
		    (:script :attrs (list :type "text/javascript")
			     (:raw
			      (ps
				(defun send ()
				  (let ((xhttp (new (-x-m-l-http-request)))
					(text (chain document (get-element-by-id "urlfield") value)))
				    (setf (getprop xhttp 'onreadystatechange) 
					  (lambda ()
					    (if (and (= (getprop this 'ready-state) 4) 
						     (= (getprop this 'status) 200))
						(progn (funcall (getprop console 'log)
								(getprop xhttp 'response-text))
						       (let* ((li
								(funcall
								 (getprop document 'create-element)
								 "li"))
							      (link
								(funcall
								 (getprop document 'create-element)
								 "a"))
							      (url (+ (chain document -u-r-l)
								      (getprop xhttp 'response-text)))
							      (linktext
								(funcall
								 (getprop document 'create-text-node)
								 url)))
							 (setf (getprop link 'href) url)
							 (chain link (append-child linktext))
							 (chain li (append-child link))
							 (chain document (get-element-by-id "urls")
								(append-child li)))))
					    t)
					  (getprop xhttp 'response-type) "text/plain")
				    (funcall (getprop xhttp 'open) "POST" "/" t)
				    (funcall (getprop xhttp 'send) text)
				    t))))))
		   (:body
		    (:form (:input :attrs '(:type "text" :id "urlfield"))
			   (:input :attrs '(:type "button" :value "send" :onclick "send()")))
		    (:ol :attrs '(:id "urls"))))))))
	((eq (getf env :request-method) :post)
	 (let ((symbol (symbol-name (gensym))))
	   (setf (gethash symbol *hash*) (read-post-body env))
	   (list '200 '(:content-type "text/plain") (list symbol))))))

(defun serve-redirect (env)
  (let ((key (gethash (subseq (getf env :request-uri) 1) *hash*)))
    (if key
	(list '200 (list :content-type "text/html" :location key)
	      (list (with-html-string
		      (:html (:head (:meta :attrs (list :http-equiv "refresh"
							:content (format nil "5; url = ~a" key))))
			     (:body (:p "redirecting..."))))))
	(list '404 (list :content-type "text/plain") (list "404")))))

(defun shortener (env)
  (print env)
  (if (string= (getf env :request-uri) "/")
      (serve-index env)
      (serve-redirect env)))

(let ((thread nil))
  (defun run-server () ; localhost:5000
    (if (or (null thread) (not (thread-alive-p thread)))
	(setf thread (make-thread (lambda () (run #'shortener)) :name "woo-server-thread"))))
  (defun stop-server ()
    (progn thread (destroy-thread thread) (setf thread nil)))
  (defun restart-server ()
    (stop-server)
    (run-server)))