diff of 41a2d28dd6005fff9199b1da097b13c3bbfebbaf
41a2d28dd6005fff9199b1da097b13c3bbfebbaf
diff --git a/aggressive-murja.asd b/aggressive-murja.asd
index 2a86a33..02ecefc 100644
--- a/aggressive-murja.asd
+++ b/aggressive-murja.asd
@@ -28,7 +28,8 @@
"cl-date-time-parser"
"alexandria"
"uuid"
- "cl-hash-util")
+ "cl-hash-util"
+ "spinneret")
:description "A rewrite of the <a href=\"https://github.com/feuery/murja-blog/\">murja blogging engine</a> in lisp"
:components ((:module "src"
:components
@@ -68,6 +69,18 @@
(:file "rss-reader-routes")
(:file "user-editor")
(:file "root-routes")))
+
+ (:module "model"
+ :components
+ ((:file "user")
+ (:file "post")
+ (:file "settings")))
+ (:module "view"
+ :components
+ ((:file "common")
+ (:module "components"
+ :components ((:file "blogpost")))
+ (:file "blog-root")))
(:file "main"))))
:in-order-to ((test-op (test-op "aggressive-murja/tests"))))
@@ -86,6 +99,5 @@
:perform (test-op (op c)
(eval (read-from-string "(fiveam:run! 'murja.tests:main-suite)"))))
-;; (asdf:make "aggressive-murja")
-;; (asdf:make "aggressive-murja/tests")
-;; (murja:start-server)
+;; (ql:quickload "aggressive-murja")
+;; (cl-user::run)
diff --git a/resources/css/murja.css b/resources/css/murja.css
index 77b22cf..3ff46d7 100644
--- a/resources/css/murja.css
+++ b/resources/css/murja.css
@@ -294,6 +294,11 @@ header {
.tags {
background-color: #A0A0A0;
font-size: 1.3em;
+ list-style: none;
+}
+
+.tags > li {
+ display: inline;
}
.feed {
@@ -434,6 +439,18 @@ input:required {
.initial-form > label > input {
}
+.page-post-list {
+ list-style: none;
+}
+
+.previously {
+ list-style: none;
+}
+
+.previously > li {
+ display: inline;
+}
+
@media only screen and (max-device-width:480px)
{
body {
diff --git a/src/model/post.lisp b/src/model/post.lisp
new file mode 100644
index 0000000..ab56ca3
--- /dev/null
+++ b/src/model/post.lisp
@@ -0,0 +1,129 @@
+(defpackage murja.model.post
+ (:use :cl)
+ (:export :Post :get-page :get-post :post-id :post-title :article :creator :tags :created-at :post-hidden? :post-unlisted? :next-post-id :previous-post-id :previouslies
+ :id :title :creator :created-at :content)
+ (:import-from :com.inuoe.jzon :parse))
+
+(in-package :murja.model.post)
+
+;; fuck it we're moving from hashmaps to clos now
+(defclass Post ()
+ ;; slots are copied from the table blog.Post, accessors are what I might call these were I designing the db nowadays
+ ((id :initarg :id :accessor post-id :col-type integer)
+ (title :initarg :title :accessor post-title :col-type string)
+ (content :initarg :content :accessor article :col-type string)
+ (creator :initarg :creator :initform nil :accessor creator)
+ (creator-id :initarg :creator-id :col-type string :reader creator-id :col-references (murja.model.user:user 'murja.model.user::id))
+ (tags :initarg :tags :accessor tags :col-type string)
+ (created-at :initarg :created-at :accessor created-at :col-type simple-date:timestamp)
+ (hidden :initarg :hidden? :accessor post-hidden? :col-type boolean)
+ (unlisted :initarg :unlisted? :accessor post-unlisted? :col-type boolean)
+ (previous :ghost t :initarg :previous :accessor previous-post-id :col-type integer :initform -1)
+ (next :initform -1 :ghost t :initarg :next :accessor next-post-id :col-type integer)
+
+ (previouslies :initform nil :ghost t :initarg ghostlies :accessor previouslies :col-type string))
+ (:metaclass postmodern:dao-class)
+ (:keys id)
+ (:table-name "blog.Post"))
+
+(defmethod print-object ((p Post) output)
+ (with-slots (creator id title content creator-id tags created-at hidden unlisted previous next previouslies) p
+ (format output "#<POST: ~{~{~a: ~s~}~^,~%~t ~}>" (list
+ (list :id id)
+ (list :title title)
+ (list :content
+ (if (> (length content) 50)
+ (format nil "~a..."
+ (str:substring 0 50 content))
+ content))
+ (list :creator-id creator-id)
+ (list :creator creator)
+ (list :tags tags)
+ (list :created-at created-at)
+ (list :hidden hidden)
+ (list :unlisted unlisted)
+ (list :previous previous)
+ (list :next next)
+ (list :previouslies previouslies)))))
+
+;; (postmodern:query "SELECT * FROM blog.Post limit 1" (:dao post :single))
+;; (postmodern:get-dao 'Post 349)
+;; #<POST: ID: 349, TITLE: "Lisp webapps ", CONTENT: "<p>So, after <a href=\"https://feuerx.net/blog/post...", CREATOR-ID: 1, TAGS: "[\"postgresql\", \"hunchentoot\", \"lisp\", \"programming\"]", CREATED-AT: #<SIMPLE-DATE:TIMESTAMP 22-02-2025T09:31:40,016>, HIDDEN: NIL, UNLISTED: NIL>
+
+(defun fix-post (p)
+ ;; let's coerce this array into list, #() is truthy according to lisp
+ (setf (tags p) (coerce (parse (tags p)) 'list))
+
+ (unless (previouslies p)
+ (format t "ERROR previouslies were nil. Have you forgotten to join them to your posts?~%"))
+
+ (if (equalp "[null]" (previouslies p))
+ (setf (previouslies p) nil)
+ (when (stringp (previouslies p))
+ (setf (previouslies p) (coerce (parse (previouslies p)) 'list))))
+
+ (setf (creator p) (postmodern:get-dao 'murja.model.user:user (creator-id p)))
+
+ ;; next-id and previous-id might point to unlisted posts. They should not do that, but I don't know how to wrangle *post-query* sql to support that, so they have to be fixed in lisp.
+ (unless (or (equalp (previous-post-id p) -1)
+ (not (caar (postmodern:query "SELECT unlisted FROM blog.Post WHERE id = $1" (previous-post-id p)))))
+ (setf (previous-post-id p)
+ (or (caar (postmodern:query "SELECT id FROM blog.Post WHERE ID < $1 AND NOT hidden AND NOT unlisted" (previous-post-id p)))
+ -1)))
+
+ (unless (or (equalp (next-post-id p) -1)
+ (not (caar (postmodern:query "SELECT unlisted FROM blog.Post WHERE id = $1" (next-post-id p)))))
+ (setf (next-post-id p)
+ (or (caar (postmodern:query "SELECT id FROM blog.Post WHERE ID > $1 AND NOT hidden AND NOT unlisted" (next-post-id p)))
+ -1)))
+ p)
+
+(defparameter *post-query*
+ "
+SELECT * FROM
+(SELECT p.*,
+ LAG(p.id, 1, -1) OVER (ORDER BY created_at) as previous,
+ LEAD(p.id, 1, -1) OVER (ORDER BY created_at) as next,
+ JSON_AGG(TO_JSONB (pl.*) - 'referencee_id') as previouslies
+ FROM blog.Post p
+ LEFT JOIN blog.Previously_Link_Titles pl ON (p.id = pl.referencee_id AND
+ EXISTS (SELECT * FROM blog.Post pp WHERE pp.id = pl.id AND NOT pp.hidden AND NOT pp.unlisted))
+ WHERE (NOT p.hidden OR (p.hidden AND $2))
+ GROUP BY p.id
+)
+where id = $1
+")
+
+(defun get-post (id &key allow-hidden?)
+ (let ((p (postmodern:query *post-query* id allow-hidden? (:dao Post :single))))
+ (when p
+ (fix-post p))
+ p))
+
+(defun get-page (page page-size &key allow-hidden? modified-since)
+ (let* ((page (if (< page 1)
+ 1
+ page)))
+ (map 'list
+ #'fix-post
+ (postmodern:query
+ "SELECT p.*, JSON_AGG(TO_JSONB (pl.*) - 'referencee_id') as previouslies
+FROM blog.Post p
+LEFT JOIN blog.Previously_Link_Titles pl ON (p.id = pl.referencee_id AND
+ EXISTS (SELECT * FROM blog.Post pp WHERE pp.id = pl.id AND NOT pp.hidden AND NOT pp.unlisted))
+WHERE ((NOT p.unlisted) OR $3)
+ AND ((NOT p.hidden) OR $3)
+ AND (($4::timestamp IS NULL) OR p.created_at > $4::timestamp)
+GROUP BY p.id
+ORDER BY p.created_at DESC
+LIMIT $2
+OFFSET $1"
+ (* (1- page) page-size)
+ page-size
+ allow-hidden?
+ (if modified-since
+ modified-since
+ :null)
+ (:dao Post)))))
+
+;;(get-post 1)
diff --git a/src/model/settings.lisp b/src/model/settings.lisp
new file mode 100644
index 0000000..a6337ad
--- /dev/null
+++ b/src/model/settings.lisp
@@ -0,0 +1,14 @@
+(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/model/user.lisp b/src/model/user.lisp
new file mode 100644
index 0000000..e06375b
--- /dev/null
+++ b/src/model/user.lisp
@@ -0,0 +1,61 @@
+(defpackage murja.model.user
+ (:use :cl)
+ (:local-nicknames (:json :com.inuoe.jzon))
+ (:export :User :user-id :user-username :user-password :user-nickname :user-img-location :abilities))
+
+(in-package :murja.model.user)
+
+(defclass User ()
+ ((id :initarg :id :accessor user-id :col-type integer)
+ (username :initarg :username :accessor user-username :col-type string)
+ (password :initarg :password :accessor user-password :col-type string)
+ (nickname :initarg :nickname :accessor user-nickname :col-type string)
+ (img-location :initform "" :initarg :img-location :accessor user-img-location :col-type string)
+ (abilities :ghost t :initarg :abilities :initform #() :accessor abilities :col-type string))
+
+ (:metaclass postmodern:dao-class)
+ (:keys id)
+ (:table-name "blog.Users"))
+
+(defmethod print-object ((usr User) output)
+ (with-slots (id username nickname img-location abilities) usr
+
+ (format output "#<USER: ~{~{~a: ~s~}~^,~%~t ~}>" (list
+ (list :id id)
+ (list :username username)
+ (list :nickname nickname)
+ (list :password "******")
+ (list :img-location img-location)
+ (list :abilities abilities)))))
+
+(defparameter *user-query*
+ "SELECT
+ u.id,
+ u.username,
+ u.nickname,
+ u.img_location,
+ u.password,
+ json_agg(DISTINCT perm.action) as abilities
+FROM
+ blog.users u
+ left JOIN blog.groupmapping gm ON u.id = gm.userid
+ left JOIN blog.grouppermissions gp ON gp.groupid = gm.groupid
+ left JOIN blog.permission perm ON gp.permissionid = perm.id
+WHERE
+ u.id = $1
+GROUP BY
+ u.id;")
+
+(defun get-user (id)
+ "Gets user and populates its abilities"
+ (let ((usr (postmodern:query *user-query* id (:dao User :single))))
+ (with-slots (abilities) usr
+ (when (stringp abilities)
+ (setf abilities (json:parse abilities))))
+ usr))
+
+
+;; (postmodern:get-dao 'User 1)
+
+;; (get-user 1)
+
diff --git a/src/view/blog-root.lisp b/src/view/blog-root.lisp
new file mode 100644
index 0000000..e95ff2a
--- /dev/null
+++ b/src/view/blog-root.lisp
@@ -0,0 +1,17 @@
+(defpackage murja.view.blog-root
+ (:use :cl :binding-arrows
+ :murja.view.components.blogpost
+ :murja.view.common :easy-routes
+ :murja.model.settings :cl-hash-util)
+ (: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)))))
diff --git a/src/view/common.lisp b/src/view/common.lisp
new file mode 100644
index 0000000..957bf7d
--- /dev/null
+++ b/src/view/common.lisp
@@ -0,0 +1,32 @@
+(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
new file mode 100644
index 0000000..8292a45
--- /dev/null
+++ b/src/view/components/blogpost.lisp
@@ -0,0 +1,56 @@
+(defpackage murja.view.components.blogpost
+ (:use :cl :binding-arrows :spinneret :murja.model.post :murja.model.user :cl-hash-util)
+ (:export :page))
+
+
+(in-package :murja.view.components.blogpost)
+
+(defun previously (prev)
+ (with-keys ("id" "title") prev
+ (with-html
+ (:li
+ (:a :title title :href (format nil "/blog/post/~d" id) "Previously")))))
+
+(defun tag (tag)
+ (with-html
+ (:li
+ (:a :href (format nil "/blog/tags/~a" tag) tag))))
+
+(defun blogpost (post)
+ (with-slots (id title creator created-at content previouslies tags) post
+ (assert creator)
+ (let ((img-location (user-img-location creator))
+ (nickname (user-nickname creator)))
+ (assert img-location)
+ (with-html
+ (:div.post
+ (:a :href (format nil "/blog/post/~d" id) title)
+ (:div.meta
+ (:img.user_avatar :src img-location)
+ (:p ("By ~a" nickname))
+ (:p ("Written at ~a" (let ((lisp-fixup:*rfc822* t))
+ (lisp-fixup:fix-timestamp created-at)))))
+
+ ;; TODO
+ ;; (:a :href ("/blog/post/edit/~d" id) "Edit this post")
+ (:article.content
+ (:raw
+ content))
+ (:ul.previously
+ (map 'list #'previously previouslies))
+ (:ul.tags
+ (map 'list #'tag tags))
+ (:div)))))) ;; next and previous post ?????????
+
+(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)))))
+
+