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 <tvl@eta.st> Autosubmit: tazjin <tazjin@tvl.su>
This commit is contained in:
Vincent Ambo
clbot
parent
b7be2660c9
commit
fe290a5ff8
3 changed files with 60 additions and 59 deletions
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue