diff of 38897e83a84687fd15bbd07dedfd5202fc2dcbed
38897e83a84687fd15bbd07dedfd5202fc2dcbed
diff --git a/aggressive-murja.asd b/aggressive-murja.asd
index 9cf662a..1daef03 100644
--- a/aggressive-murja.asd
+++ b/aggressive-murja.asd
@@ -48,7 +48,8 @@
(:module "model"
:components
((:file "user")
- (:file "post")))
+ (:file "post")
+ (:file "log")))
(:module "middleware"
:components ((:file "json")
(:file "db")
@@ -90,10 +91,12 @@
:components ((:file "tag-script")
(:file "previouslies-script")
(:file "dnd-script")
- (:file "editor")))
+ (:file "editor")
+ (:file "log")))
(:file "post-list")
(:file "media-admin")
- (:file "new-post")))
+ (:file "new-post")
+ (:file "logs")))
(:file "rss")))
(:file "main"))))
:build-operation program-op
diff --git a/resources/testlog b/resources/testlog
new file mode 100644
index 0000000..283c13c
--- /dev/null
+++ b/resources/testlog
@@ -0,0 +1,10 @@
+Nov 14 20:52:13 feuerx-upcloud murja[3995430]: Connecting to db (blogdb blogadmin $password localhost PORT 5432)
+Nov 14 20:52:13 feuerx-upcloud murja[3995430]: löydetäänköhän me NIL
+Nov 14 20:52:13 feuerx-upcloud murja[3995430]: Connecting to db (blogdb blogadmin $password localhost PORT 5432)
+Nov 14 20:52:13 feuerx-upcloud murja[3995430]: *inject-to-sidebar* is nothing
+Nov 14 20:52:13 feuerx-upcloud murja[3995430]: 127.0.0.1 (34.230.124.21) - [2025-11-14 20:52:13] "GET /post/3 HTTP/1.1" 200 37095 "-" "Mozilla/5.0 AppleWebKit/537.36 (KHTML, like Gecko; compatible; Amazonbot/0.1; +https://developer.amazon.com/support/amazonbot) Chrome/119.0.6045.214 Safari/537.36"
+Nov 14 20:52:17 feuerx-upcloud murja[3995430]: Connecting to db (blogdb blogadmin $password localhost PORT 5432)
+Nov 14 20:52:17 feuerx-upcloud murja[3995430]: löydetäänköhän me NIL
+Nov 14 20:52:17 feuerx-upcloud murja[3995430]: Connecting to db (blogdb blogadmin $password localhost PORT 5432)
+Nov 14 20:52:17 feuerx-upcloud murja[3995430]: *inject-to-sidebar* is nothing
+Nov 14 20:52:17 feuerx-upcloud murja[3995430]: 127.0.0.1 (44.205.192.249) - [2025-11-14 20:52:17] "GET /post/9 HTTP/1.1" 200 39075 "-" "Mozilla/5.0 AppleWebKit/537.36 (KHTML, like Gecko; compatible; Amazonbot/0.1; +https://developer.amazon.com/support/amazonbot) Chrome/119.0.6045.214 Safari/537.36"
\ No newline at end of file
diff --git a/src/local-lib/lisp-fixup.lisp b/src/local-lib/lisp-fixup.lisp
index f6fed47..d594457 100644
--- a/src/local-lib/lisp-fixup.lisp
+++ b/src/local-lib/lisp-fixup.lisp
@@ -9,7 +9,8 @@
:sha-512 :partial
:compose :drop
:slurp-bytes :slurp-utf-8
- :range :range2))
+ :range :range2
+ :formdata->hashmap))
(in-package :lisp-fixup)
@@ -183,3 +184,17 @@
(let ((key-val (gethash key l)))
(push l (gethash key-val acc))))
acc))
+
+
+(defun formdata->hashmap (form-body)
+ (reduce (lambda (acc pair)
+ (let ((k (first pair))
+ (v (hunchentoot:url-decode (second pair))))
+ (setf (gethash k acc) v)
+ acc))
+ (binding-arrows:->>
+ form-body
+ (str:split "&")
+ (mapcar (lisp-fixup:partial #'str:split "=")))
+
+ :initial-value (hash)))
diff --git a/src/model/log.lisp b/src/model/log.lisp
new file mode 100644
index 0000000..a98e27c
--- /dev/null
+++ b/src/model/log.lisp
@@ -0,0 +1,88 @@
+(defpackage murja.model.log
+ (:use :cl :binding-arrows)
+ (:import-from :halisql :defqueries)
+ (:import-from :lisp-fixup :partial)
+ (:export :get-alarmy-groups :get-groups :get-logs))
+
+(in-package :murja.model.log)
+
+(defun get-logs ()
+ "Shells out to `journalctl -xeu Murja.service` and returns whatever it happens to output.
+
+If lisp-fixup:*dev?* happens to be truthy, this instead cats a log-file from `(asdf:system-relative-pathname :aggressive-murja \"resources/testlog\")`"
+ (str:split (format nil "~%")
+ (let ((fstr (make-array '(0) :element-type 'character
+ :fill-pointer 0 :adjustable t)))
+ (with-output-to-string (s fstr)
+ (if lisp-fixup:*dev?*
+ (sb-ext:run-program "/bin/cat" (list (format nil "~a" (asdf:system-relative-pathname :aggressive-murja "resources/testlog"))) :output s)
+ (sb-ext:run-program "/usr/bin/journalctl" (list "-xeu" "Murja.service") :output s))
+ fstr))))
+
+(defun get-groups ()
+ (coerce
+ (postmodern:query "SELECT name, alarmy FROM blog.log_group" :array-hash)
+ 'list))
+
+
+(defun count-reads (groups logs)
+ "Takes in whatever groups there are in the database, current logs and returns counts of each group in a hashmap"
+ (reduce (lambda (acc group-regex)
+ (let ((count (->>
+ logs
+ (remove-if-not (partial #'cl-ppcre:scan group-regex))
+ length)))
+ (setf (gethash group-regex acc)
+ count)
+ acc))
+ (->>
+ groups
+ (mapcar (partial #'gethash "name")))
+ :initial-value (make-hash-table)))
+
+(defqueries "log-fns")
+
+(defun db-counts (user-id)
+ (let ((counts (coerce (get-log-group-counts* user-id) 'list)))
+ (reduce (lambda (acc hash-table)
+ (setf (gethash (gethash "name" hash-table) acc)
+ (gethash "read_count" hash-table))
+ acc)
+ counts
+ :initial-value (make-hash-table :test 'equal))))
+
+(defun get-alarmy-groups (user-id read-counts groups)
+ (let ((db-counts (db-counts user-id)))
+ (->>
+ groups
+ (remove-if-not (partial #'gethash "alarmy"))
+ (remove-if (lambda (group)
+ (let ((name (gethash "name" group)))
+ (= (or (gethash name db-counts) 0)
+ (gethash name read-counts)))))
+ (mapcar (partial #'gethash "name")))))
+
+
+;; (defroute get-logs-groups ("/api/logs/groups" :method :get
+;; :decorators (@transaction
+;; @json
+;; @authenticated
+;; (@can? "update-settings"))) ()
+;; (let ((user-id (gethash "id" *user*)))
+;; (assert user-id)
+;; (let* ((groups (get-groups))
+;; (read-counts (count-reads groups (get-logs)))
+;; (alarmy-groups (get-alarmy-groups user-id read-counts groups)))
+
+;; (dolist (group groups)
+;; (let ((name (gethash "name" group)))
+;; (if (member name alarmy-groups)
+;; (setf (gethash "sound-alarm" group) t)
+;; (setf (gethash "sound-alarm" group) nil))))
+
+;; (dolist (k (alexandria:hash-table-alist read-counts))
+;; (destructuring-bind (group . count) k
+;; (log:info "Updating ~a to ~d~%" group count)
+;; (upsert-readcount* count user-id group)))
+
+;; (stringify (or groups #())))))
diff --git a/src/routes/login-routes.lisp b/src/routes/login-routes.lisp
index 2865581..0a3043e 100644
--- a/src/routes/login-routes.lisp
+++ b/src/routes/login-routes.lisp
@@ -124,33 +124,11 @@
-
-
-
-
-
-
-
-
-
-(defun formdata->hashmap (form-body)
- (reduce (lambda (acc pair)
- (let ((k (first pair))
- (v (hunchentoot:url-decode (second pair))))
- (setf (gethash k acc) v)
- acc))
- (->>
- form-body
- (str:split "&")
- (mapcar (lisp-fixup:partial #'str:split "=")))
-
- :initial-value (hash)))
-
;; forms-based login
(defroute forms-post-login ("/api/login"
:method :post
:decorators (@test-now @transaction)) ()
- (let* ((form (formdata->hashmap (hunchentoot:raw-post-data :force-text t)))
+ (let* ((form (lisp-fixup:formdata->hashmap (hunchentoot:raw-post-data :force-text t)))
(username (gethash "username" form))
(password (gethash "password" form))
(user-row (murja.users.user-db:select-user-by-login username (sha-512 password))))
diff --git a/src/routes/settings-routes.lisp b/src/routes/settings-routes.lisp
index 23adc3c..fc9c771 100644
--- a/src/routes/settings-routes.lisp
+++ b/src/routes/settings-routes.lisp
@@ -43,132 +43,3 @@
(update-setting k v))))
(setf (hunchentoot:return-code*) 204)
""))
-
-(defun get-logs ()
- "Shells out to `journalctl -xeu Murja.service` and returns whatever it happens to output"
- (let ((fstr (make-array '(0) :element-type 'character
- :fill-pointer 0 :adjustable t)))
- (with-output-to-string (s fstr)
- (sb-ext:run-program "/usr/bin/journalctl" (list "-xeu" "Murja.service") :output s ))
- fstr))
-
-(defroute api-logs ("/api/logs" :method :get
- :decorators (@transaction
- @json
- @authenticated
- (@can? "update-settings"))) ()
- (log:info "~a is asking for logs ~%" *user*)
- (labels ((logify (l)
- (let ((ht (make-hash-table)))
- (setf (gethash "row" ht) l)
- ht)))
- (if (uiop:file-exists-p *log-file*)
- (->>
- (get-logs)
- (mapcar #'logify)
- stringify)
- (->>
- (list "no logs found")
- (mapcar #'logify)
- stringify))))
-
-(defroute post-logs-groups ("/api/logs/groups" :method :post
- :decorators (@transaction
- @json
- @authenticated
- (@can? "update-settings"))) ()
- (let* ((body-str (hunchentoot:raw-post-data :force-text t))
- (body (coerce (parse body-str) 'list)))
- (log:info "Trying to save ~a~%" body-str)
- (postmodern:execute "DELETE FROM blog.log_group;")
- (dolist (group body)
- (postmodern:execute "INSERT INTO blog.log_group (name, alarmy) VALUES ($1, $2)"
- (gethash "name" group)
- (gethash "alarmy" group)))
-
- (setf (hunchentoot:return-code*) 204)
- ""))
-
-(defun get-groups ()
- (coerce
- (postmodern:query "SELECT name, alarmy FROM blog.log_group" :array-hash)
- 'list))
-
-(defun count-reads (groups logs)
- "Takes in whatever groups there are in the database, current logs and returns counts of each group in a hashmap"
- (reduce (lambda (acc group-regex)
- (let ((count (->>
- logs
- (remove-if-not (partial #'cl-ppcre:scan group-regex))
- length)))
- (setf (gethash group-regex acc)
- count)
- acc))
- (->>
- groups
- (mapcar (partial #'gethash "name")))
- :initial-value (make-hash-table)))
-
-(defqueries "log-fns")
-
-(defun db-counts (user-id)
- (let ((counts (coerce (get-log-group-counts* user-id) 'list)))
- (format t "counts: ~a~&" (mapcar #'alexandria:hash-table-alist counts))
- (reduce (lambda (acc hash-table)
- (setf (gethash (gethash "name" hash-table) acc)
- (gethash "read_count" hash-table))
- acc)
- counts
- :initial-value (make-hash-table :test 'equal))))
-
-(defun get-alarmy-groups (user-id read-counts groups)
- (let ((db-counts (db-counts user-id)))
- (->>
- groups
- (remove-if-not (partial #'gethash "alarmy"))
- (remove-if (lambda (group)
- (let ((name (gethash "name" group)))
- (= (or (gethash name db-counts) 0)
- (gethash name read-counts)))))
- (mapcar (partial #'gethash "name")))))
-
-(defroute get-log-alarms ("/api/logs/alarm" :method :get
- :decorators (@transaction
- @json
- @authenticated
- (@can? "update-settings"))) ()
- ;; hopefully nobody would be stupid enough to cache apis like these
- ;; but let's be sure
- (setf (hunchentoot:header-out "Cache-Control") "no-store")
-
- (let* ((user-id (gethash "id" *user*))
- (groups (get-groups))
- (read-counts (count-reads groups (get-logs)))
- (alarmy-groups (get-alarmy-groups user-id read-counts groups)))
- (format nil "{\"alarm\": ~:[false~;true~]}" alarmy-groups)))
-
-
-
-(defroute get-logs-groups ("/api/logs/groups" :method :get
- :decorators (@transaction
- @json
- @authenticated
- (@can? "update-settings"))) ()
- (let ((user-id (gethash "id" *user*)))
- (assert user-id)
- (let* ((groups (get-groups))
- (read-counts (count-reads groups (get-logs)))
- (alarmy-groups (get-alarmy-groups user-id read-counts groups)))
-
- (dolist (group groups)
- (let ((name (gethash "name" group)))
- (if (member name alarmy-groups)
- (setf (gethash "sound-alarm" group) t)
- (setf (gethash "sound-alarm" group) nil))))
-
- (dolist (k (alexandria:hash-table-alist read-counts))
- (destructuring-bind (group . count) k
- (log:info "Updating ~a to ~d~%" group count)
- (upsert-readcount* count user-id group)))
-
- (stringify (or groups #())))))
diff --git a/src/view/admin/components/log.lisp b/src/view/admin/components/log.lisp
new file mode 100644
index 0000000..c050f47
--- /dev/null
+++ b/src/view/admin/components/log.lisp
@@ -0,0 +1,16 @@
+(defpackage murja.view.admin.components.log
+ (:use :cl :binding-arrows :spinneret)
+ (:export :log-group))
+
+(in-package :murja.view.admin.components.log)
+
+(defun log-group (group-log)
+ (destructuring-bind (group . log) group-log
+ (with-html
+ (let* ((name (gethash "name" group)))
+ ;;(alarmy (gethash "alarmy" group))
+
+ (:li (:details
+ (:summary ("~a (~d)" name (length log)))
+ (dolist (line log)
+ (:p line))))))))
diff --git a/src/view/admin/logs.lisp b/src/view/admin/logs.lisp
new file mode 100644
index 0000000..35b0fa8
--- /dev/null
+++ b/src/view/admin/logs.lisp
@@ -0,0 +1,61 @@
+(defpackage murja.view.admin.logs
+ (:use :cl :binding-arrows :spinneret :com.inuoe.jzon :easy-routes :murja.model.log :murja.view.admin.components.log)
+ (:import-from :murja.view.components.tabs :deftab))
+
+(in-package :murja.view.admin.logs)
+
+
+
+(defroute post-logs-groups ("/api/logs/groups" :method :post
+ :decorators (murja.middleware.db:@db
+ murja.middleware.auth:@ssr-authenticated)) ()
+ (format t "Congraz on finding the REAL post-logs-groups~%")
+ (let ((form (lisp-fixup:formdata->hashmap (hunchentoot:raw-post-data :force-text t))))
+ (log:info "Trying to save ~a~%" (alexandria:hash-table-alist form))
+ ;;(postmodern:execute "DELETE FROM blog.log_group;")
+
+ (postmodern:execute "INSERT INTO blog.log_group (name, alarmy) VALUES ($1, $2) ON CONFLICT DO NOTHING"
+ (gethash "name" form)
+ (equalp
+ (gethash "alarmy" form) "on")))
+
+ (hunchentoot:redirect "/blog/logs"))
+
+(deftab blog/logs (:url "/logs"
+ :title "Logs"
+ :require-login t
+ :needed-abilities ("update-settings"))
+ (let* ((groups (get-groups))
+ (whole-log (get-logs))
+ (groups-with-logs (alexandria:hash-table-alist
+ (reduce
+ (lambda (acc group)
+ (let ((name (gethash "name" group)))
+ (setf (gethash group acc)
+ (remove-if-not (lambda (line)
+ (cl-ppcre:all-matches-as-strings name line))
+ whole-log))
+ acc))
+ groups
+ :initial-value (cl-hash-util:hash))))
+
+ (grouped-lines (apply #'concatenate 'list (map 'list
+ #'cdr
+ groups-with-logs)))
+ (untitled-group (cons (let ((hash (make-hash-table :test 'equal)))
+ (setf (gethash "name" hash) "Untitled")
+ hash)
+ (remove-if (lambda (line)
+ (member line grouped-lines :test 'equal))
+ whole-log)))
+
+ (groups-with-logs (cons untitled-group groups-with-logs)))
+ (:h* ("Groups (~d)" (length groups-with-logs)))
+ (:ul
+ (dolist (group-log groups-with-logs)
+ (log-group group-log)))
+
+ (:form :method "post" :action "/api/logs/groups" :onsubmit "location.reload()"
+ (:label "Log regexp " (:input :type "text" :name "name" :id "name"))
+ (:label "Hits cause alarm " (:input :type "checkbox" :name "alarmy" :id "alarmy"))
+ (:input :type :submit))))
diff --git a/src/view/components/tabs.lisp b/src/view/components/tabs.lisp
index 2c895d1..f1039d7 100644
--- a/src/view/components/tabs.lisp
+++ b/src/view/components/tabs.lisp
@@ -53,7 +53,10 @@
(let ((murja.settings:*settings* (murja.settings:get-settings)))
(with-html
,@rst)))))))
- (defroute ,sym (,url
+ (defroute ,sym (,(if lisp-fixup:*dev?*
+ ;; we handle /blog prefix on our own only on dev
+ (format nil "/blog~A" url)
+ url)
:method :get
:decorators (@transaction
(@ssr-authenticated :require-authentication ,require-login )