From fe290a5ff8033b1b606ac80131ec2e5b0b30f0e4 Mon Sep 17 00:00:00 2001 From: Vincent Ambo Date: Thu, 3 Feb 2022 02:18:09 +0300 Subject: refactor(web/panettone): Use postmodern connection pools 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 Autosubmit: tazjin --- web/panettone/src/model.lisp | 44 +++++++++++-------------- web/panettone/src/packages.lisp | 6 ++-- web/panettone/src/panettone.lisp | 71 +++++++++++++++++++++------------------- 3 files changed, 61 insertions(+), 60 deletions(-) (limited to 'web') diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp index a3b75380c8..c54a0ae474 100644 --- a/web/panettone/src/model.lisp +++ b/web/panettone/src/model.lisp @@ -1,28 +1,24 @@ (in-package :panettone.model) (declaim (optimize (safety 3))) -(defun connect-postgres (&key - (host (or (uiop:getenvp "PGHOST") "localhost")) - (user (or (uiop:getenvp "PGUSER") "panettone")) - (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 - (function &rest args) - "Make a new thread as per `BORDEAUX-THREADS:MAKE-THREAD' but with its own, new -database connection." - (let ((spec `(,(or (uiop:getenvp "PGDATABASE") "panettone") - ,(or (uiop:getenvp "PGUSER") "panettone") - ,(or (uiop:getenvp "PGPASSWORD") "password") - ,(or (uiop:getenvp "PGHOST") "localhost") - :port ,(or (integer-env "PGPORT") 5432)))) - (apply #'bt:make-thread - (lambda () - (postmodern:call-with-connection spec function)) - args))) +(defvar *pg-spec* nil + "Connection spec for use with the with-connection macro. Needs to be +initialised at launch time.") + +(defun make-pg-spec () + "Construct the Postgres connection spec from the environment." + (list (or (uiop:getenvp "PGDATABASE") "panettone") + (or (uiop:getenvp "PGUSER") "panettone") + (or (uiop:getenvp "PGPASSWORD") "password") + (or (uiop:getenvp "PGHOST") "localhost") + + :port (or (integer-env "PGPORT") 5432) + :application-name "panettone" + :pooled-p t)) + +(defun prepare-db-connections () + "Initialises the connection spec used for all Postgres connections." + (setq *pg-spec* (make-pg-spec))) ;;; ;;; Schema @@ -268,7 +264,7 @@ type `ISSUE-NOT-FOUND'." (with-column-writers ('num_comments 'num-comments) (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." (query (:select (:count '*) @@ -306,7 +302,6 @@ NOTE: This makes a database query, so be wary of N+1 queries" :where (:= 'issue-id issue-id)) (:asc 'created-at)))) - ;;; ;;; Writing ;;; @@ -414,7 +409,6 @@ explicitly subscribing to / unsubscribing from individual issues." (comment - (connect-postgres) (ddl/init) (make-instance 'issue :subject "test") (create-issue :subject "test" diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp index b0833e4541..81d2bed728 100644 --- a/web/panettone/src/packages.lisp +++ b/web/panettone/src/packages.lisp @@ -32,7 +32,9 @@ (:use :cl :panettone.util :klatre :postmodern :iterate) (:import-from :alexandria :if-let :when-let :define-constant) (:export - :connect-postgres :ddl/init :make-thread + :prepare-db-connections + :ddl/init + :*pg-spec* :user-settings :user-dn :enable-email-notifications-p :settings-for-user @@ -76,7 +78,7 @@ :panettone.model :id :subject :body :author-dn :issue-id :status :created-at :field :previous-value :new-value :acting-user-dn - :issue-comments :num-comments :issue-events) + :*pg-spec*) (:import-from :panettone.irc :send-irc-notification) (:shadow :next) (:export :start-pannetone :config :main)) diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp index 4c9c7dafee..3de7fe25ba 100644 --- a/web/panettone/src/panettone.lisp +++ b/web/panettone/src/panettone.lisp @@ -215,7 +215,7 @@ (who:esc (format nil "#~A" issue-id))) " - " (created-by-at issue) - (let ((num-comments (length (issue-comments issue)))) + (let ((num-comments (length (model:issue-comments issue)))) (unless (zerop num-comments) (who:htm (:span :class "comment-count" @@ -383,8 +383,8 @@ (:open "Close") (:closed "Reopen")))))) (:p (who:str (render-markdown (body issue)))) - (let* ((comments (issue-comments issue)) - (events (issue-events issue)) + (let* ((comments (model:issue-comments issue)) + (events (model:issue-events issue)) (history (merge 'list comments events @@ -412,14 +412,15 @@ "Send an email notification to all subscribers to the given issue with the given subject an body (in a thread, to avoid blocking)" (let ((current-user *user*)) - (model:make-thread + (bordeaux-threads:make-thread (lambda () - (dolist (user-dn (model:issue-subscribers issue-id)) - (when (not (equal (dn current-user) user-dn)) - (email:notify-user - user-dn - :subject subject - :message message))))))) + (pomo:with-connection *pg-spec* + (dolist (user-dn (model:issue-subscribers issue-id)) + (when (not (equal (dn current-user) user-dn)) + (email:notify-user + user-dn + :subject subject + :message message)))))))) (defun link-to-issue (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*) :utf-8))))) -(defun @txn (next) - (pomo:with-transaction () - (catch - ;; 'hunchentoot:handler-done is unexported, but is used by functions - ;; like hunchentoot:redirect to nonlocally abort the request handler - - ;; this doesn't mean an error occurred, so we need to catch it here to - ;; make the transaction still get committed - (intern "HANDLER-DONE" "HUNCHENTOOT") - (funcall next)))) +(defun @db (next) + "Decorator for handlers that use the database, wrapped in a transaction." + (pomo:with-connection *pg-spec* + (pomo:with-transaction () + (catch + ;; 'hunchentoot:handler-done is unexported, but is used by functions + ;; like hunchentoot:redirect to nonlocally abort the request handler - + ;; this doesn't mean an error occurred, so we need to catch it here to + ;; make the transaction still get committed + (intern "HANDLER-DONE" "HUNCHENTOOT") + (funcall next))))) (defun @handle-issue-not-found (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:redirect "/")) -(defroute index ("/" :decorators (@auth-optional)) () +(defroute index ("/" :decorators (@auth-optional @db)) () (let ((issues (model:list-issues :status :open))) (render/index :issues issues))) -(defroute settings ("/settings" :method :get :decorators (@auth)) () +(defroute settings ("/settings" :method :get :decorators (@auth @db)) () (render/settings)) -(defroute save-settings ("/settings" :method :post :decorators (@auth)) +(defroute save-settings ("/settings" :method :post :decorators (@auth @db)) (&post enable-email-notifications) (let ((settings (model:settings-for-user (dn *user*)))) (model:update-user-settings @@ -488,7 +491,7 @@ given subject an body (in a thread, to avoid blocking)" (render/settings))) (defroute handle-closed-issues - ("/issues/closed" :decorators (@auth-optional)) () + ("/issues/closed" :decorators (@auth-optional @db)) () (let ((issues (model:list-issues :status :closed))) (render/closed-issues :issues issues))) @@ -496,7 +499,7 @@ given subject an body (in a thread, to avoid blocking)" (render/issue-form)) (defroute handle-create-issue - ("/issues" :method :post :decorators (@auth @txn)) + ("/issues" :method :post :decorators (@auth @db)) (&post subject body) (if (string= subject "") (render/issue-form @@ -518,7 +521,7 @@ given subject an body (in a thread, to avoid blocking)" (hunchentoot:redirect "/")))) (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)) (let* ((issue (model:get-issue id)) (*title* (format nil "~A | Panettone" @@ -526,14 +529,14 @@ given subject an body (in a thread, to avoid blocking)" (render/issue 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)) (let* ((issue (model:get-issue id)) (*title* "Edit Issue | Panettone")) (render/issue-form 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 ;; right now and those don't support PUT :method :post) @@ -551,7 +554,7 @@ given subject an body (in a thread, to avoid blocking)" (defroute handle-create-comment ("/issues/:id/comments" - :decorators (@auth @handle-issue-not-found @txn) + :decorators (@auth @handle-issue-not-found @db) :method :post) (&path (id 'integer) &post body) (flet ((redirect-to-issue () @@ -578,7 +581,7 @@ given subject an body (in a thread, to avoid blocking)" (redirect-to-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) (&path (id 'integer)) (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))) (defroute open-issue - ("/issues/:id/open" :decorators (@auth) + ("/issues/:id/open" :decorators (@auth @db) :method :post) (&path (id 'integer)) (model:set-issue-status id :open) @@ -634,17 +637,17 @@ given subject an body (in a thread, to avoid blocking)" (defun migrate-db () "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 (ldap-host "localhost") (ldap-port 389) - postgres-params session-secret) (connect-ldap :host ldap-host :port ldap-port) - (apply #'model:connect-postgres postgres-params) + (model:prepare-db-connections) (migrate-db) (when session-secret @@ -669,6 +672,8 @@ given subject an body (in a thread, to avoid blocking)" :ldap-port ldap-port :session-secret session-secret) + (format t "launched panettone on port ~A~%" port) + (sb-thread:join-thread (find-if (lambda (th) (string= (sb-thread:thread-name th) -- cgit 1.4.1