diff of 1b1340010e4812b1705403fac72c820fdd1d761f
1b1340010e4812b1705403fac72c820fdd1d761f
diff --git a/aggressive-murja.asd b/aggressive-murja.asd
index 8c6a6f8..7b07ec6 100644
--- a/aggressive-murja.asd
+++ b/aggressive-murja.asd
@@ -1,3 +1,6 @@
+(require 'asdf)
+(in-package :asdf-user)
+
(defsystem "aggressive-murja"
:version "3.0.0-devel"
:author "Ilpo Lehtinen"
@@ -63,9 +66,9 @@
(:file "rss-reader-routes")
(:file "root-routes")))
(:file "main"))))
- :in-order-to ((test-op (test-op "pichunter/tests"))))
+ :in-order-to ((test-op (test-op "aggressive-murja/tests"))))
-(defsystem "aggressive-murja-tests"
+(defsystem "aggressive-murja/tests"
:author "Ilpo Lehtinen"
:licence "GPLv3"
:depends-on ("aggressive-murja"
@@ -74,6 +77,11 @@
:components
((:file "literal")
(:file "literal-test")
- (:file "tests"))))
+ (:file "tests")
+ (:file "rss-tests"))))
: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)
diff --git a/resources/sql/022-fix-rss-cache.sql b/resources/sql/022-fix-rss-cache.sql
new file mode 100644
index 0000000..048ff8c
--- /dev/null
+++ b/resources/sql/022-fix-rss-cache.sql
@@ -0,0 +1,2 @@
+ALTER TABLE blog.feed_subscription
+ADD COLUMN last_modified TIMESTAMP NULL;
diff --git a/resources/sql/reader-fns.sql b/resources/sql/reader-fns.sql
index aceb8b1..a3847d1 100644
--- a/resources/sql/reader-fns.sql
+++ b/resources/sql/reader-fns.sql
@@ -27,7 +27,7 @@ SELECT fs.id, fs.name, fs.url,
'nickname',
u.Nickname,
'img_location',
- u.Img_location) as "creator"
+ u.Img_location) as "creator", fs.last_modified
FROM blog.feed_subscription fs
JOIN blog.Users u ON u.ID = fs.owner;
@@ -54,3 +54,8 @@ SELECT fs.name, fs.url
FROM blog.feed_subscription fs
JOIN blog.feed_item fi ON fi.feed = fs.id
WHERE fi.id = $1 AND fs.owner = $2;
+
+-- name: update-last-modified @execute
+UPDATE blog.feed_subscription
+SET last_modified = $2
+WHERE id = $1;
diff --git a/resources/test/rss-sample.xml b/resources/test/rss-sample.xml
new file mode 100644
index 0000000..a3ecaec
--- /dev/null
+++ b/resources/test/rss-sample.xml
@@ -0,0 +1,32 @@
+<?xml version="1.0"?>
+<rss version="2.0">
+ <channel>
+ <title>murja-test-instance</title>
+ <link>http://localhost:3010/</link>
+ <description>Automatic tests </description>
+ <language>fi-FI</language>
+
+ <pubDate>Tue, 10 Jun 2024 04:00:00 GMT</pubDate>
+ <lastBuildDate>Tue, 10 Jun 2024 09:41:01 GMT</lastBuildDate>
+ <generator>murja test data</generator>
+
+ <item>
+ <title>Test title</title>
+ <link>http://localhost:3010/blog/post/1</link>
+ <description>Mitä dadaa?</description>
+ <pubDate>Tue, 03 Jun 2003 09:39:21 GMT</pubDate>
+ </item>
+ <item>
+ <title>Test title 2</title>
+ <link>http://localhost:3010/blog/post/2</link>
+ <description>Mitä ihmeen dadaa?</description>
+ <pubDate>Tue, 03 Jun 2023 09:39:21 GMT</pubDate>
+ </item>
+ <item>
+ <title>Test title 3</title>
+ <link>http://localhost:3010/blog/post/2</link>
+ <description>Mitä ihmettä?</description>
+ <pubDate>Tue, 03 Jun 2024 09:39:21 GMT</pubDate>
+ </item>
+ </channel>
+</rss>
diff --git a/run_tests.sh b/run_tests.sh
new file mode 100755
index 0000000..af64293
--- /dev/null
+++ b/run_tests.sh
@@ -0,0 +1 @@
+sbcl --disable-debugger --load ./aggressive-murja.asd --eval '(asdf:make "aggressive-murja")' --eval '(asdf:make "aggressive-murja/tests")' --eval "(fiveam:run! 'murja.tests:main-suite)" --eval '(sb-ext:exit)'
diff --git a/src/local-lib/lisp-fixup.lisp b/src/local-lib/lisp-fixup.lisp
index 4b85eaa..906aefb 100644
--- a/src/local-lib/lisp-fixup.lisp
+++ b/src/local-lib/lisp-fixup.lisp
@@ -2,9 +2,10 @@
(:use :cl)
(:export :if-modified-since->simpledate-timestamp :*rfc822*
:fix-timestamp
- :sha-512 :partial
- :compose :drop
- :slurp-bytes :slurp-utf-8))
+ :sha-512 :partial
+ :compose :drop
+ :slurp-bytes :slurp-utf-8
+ :range :range2))
(in-package :lisp-fixup)
@@ -51,6 +52,15 @@
:initial-value x
:from-end t)))
+(defun range2 (a b)
+ (assert (<= a b))
+ (when (not (equalp a b))
+ (cons a (range2 (1+ a) b))))
+
+(defun range (b)
+ (assert (> b 0))
+ (range2 0 b))
+
(defvar *rfc822* nil)
(defun weekday->string (day)
@@ -94,7 +104,19 @@
("October" 10)
("November" 11)
("December" 12)
- (t "")))
+
+ ("Jan" 1)
+ ("Feb" 2)
+ ("Mar" 3)
+ ("Apr" 4)
+ ("May" 5)
+ ("Jun" 6)
+ ("Jul" 7)
+ ("Aug" 8)
+ ("Sep" 9)
+ ("Oct" 10)
+ ("Nov" 11)
+ ("Dec" 12)))
(defun fix-timestamp (timestamp)
"Fixes timestamps returned from postmodern to a json-format elm can parse"
@@ -113,13 +135,16 @@
;; Wed, 30 March 2016 08:09:00 GMT
(defun if-modified-since->simpledate-timestamp (header)
+ "Transforms timestamp strings as specified by Last-Modified
+ 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)
(destructuring-bind (h m sec) (str:split #\: timestamp)
(let ((month (month->ordinal month)))
- (apply #'simple-date:encode-timestamp
- (mapcar (lambda (e)
- (if (stringp e)
- (parse-integer e)
- e))
- (list year month day h m sec))))))))
+ (when month
+ (apply #'simple-date:encode-timestamp
+ (mapcar (lambda (e)
+ (if (stringp e)
+ (parse-integer e)
+ e))
+ (list year month day h m sec)))))))))
diff --git a/src/migration-list.lisp b/src/migration-list.lisp
index fb68da0..bbc5dd3 100644
--- a/src/migration-list.lisp
+++ b/src/migration-list.lisp
@@ -26,6 +26,7 @@
(defmigration "019-rss-settings")
(defmigration "020-rss-reader-stuff")
(defmigration "021-more-rss-reader-stuff")
+(defmigration "022-fix-rss-cache")
(defun prepare-e2e-migration ()
(postmodern:execute "DELETE FROM blog.Users")
diff --git a/src/routes/post-routes.lisp b/src/routes/post-routes.lisp
index d4bb827..7761f42 100644
--- a/src/routes/post-routes.lisp
+++ b/src/routes/post-routes.lisp
@@ -86,7 +86,7 @@
(let ((creator-id (gethash "id" *user*)))
(prin1-to-string (caar (murja.posts.post-db:insert-post "New title" "New post" creator-id "[]" t nil)))))
-(defconstant *excerpt-html-template*
+(defvar *excerpt-html-template*
" <blockquote class=\"excerpt\">
<header>
<a href=~s> ~s says...</a>
diff --git a/src/rss/reader-db.lisp b/src/rss/reader-db.lisp
index 1f4399f..3c081e2 100644
--- a/src/rss/reader-db.lisp
+++ b/src/rss/reader-db.lisp
@@ -3,7 +3,7 @@
(:import-from :halisql :defqueries)
(:import-from :lisp-fixup :partial :compose)
(:import-from :cl-date-time-parser :parse-date-time)
- (:export :get-feed-name-and-url :*updates* :get-user-feeds :subscribe-to-feed :mark-as-read :delete-feed))
+ (:export :*last-updated* :get-feed-name-and-url :*updates* :get-user-feeds :subscribe-to-feed :mark-as-read :delete-feed :download))
(in-package :murja.rss.reader-db)
@@ -39,16 +39,29 @@
(defun subscribe-to-feed (feed-name feed-url owner)
(insert-feed feed-name feed-url (gethash "id" owner)))
-(defun download (url)
+(defun download (url modified-since)
"Drakma decides to return either strings or array<byte>s based on random
(can't find the documentation about this logic) whims. This function performs
the http-request through drakma, checks which is returned, and in case of array<byte>s,
-pipes it through trivial-utf-8:utf-8-bytes-to-string"
- (let ((result (drakma:http-request url :user-agent "drakma / murja-blog-engine rss updater")))
- (if (and (arrayp result)
- (not (stringp result)))
- (trivial-utf-8:utf-8-bytes-to-string result)
- result)))
+pipes it through trivial-utf-8:utf-8-bytes-to-string.
+
+The second value returned is the last-modified response header as simpledate-timestamp"
+ (multiple-value-bind (body status headers) (drakma:http-request url
+ :user-agent "drakma / murja-blog-engine rss updater"
+ :additional-headers (when modified-since
+ (list (cons "If-Modified-Since" modified-since))))
+ (let* ((last-modified-header (cdr (assoc :last-modified headers)))
+ (_ (log:info "last-modified-header: ~a~%" last-modified-header))
+ (last-modified (lisp-fixup:if-modified-since->simpledate-timestamp
+ last-modified-header)))
+ (log:info "last-modified: ~a~%" last-modified)
+
+ (values
+ (if (and (arrayp body)
+ (not (stringp body)))
+ (trivial-utf-8:utf-8-bytes-to-string body)
+ body)
+ last-modified))))
;; (setf drakma:*header-stream* *standard-output*)
(defun get-child-item-value (name children)
@@ -62,6 +75,7 @@ pipes it through trivial-utf-8:utf-8-bytes-to-string"
first))
(defun parse-rss (feed-id feed-parsed)
+ (log:info "Parsing rss")
(let ((channel (first (xmls:node-children feed-parsed))))
(dolist (item (remove-if-not (lambda (item)
(string= (xmls:node-name item) "item"))
@@ -81,6 +95,7 @@ pipes it through trivial-utf-8:utf-8-bytes-to-string"
(insert-feed-item title link description author pubDate feed-id)))))
(defun parse-atom (author feed-id feed-parsed)
+ (log:info "parsing atom~%")
(let ((entries (->>
feed-parsed
(xmls:node-children)
@@ -97,17 +112,27 @@ pipes it through trivial-utf-8:utf-8-bytes-to-string"
(insert-feed-item title link description author pubDate feed-id)))))
(defun update-feed (feed)
- (let* ((url (gethash "url" feed))
- (feed-id (gethash "id" feed))
- (feed-contents (download url))
- (feed-parsed (xmls:parse feed-contents))
- (feed-ns (xmls:node-ns feed-parsed)))
-
- (if (cl-ppcre:all-matches-as-strings "Atom" feed-ns)
- (let ((author (first (xmls:node-children
- (get-child-item-value "author" (xmls:node-children feed-parsed))))))
- (parse-atom author feed-id feed-parsed))
- (parse-rss feed-id feed-parsed))))
+ (let* ((if-modified-since (gethash "last_modified" feed))
+ (if-modified-since (unless (equalp if-modified-since :null)
+ if-modified-since))
+ (url (gethash "url" feed))
+ (feed-id (gethash "id" feed)))
+ (log:info "Updating feed ~a~%" url)
+ (multiple-value-bind (feed-contents last-modified) (download url if-modified-since)
+ (let* ((feed-parsed (xmls:parse feed-contents))
+ (feed-ns (xmls:node-ns feed-parsed)))
+
+ (log:info "did we get rss or atom?")
+ (if (and feed-ns
+ (cl-ppcre:all-matches-as-strings "Atom" feed-ns))
+ (let ((author (first (xmls:node-children
+ (get-child-item-value "author" (xmls:node-children feed-parsed))))))
+ (parse-atom author feed-id feed-parsed))
+ (parse-rss feed-id feed-parsed))
+
+ (log:info "Updating ~a last-modified to ~a~%" feed-id last-modified)
+ (update-last-modified feed-id last-modified)
+ (log:info "Updated~%")))))
(defun current-hour ()
(multiple-value-bind (second minute hour) (decode-universal-time (get-universal-time))
@@ -125,11 +150,10 @@ pipes it through trivial-utf-8:utf-8-bytes-to-string"
(defvar *updates* nil)
(defun update-feeds ()
- (setf *last-updated* nil)
(when (or (not *last-updated*)
;; hourly rate limit
(> (- (current-hour) *last-updated*) 1))
- (log:info "Updating all feeds")
+ (log:info "Updating all feeds~%")
(dolist (feed (coerce (get-all-feeds) 'list))
(update-feed feed))
diff --git a/test/rss-tests.lisp b/test/rss-tests.lisp
new file mode 100644
index 0000000..0f95666
--- /dev/null
+++ b/test/rss-tests.lisp
@@ -0,0 +1,116 @@
+(defpackage murja.tests.rss
+ (:use :cl :fiveam)
+ (:import-from :murja.users.user-db :register-user)
+ (:import-from :murja.rss.reader-db :update-feeds)
+ (:import-from :easy-routes :defroute)
+ (:import-from :halisql :*system-name*)
+ (:import-from :lisp-fixup :slurp-utf-8)
+ (:import-from :murja.tests :prepare-db-and-server :drakma->string :url :main-suite :prepare-db-and-server))
+
+(in-package :murja.tests.rss)
+(in-suite main-suite)
+
+;; let's mock a few rss feeds that return something sensible in their Last-Modified
+(defvar rss-sample (slurp-utf-8
+ (asdf:system-relative-pathname *system-name*
+ "resources/test/rss-sample.xml")))
+(defvar rss1-hook nil)
+
+(defvar rss1route-called nil)
+(defroute test-route ("/api/rssdemo1" :method :get) ()
+ (assert (not (equalp rss1route-called nil)))
+ (incf rss1route-called)
+ (format t "Returning rss from rssdemo1, callcounter is ~d~%" rss1route-called)
+ (when rss1-hook
+ (log:info "calling test hook #1~%")
+ (funcall rss1-hook))
+ (setf (hunchentoot:content-type*) "application/rss+xml")
+ (setf (hunchentoot:header-out "Last-Modified") "Mon, 06 May 2024 23:23:23 GMT")
+ rss-sample)
+
+(defvar rss2route-called nil)
+(defvar rss2-hook nil)
+(defroute test-route2 ("/api/rssdemo2" :method :get) ()
+ (assert (not (equalp rss2route-called nil)))
+ (incf rss2route-called)
+ (format t "Returning rss from rssdemo2, callcounter is ~d~%" rss2route-called)
+ (when rss2-hook
+ (log:info "rss2-hook: ~a" rss2-hook)
+ (funcall rss2-hook))
+ (setf (hunchentoot:content-type*) "application/rss+xml")
+ (setf (hunchentoot:header-out "Last-Modified") "Mon, 01 Jan 2024 22:21:20 GMT")
+ (log:info "returning from rssdemo2~%")
+ rss-sample)
+
+(defvar amount-of-if-modified-sinces nil)
+(defvar is-called nil)
+
+;; the actual tests
+(def-test reader-test (:fixture prepare-db-and-server)
+ (register-user "testuser" "Testuser" "" "passw0rd")
+ (setf rss1route-called 0)
+ (setf rss2route-called 0)
+ (setf amount-of-if-modified-sinces 0)
+ (unwind-protect
+ (let ((feed-urls (mapcar
+ (lisp-fixup:partial #'format nil "~a/api/rssdemo~d" (url))
+ (lisp-fixup:range2 1 3)))
+ (feed-names (mapcar
+ (lisp-fixup:partial #'format nil "rss-~d")
+ (lisp-fixup:range2 1 3)))
+ (owner (caar (postmodern:query "SELECT ID FROM blog.Users"))))
+ (is (not (equalp nil owner)))
+
+ ;; insert the test feeds (update) shall poll
+ (dotimes (i 2)
+ (postmodern:execute "INSERT INTO blog.feed_subscription (name, url, owner) VALUES ($1, $2, $3)"
+ (nth i feed-names)
+ (nth i feed-urls)
+ owner))
+
+ ;; ;; these are supposed to be NULL each
+ (let ((last-modifieds (mapcar #'car (postmodern:query "SELECT last_modified FROM blog.feed_subscription"))))
+ (is (equalp 2
+ (length last-modifieds)))
+
+
+ (is (every (lisp-fixup:partial #'equalp :null) last-modifieds)))
+
+ (update-feeds)
+
+ ;; both feed endpoints are called
+ (is (equalp 1 rss1route-called))
+ (is (equalp 1 rss2route-called))
+
+ ;; these are now supposed be something sensible
+ (let ((last-modifieds (mapcar #'car (postmodern:query "SELECT last_modified FROM blog.feed_subscription"))))
+ (is (every (complement (lisp-fixup:partial #'equalp :null)) last-modifieds))
+
+ ;; let's use hooks to see if the last last-modified is sent in the if-modified-since
+ (let ((hook (lambda ()
+ (setf is-called t)
+ (log:info "Set is-called into t; if-modified-since: ~a~%" (hunchentoot:header-in* "if-modified-since"))
+
+ (when (hunchentoot:header-in* "if-modified-since")
+ (incf amount-of-if-modified-sinces)))))
+ (setf rss1-hook hook)
+ (setf rss2-hook hook)
+
+ (setf murja.rss.reader-db:*last-updated* nil)
+ (log:info "re-updating feeds")
+ (update-feeds)
+ (is (not (equalp nil is-called)))
+ (is (equalp amount-of-if-modified-sinces 2)))))
+ (setf rss1route-called nil)
+ (setf rss2route-called nil)
+
+ (setf rss1-hook nil)
+ (setf rss2-hook nil)
+ (setf amount-of-if-modified-sinces nil)
+ (setf is-called nil)))
+
+;; (setf fiveam:*run-test-when-defined* t)
+
+(if (and (sb-ext:posix-getenv "GHA")
+ (not (run! 'main-suite)))
+ (sb-ext:exit :code 666))
diff --git a/test/tests.lisp b/test/tests.lisp
index d04fdb0..4f800ea 100644
--- a/test/tests.lisp
+++ b/test/tests.lisp
@@ -2,7 +2,7 @@
(:use :cl :fiveam)
(:import-from :murja.users.user-db :register-user)
(:import-from :murja.tests.literal :literal)
- (:export :main-suite))
+ (:export :prepare-db-and-server :drakma->string :url :main-suite :prepare-db-and-server))
(in-package :murja.tests)
@@ -217,9 +217,3 @@ values ($1, $2, $3, $4, $5, $6, $7) returning id;"
(is (string= last-modified "Thu, 12 Jan 2017 00:00:00 GMT"))
(is (every (lambda (line) (not (str:contains? "2015" line))) pubdates))
(is (= 2 (length pubdates))))))))
-
-;; (setf fiveam:*run-test-when-defined* t)
-
-(if (and (sb-ext:posix-getenv "GHA")
- (not (run! 'main-suite)))
- (sb-ext:exit :code 666))