feat(panettone): Use postgres as the storage backend r/1497

Switch from cl-prevalence to postgres (via postmodern) as the storage
backend for panettone. The first time the application starts up after
this commit, it will (idempotently) initialize the db schema and migrate
over all data from the prevalence snapshot to the database - the plan is
then to get rid of the prevalence classes and dependency once that's
deployed.

Change-Id: I4f35707efead67d8854f1c224ef67f8471620453
Reviewed-on: https://cl.tvl.fyi/c/depot/+/1467
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>
Reviewed-by: eta <eta@theta.eu.org>

1 files changed, 133 insertions, 115 deletions

diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
index 7d29edb7ac..07285e6930 100644
--- a/web/panettone/src/panettone.lisp
+++ b/web/panettone/src/panettone.lisp
@@ -5,14 +5,15 @@
 ;;; Data model
 ;;;
 
-(deftype issue-status ()
-  '(member :open :closed))
+(deftype issue-status () '(member :open :closed))
 
 (defclass/std issue-comment ()
   ((body :type string)
    (author-dn :type string)
    (created-at :type local-time:timestamp
-               :std (local-time:now))))
+               :std (local-time:now)))
+  (:documentation
+   "DEPRECATED: use `PANETTONE.MODEL::ISSUE-COMMENT' instead"))
 
 (defclass/std issue (cl-prevalence:object-with-id)
   ((subject body :type string :std "")
@@ -20,7 +21,9 @@
    (comments :std nil :type list :with-prefix)
    (status :std :open :type issue-status)
    (created-at :type local-time:timestamp
-               :std (local-time:now))))
+               :std (local-time:now)))
+  (:documentation
+   "DEPRECATED: use `PANETTONE.MODEL::ISSUE' instead"))
 
 (defclass/std user ()
   ((cn dn mail displayname :type string)))
@@ -84,12 +87,12 @@ successful, `nil' otherwise"
   (when-let ((user (if (typep user-or-username 'user) user-or-username
                        (find-user user-or-username))))
     (let ((dn (dn user)))
-      (multiple-value-bind (_r code-sym _msg)
-          (ldap:bind
-           (ldap:new-ldap :host (ldap:host *ldap*)
-                          :port (ldap:port *ldap*)
-                          :user dn
-                          :pass password))
+      (let ((code-sym
+              (nth-value 1 (ldap:bind
+                            (ldap:new-ldap :host (ldap:host *ldap*)
+                                           :port (ldap:port *ldap*)
+                                           :user dn
+                                           :pass password)))))
         (when (equalp code-sym 'trivial-ldap:success)
           user)))))
 
@@ -103,58 +106,6 @@ successful, `nil' otherwise"
 (defvar *p-system* nil
   "The persistence system for this instance of Panettone")
 
-(define-condition issue-not-found (error)
-  ((id :type integer
-       :initarg :id
-       :reader not-found-id
-       :documentation "ID of the issue that was not found"))
-  (:documentation
-   "Error condition for when an issue requested by ID is not
-  found"))
-
-(defun get-issue (system id)
-  (restart-case
-      (or
-       (cl-prevalence:find-object-with-id system 'issue id)
-       (error 'issue-not-found :id id))
-    (different-id (new-id)
-      :report "Use a different issue ID"
-      :interactive (lambda ()
-                     (format t "Enter a new ID: ")
-                     (multiple-value-list (eval (read))))
-      (get-issue system new-id))))
-
-(defun list-issues (system)
-  (cl-prevalence:find-all-objects system 'issue))
-
-(defun issues-with-status (system status)
-  (remove-if-not (lambda (issue) (eq (status issue) status))
-                 (list-issues system)))
-
-(defun open-issues (system) (issues-with-status system :open))
-(defun closed-issues (system) (issues-with-status system :closed))
-
-(defun create-issue (system &rest attrs)
-  (cl-prevalence:tx-create-object
-   system
-   'issue
-   (chunk-list 2 attrs)))
-
-(defun add-comment (system issue-id &rest attrs)
-  "Add a comment with the given ATTRS to the issue ISSUE-ID, and return the
-updated issue"
-  (let* ((comment (apply #'make-instance 'issue-comment attrs))
-         (issue (get-issue system issue-id))
-         (comments (append (issue-comments issue)
-                           (list comment))))
-    (cl-prevalence:tx-change-object-slots
-     system
-     'issue
-     issue-id
-     `((comments ,comments)))
-    (setf (slot-value issue 'comments) comments)
-    comments))
-
 (defun initialize-persistence (data-dir)
   "Initialize the Panettone persistence system, storing data in DATA-DIR"
   (ensure-directories-exist data-dir)
@@ -165,9 +116,67 @@ updated issue"
                       "/snapshot.xml")))
 
 
-  (when (null (list-issues *p-system*))
+  (when (null (cl-prevalence:find-all-objects *p-system* 'issue))
     (cl-prevalence:tx-create-id-counter *p-system*)))
 
+(defun prevalence->postgresql (system &key force)
+  "Idempotently migrate all data from the cl-prevalence system SYSTEM into the
+global postgresql connection (eg as initialized by
+`model:connect-postgres'). With FORCE=t, will clear the database first"
+  (pomo:with-transaction (prevalence->postgresql)
+    (when force
+      (pomo:query (:delete-from 'issues)))
+    (iter
+      (for issue in (cl-prevalence:find-all-objects system 'issue))
+      (counting
+       (unless (model:issue-exists-p (get-id issue))
+         (model:create-issue
+          :id (get-id issue)
+          :subject (subject issue)
+          :body (or (body issue) "")
+          :status (status issue)
+          :author-dn (author-dn issue)
+          :created-at (created-at issue)))
+       into num-issues)
+      (sum
+       (iter
+         (for comment in (issue-comments issue))
+         (counting
+          (unless (pomo:query
+                   (:select
+                    (:exists
+                     (:select 1
+                      :from 'issue_comments
+                      :where (:and
+                              (:= 'issue_id (get-id issue))
+                              (:= 'body (body comment))
+                              (:= 'author_dn (author-dn comment))))))
+                   :single)
+            (model:create-issue-comment
+             :body (body comment)
+             :author-dn (author-dn comment)
+             :issue-id (get-id issue)
+             :created-at (created-at comment)))))
+       into num-comments)
+      (finally
+       (let ((next-id (pomo:query
+                       (:select (:+ 1 (:max 'id))
+                        :from 'issues)
+                       :single)))
+         (pomo:query
+          (pomo:sql-compile
+           `(:alter-sequence issues_id_seq :restart ,next-id))))
+       (format t "Created ~A issues and ~A comments~&"
+               num-issues num-comments)
+       (return (values num-issues num-comments))))))
+
+(comment
+ (initialize-persistence "/home/grfn/code/depot/web/panettone/")
+ (model:connect-postgres)
+ (model:ddl/init)
+ (prevalence->postgresql *p-system* :force t)
+ )
+
 ;;;
 ;;; Views
 ;;;
@@ -178,7 +187,7 @@ updated issue"
 
 (setf (who:html-mode) :html5)
 
-(defun render/footer-nav (&rest extra)
+(defun render/footer-nav ()
   (who:with-html-output (*standard-output*)
     (:footer
      (:nav
@@ -250,6 +259,7 @@ updated issue"
                :value "Submit"))))))
 
 (defun created-by-at (issue)
+  (check-type issue model:issue)
   (who:with-html-output (*standard-output*)
     (:span :class "created-by-at"
            "Opened by "
@@ -269,7 +279,7 @@ updated issue"
     (:ol
      :class "issue-list"
      (dolist (issue issues)
-       (let ((issue-id (get-id issue)))
+       (let ((issue-id (model:id issue)))
          (who:htm
           (:li
            (:a :href (format nil "/issues/~A" issue-id)
@@ -350,8 +360,8 @@ updated issue"
              :value "Comment"))))
 
 (defun render/issue (issue)
-  (check-type issue issue)
-  (let ((issue-id (get-id issue))
+  (check-type issue model:issue)
+  (let ((issue-id (id issue))
         (issue-status (status issue)))
     (render ()
       (:header
@@ -397,7 +407,7 @@ updated issue"
                          " at "
                          (who:esc (format-dottime (created-at comment)))))))))
            (when *user*
-             (render/new-comment (get-id issue))))))))))
+             (render/new-comment (id issue))))))))))
 
 (defun render/not-found (entity-type)
   (render ()
@@ -420,6 +430,22 @@ updated issue"
               (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 @handle-issue-not-found (next)
+  (handler-case (funcall next)
+    (issue-not-found (err)
+      (render/not-found
+       (format nil "Issue #~A" (model:id err))))))
+
 (defroute login-form ("/login" :method :get)
     (original-uri)
   (if (hunchentoot:session-value 'user)
@@ -439,84 +465,69 @@ updated issue"
   (hunchentoot:redirect "/"))
 
 (defroute index ("/" :decorators (@auth-optional)) ()
-  (let ((issues (open-issues *p-system*)))
+  (let ((issues (model:list-issues :status :open)))
     (render/index :issues issues)))
 
 (defroute handle-closed-issues
     ("/issues/closed" :decorators (@auth-optional)) ()
-  (let ((issues (closed-issues *p-system*)))
+  (let ((issues (model:list-issues :status :closed)))
     (render/closed-issues :issues issues)))
 
 (defroute new-issue ("/issues/new" :decorators (@auth)) ()
   (render/new-issue))
 
 (defroute handle-create-issue
-    ("/issues" :method :post :decorators (@auth))
+    ("/issues" :method :post :decorators (@auth @txn))
     (&post subject body)
   (if (string= subject "")
       (render/new-issue "Subject is required")
       (progn
-        (cl-prevalence:execute-transaction
-         (create-issue *p-system*
-                       'subject subject
-                       'body body
-                       'author-dn (dn *user*)))
-        (cl-prevalence:snapshot *p-system*)
+        (model:create-issue :subject subject
+                                      :body body
+                                      :author-dn (dn *user*))
         (hunchentoot:redirect "/"))))
 
-(defroute show-issue ("/issues/:id" :decorators (@auth-optional))
+(defroute show-issue
+    ("/issues/:id" :decorators (@auth-optional @handle/issue-not-found))
     (&path (id 'integer))
   (handler-case
-      (let* ((issue (get-issue *p-system* id))
+      (let* ((issue (model:get-issue id))
              (*title* (format nil "~A | Panettone"
                               (subject issue))))
         (render/issue issue))
     (issue-not-found (_)
+      (declare (ignore _))
       (render/not-found "Issue"))))
 
 (defroute handle-create-comment
-    ("/issues/:id/comments" :decorators (@auth)
-                            :method :post)
+    ("/issues/:id/comments"
+     :decorators (@auth @handle-issue-not-found @txn)
+     :method :post)
     (&path (id 'integer) &post body)
   (flet ((redirect-to-issue ()
            (hunchentoot:redirect (format nil "/issues/~A" id))))
-    (if (string= body "")
-        (redirect-to-issue)
-        (handler-case
-            (progn
-              (cl-prevalence:execute-transaction
-               (add-comment *p-system* id
-                            :body body
-                            :author-dn (dn *user*)))
-              (cl-prevalence:snapshot *p-system*)
-              (redirect-to-issue))
-          (issue-not-found (_)
-            (render/not-found "Issue"))))))
+    (cond
+      ((string= body "")
+       (redirect-to-issue))
+      (:else
+       (model:create-issue-comment
+        :issue-id id
+        :body body
+        :author-dn (dn *user*))
+       (redirect-to-issue)))))
 
 (defroute close-issue
-    ("/issues/:id/close" :decorators (@auth)
+    ("/issues/:id/close" :decorators (@auth @handle-issue-not-found @txn)
                          :method :post)
     (&path (id 'integer))
-  (cl-prevalence:execute-transaction
-   (cl-prevalence:tx-change-object-slots
-    *p-system*
-    'issue
-    id
-    '((status :closed))))
-  (cl-prevalence:snapshot *p-system*)
+  (model:set-issue-status id :closed)
   (hunchentoot:redirect (format nil "/issues/~A" id)))
 
 (defroute open-issue
     ("/issues/:id/open" :decorators (@auth)
                          :method :put)
     (&path (id 'integer))
-  (cl-prevalence:execute-transaction
-   (cl-prevalence:tx-change-object-slots
-    *p-system*
-    'issue
-    id
-    '((status open))))
-  (cl-prevalence:snapshot *p-system*)
+  (model:set-issue-status id :open)
   (hunchentoot:redirect (format nil "/issues/~A" id)))
 
 (defroute styles ("/main.css") ()
@@ -526,23 +537,30 @@ updated issue"
 (defvar *acceptor* nil
   "Hunchentoot acceptor for Panettone's web server.")
 
+(defun migrate-db ()
+  "Migrate the database to the latest version of the schema
+
+In this iteration, intiialize the DDL and move all data from the prevalence
+snapshot to the DB. In future iterations, this will do things like adding new
+tables and columns"
+  (model:ddl/init)
+  (prevalence->postgresql *p-system*))
+
 (defun start-panettone (&key port data-dir
                           (ldap-host "localhost")
-                          (ldap-port 389))
+                          (ldap-port 389)
+                          postgres-params)
   (connect-ldap :host ldap-host
                 :port ldap-port)
+
   (initialize-persistence data-dir)
+  (apply #'model:connect-postgres postgres-params)
+  (migrate-db)
 
   (setq *acceptor*
         (make-instance 'easy-routes:routes-acceptor :port port))
   (hunchentoot:start *acceptor*))
 
-(defun integer-env (var &key default)
-  (or
-   (when-let ((str (uiop:getenvp var)))
-     (try-parse-integer str))
-   default))
-
 (defun main ()
   (let ((port (integer-env "PANETTONE_PORT" :default 6161))
         (ldap-port (integer-env "LDAP_PORT" :default 389))