From 7485a61c41988e5f1d05f46e848f1af96fb28d0f Mon Sep 17 00:00:00 2001 From: Mil Date: Sun, 27 Feb 2022 02:21:21 +0000 Subject: [PATCH] Initial commit --- webshit.lisp | 219 +++++++++++++++++++++++++++++++++++++++++++++++++++ webshit2.asd | 8 ++ 2 files changed, 227 insertions(+) create mode 100644 webshit.lisp create mode 100644 webshit2.asd diff --git a/webshit.lisp b/webshit.lisp new file mode 100644 index 0000000..a50d39c --- /dev/null +++ b/webshit.lisp @@ -0,0 +1,219 @@ +;;;; webshit.lisp +;;; to be: a personal website fit for illustrators + +(defpackage :webshit2 + (:use :common-lisp :bknr.datastore :woo :spinneret :split-sequence :bordeaux-threads :parenscript)) +(in-package :webshit2) + +;;; HTTP stuff + +(defparameter *old-requests* ()) + +(defun http-status (status) + (list status '(:content-type "text/html") + (list (with-html-string (:doctype) (:html (:h1 (write-to-string status))))))) + +(defun mangle-path (path) + (reverse (split-sequence #\/ path :remove-empty-subseqs t))) + +;;; POST handling + +(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 keyval->plist (string) + (let ((sections (split-sequence #\; string :remove-empty-subseqs t)) + (list ())) + (dolist (s sections) + (let ((head (subseq s 0 (position #\= s))) + (tail (subseq s (+ 1 (position #\= s))))) + (push (split-sequence #\, tail :remove-empty-subseqs t) list) + (push (intern (string-upcase head) "KEYWORD") list))) + list)) + +;;; session + +(defclass http-session (store-object) + ((key + :initarg :key + :accessor session-key + :index-type bknr.indices:unique-index + :index-initargs (:test #'equal) + :index-reader sessions-with-key + :index-values all-sessions) + (expiry + :initarg :expiry + :accessor session-expiry) + (buckets + :initarg :buckets + :accessor session-buckets) + (extra-data + :initarg :extra + :accessor session-extra)) + (:metaclass persistent-class)) + +(defun get-session (env) + (let ((client-key (caadr (keyval->plist (gethash "cookie" (getf env :headers)))))) + (sessions-with-key client-key))) + +(defun make-session () + (let ((key (format nil "~a" (uuid:make-v4-uuid)))) + (make-instance 'http-session + :key key :expiry nil :buckets nil :extra nil))) + +;;; request handlers + +(defparameter *handler-map* (make-hash-table :test #'equal)) + +(defun register-handler (path function) + (setf (gethash path *handler-map*) function)) + +(defun %find-handler (path) + (if path + (let ((handler (gethash path *handler-map*))) + (or handler (%find-handler (cdr path)))) + (gethash :default-handler *handler-map*))) + +(defun find-handler (path) + (if (stringp path) + (%find-handler (mangle-path path)) + (%find-handler path))) + +(register-handler :default-handler (lambda (&rest args) (declare (ignore args)) (http-status 404))) + +;;; buckets + +(defclass bucket (store-object) + ((directory :initarg :directory :accessor bucket-directory + :index-type bknr.indices:unique-index + :index-initargs (:test #'equal) ; <- change this!! + :index-reader bucket-by-path + :index-values all-directories) + (type :initarg :type :accessor bucket-type ; Independent from auth method and such things, + :index-type bknr.indices:hash-index ; because coupling such functionality would probably + :index-initargs (:test #'equal) ; cause problems. + :index-reader bucket-by-type ; This is just a text field. + :index-values all-types + :initform "none") + (name :initarg :name :accessor bucket-name + :index-type bknr.indices:unique-index + :index-initargs (:test #'equal) + :index-reader bucket-by-name) + (updated-time :initform :modified-time :accessor bucket-time) + (comment :initarg :comment :accessor bucket-comment)) + (:metaclass persistent-class)) + +(defclass password-bucket (bucket) + ((password-hash :initarg :password-hash :accessor bucket-password-hash) + (salt :initarg :salt :accessor bucket-salt) + (crypt :initarg :crypt :accessor bucket-crypt)) + (:metaclass persistent-class)) + +;; (defclass public-bucket (bucket) +;; ((preview-files :initarg :preview-files :accessor bucket-preview-files) +;; (public-id :initarg :public-id :accessor public-id +;; :index-type bknr.indices:unique-index +;; :index-initargs))) + +;; (defclass monero-bucket (bucket)) + +(defun bucket-exists-p (name) + (probe-file (concatenate 'string "buckets/" name))) + +(defun open-bucket-to (session bucket) + (with-transaction () + (setf (session-buckets session) + (remove-duplicates (cons bucket (session-buckets session)) + :test #'equal)))) + +(defun render-bucket (env path) + (let* ((files (map 'list #'file-namestring + (uiop:directory-files path)))) + (list (with-html-string (:doctype) + (:html + (:head (:script ())) + (:body + (:ol (dolist (i files) + (:li (:a :attrs (list :href i) i)))))))))) + +(defun render-bucket-index (env) + (declare (ignore env)) + (let ((dirs ())) + (list (with-html-string (:doctype) + (: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 "keyfield") value))) + (setf (getprop xhttp 'onreadystatechange) + (lambda () + (and (= (getprop this 'ready-state) 4) + (= (getprop this 'status) 200) + (funcall (getprop console 'log) (getprop xhttp 'response-text))) + t) + (getprop xhttp 'response-type) "text/plain") + (setf text (funcall (getprop text 'replace) (regex "/\\n/g") ",")) + (funcall (getprop xhttp 'open) "POST" "/buckets/" t) + (funcall (getprop xhttp 'send) (+ "keys=" text ";")) + t)))))) + (:body + (:form (:textarea :attrs (list :type "text" :id "keyfield")) + (:input :attrs (list :type "button" :value "send" :onclick "send()"))) + (:ol (dolist (i dirs) + (:li (:a :attrs (list :href i) i)))))))))) + +(defun send-bucket-cookie (env) + (let* ((session (or (get-session env) (make-session))) + (keys (getf (keyval->plist (read-post-body env)) :keys))) + (map 'nil (lambda (k) (and (bucket-exists-p k) (open-bucket-to session k))) keys) + (list 200 (list :content-type "text/html" + :set-cookie (concatenate 'string "sesh=" (session-key session))) + (list (with-html-string + (dolist (key (session-buckets session)) + (print key) + (if (bucket-exists-p key) + (:li key)))))))) + +(defun serve-bucket (env) + (let ((path (subseq (getf env :request-uri) 1))) + (cond ((eq (getf env :request-method) :post) + (send-bucket-cookie env)) + ((probe-file path) + (if (string= path "buckets/") + (list 200 '(:content-type "text/html") (render-bucket-index env)) + (list 200 '(:content-type "text/html") (render-bucket env path)))) + (t (http-status 404))))) + +(register-handler (mangle-path "/buckets/") 'serve-bucket) + +;;; server! + +(defun app (env) + ;;;(print env) + (push env *old-requests*) + (if (string= (getf env :request-uri) "/favicon.ico") + '(200 (:content-type "image/vnd.microsoft.icon") #p"res/favicon.ico") + (funcall (find-handler (getf env :request-uri)) env))) + +(let ((thread nil)) + (defun run-server () + (if (or (null thread) (not (thread-alive-p thread))) + (setf thread (make-thread (lambda () (run #'app)) :name "woo-server-thread")))) + (defun stop-server () + (progn thread (destroy-thread thread) (setf thread nil))) + (defun restart-server () + (stop-server) + (run-server))) + +;;; BKNR + +(make-instance 'mp-store + :directory "bknr/" + :subsystems (list (make-instance 'store-object-subsystem))) diff --git a/webshit2.asd b/webshit2.asd new file mode 100644 index 0000000..abbd262 --- /dev/null +++ b/webshit2.asd @@ -0,0 +1,8 @@ +(defsystem "webshit2" + :description "Upcoming web site." + :version "0.0.1" + :author "Meido " + :licence "GPL" + :depends-on ("bknr.datastore" "woo" "spinneret" "split-sequence" "bordeaux-threads" "parenscript" + "uuid" "flexi-streams") + :components ((:file "webshit")))