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