src/view/components/tabs.lisp

(defpackage murja.view.components.tabs
  (:use :cl :easy-routes :murja.middleware.auth :murja.view.components.root :spinneret)
  (:import-from :murja.middleware.db :@transaction)
  (:export :*inject-to-head* :deftab))

(in-package :murja.view.components.tabs)

(defclass tab ()
  ((url :initarg :url :initform nil :accessor tab-url)
   (component :initarg :component :initform (error "Component needed") :accessor tab-component)
   (title :initarg :title :initform (error "Title needed") :accessor title)
   (require-login :initarg :require-login :initform nil :accessor require-login)
   (needed-abilities :initarg :abilities :initform nil :accessor abilities)
   (subtab :initarg :subtab :initform nil :accessor subtab)))

;; A hack for deducing runtime if a value is instanceof 'tab.
;; I got tired of trying to find a java-style instanceof operator that would polymorphically work for every value :D
(defmethod is-tab? ((tabb tab))
  t)

(defmethod is-tab? ((tabb t))
  nil)

(defmethod print-object ((tabb tab) output)
  (format output "#<TAB: ~a ~a>" (tab-url tabb) (title tabb)))


(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *tabs* (make-hash-table :test 'equal)
    "A list of tabs, keyed by symbol and valued by instances of tab class"))


(defmacro deftab (sym (&key
			 url
			 (title "")
			 subtab 
			 require-login
			 needed-abilities
			 captured-url-params
			 inject-to-head)
		  &body rst)
  `(progn
     (setf (gethash (quote ,sym) *tabs*)
	   (make-instance 'tab :url ,url
			       :abilities (list ,@needed-abilities)
			       :require-login ,require-login
			       :subtab (quote ,subtab)
			       :title ,title
			       :component (lambda (&rest all)
					    (destructuring-bind ,captured-url-params all 
					      (murja.middleware.db:with-db
						  (let ((murja.settings:*settings* (murja.settings:get-settings)))
						    (with-html 
						      ,@rst)))))))
     (defroute ,sym (,url 
		     :method :get
		     :decorators (@transaction
				  (@ssr-authenticated :require-authentication ,require-login )
				  ;;@check-if-initial
				  (@dispatcher ,inject-to-head)
				  )) ()
       (values (quote ,sym) (list ,@captured-url-params)))))

(defun tab-container (selected-tab tablist tab-parameters)
  (assert (is-tab? selected-tab))
  (assert (every #'is-tab? tablist))
  
  (sort tablist (lambda (a b)
		  (string-lessp (title a) (title b))))
  
  (with-html
    (:div.tabs :id "topbar"
	       (:ul.tab-headers
		(dolist (tab tablist)
		  (unless (subtab tab)
		    (:li :class (format nil "tab-header ~a" (if (equalp tab selected-tab)
								"tab-selected"
								""))
			 ;; wonder if this is actually necessary or just an artifact of the old newui branch?
			 :data-href (tab-url tab)
			 (:a :href (tab-url tab)
			     (title tab))))))
	       (apply (tab-component selected-tab) tab-parameters))))
  

(defun @dispatcher (next inject-to-head)
  (multiple-value-bind (sym url-params) (funcall next)
    (let* ((tab (gethash sym *tabs*))
	   ;; inject-to-head gets passed through to macros here as an unevaluated list
	   ;; and I don't understand why that happens, but this fixes the symptom and
	   ;; shouldn't expose too much vulnerabilities as :inject-to-head is trusted data 
	   (inject-to-head (map 'list
				#'eval
				inject-to-head))
	   (usr-abilities (when *user*
			    (coerce (murja.model.user:abilities *user*) 'list))))
      (assert tab)
      (if (or (not (abilities tab))
	      (intersection usr-abilities (abilities tab))
	      (or (not (require-login tab))
		  *user*))
	  (let ((*inject-to-head* inject-to-head))
	    (root-component
	     (tab-container tab 
			    (remove-if-not (lambda (tab)
					     (or (not (require-login tab))
						 (subtab tab)
						 *user*))
					   (alexandria:hash-table-values 
					    *tabs*))
			    url-params)))
	  (progn
	    (setf (hunchentoot:return-code*) 404)
	    "Nothing found")))))