diff of 72113ea75e4b1adaaaa498ca9a279ad647c790e6
72113ea75e4b1adaaaa498ca9a279ad647c790e6
diff --git a/aggressive-murja.asd b/aggressive-murja.asd
index 057862e..4359189 100644
--- a/aggressive-murja.asd
+++ b/aggressive-murja.asd
@@ -2,7 +2,7 @@
(in-package :asdf-user)
(defsystem "aggressive-murja"
- :version "3.0.0-devel"
+ :version "3.0.0"
:author "Ilpo Lehtinen"
:licence "GPLv3"
:depends-on ("postmodern"
@@ -37,10 +37,12 @@
(:file "migration-list")
(:module "users"
:components ((:file "user-db")))
+ (:file "session-db")
(:module "middleware"
:components ((:file "json")
(:file "db")
(:file "auth")))
+ (:file "session")
(:module "posts"
:components
((:file "post-db")))
diff --git a/elm-frontti/src/Main.elm b/elm-frontti/src/Main.elm
index 1dd8b97..b660704 100644
--- a/elm-frontti/src/Main.elm
+++ b/elm-frontti/src/Main.elm
@@ -806,6 +806,11 @@ update msg model =
Err error ->
( { model | view_state = ShowError (errToString error) }
, Cmd.none)
+ SetDomain dm ->
+ ({ model | settings = Maybe.map (\settings ->
+ { settings | domain = dm })
+ model.settings}
+ , Cmd.none)
doGoHome_ model other_cmds =
(model, Cmd.batch (List.append [ getSettings
diff --git a/elm-frontti/src/Message.elm b/elm-frontti/src/Message.elm
index 649b76d..8ac0314 100644
--- a/elm-frontti/src/Message.elm
+++ b/elm-frontti/src/Message.elm
@@ -229,6 +229,7 @@ type Msg
| LogGroupsSaved (Result Http.Error ())
| GotLogGroups (Result Http.Error (List Logs.Group))
| GotTopbarLogAlarm (Result Http.Error Logs.TopbarAlarm)
+ | SetDomain String
-- ports
port reallySetupAce : String -> Cmd msg
diff --git a/elm-frontti/src/Settings.elm b/elm-frontti/src/Settings.elm
index d5daad3..18c3f8c 100644
--- a/elm-frontti/src/Settings.elm
+++ b/elm-frontti/src/Settings.elm
@@ -10,17 +10,20 @@ type alias Settings =
, blog_title : String
, recent_post_count : Int
, previously_label: String
+ , domain: String
}
-settingsDecoder = Decode.map4 Settings
+settingsDecoder = Decode.map5 Settings
(Decode.field "time-format" Decode.string)
(Decode.field "blog-title" Decode.string)
(Decode.field "recent-post-count" Decode.int)
(Decode.field "previously_label" Decode.string)
+ (Decode.field "domain" Decode.string)
encodeSettings settings =
object
[ ( "time-format", string settings.time_format )
, ( "blog-title", string settings.blog_title)
, ( "recent-post-count", int settings.recent_post_count)
- , ( "previously_label", string settings.previously_label) ]
+ , ( "previously_label", string settings.previously_label)
+ , ( "domain", string settings.domain)]
diff --git a/elm-frontti/src/SettingsEditor.elm b/elm-frontti/src/SettingsEditor.elm
index 4e8d11a..a0be10c 100644
--- a/elm-frontti/src/SettingsEditor.elm
+++ b/elm-frontti/src/SettingsEditor.elm
@@ -28,11 +28,17 @@ editor settings =
, value (String.fromInt settings.recent_post_count)
, type_ "number"] []
- , label [ for "previously_label" ]
+ , label [ for "previously" ]
[ text "Previously link label" ]
, input [ id "previously"
, onInput SetPreviouslyLabel
- , value settings.previously_label] []
+ , value settings.previously_label] []
+
+ , label [ for "domain" ]
+ [ text "Site domain (relevant for cookies)" ]
+ , input [ id "domain"
+ , onInput SetDomain
+ , value settings.domain] []
, button [ onClick SaveSettings ]
[ text "Save settings"]]
diff --git a/resources/sql/025-session-table.sql b/resources/sql/025-session-table.sql
new file mode 100644
index 0000000..505a1f4
--- /dev/null
+++ b/resources/sql/025-session-table.sql
@@ -0,0 +1,24 @@
+CREATE TABLE blog.serialized_session
+(
+ session_key uuid not null default gen_random_uuid () primary key,
+ owner int not null,
+ expires_at timestamp NOT NULL DEFAULT NOW() + '3 months',
+ foreign key (owner) references blog.users(id)
+ on update cascade
+ on delete cascade
+);
+
+CREATE TABLE blog.session_store
+(
+ session_key uuid not null,
+ var_name text not null,
+ val text not null,
+ primary key (session_key, var_name),.
+ foreign key (session_key) references blog.serialized_session(session_key)
+ on update cascade
+ on delete cascade
+);
+
+-- related to session cookies
+INSERT INTO blog.Settings VALUES ('domain', '"http://example.com"')
+ON CONFLICT DO NOTHING;
diff --git a/resources/sql/session-fns.sql b/resources/sql/session-fns.sql
new file mode 100644
index 0000000..6d5c9c1
--- /dev/null
+++ b/resources/sql/session-fns.sql
@@ -0,0 +1,48 @@
+-- name: set-session-val* @execute
+insert into blog.session_store (session_key, var_name, val)
+values ($1, $2, $3)
+on conflict(session_key, var_name) do
+update set val = excluded.val;
+
+-- name: ensure-session*
+-- 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;
+
+-- 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;
+
+-- 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;
+
+-- 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;
+
+-- 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;
+
+-- name: all-session-vals
+-- returns: :array-hash
+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;
diff --git a/src/local-lib/lisp-fixup.lisp b/src/local-lib/lisp-fixup.lisp
index 906aefb..7cf3a9e 100644
--- a/src/local-lib/lisp-fixup.lisp
+++ b/src/local-lib/lisp-fixup.lisp
@@ -1,6 +1,7 @@
(defpackage lisp-fixup
(:use :cl)
(:export :if-modified-since->simpledate-timestamp :*rfc822*
+ :*dev?* :to-secs
:fix-timestamp
:sha-512 :partial
:compose :drop
@@ -9,6 +10,8 @@
(in-package :lisp-fixup)
+(defvar *dev?* nil "True if we're running in dev")
+
(defun sha-512 (str)
(ironclad:byte-array-to-hex-string
(ironclad:digest-sequence :sha512
@@ -148,3 +151,13 @@
(parse-integer e)
e))
(list year month day h m sec)))))))))
+
+(defun to-secs (year month day hour min sec ms)
+ (+ (* year 31556926)
+ ;; a bad average-based approximation due to "a month" not being a constant (calculated with: (round (/ 31556926 12)))
+ (* month 2629744)
+ (* day 86400)
+ (* hour 3600)
+ (* min 60)
+ sec
+ (round (/ ms 1000))))
diff --git a/src/main.lisp b/src/main.lisp
index 8524130..e682886 100644
--- a/src/main.lisp
+++ b/src/main.lisp
@@ -7,6 +7,8 @@
(in-package :murja)
+(defvar *server* nil)
+
(defun stop-server ()
(hunchentoot:stop *server*))
@@ -38,8 +40,9 @@
(defun run ()
"Starts up the aggressive-murja system. Sets logging up in a way that should show up in the logs view"
(setf hunchentoot:*catch-errors-p* nil)
- (bordeaux-threads:make-thread
- (lambda ()
- (murja:main))))
+ (let ((lisp-fixup:*dev?* t))
+ (bordeaux-threads:make-thread
+ (lambda ()
+ (murja:main)))))
;; (start-server :port 3010)
diff --git a/src/middleware/auth.lisp b/src/middleware/auth.lisp
index 6eb9acb..a4d7b20 100644
--- a/src/middleware/auth.lisp
+++ b/src/middleware/auth.lisp
@@ -1,28 +1,64 @@
(defpackage murja.middleware.auth
(:use :cl :postmodern)
(:import-from :murja.users.user-db :get-user-by-id)
- (:export :*user* :@can?))
+ (:export :*session-key* :*user* :@can?))
(in-package :murja.middleware.auth)
(defvar *user* nil
"A special variable for storing the logged in user (as defined in the db)")
-(defun @authenticated (next)
- (let ((user-id (hunchentoot:session-value :logged-in-user-id)))
- (if user-id
- (let ((user (get-user-by-id user-id)))
- (if (and user
- (string= (hunchentoot:session-value :logged-in-username)
- (gethash "username" user)))
- (let ((*user* user))
- (funcall next))
- (progn
- (setf (hunchentoot:return-code*) 401)
- "not authorized")))
+(defvar *session-key* nil
+ "A special var that stores a non-expired database session-key used for re-populating http-session upon its death")
+
+(defun kw (str)
+ (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)))
+ (log:info "populating session for user ~a" username)
+ (dolist (pair session-vals)
+ (let ((k (gethash "var_name" pair))
+ (v (gethash "val" pair)))
+
+
+ (setf (hunchentoot:session-value (kw k)) v)
+
+ ;; want these logs only in dev
+ (when lisp-fixup:*dev?*
+ (log:info "populating session var from db ~a => ~a" k v))))))
+
+(defun @authenticated (next &key (retries 0))
+ (let ((session-cookie (hunchentoot:cookie-in "murja-session"))
+ (username-cookie (hunchentoot:cookie-in "murja-username"))
+ (user-id (hunchentoot:session-value :logged-in-user-id)))
+ (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
- (setf (hunchentoot:return-code*) 401)
- "not authorized"))))
+ ;; 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 user-id
+ (let ((user (get-user-by-id user-id)))
+ (if (and user
+ (string= (hunchentoot:session-value :logged-in-username)
+ (gethash "username" user)))
+ (let ((*user* user)
+ (*session-key* session-cookie))
+ (funcall next))
+ (progn
+ (setf (hunchentoot:return-code*) 401)
+ "not authorized")))
+ (progn
+ (setf (hunchentoot:return-code*) 401)
+ (log:warn "failed auth at @authenticated")
+ "not authorized")))))
(defun @can? (ability next)
(if (and *user*
diff --git a/src/migration-list.lisp b/src/migration-list.lisp
index 5449004..49f9f6d 100644
--- a/src/migration-list.lisp
+++ b/src/migration-list.lisp
@@ -29,6 +29,7 @@
(defmigration "022-fix-rss-cache")
(defmigration "023-loggroups")
(defmigration "024-loggroup-read-count")
+(defmigration "025-session-table")
(defun prepare-e2e-migration ()
(postmodern:execute "DELETE FROM blog.Users")
diff --git a/src/routes/login-routes.lisp b/src/routes/login-routes.lisp
index 20a24fc..582f1b1 100644
--- a/src/routes/login-routes.lisp
+++ b/src/routes/login-routes.lisp
@@ -1,5 +1,6 @@
(defpackage murja.routes.login-routes
(: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.db :@transaction)
@@ -10,6 +11,20 @@
(in-package :murja.routes.login-routes)
+(defun get-session-key (username)
+ "Creates a new db-backed session for new logins"
+ (let ((old-session (murja.session.db:login-query-session* 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)))
+ (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)))
(username (gethash "username" body-params))
@@ -17,10 +32,37 @@
(user-row (murja.users.user-db:select-user-by-login username (sha-512 password))))
(if (and user-row
(string= (gethash "username" user-row) username))
- (progn
- (setf (hunchentoot:session-value :logged-in-username) username)
- (setf (hunchentoot:session-value :logged-in-user-id) (gethash "userid" user-row))
- (stringify user-row))
+ (let ((settings (murja.routes.settings-routes:get-settings))
+ (murja.middleware.auth:*user* (murja.users.user-db:get-user-by-id (gethash "userid" user-row))))
+ (multiple-value-bind (session-key max-age) (get-session-key username)
+ (if session-key
+ (let ((murja.middleware.auth:*session-key* session-key))
+
+ (set-session-value :logged-in-username username)
+ (set-session-value :logged-in-user-id (gethash "userid" user-row))
+
+ (hunchentoot:set-cookie "murja-username" :value username
+ :secure t
+ :max-age max-age
+ :http-only t
+ :domain ;;send :domain only in linux production envs
+ (unless lisp-fixup:*dev?*
+ (gethash "domain" settings))
+ :same-site "Strict")
+
+ (hunchentoot:set-cookie "murja-session" :value session-key
+ :secure t
+ :max-age max-age
+ :http-only t
+ :domain (unless lisp-fixup:*dev?*
+ (gethash "domain" settings))
+ :same-site "Strict")
+
+ (stringify user-row))
+ (progn
+ (log:error "~a tried to log-in but get-session-key didn't return a session key. This happening signifies a bug" username)
+ (setf (hunchentoot:return-code*) 500)
+ "catastrophic error"))))
(progn
(setf (hunchentoot:return-code*) 401)
diff --git a/src/routes/root-routes.lisp b/src/routes/root-routes.lisp
index a09a432..21f381a 100644
--- a/src/routes/root-routes.lisp
+++ b/src/routes/root-routes.lisp
@@ -118,6 +118,9 @@
(defroute asjdisdjfiosd ("/blog/logs" :method :get) ()
*root*)
+(defroute aesdfg ("/blog/settings" :method :get) ()
+ *root*)
+
(defroute ddddddd ("/blog/page/:page" :method :get) ()
*root*)
diff --git a/src/session-db.lisp b/src/session-db.lisp
new file mode 100644
index 0000000..81753bf
--- /dev/null
+++ b/src/session-db.lisp
@@ -0,0 +1,20 @@
+(defpackage murja.session.db
+ (:use :cl)
+ (:import-from :halisql :defqueries)
+ (:export :ensure-username-session* :assert-ownership
+ :assert-ownership-username :all-session-vals
+ :login-query-session*
+ :set-session-val* :ensure-session*
+ :insert-session* :get-session-val*))
+
+(in-package :murja.session.db)
+
+(defqueries "session-fns")
+
+(defun assert-ownership (user-id session-key)
+ (let ((session (ensure-session* user-id session-key)))
+ (assert session)))
+
+(defun assert-ownership-username (username session-key)
+ (let ((session (ensure-username-session* username session-key)))
+ (assert session)))
diff --git a/src/session.lisp b/src/session.lisp
new file mode 100644
index 0000000..3be068a
--- /dev/null
+++ b/src/session.lisp
@@ -0,0 +1,26 @@
+(defpackage murja.session
+ (:use :cl)
+ (:import-from :murja.session.db :assert-ownership :set-session-val* :get-session-val*)
+ (:import-from :murja.middleware.auth :*user* :*session-key*))
+
+(in-package :murja.session)
+
+(defun set-session-value (key val)
+ (assert *user*)
+ (assert *session-key*)
+ (let ((user-id (gethash "id" *user*)))
+ (assert-ownership user-id *session-key*)
+
+ (set-session-val* *session-key* (str:downcase (symbol-name key)) val)
+ (setf (hunchentoot:session-value key) val)))
+
+
+(defun get-session-value (key)
+ (assert *user*)
+ (assert *session-key*)
+ (let* ((user-id (gethash "id" *user*))
+ (res (coerce (get-session-val* user-id key) 'list)))
+ (when res
+ (gethash "val" (first res)))))
+
+
diff --git a/src/users/user-db.lisp b/src/users/user-db.lisp
index ea63bc4..e4a5567 100644
--- a/src/users/user-db.lisp
+++ b/src/users/user-db.lisp
@@ -1,7 +1,7 @@
(defpackage :murja.users.user-db
(:use :cl :postmodern)
(:import-from :lisp-fixup :sha-512)
- (:export :get-session-user-by-id :select-user-by-login :register-user)
+ (:export :get-session-user-by-id :get-user-by-id :select-user-by-login :register-user)
(:import-from :halisql :defqueries))
(in-package :murja.users.user-db)