diff of bb29e797eb31817f9a47b6ddeb452bdf385bd378
bb29e797eb31817f9a47b6ddeb452bdf385bd378
diff --git a/aggressive-murja.asd b/aggressive-murja.asd
index 02ecefc..3b2051f 100644
--- a/aggressive-murja.asd
+++ b/aggressive-murja.asd
@@ -42,6 +42,7 @@
(:module "users"
:components ((:file "user-db")))
(:file "session-db")
+ (:file "settings")
(:module "middleware"
:components ((:file "json")
(:file "db")
@@ -73,13 +74,13 @@
(:module "model"
:components
((:file "user")
- (:file "post")
- (:file "settings")))
+ (:file "post")))
(:module "view"
:components
- ((:file "common")
- (:module "components"
- :components ((:file "blogpost")))
+ ((:module "components"
+ :components ((:file "root")
+ (:file "tabs")
+ (:file "blogpost")))
(:file "blog-root")))
(:file "main"))))
:in-order-to ((test-op (test-op "aggressive-murja/tests"))))
diff --git a/src/local-lib/lisp-fixup.lisp b/src/local-lib/lisp-fixup.lisp
index 99b5cdd..c70c47d 100644
--- a/src/local-lib/lisp-fixup.lisp
+++ b/src/local-lib/lisp-fixup.lisp
@@ -1,6 +1,7 @@
(defpackage lisp-fixup
- (:use :cl)
+ (:use :cl :cl-hash-util)
(:export :if-modified-since->simpledate-timestamp :*rfc822*
+ :group-by
:*dev?* :to-secs
:fix-timestamp
:*now*
@@ -126,6 +127,7 @@
"Fixes timestamps returned from postmodern to a json-format elm can parse"
(multiple-value-bind (year month day hour minute second millisec)
(simple-date:decode-timestamp timestamp)
+ (declare (ignore millisec))
(let ((weekday (simple-date:day-of-week timestamp)))
(if *rfc822*
@@ -143,6 +145,7 @@
header (RFC822?) into something you can dump into PostgreSQL"
(let* ((header (str:trim (second (str:split #\, header)))))
(destructuring-bind (day month year timestamp gmt ) (str:split #\Space header)
+ (declare (ignore gmt))
(destructuring-bind (h m sec) (str:split #\: timestamp)
(let ((month (month->ordinal month)))
(when month
@@ -164,3 +167,11 @@
(round (/ ms 1000))))
(defvar *now* nil)
+
+(defun group-by (key list)
+ "Groups a list of hashmaps into a resulting hashmap per `key`"
+ (let ((acc (hash)))
+ (dolist (l list)
+ (let ((key-val (gethash key l)))
+ (push l (gethash key-val acc))))
+ acc))
diff --git a/src/middleware/db.lisp b/src/middleware/db.lisp
index be8da67..2894bbb 100644
--- a/src/middleware/db.lisp
+++ b/src/middleware/db.lisp
@@ -53,4 +53,5 @@
(setf (hunchentoot:return-code*) 500)
(return-from @transaction "Internal Server Error"))))
(with-transaction ()
- (funcall next)))))
+ (let ((murja.settings:*settings* (murja.settings:get-settings)))
+ (funcall next))))))
diff --git a/src/model/settings.lisp b/src/model/settings.lisp
deleted file mode 100644
index a6337ad..0000000
--- a/src/model/settings.lisp
+++ /dev/null
@@ -1,14 +0,0 @@
-(defpackage murja.model.settings
- (:use :cl)
- (:export :get-settings))
-
-(in-package :murja.model.settings)
-
-(defun get-settings ()
- (reduce (lambda (acc pair)
- (destructuring-bind (k v) pair
- (setf (gethash k acc) (com.inuoe.jzon:parse v))
- acc))
- (postmodern:query "SELECT key, value FROM blog.Settings")
-
- :initial-value (make-hash-table :test 'equal)))
diff --git a/src/settings.lisp b/src/settings.lisp
new file mode 100644
index 0000000..7c06fcf
--- /dev/null
+++ b/src/settings.lisp
@@ -0,0 +1,16 @@
+(defpackage murja.settings
+ (:use :cl)
+ (:export :*settings* :get-settings))
+
+(in-package :murja.settings)
+
+(defun get-settings ()
+ (reduce (lambda (acc pair)
+ (destructuring-bind (k v) pair
+ (setf (gethash k acc) (com.inuoe.jzon:parse v))
+ acc))
+ (postmodern:query "SELECT key, value FROM blog.Settings")
+
+ :initial-value (make-hash-table :test 'equal)))
+
+(defvar *settings* nil "A hashmap view of `select * from blog.settings`. If this variable is nil, wrap your route with @transaction middleware. If you setf keys here, remember to update db too with murja.settings:update-setting")
diff --git a/src/view/blog-root.lisp b/src/view/blog-root.lisp
index e95ff2a..672b55e 100644
--- a/src/view/blog-root.lisp
+++ b/src/view/blog-root.lisp
@@ -1,17 +1,15 @@
(defpackage murja.view.blog-root
(:use :cl :binding-arrows
:murja.view.components.blogpost
- :murja.view.common :easy-routes
- :murja.model.settings :cl-hash-util)
+ :easy-routes
+ :murja.settings :cl-hash-util)
+ (:import-from :murja.view.components.tabs :deftab)
(:import-from :murja.model.post :get-page))
(in-package :murja.view.blog-root)
-
-(defroute root ("/" :method :get
- :decorators (murja.middleware.db:@transaction)) ()
- (with-keys ("recent-post-count" "blog-title") (get-settings)
- (let ((page (get-page 1 recent-post-count)))
-
- (with-page (format nil "~s - Page ~d" blog-title 1)
- (page page)))))
+(deftab root (:url "/"
+ :title "Home")
+ (let* ((recent-post-count (gethash "recent-post-count" murja.settings:*settings*))
+ (loaded-page (get-page 1 recent-post-count)))
+ (page loaded-page)))
diff --git a/src/view/common.lisp b/src/view/common.lisp
deleted file mode 100644
index 957bf7d..0000000
--- a/src/view/common.lisp
+++ /dev/null
@@ -1,32 +0,0 @@
-(defpackage murja.view.common
- (:use :cl :binding-arrows :spinneret :cl-hash-util :murja.model.settings)
- (:export :with-page))
-
-(in-package :murja.view.common)
-
- ;; <link href="/resources/murja.css" rel="stylesheet" type="text/css">
- ;; <script src="https://unpkg.com/ace-custom-element@latest/dist/index.min.js" type="module"></script>
- ;; <meta charset="UTF-8" />
- ;; <script src="/resources/murja.js"></script>
-
-(defun header ()
- (with-keys ("blog-title") (get-settings)
- (with-html
- (:header
- ;; TODO should :href to blog home be parametrizable
- (:a :href "/" blog-title)))))
-
-
-
-(defmacro with-page (title &body body)
- `(format nil "<!DOCTYPE html>~%~a"
- (with-html-string
- (:html
- (:head
- (:title ,title)
- (:link :href "/resources/murja.css" :rel "stylesheet" :type "text/css")
- (:meta :charset "UTF-8")
- (:script :src "/resources/murja.js"))
- (:body
- (header)
- ,@body)))))
diff --git a/src/view/components/blogpost.lisp b/src/view/components/blogpost.lisp
index 8292a45..c4edfca 100644
--- a/src/view/components/blogpost.lisp
+++ b/src/view/components/blogpost.lisp
@@ -44,13 +44,12 @@
(defun page (page)
(with-html
- (:div (:h* "Page chrome")
- (:ul.page-post-list
- (map 'list
- (lisp-fixup:compose (lambda (c)
- (with-html
- (:li c)))
- #'blogpost)
- page)))))
+ (:ul.page-post-list
+ (map 'list
+ (lisp-fixup:compose (lambda (c)
+ (with-html
+ (:li c)))
+ #'blogpost)
+ page))))
diff --git a/src/view/components/root.lisp b/src/view/components/root.lisp
new file mode 100644
index 0000000..c0db5f2
--- /dev/null
+++ b/src/view/components/root.lisp
@@ -0,0 +1,72 @@
+(defpackage murja.view.components.root
+ (:use :cl :spinneret :binding-arrows
+ :murja.settings
+ :murja.middleware.auth
+ :murja.model.user)
+
+ (:export :*inject-to-head* :root-component)
+ (:import-from :murja.posts.post-db :get-titles-by-year))
+
+(in-package :murja.view.components.root)
+
+(defun sidebar-tree ()
+ (let* ((sidebar-titles (->>
+ (get-titles-by-year)
+ (lisp-fixup:group-by "Year"))))
+ (with-html
+ (:ul :id "grouper"
+ (loop for year being the hash-keys of sidebar-titles
+ collecting (:li
+ (:details
+ (:summary (format nil "~a (~d)" year (length (gethash year sidebar-titles))))
+ (:ul
+ (let ((by-month (lisp-fixup:group-by "Month" (gethash year sidebar-titles))))
+ (loop for month being the hash-keys of by-month
+ collecting (:li
+ (:details
+ (:summary (format nil "~a (~d)" month (length (gethash month by-month))))
+ (:ul
+ (map 'list
+ (lambda (title)
+ (cl-hash-util:with-keys ("Id" "Title") title
+ (:li (:a :href (format nil "/blog/post/~d" Id)
+ Title))))
+ (gethash month by-month)))))))))))))))
+
+(defun loginform/user-widget ()
+ (with-html
+ (if *user*
+ (:p :data-testid "welcome-user-label"
+ "Welcome, " (:a :href "/blog/usersettings" (user-nickname *user*)))
+ (:form :method "post" :action "/api/login"
+ (:label "Username "
+ (:input :id "username" :name "username" :data-testid "username-input-field"))
+ (:label "Password "
+ (:input :id "password" :name "password" :type "password" :data-testid "password-input-field"))
+ (:input :type :submit :value "Log in")))))
+
+
+
+(defvar *inject-to-head* nil)
+(defmacro root-component (inner-component)
+ (assert inner-component)
+ "Returns the root html element of murja with `inner-component` embedded inside it"
+ `(format nil "<!DOCTYPE html>~%~a"
+ (with-html-string
+ (:html
+ (:head
+ (:link :href "/resources/murja.css" :rel "stylesheet" :type "text/css")
+ (:script :src "/resources/newui.js")
+ (:meta :charset "UTF-8")
+ (dolist (head-element *inject-to-head*)
+ (funcall head-element)))
+
+ (:body
+ (:header
+ (:a :href "/" (gethash "blog-title" *settings* )))
+
+ (:div :class "sidebar-flex"
+ ,inner-component
+ (:div :id "sidebar"
+ (loginform/user-widget)
+ (sidebar-tree))))))))
diff --git a/src/view/components/tabs.lisp b/src/view/components/tabs.lisp
new file mode 100644
index 0000000..30aacf5
--- /dev/null
+++ b/src/view/components/tabs.lisp
@@ -0,0 +1,110 @@
+(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 ,needed-abilities
+ :require-login ,require-login
+ :subtab ,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 ,(intern (format nil "~a-sym" sym)) (,url
+ :method :get
+ :decorators (@transaction
+ ;;@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 (lisp-fixup:compose #'string-lessp #'title))
+
+ (with-html
+ (:div.tabs :id "topbar"
+ (:ul.tab-headers
+ (dolist (tab tablist)
+ (:li :class (format nil "tab-header ~a" (when (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")))))
+