From d0d4ac64a4f5aafc5cd895420c54a17293be0327 Mon Sep 17 00:00:00 2001
From: Mil <mil@bloome.rs>
Date: Thu, 10 Mar 2022 18:44:16 +0000
Subject: [PATCH] Add the URL shortener toy

Because why not. It's not actually used anywhere.
---
 short.lisp | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 89 insertions(+)
 create mode 100644 short.lisp

diff --git a/short.lisp b/short.lisp
new file mode 100644
index 0000000..fb80547
--- /dev/null
+++ b/short.lisp
@@ -0,0 +1,89 @@
+(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)))