mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

refactor(web/panettone): Use postmodern connection pools

Browse source 
Instead of managing Postgres connections on our own, use the
`with-connection` postmodern function with pooling enabled as a route
decorator.

This should resolve at least some of the issues from b/113 with
leaking connections, and an unreported issue with connections being
reused while transactions are in progress.

Change-Id: I1ed68667a3240900de1ae69df37d2d3018caf204
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5198
Tested-by: BuildkiteCI
Reviewed-by: eta <tvl@eta.st>
Autosubmit: tazjin <tazjin@tvl.su>
This commit is contained in:
Vincent Ambo 2022-02-03 02:18:09 +03:00 committed by clbot
parent b7be2660c9
commit fe290a5ff8
3 changed files with 60 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
web/panettone/src/model.lisp
View file

@ -1,28 +1,24 @@
(in-package :panettone.model) (in-package :panettone.model)
(declaim (optimize (safety 3))) (declaim (optimize (safety 3)))
(defun connect-postgres (&key (defvar *pg-spec* nil
(host (or (uiop:getenvp "PGHOST") "localhost")) "Connection spec for use with the with-connection macro. Needs to be
(user (or (uiop:getenvp "PGUSER") "panettone")) initialised at launch time.")
(password (or (uiop:getenvp "PGPASSWORD") "password"))
(database (or (uiop:getenvp "PGDATABASE") "panettone"))
(port (or (integer-env "PGPORT") 5432)))
"Initialize the global postgresql connection for Panettone"
(postmodern:connect-toplevel database user password host :port port))
(defun make-thread (defun make-pg-spec ()
(function &rest args) "Construct the Postgres connection spec from the environment."
"Make a new thread as per `BORDEAUX-THREADS:MAKE-THREAD' but with its own, new (list (or (uiop:getenvp "PGDATABASE") "panettone")
database connection." (or (uiop:getenvp "PGUSER") "panettone")
(let ((spec `(,(or (uiop:getenvp "PGDATABASE") "panettone") (or (uiop:getenvp "PGPASSWORD") "password")
,(or (uiop:getenvp "PGUSER") "panettone") (or (uiop:getenvp "PGHOST") "localhost")
,(or (uiop:getenvp "PGPASSWORD") "password")
,(or (uiop:getenvp "PGHOST") "localhost") :port (or (integer-env "PGPORT") 5432)
:port ,(or (integer-env "PGPORT") 5432)))) :application-name "panettone"
(apply #'bt:make-thread :pooled-p t))
(lambda ()
(postmodern:call-with-connection spec function)) (defun prepare-db-connections ()
args))) "Initialises the connection spec used for all Postgres connections."
(setq *pg-spec* (make-pg-spec)))
;;; ;;;
;;; Schema ;;; Schema
@ -268,7 +264,7 @@ type `ISSUE-NOT-FOUND'."
(with-column-writers ('num_comments 'num-comments) (with-column-writers ('num_comments 'num-comments)
(query-dao 'issue query status)))) (query-dao 'issue query status))))
(defmethod num-comments ((issue-id integer)) (defmethod count-comments ((issue-id integer))
"Return the number of comments for the given ISSUE-ID." "Return the number of comments for the given ISSUE-ID."
(query (query
(:select (:count '*) (:select (:count '*)
@ -306,7 +302,6 @@ NOTE: This makes a database query, so be wary of N+1 queries"
:where (:= 'issue-id issue-id)) :where (:= 'issue-id issue-id))
(:asc 'created-at)))) (:asc 'created-at))))
;;; ;;;
;;; Writing ;;; Writing
;;; ;;;
@ -414,7 +409,6 @@ explicitly subscribing to / unsubscribing from individual issues."
(comment (comment
(connect-postgres)
(ddl/init) (ddl/init)
(make-instance 'issue :subject "test") (make-instance 'issue :subject "test")
(create-issue :subject "test" (create-issue :subject "test"

6
web/panettone/src/packages.lisp
View file

@ -32,7 +32,9 @@
(:use :cl :panettone.util :klatre :postmodern :iterate) (:use :cl :panettone.util :klatre :postmodern :iterate)
(:import-from :alexandria :if-let :when-let :define-constant) (:import-from :alexandria :if-let :when-let :define-constant)
(:export (:export
:connect-postgres :ddl/init :make-thread :prepare-db-connections
:ddl/init
:*pg-spec*
:user-settings :user-settings
:user-dn :enable-email-notifications-p :settings-for-user :user-dn :enable-email-notifications-p :settings-for-user
@ -76,7 +78,7 @@
:panettone.model :panettone.model
:id :subject :body :author-dn :issue-id :status :created-at :id :subject :body :author-dn :issue-id :status :created-at
:field :previous-value :new-value :acting-user-dn :field :previous-value :new-value :acting-user-dn
:issue-comments :num-comments :issue-events) :*pg-spec*)
(:import-from :panettone.irc :send-irc-notification) (:import-from :panettone.irc :send-irc-notification)
(:shadow :next) (:shadow :next)
(:export :start-pannetone :config :main)) (:export :start-pannetone :config :main))

71
web/panettone/src/panettone.lisp
View file

@ -215,7 +215,7 @@
(who:esc (format nil "#~A" issue-id))) (who:esc (format nil "#~A" issue-id)))
" - " " - "
(created-by-at issue) (created-by-at issue)
(let ((num-comments (length (issue-comments issue)))) (let ((num-comments (length (model:issue-comments issue))))
(unless (zerop num-comments) (unless (zerop num-comments)
(who:htm (who:htm
(:span :class "comment-count" (:span :class "comment-count"
@ -383,8 +383,8 @@
(:open "Close") (:open "Close")
(:closed "Reopen")))))) (:closed "Reopen"))))))
(:p (who:str (render-markdown (body issue)))) (:p (who:str (render-markdown (body issue))))
(let* ((comments (issue-comments issue)) (let* ((comments (model:issue-comments issue))
(events (issue-events issue)) (events (model:issue-events issue))
(history (merge 'list (history (merge 'list
comments comments
events events
@ -412,14 +412,15 @@
"Send an email notification to all subscribers to the given issue with the "Send an email notification to all subscribers to the given issue with the
given subject an body (in a thread, to avoid blocking)" given subject an body (in a thread, to avoid blocking)"
(let ((current-user *user*)) (let ((current-user *user*))
(model:make-thread (bordeaux-threads:make-thread
(lambda () (lambda ()
(dolist (user-dn (model:issue-subscribers issue-id)) (pomo:with-connection *pg-spec*
(when (not (equal (dn current-user) user-dn)) (dolist (user-dn (model:issue-subscribers issue-id))
(email:notify-user (when (not (equal (dn current-user) user-dn))
user-dn (email:notify-user
:subject subject user-dn
:message message))))))) :subject subject
:message message))))))))
(defun link-to-issue (issue-id) (defun link-to-issue (issue-id)
(format nil "https://b.tvl.fyi/issues/~A" issue-id)) (format nil "https://b.tvl.fyi/issues/~A" issue-id))
@ -437,15 +438,17 @@ given subject an body (in a thread, to avoid blocking)"
(hunchentoot:request-uri*) (hunchentoot:request-uri*)
:utf-8))))) :utf-8)))))
(defun @txn (next) (defun @db (next)
(pomo:with-transaction () "Decorator for handlers that use the database, wrapped in a transaction."
(catch (pomo:with-connection *pg-spec*
;; 'hunchentoot:handler-done is unexported, but is used by functions (pomo:with-transaction ()
;; like hunchentoot:redirect to nonlocally abort the request handler - (catch
;; this doesn't mean an error occurred, so we need to catch it here to ;; 'hunchentoot:handler-done is unexported, but is used by functions
;; make the transaction still get committed ;; like hunchentoot:redirect to nonlocally abort the request handler -
(intern "HANDLER-DONE" "HUNCHENTOOT") ;; this doesn't mean an error occurred, so we need to catch it here to
(funcall next)))) ;; make the transaction still get committed
(intern "HANDLER-DONE" "HUNCHENTOOT")
(funcall next)))))
(defun @handle-issue-not-found (next) (defun @handle-issue-not-found (next)
(handler-case (funcall next) (handler-case (funcall next)
@ -472,14 +475,14 @@ given subject an body (in a thread, to avoid blocking)"
(hunchentoot:delete-session-value 'user) (hunchentoot:delete-session-value 'user)
(hunchentoot:redirect "/")) (hunchentoot:redirect "/"))
(defroute index ("/" :decorators (@auth-optional)) () (defroute index ("/" :decorators (@auth-optional @db)) ()
(let ((issues (model:list-issues :status :open))) (let ((issues (model:list-issues :status :open)))
(render/index :issues issues))) (render/index :issues issues)))
(defroute settings ("/settings" :method :get :decorators (@auth)) () (defroute settings ("/settings" :method :get :decorators (@auth @db)) ()
(render/settings)) (render/settings))
(defroute save-settings ("/settings" :method :post :decorators (@auth)) (defroute save-settings ("/settings" :method :post :decorators (@auth @db))
(&post enable-email-notifications) (&post enable-email-notifications)
(let ((settings (model:settings-for-user (dn *user*)))) (let ((settings (model:settings-for-user (dn *user*))))
(model:update-user-settings (model:update-user-settings
@ -488,7 +491,7 @@ given subject an body (in a thread, to avoid blocking)"
(render/settings))) (render/settings)))
(defroute handle-closed-issues (defroute handle-closed-issues
("/issues/closed" :decorators (@auth-optional)) () ("/issues/closed" :decorators (@auth-optional @db)) ()
(let ((issues (model:list-issues :status :closed))) (let ((issues (model:list-issues :status :closed)))
(render/closed-issues :issues issues))) (render/closed-issues :issues issues)))
@ -496,7 +499,7 @@ given subject an body (in a thread, to avoid blocking)"
(render/issue-form)) (render/issue-form))
(defroute handle-create-issue (defroute handle-create-issue
("/issues" :method :post :decorators (@auth @txn)) ("/issues" :method :post :decorators (@auth @db))
(&post subject body) (&post subject body)
(if (string= subject "") (if (string= subject "")
(render/issue-form (render/issue-form
@ -518,7 +521,7 @@ given subject an body (in a thread, to avoid blocking)"
(hunchentoot:redirect "/")))) (hunchentoot:redirect "/"))))
(defroute show-issue (defroute show-issue
("/issues/:id" :decorators (@auth-optional @handle-issue-not-found)) ("/issues/:id" :decorators (@auth-optional @handle-issue-not-found @db))
(&path (id 'integer)) (&path (id 'integer))
(let* ((issue (model:get-issue id)) (let* ((issue (model:get-issue id))
(*title* (format nil "~A | Panettone" (*title* (format nil "~A | Panettone"
@ -526,14 +529,14 @@ given subject an body (in a thread, to avoid blocking)"
(render/issue issue))) (render/issue issue)))
(defroute edit-issue (defroute edit-issue
("/issues/:id/edit" :decorators (@auth @handle-issue-not-found)) ("/issues/:id/edit" :decorators (@auth @handle-issue-not-found @db))
(&path (id 'integer)) (&path (id 'integer))
(let* ((issue (model:get-issue id)) (let* ((issue (model:get-issue id))
(*title* "Edit Issue | Panettone")) (*title* "Edit Issue | Panettone"))
(render/issue-form issue))) (render/issue-form issue)))
(defroute update-issue (defroute update-issue
("/issues/:id" :decorators (@auth @handle-issue-not-found @txn) ("/issues/:id" :decorators (@auth @handle-issue-not-found @db)
;; NOTE: this should be a put, but we're all HTML forms ;; NOTE: this should be a put, but we're all HTML forms
;; right now and those don't support PUT ;; right now and those don't support PUT
:method :post) :method :post)
@ -551,7 +554,7 @@ given subject an body (in a thread, to avoid blocking)"
(defroute handle-create-comment (defroute handle-create-comment
("/issues/:id/comments" ("/issues/:id/comments"
:decorators (@auth @handle-issue-not-found @txn) :decorators (@auth @handle-issue-not-found @db)
:method :post) :method :post)
(&path (id 'integer) &post body) (&path (id 'integer) &post body)
(flet ((redirect-to-issue () (flet ((redirect-to-issue ()
@ -578,7 +581,7 @@ given subject an body (in a thread, to avoid blocking)"
(redirect-to-issue))))) (redirect-to-issue)))))
(defroute close-issue (defroute close-issue
("/issues/:id/close" :decorators (@auth @handle-issue-not-found @txn) ("/issues/:id/close" :decorators (@auth @handle-issue-not-found @db)
:method :post) :method :post)
(&path (id 'integer)) (&path (id 'integer))
(model:set-issue-status id :closed) (model:set-issue-status id :closed)
@ -602,7 +605,7 @@ given subject an body (in a thread, to avoid blocking)"
(hunchentoot:redirect (format nil "/issues/~A" id))) (hunchentoot:redirect (format nil "/issues/~A" id)))
(defroute open-issue (defroute open-issue
("/issues/:id/open" :decorators (@auth) ("/issues/:id/open" :decorators (@auth @db)
:method :post) :method :post)
(&path (id 'integer)) (&path (id 'integer))
(model:set-issue-status id :open) (model:set-issue-status id :open)
@ -634,17 +637,17 @@ given subject an body (in a thread, to avoid blocking)"
(defun migrate-db () (defun migrate-db ()
"Migrate the database to the latest version of the schema" "Migrate the database to the latest version of the schema"
(model:ddl/init)) (pomo:with-connection *pg-spec*
(model:ddl/init)))
(defun start-panettone (&key port (defun start-panettone (&key port
(ldap-host "localhost") (ldap-host "localhost")
(ldap-port 389) (ldap-port 389)
postgres-params
session-secret) session-secret)
(connect-ldap :host ldap-host (connect-ldap :host ldap-host
:port ldap-port) :port ldap-port)
(apply #'model:connect-postgres postgres-params) (model:prepare-db-connections)
(migrate-db) (migrate-db)
(when session-secret (when session-secret
@ -669,6 +672,8 @@ given subject an body (in a thread, to avoid blocking)"
:ldap-port ldap-port :ldap-port ldap-port
:session-secret session-secret) :session-secret session-secret)
(format t "launched panettone on port ~A~%" port)
(sb-thread:join-thread (sb-thread:join-thread
(find-if (lambda (th) (find-if (lambda (th)
(string= (sb-thread:thread-name th) (string= (sb-thread:thread-name th)