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.
252 lines
8.1 KiB
252 lines
8.1 KiB
;;;; 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)
|
|
|
|
(defparameter *project-directory* (asdf:system-source-directory :webshit2))
|
|
|
|
(defun make-absolute (&rest paths)
|
|
(merge-pathnames
|
|
(reduce (lambda (s ss) (concatenate 'string s ss))
|
|
(map 'list
|
|
(lambda (path)
|
|
(if (char= (char path 0) #\/) (subseq path 1) path))
|
|
paths))
|
|
*project-directory*))
|
|
|
|
(map 'list (lambda (dir) (ensure-directories-exist (make-absolute dir)))
|
|
(list
|
|
"bknr/"
|
|
"buckets/"
|
|
"static/"
|
|
))
|
|
|
|
;;; 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 (make-absolute "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 (make-absolute 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 ()
|
|
(if (and (= (getprop this 'ready-state) 4)
|
|
(= (getprop this 'status) 200))
|
|
(progn
|
|
(funcall (getprop console 'log) (getprop xhttp 'response-text))
|
|
(setf (chain document (get-element-by-id "buckets")
|
|
inner-h-t-m-l)
|
|
(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 :attrs (list :id "buckets") (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 (make-absolute 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)
|
|
|
|
;;; Static files
|
|
|
|
(defun serve-file (env) ; This is dum
|
|
(if (uiop:file-exists-p (make-absolute (getf env :request-uri)))
|
|
(list 200 '(:content-type "text/html") (make-absolute (getf env :request-uri)))
|
|
(http-status 404)))
|
|
|
|
(register-handler (mangle-path "/static/") 'serve-file)
|
|
|
|
;;; 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") (make-absolute #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 :address "0.0.0.0"))
|
|
: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)))
|