about summary refs log tree commit diff
diff options
context:
space:
mode:
-rw-r--r--web/panettone/default.nix2
-rw-r--r--web/panettone/src/model.lisp225
-rw-r--r--web/panettone/src/packages.lisp28
-rw-r--r--web/panettone/src/panettone.lisp248
-rw-r--r--web/panettone/src/util.lisp7
5 files changed, 394 insertions, 116 deletions
diff --git a/web/panettone/default.nix b/web/panettone/default.nix
index 2de000b7e852..93000b0f50a1 100644
--- a/web/panettone/default.nix
+++ b/web/panettone/default.nix
@@ -12,6 +12,7 @@ depot.nix.buildLisp.program {
     hunchentoot
     lass
     local-time
+    postmodern
     trivial-ldap
 
     depot.lisp.klatre
@@ -21,6 +22,7 @@ depot.nix.buildLisp.program {
     ./panettone.asd
     ./src/packages.lisp
     ./src/css.lisp
+    ./src/model.lisp
     ./src/panettone.lisp
   ];
 }
diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp
new file mode 100644
index 000000000000..3b19901c9945
--- /dev/null
+++ b/web/panettone/src/model.lisp
@@ -0,0 +1,225 @@
+(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))
+
+;;;
+;;; Schema
+;;;
+
+(define-constant +issue-statuses+ '(:open :closed)
+  :test #'equal)
+
+(deftype issue-status ()
+  "Type specifier for the status of an `issue'"
+  (cons 'member +issue-statuses+))
+
+(defun ddl/create-issue-status ()
+  "Issue DDL to create the `issue-status' type, if it doesn't exist"
+  (unless (query (:select (:exists (:select 1
+                                    :from 'pg_type
+                                    :where (:= 'typname "issue_status"))))
+                 :single)
+    (query (sql-compile
+            `(:create-enum issue-status ,+issue-statuses+)))))
+
+(defclass issue ()
+  ((id :col-type serial :initarg :id :accessor id)
+   (subject :col-type string :initarg :subject :accessor subject)
+   (body :col-type string :initarg :body :accessor body :col-default "")
+   (author-dn :col-type string :initarg :author-dn :accessor author-dn)
+   (comments :type list :accessor issue-comments)
+   (num-comments :type integer :accessor num-comments)
+   (status :col-type issue_status
+           :initarg :status
+           :accessor status
+           :initform :open
+           :col-default "open")
+   (created-at :col-type timestamp
+               :col-default (local-time:now)
+               :accessor created-at))
+  (:metaclass dao-class)
+  (:keys id)
+  (:table-name issues)
+  (:documentation
+   "Issues are the primary entity in the Panettone database. An issue is
+   reported by a user, has a subject and an optional body, and can be either
+   open or closed"))
+
+(defmethod cl-postgres:to-sql-string ((kw (eql :open)))
+  (cl-postgres:to-sql-string "open"))
+(defmethod cl-postgres:to-sql-string ((kw (eql :closed)))
+  (cl-postgres:to-sql-string "closed"))
+
+(defun created-at->timestamp (object)
+  (assert (slot-exists-p object 'created-at))
+  (unless (or (not (slot-boundp object 'created-at))
+              (typep (slot-value object 'created-at) 'local-time:timestamp))
+    (setf (slot-value object 'created-at)
+          (local-time:universal-to-timestamp (created-at object)))))
+
+(defmethod initialize-instance :after
+    ((issue issue) &rest initargs &key &allow-other-keys)
+  (declare (ignore initargs))
+  (unless (symbolp (status issue))
+    (setf (status issue)
+          (intern (string-upcase (status issue))
+                  "KEYWORD")))
+  (created-at->timestamp issue))
+
+(deftable issue (!dao-def))
+
+(defclass issue-comment ()
+  ((id :col-type integer :col-identity t :initarg :id :accessor id)
+   (body :col-type string :initarg :body :accessor body)
+   (author-dn :col-type string :initarg :author-dn :accessor author-dn)
+   (issue-id :col-type integer :initarg :issue-id :accessor :user-id)
+   (created-at :col-type timestamp
+               :col-default (local-time:now)
+               :accessor created-at))
+  (:metaclass dao-class)
+  (:keys id)
+  (:table-name issue_comments)
+  (:documentation "Comments on an `issue'"))
+(deftable (issue-comment "issue_comments")
+  (!dao-def)
+  (!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade))
+
+(defmethod initialize-instance :after
+    ((issue-comment issue-comment) &rest initargs &key &allow-other-keys)
+  (declare (ignore initargs))
+  (created-at->timestamp issue-comment))
+
+(defun ddl/create-tables ()
+  "Issue DDL to create all tables, if they don't already exist."
+  (dolist (table '(issue issue-comment))
+    (unless (table-exists-p (dao-table-name table))
+      (create-table table))))
+
+(defun ddl/init ()
+  "Idempotently nitialize the full database schema for Panettone"
+  (ddl/create-issue-status)
+  (ddl/create-tables))
+
+;;;
+;;; Querying
+;;;
+
+(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 (id)
+  "Look up the 'issue with the given ID and return it, or signal a condition of
+type `ISSUE-NOT-FOUND'."
+  (restart-case
+      (or (get-dao '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 new-id))))
+
+(defun issue-exists-p (id)
+  "Returns `T' if an issue with the given ID exists"
+  (query
+   (:select (:exists (:select 1
+                      :from 'issues
+                      :where (:= 'id id))))
+   :single))
+
+(defun list-issues (&key status (with '(:num-comments)))
+  "Return a list of all issues with the given STATUS (or all if nil), ordered by
+  ID descending. If WITH contains `:NUM-COMMENTS' (the default) each issue will
+  have the `num-comments' slot filled with the number of comments on that issue
+  (to avoid N+1 queries)."
+  (let* ((condition (unless (null status)
+                      `(:where (:= status $1))))
+         (select (if (find :num-comments with)
+                     `(:select issues.* (:as (:count issue-comments.id)
+                                             num-comments)
+                               :from issues
+                               :left-join issue-comments
+                               :on (:= issues.id issue-comments.issue-id)
+                               ,@condition
+                               :group-by issues.id)
+                     `(:select * :from issues ,@condition)))
+         (query (sql-compile
+                 `(:order-by ,select (:desc id)))))
+    (with-column-writers ('num_comments 'num-comments)
+      (query-dao 'issue query status))))
+
+(defmethod num-comments ((issue-id integer))
+  "Return the number of comments for the given ISSUE-ID."
+  (query
+   (:select (:count '*)
+    :from 'issue-comments
+    :where (:= 'issue-id issue-id))
+   :single))
+
+(defmethod slot-unbound (cls (issue issue) (slot (eql 'comments)))
+  (declare (ignore cls) (ignore slot))
+  (setf (issue-comments issue) (issue-comments (id issue))))
+
+(defmethod issue-comments ((issue-id integer))
+  "Return a list of all comments with the given ISSUE-ID, sorted oldest first.
+NOTE: This makes a database query, so be wary of N+1 queries"
+  (query-dao
+   'issue-comment
+   (:order-by
+    (:select '*
+     :from 'issue-comments
+     :where (:= 'issue-id issue-id))
+    (:asc 'created-at))))
+
+;;;
+;;; Writing
+;;;
+
+(defun create-issue (&rest attrs)
+  "Insert a new issue into the database with the given ATTRS, which should be
+a plist of initforms, and return an instance of `issue'"
+  (insert-dao (apply #'make-instance 'issue attrs)))
+
+(defun delete-issue (issue)
+  (delete-dao issue))
+
+(defun set-issue-status (issue-id status)
+  "Set the status of the issue with the given ISSUE-ID to STATUS in the db. If
+the issue doesn't exist, signals `issue-not-found'"
+  (check-type issue-id integer)
+  (check-type status issue-status)
+  (when (zerop (execute (:update 'issues
+                         :set 'status (cl-postgres:to-sql-string status)
+                         :where (:= 'id issue-id))))
+    (error 'issue-not-found :id issue-id)))
+
+(defun create-issue-comment (&rest attrs &key issue-id &allow-other-keys)
+  "Insert a new issue comment into the database with the given ATTRS and
+ISSUE-ID, which should be a plist of initforms, and return an instance of
+`issue-comment'. If no issue exists with `ID' ISSUE-ID, signals
+`issue-not-found'."
+  (unless (issue-exists-p issue-id)
+    (error 'issue-not-found :id issue-id))
+  (insert-dao (apply #'make-instance 'issue-comment :issue-id issue-id attrs)))
+
+(comment
+ (connect-postgres)
+ (ddl/init)
+ (make-instance 'issue :subject "test")
+ (create-issue :subject "test"
+               :author-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
+ )
diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp
index 8ebf528cca70..169d8833a7bd 100644
--- a/web/panettone/src/packages.lisp
+++ b/web/panettone/src/packages.lisp
@@ -1,10 +1,36 @@
+(defpackage panettone.util
+  (:use :cl :klatre)
+  (:import-from :alexandria :when-let)
+  (:export :integer-env))
+
 (defpackage panettone.css
   (:use :cl :lass)
   (:export :styles))
 
+(defpackage panettone.model
+  (:nicknames :model)
+  (:use :cl :panettone.util :klatre :postmodern)
+  (:import-from :alexandria :if-let :define-constant)
+  (:export
+   :connect-postgres :ddl/init
+
+   :issue
+   :issue-comment
+   :id :subject :body :author-dn :issue-id :status :created-at
+
+   :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status
+   :delete-issue
+
+   :issue-comments :num-comments :create-issue-comment))
+
 (defpackage panettone
-  (:use :cl :klatre :easy-routes)
+  (:use :cl :panettone.util :klatre :easy-routes :iterate)
   (:import-from :cl-prevalence :get-id)
   (:import-from :defclass-std :defclass/std)
   (:import-from :alexandria :if-let :when-let)
+  (:import-from
+   :panettone.model
+   :id :subject :body :author-dn :issue-id :status :created-at
+   :issue-comments :num-comments)
+  (:shadow :next)
   (:export :start-pannetone :config :main))
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
index 7d29edb7ac75..07285e69303a 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))
diff --git a/web/panettone/src/util.lisp b/web/panettone/src/util.lisp
new file mode 100644
index 000000000000..9fd9ceaa79a4
--- /dev/null
+++ b/web/panettone/src/util.lisp
@@ -0,0 +1,7 @@
+(in-package :panettone.util)
+
+(defun integer-env (var &key default)
+  (or
+   (when-let ((str (uiop:getenvp var)))
+     (try-parse-integer str))
+   default))