diff of c0545ffbc70a5560f7532f1d110cdcb4b39fc2f4
c0545ffbc70a5560f7532f1d110cdcb4b39fc2f4
diff --git a/aggressive-murja.asd b/aggressive-murja.asd
index 4359189..3c81431 100644
--- a/aggressive-murja.asd
+++ b/aggressive-murja.asd
@@ -26,7 +26,8 @@
"xmls"
;; works in cl universal time (epoch at 1900)
"cl-date-time-parser"
- "alexandria")
+ "alexandria"
+ "uuid")
:description "A rewrite of the <a href=\"https://github.com/feuery/murja-blog/\">murja blogging engine</a> in lisp"
:components ((:module "src"
:components
@@ -77,7 +78,8 @@
((:file "literal")
(:file "literal-test")
(:file "tests")
- (:file "rss-tests"))))
+ (:file "rss-tests")
+ (:file "session-tests"))))
:perform (test-op (op c)
(eval (read-from-string "(fiveam:run! 'murja.tests:main-suite)"))))
diff --git a/resources/sql/session-fns.sql b/resources/sql/session-fns.sql
index 6d5c9c1..9e66362 100644
--- a/resources/sql/session-fns.sql
+++ b/resources/sql/session-fns.sql
@@ -8,36 +8,36 @@ update set val = excluded.val;
-- count: single
select ss.session_key
from blog.serialized_session ss
-where ss.owner = $1 AND ss.session_key = $2 AND now() < ss.expires_at;
+where ss.owner = $2 AND ss.session_key = $3 AND $1 < ss.expires_at;
-- name: ensure-username-session*
-- count: single
select ss.session_key
from blog.serialized_session ss
join blog.users usr on ss.owner = usr.id
-where usr.username = $1 AND ss.session_key = $2 AND now() < ss.expires_at;
+where usr.username = $2 AND ss.session_key = $3 AND $1 < ss.expires_at;
-- name: login-query-session*
-- count: single
select ss.session_key
from blog.serialized_session ss
join blog.users usr on ss.owner = usr.id
-where usr.username = $1 AND now() < ss.expires_at;
+where usr.username = $2 AND $1 < ss.expires_at;
-- name: insert-session*
-- returns: :array-hash
insert into blog.serialized_session (owner)
select usr.id
from blog.users usr
-where usr.username = $1
-returning session_key, expires_at - now() AS max_age;
+where usr.username = $2
+returning session_key, expires_at - $1 AS max_age;
-- name: get-session-val*
-- returns: :array-hash
select sstore.val
from blog.session_store sstore
join blog.serialized_session ss on ss.session_key = sstore.session_key
-where ss.owner = $1 AND sstore.var_name = $2 AND now() < ss.expires_at;
+where ss.owner = $2 AND sstore.var_name = $3 AND $1 < ss.expires_at;
-- name: all-session-vals
-- returns: :array-hash
@@ -45,4 +45,4 @@ select sstore.var_name, sstore.val
from blog.session_store sstore
join blog.serialized_session ss on sstore.session_key = ss.session_key
join blog.users usr on ss.owner = usr.id
-where usr.username = $1 and ss.session_key = $2 and now() < ss.expires_at;
+where usr.username = $2 and ss.session_key = $3 and $1 < ss.expires_at;
diff --git a/src/local-lib/lisp-fixup.lisp b/src/local-lib/lisp-fixup.lisp
index 7cf3a9e..99b5cdd 100644
--- a/src/local-lib/lisp-fixup.lisp
+++ b/src/local-lib/lisp-fixup.lisp
@@ -3,6 +3,7 @@
(:export :if-modified-since->simpledate-timestamp :*rfc822*
:*dev?* :to-secs
:fix-timestamp
+ :*now*
:sha-512 :partial
:compose :drop
:slurp-bytes :slurp-utf-8
@@ -161,3 +162,5 @@
(* min 60)
sec
(round (/ ms 1000))))
+
+(defvar *now* nil)
diff --git a/src/middleware/auth.lisp b/src/middleware/auth.lisp
index a4d7b20..62709e6 100644
--- a/src/middleware/auth.lisp
+++ b/src/middleware/auth.lisp
@@ -1,7 +1,7 @@
(defpackage murja.middleware.auth
(:use :cl :postmodern)
(:import-from :murja.users.user-db :get-user-by-id)
- (:export :*session-key* :*user* :@can?))
+ (:export :*now* :*session-key* :*user* :@can?))
(in-package :murja.middleware.auth)
@@ -15,7 +15,7 @@
(read-from-string (format nil ":~a" str)))
(defun populate-http-session (username session-key)
- (let ((session-vals (coerce (murja.session.db:all-session-vals username session-key) 'list)))
+ (let ((session-vals (coerce (murja.session.db:all-session-vals (murja.session.db:now) username session-key) 'list)))
(log:info "populating session for user ~a" username)
(dolist (pair session-vals)
(let ((k (gethash "var_name" pair))
@@ -32,18 +32,21 @@
(let ((session-cookie (hunchentoot:cookie-in "murja-session"))
(username-cookie (hunchentoot:cookie-in "murja-username"))
(user-id (hunchentoot:session-value :logged-in-user-id)))
+ (when lisp-fixup:*dev?*
+ (log:info "Read session-cookie ~a for user ~a" session-cookie username-cookie))
(if (and (not user-id)
session-cookie
(< retries 1))
;; if session-cookie is found but hunchentoot's session is expired, lets try to restore
;; it from the db and retry calling this middleware function. If retries > 0 and
;; restoring-from-db has failed, we're returning 401 to the caller.
- (progn
- ;; if this assertion fails, currently it probably returns 500. Should we return 401 to
- ;; callers providing non-matching username and cookie?
- (murja.session.db:assert-ownership-username username-cookie session-cookie)
- (populate-http-session username-cookie session-cookie)
- (@authenticated next :retries (1+ retries)))
+ (if (murja.session.db:assert-ownership-username username-cookie session-cookie)
+ (progn
+ (populate-http-session username-cookie session-cookie)
+ (@authenticated next :retries (1+ retries)))
+ (progn
+ (setf (hunchentoot:return-code*) 401)
+ "not authorized"))
(if user-id
(let ((user (get-user-by-id user-id)))
(if (and user
@@ -70,5 +73,15 @@
(setf (hunchentoot:return-code*) 401)
(format nil "you need to be able to ~a" ability))))
-
-
+(defun @test-now (next)
+ (if (and murja.middleware.db:*automatic-tests-on?*
+ (hunchentoot:header-in* :x-murja-now))
+ (let ((lisp-fixup:*now* (lisp-fixup:if-modified-since->simpledate-timestamp
+ (hunchentoot:header-in* :x-murja-now))))
+ (log:info "parsed the :now in a test as ~a" lisp-fixup:*now*)
+ (funcall next))
+ (progn
+ (when murja.middleware.db:*automatic-tests-on?*
+ (log:info "didn't find header x-murja-now"))
+ (funcall next))))
+
diff --git a/src/routes/login-routes.lisp b/src/routes/login-routes.lisp
index 582f1b1..122e28e 100644
--- a/src/routes/login-routes.lisp
+++ b/src/routes/login-routes.lisp
@@ -2,7 +2,7 @@
(:use :cl)
(:import-from :murja.session :set-session-value)
(:import-from :lisp-fixup :sha-512)
- (:import-from :murja.middleware.auth :@authenticated :*user*)
+ (:import-from :murja.middleware.auth :@test-now :@authenticated :*user*)
(:import-from :murja.middleware.db :@transaction)
(:import-from :murja.middleware.json :@json)
@@ -13,20 +13,21 @@
(defun get-session-key (username)
"Creates a new db-backed session for new logins"
- (let ((old-session (murja.session.db:login-query-session* username)))
+ (let ((old-session (murja.session.db:login-query-session* (murja.session.db:now) username)))
(when old-session
(log:error "~a tried to log in with an existing session" username))
(unless old-session
- (let* ((session-data (first (coerce (murja.session.db:insert-session* username) 'list)))
+ (let* ((session-data (first (coerce (murja.session.db:insert-session* (murja.session.db:now) username) 'list)))
(key (gethash "session_key" session-data))
(max-age (gethash "max_age" session-data)))
(multiple-value-bind (year month day hour min sec ms)
(simple-date:decode-interval max-age)
(values key (lisp-fixup:to-secs year month day hour min sec ms)))))))
-(defroute post-login ("/api/login/login" :method :post :decorators (@transaction @json)) ()
- (let* ((body-params (parse (hunchentoot:raw-post-data :force-text t)))
+(defroute post-login ("/api/login/login" :method :post :decorators (@test-now @transaction @json)) ()
+ (let* ((body (hunchentoot:raw-post-data :force-text t))
+ (body-params (parse body))
(username (gethash "username" body-params))
(password (gethash "password" body-params))
(user-row (murja.users.user-db:select-user-by-login username (sha-512 password))))
@@ -68,7 +69,8 @@
(setf (hunchentoot:return-code*) 401)
"not authorized"))))
-(defroute api-session ("/api/login/session" :method :get :decorators (@transaction
+(defroute api-session ("/api/login/session" :method :get :decorators (@test-now
+ @transaction
@json
@authenticated)) ()
(if *user*
diff --git a/src/session-db.lisp b/src/session-db.lisp
index 81753bf..ce88694 100644
--- a/src/session-db.lisp
+++ b/src/session-db.lisp
@@ -4,6 +4,7 @@
(:export :ensure-username-session* :assert-ownership
:assert-ownership-username :all-session-vals
:login-query-session*
+ :now
:set-session-val* :ensure-session*
:insert-session* :get-session-val*))
@@ -11,10 +12,25 @@
(defqueries "session-fns")
+(defun now ()
+ (or lisp-fixup:*now*
+ (simple-date:universal-time-to-timestamp (get-universal-time))))
+
(defun assert-ownership (user-id session-key)
- (let ((session (ensure-session* user-id session-key)))
- (assert session)))
+ (let ((session (ensure-session* (now) user-id session-key)))
+ (assert session)
+ t))
+
+;; (uuid:make-uuid-from-string "465a810c-25f5-40eb-9ef4-b5c127dcd3f0")
+;; (uuid:make-uuid-from-string "lol tää ei kyl oo uuid :D")
(defun assert-ownership-username (username session-key)
- (let ((session (ensure-username-session* username session-key)))
- (assert session)))
+ (handler-case
+ (uuid:make-uuid-from-string session-key)
+ (simple-error (sm)
+ (log:warn "~a ~% ~ais not an uuid" sm session-key)
+ (return-from assert-ownership-username nil)))
+
+ (let ((session (ensure-username-session* (now) username session-key)))
+ ;; cast into t/nil
+ (not (equalp session nil))))
diff --git a/src/session.lisp b/src/session.lisp
index 3be068a..95e154b 100644
--- a/src/session.lisp
+++ b/src/session.lisp
@@ -19,7 +19,7 @@
(assert *user*)
(assert *session-key*)
(let* ((user-id (gethash "id" *user*))
- (res (coerce (get-session-val* user-id key) 'list)))
+ (res (coerce (get-session-val* (murja.session.db:now) user-id key) 'list)))
(when res
(gethash "val" (first res)))))
diff --git a/test/rss-tests.lisp b/test/rss-tests.lisp
index 0f95666..d86230d 100644
--- a/test/rss-tests.lisp
+++ b/test/rss-tests.lisp
@@ -108,9 +108,3 @@
(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/session-tests.lisp b/test/session-tests.lisp
new file mode 100644
index 0000000..e8d578c
--- /dev/null
+++ b/test/session-tests.lisp
@@ -0,0 +1,105 @@
+(defpackage murja.tests.session
+ (:use :cl :fiveam)
+ (:import-from :binding-arrows :->>)
+ (:import-from :murja.users.user-db :register-user)
+ (:import-from :halisql :*system-name*)
+ (:import-from :murja.tests :url :prepare-db-and-server :drakma->string :url :main-suite :prepare-db-and-server))
+
+(in-package :murja.tests.session)
+(in-suite main-suite)
+
+(defvar username "testuser")
+(defvar passwd "passw0rd")
+
+(defvar cookie-dada "murja-session=cb5b4da0-7d79-4b05-ad0d-dd0856cb758e; Max-Age=7776000; SameSite=Strict; Secure; HttpOnly,murja-username=testuser; Max-Age=7776000; SameSite=Strict; Secure; HttpOnly,hunchentoot-session=4:05D82A7F4C9389BC7C267239AC0DFAB3; Path=/; HttpOnly")
+
+(defun cookies->hash (cookies)
+ (alexandria:plist-hash-table (->>
+ cookies
+ (str:split #\,)
+ (mapcar (lisp-fixup:partial #'str:split #\;))
+ (mapcar #'first)
+ (mapcar (lisp-fixup:partial #'str:split #\=))
+ (apply #'concatenate 'list))
+ :test 'equal))
+
+
+(def-test session-test (:fixture prepare-db-and-server)
+ (register-user username "Testuser" "" passwd)
+
+ ;; pre-state is not insane
+ (is (not (equalp nil
+ (postmodern:query "SELECT * FROM blog.users"))))
+
+ (postmodern:execute "INSERT INTO blog.groupmapping
+SELECT usr.id, grp.id, true
+FROM blog.users usr
+JOIN blog.usergroup grp ON grp.name = 'Admins'
+ON CONFLICT DO NOTHING")
+
+ (is (not (equalp nil
+ (postmodern:query "SELECT * FROM blog.groupmapping"))))
+ (is (equalp nil
+ (postmodern:query "SELECT * FROM blog.session_store")))
+ (is (equalp nil
+ (postmodern:query "SELECT * FROM blog.serialized_session")))
+
+ ;; does session-route return 401 as expected with an uninitialized session?
+ (multiple-value-bind (body status) (drakma:http-request (format nil "~a/api/login/session" (url)))
+ (is (equalp 401 status)))
+
+ ;; how does it handle rubbish session-key cookies?
+ (multiple-value-bind (body status) (drakma:http-request (format nil "~a/api/login/session" (url))
+ :additional-headers `(("Cookie" . "murja-session=ihme_roskaa; murja-username=testuser")
+ ("x-murja-now" . "Fri, 27 Dec 2024 09:48:46 EST")))
+ (is (equalp 401 status)))
+
+ ;; how about innocent looking keys that parse as cookies?
+ (multiple-value-bind (body status) (drakma:http-request (format nil "~a/api/login/session" (url))
+ :additional-headers `(("Cookie" . ,(format nil "murja-session=~a; murja-username=testuser" (uuid:make-v4-uuid)))))
+ (is (equalp 401 status)))
+
+ ;; how does it handle rubbish usernames?
+ (multiple-value-bind (body status) (drakma:http-request (format nil "~a/api/login/session" (url))
+ :additional-headers `(("Cookie" . "murja-session=ihme_roskaa; murja-username=user_that_never_existed")))
+ (is (equalp 401 status)))
+
+ ;; let's log in
+ (multiple-value-bind (body status headers)
+ (drakma:http-request (format nil "~a/api/login/login" (url))
+ :method :post
+ :content (format nil "{\"username\": \"~a\", \"password\": \"~a\"}" username passwd))
+ (is (equalp 200 status))
+ (let* ((cookies-str (cdr (assoc :set-cookie headers)))
+ (cookies (cookies->hash cookies-str))
+ (hunchentoot-session (gethash "hunchentoot-session" cookies))
+ (murja-session (gethash "murja-session" cookies))
+ (murja-username (gethash "murja-username" cookies)))
+
+ ;; you could probably integration-test a lot by seeing what that body contains
+
+ ;; valid hunchentoot-session overrides rubbish cookies
+ (multiple-value-bind (body status) (drakma:http-request (format nil "~a/api/login/session" (url))
+ :additional-headers `(("Cookie" . ,(format nil "hunchentoot-session=~a;murja-session=~a; murja-username=~a" hunchentoot-session murja-session "NON_EXISTANT_DUDE"))))
+ (is (equalp 200 status)))
+
+ ;; valid cookies repopulate the session
+ (multiple-value-bind (body status) (drakma:http-request (format nil "~a/api/login/session" (url))
+ :additional-headers `(("Cookie" . ,(format nil "murja-session=~a; murja-username=~a" murja-session murja-username))))
+ (is (equalp 200 status)))
+
+
+ ;; let's timejump 4 months and see if the session expires correctly
+
+ (multiple-value-bind (body status) (drakma:http-request (format nil "~a/api/login/session" (url))
+ :additional-headers `(("Cookie" . ,(format nil "murja-session=~a; murja-username=~a" murja-session murja-username))
+ ("x-murja-now" . ,(let ((lisp-fixup:*rfc822* t))
+ (lisp-fixup:fix-timestamp (caar (postmodern:query "SELECT now() + '4 months'")))))))
+ (is (equalp 401 status))))))
+
+;; (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 4f800ea..66eb3e0 100644
--- a/test/tests.lisp
+++ b/test/tests.lisp
@@ -18,6 +18,7 @@
(def-fixture prepare-db-and-server ()
;; easy-route handlers don't inherit this value as t in their environment if changed with only let here
(setf murja.middleware.db:*automatic-tests-on?* t)
+ (setf lisp-fixup:*dev?* t)
(murja.middleware.db:with-db
(unwind-protect
(progn
@@ -33,6 +34,7 @@
(postmodern:execute "DROP TABLE IF EXISTS public.migrations_tracker")
(hunchentoot:stop *test-server*)
(setf *test-server* nil)
+ (setf lisp-fixup:*dev?* nil)
(setf murja.middleware.db:*automatic-tests-on?* nil))))
(def-test multiple-migrations (:fixture prepare-db-and-server)