You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
90 lines
3.0 KiB
90 lines
3.0 KiB
(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)))
|