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)
(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))
(defvar *pg-spec* nil
"Connection spec for use with the with-connection macro. Needs to be
initialised at launch time.")
(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)))
(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"

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

@ -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))

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

@ -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 ()
(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)))))))
:message message))))))))
(defun link-to-issue (issue-id)
(format nil "https://b.tvl.fyi/issues/~A" issue-id))
@ -437,7 +438,9 @@ given subject an body (in a thread, to avoid blocking)"
(hunchentoot:request-uri*)
:utf-8)))))
(defun @txn (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
@ -445,7 +448,7 @@ given subject an body (in a thread, to avoid blocking)"
;; 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))))
(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)