about summary refs log tree commit diff
path: root/web/panettone/src/panettone.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'web/panettone/src/panettone.lisp')
-rw-r--r--web/panettone/src/panettone.lisp71
1 files changed, 38 insertions, 33 deletions
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
index 4c9c7dafee9b..3de7fe25baad 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)