Initial commit

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)))

webshit2.asd

@@ -0,0 +1,8 @@
+(defsystem "webshit2"
+  :description "Upcoming web site."
+  :version "0.0.1"
+  :author "Meido <mil@bloome.rs>"
+  :licence "GPL"
+  :depends-on ("bknr.datastore" "woo" "spinneret" "split-sequence" "bordeaux-threads" "parenscript"
+				"uuid" "flexi-streams")
+  :components ((:file "webshit")))