about summary refs log tree commit diff
path: root/web/panettone/src
diff options
context:
space:
mode:
Diffstat (limited to 'web/panettone/src')
-rw-r--r--web/panettone/src/.gitignore2
-rw-r--r--web/panettone/src/authentication.lisp115
-rw-r--r--web/panettone/src/css.lisp227
-rw-r--r--web/panettone/src/email.lisp48
-rw-r--r--web/panettone/src/inline-markdown.lisp131
-rw-r--r--web/panettone/src/irc.lisp35
-rw-r--r--web/panettone/src/model.lisp421
-rw-r--r--web/panettone/src/packages.lisp82
-rw-r--r--web/panettone/src/panettone.lisp687
-rw-r--r--web/panettone/src/util.lisp7
10 files changed, 1755 insertions, 0 deletions
diff --git a/web/panettone/src/.gitignore b/web/panettone/src/.gitignore
new file mode 100644
index 000000000000..10aa5440d832
--- /dev/null
+++ b/web/panettone/src/.gitignore
@@ -0,0 +1,2 @@
+# I use this as the out-link for my local lisp dev env
+sbcl
diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp
new file mode 100644
index 000000000000..07b9a6a87cd5
--- /dev/null
+++ b/web/panettone/src/authentication.lisp
@@ -0,0 +1,115 @@
+(in-package :panettone.authentication)
+
+(defvar *user* nil
+  "The currently logged-in user")
+
+(defvar *ldap* nil
+  "The ldap connection")
+
+(defvar *ldap-host* "localhost"
+  "The host for the ldap connection")
+
+(defvar *ldap-port* 389
+  "The port for the ldap connection")
+
+(defclass/std user ()
+  ((cn dn mail displayname :type string)))
+
+(defun connect-ldap (&key
+                       (host "localhost")
+                       (port 389))
+  (setq *ldap-host* host
+        *ldap-port* port
+        *ldap* (ldap:new-ldap :host host :port port)))
+
+(defun reconnect-ldap ()
+  (setq *ldap* (ldap:new-ldap
+                :host *ldap-host*
+                :port *ldap-port*)))
+
+(defmacro with-ldap ((&key (max-tries 1)) &body body)
+  "Execute BODY in a context where ldap connection errors trigger a reconnect
+and a retry"
+  (with-gensyms (n try retry e)
+    `(flet
+         ((,try
+              (,n)
+            (flet ((,retry (,e)
+                     (if (>= ,n ,max-tries)
+                         (error ,e)
+                         (progn
+                           (reconnect-ldap)
+                           (,try (1+ ,n))))))
+              (handler-case
+                  (progn
+                    ,@body)
+                (end-of-file (,e) (,retry ,e))
+                (trivial-ldap:ldap-connection-error (,e) (,retry ,e))))))
+       (,try 0))))
+
+(defun ldap-entry->user (entry)
+  (apply
+   #'make-instance
+   'user
+   :dn (ldap:dn entry)
+   (alexandria:mappend
+    (lambda (field)
+      (list field (car (ldap:attr-value entry field))))
+    (list :mail
+          :cn
+          :displayname))))
+
+(defun find-user/ldap (username)
+  (check-type username (simple-array character (*)))
+  (with-ldap ()
+    (ldap:search
+     *ldap*
+     `(and (= objectClass organizationalPerson)
+           (or
+            (= cn ,username)
+            (= dn ,username)))
+     ;; TODO(grfn): make this configurable
+     :base "ou=users,dc=tvl,dc=fyi")
+    (ldap:next-search-result *ldap*)))
+
+(defun find-user (username)
+  (check-type username (simple-array character (*)))
+  (when-let ((ldap-entry (find-user/ldap username)))
+    (ldap-entry->user ldap-entry)))
+
+(defun find-user-by-dn (dn)
+  "Look up the user with the given DN in the LDAP database, returning an
+instance of `user'"
+  (with-ldap ()
+    (let ((have-results
+            (handler-case
+              (ldap:search *ldap* `(= objectClass organizationalPerson)
+                           :base dn
+                           :scope 'ldap:base)
+              ; catch ldap-errors generated by trivial-ldap:parse-ldap-message
+              ; since this is thrown on conditions which we don't want this
+              ; function to fail like when there are no search results
+              (trivial-ldap:ldap-error (e) nil))))
+      (when have-results
+        (when-let ((ldap-entry (ldap:next-search-result *ldap*)))
+          (ldap-entry->user ldap-entry))))))
+
+(comment
+ (find-user-by-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
+ )
+
+(defun authenticate-user (user-or-username password)
+  "Checks the given USER-OR-USERNAME has the given PASSWORD, by making a bind
+request against the ldap server at *ldap*. Returns the user if authentication is
+successful, `nil' otherwise"
+  (when-let ((user (if (typep user-or-username 'user) user-or-username
+                       (find-user user-or-username))))
+    (let ((dn (dn user)))
+      (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)))))
diff --git a/web/panettone/src/css.lisp b/web/panettone/src/css.lisp
new file mode 100644
index 000000000000..0919cc62f602
--- /dev/null
+++ b/web/panettone/src/css.lisp
@@ -0,0 +1,227 @@
+(in-package :panettone.css)
+(declaim (optimize (safety 3)))
+
+(defparameter color/black
+  "rgb(24, 24, 24)")
+
+(defparameter color/light-gray
+  "#EEE")
+
+(defparameter color/gray
+  "#8D8D8D")
+
+(defparameter color/primary
+  "rgb(106, 154, 255)")
+
+(defparameter color/primary-light
+  "rgb(150, 166, 200)")
+
+(defparameter color/success
+  "rgb(168, 249, 166)")
+
+(defparameter color/success-2
+  "rgb(168, 249, 166)")
+
+(defparameter color/failure
+  "rgb(247, 167, 167)")
+
+(defun button (selector)
+  `((,selector
+     :background-color ,color/success
+     :padding "0.5rem"
+     :text-decoration "none"
+     :transition "box-shadow" "0.15s" "ease-in-out")
+
+    ((:and ,selector :hover)
+     :box-shadow "0.25rem" "0.25rem" "0" "0" "rgba(0,0,0,0.08)")
+
+    ((:and ,selector (:or :active :focus))
+     :box-shadow "0.1rem" "0.1rem" "0" "0" "rgba(0,0,0,0.05)"
+     :outline "none"
+     :border "none")))
+
+(defparameter markdown-styles
+  `((blockquote
+     :border-left "5px" "solid" ,color/light-gray
+     :padding-left "1rem"
+     :margin-left "0rem")
+    (pre
+     :overflow-x "auto")))
+
+(defparameter issue-list-styles
+  `((.issue-list
+     :list-style-type "none"
+     :padding-left 0
+
+     (.issue-subject
+      :font-weight "bold")
+
+     (li
+      :padding-bottom "1rem")
+
+     ((li + li)
+      :border-top "1px" "solid" ,color/gray)
+
+     (a
+      :text-decoration "none"
+      :display "block")
+
+     ((:and a :hover)
+      :outline "none"
+
+      (.issue-subject
+       :color ,color/primary)))
+
+    (.comment-count
+     :color ,color/gray)))
+
+(defparameter issue-history-styles
+  `((.issue-history
+     :list-style "none"
+     :border-top "1px" "solid" ,color/gray
+     :padding-top "1rem"
+     :padding-left "2rem"
+
+     (.comment-info
+      :color ,color/gray
+      :margin 0
+      :padding-top "1rem"
+
+      (a :text-decoration "none")
+      ((:and a :hover)
+       :text-decoration "underline"))
+
+     ((:or .comment .event)
+      :padding-top "1rem"
+      :padding-bottom "1rem"
+      :border-bottom "1px" "solid" ,color/gray
+
+      (p :margin 0))
+
+     ((:and (:or .comment .event) :target)
+      :border-color ,color/primary
+      :border-bottom-width "3px")
+
+     (.event
+      :color ,color/gray))))
+
+(defparameter form-styles
+  `(((:or (:and input (:or (:= type "text")
+                           (:= type "password")))
+          textarea)
+     :width "100%"
+     :padding "0.5rem"
+     :outline "none"
+     :border-top "none"
+     :border-left "none"
+     :border-right "none"
+     :border-bottom "1px" "solid" ,color/gray
+     :margin-bottom "1rem")
+
+    (textarea
+     :resize "vertical")
+
+    ((:and input (:= type "submit"))
+     :-webkit-appearance "none"
+     :border "none"
+     :cursor "pointer"
+     :font-size "1rem")
+
+    ,@(button '(:and input (:= type "submit")))
+
+    (.form-link
+     ((:and input (:= type "submit"))
+      :background-color "initial"
+      :color "inherit"
+      :padding 0
+      :text-decoration "underline")
+
+     ((:and input (:= type "submit")
+            (:or :hover :active :focus))
+      :box-shadow 0 0 0 0))
+
+    (.form-group
+     :margin-top "1rem")
+
+    (label.checkbox
+     :cursor "pointer")))
+
+(defparameter issue-styles
+  `((.issue-info
+     :display "flex"
+     :justify-content "space-between"
+     :align-items "center"
+
+     ,@(button '.edit-issue)
+
+     (.created-by-at
+      :flex 1)
+
+     (.edit-issue
+      :background-color ,color/light-gray
+      :flex 0
+      :margin-right "0.5rem")
+
+     (.close-issue
+      :background-color ,color/failure))))
+
+(defparameter styles
+  `(,@form-styles
+    ,@issue-list-styles
+    ,@issue-styles
+    ,@issue-history-styles
+    ,@markdown-styles
+
+    (body
+     :font-family "sans-serif"
+     :color ,color/black)
+
+    (a :color "inherit")
+
+    (.content
+     :max-width "800px"
+     :margin "0 auto")
+
+    (header
+     :display "flex"
+     :align-items "center"
+     :border-bottom "1px" "solid" ,color/black
+     :margin-bottom "1rem"
+
+     (h1
+      :padding 0
+      :flex 1)
+
+     (.issue-number
+      :color ,color/gray
+      :font-size "1.5rem"))
+
+    (nav
+     :display "flex"
+     :color ,color/gray
+     :justify-content "space-between"
+
+     (.nav-group
+      :display "flex"
+      (>*
+       :margin-left "0.5rem")))
+
+    (footer
+     :border-top "1px" "solid" ,color/gray
+     :padding-top "1rem"
+     :margin-top "1rem"
+     :color ,color/gray)
+
+    ,@(button '.new-issue)
+
+    (.alert
+     :padding "0.5rem"
+     :margin-bottom "1rem"
+     :background-color ,color/failure)
+
+    (.login-form
+     :max-width "300px"
+     :margin "0 auto")
+
+    (.created-by-at
+     :color ,color/gray)))
diff --git a/web/panettone/src/email.lisp b/web/panettone/src/email.lisp
new file mode 100644
index 000000000000..cb01c488a2a6
--- /dev/null
+++ b/web/panettone/src/email.lisp
@@ -0,0 +1,48 @@
+(in-package :panettone.email)
+(declaim (optimize (safety 3)))
+
+(defvar *smtp-server* "localhost"
+  "The host for SMTP connections")
+
+(defvar *smtp-server-port* 2525
+  "The port for SMTP connections")
+
+(defvar *notification-from* "tvlbot@tazj.in"
+  "The email address to send email notifications from")
+
+(defvar *notification-from-display-name* "Panettone"
+  "The Display Name to use when sending email notifications")
+
+(defvar *notification-subject-prefix* "[panettone]"
+  "String to prefix all email subjects with")
+
+(defun send-email-notification (&key to subject message)
+  "Sends an email to TO with the given SUBJECT and MESSAGE, using the current
+values of `*smtp-server*', `*smtp-server-port*' and `*email-notification-from*'"
+  (let ((subject (if *notification-subject-prefix*
+                     (format nil "~A ~A"
+                             *notification-subject-prefix*
+                             subject)
+                     subject)))
+    (cl-smtp:send-email
+     *smtp-server*
+     *notification-from*
+     to
+     subject
+     message
+     :port *smtp-server-port*
+     :display-name *notification-from-display-name*)))
+
+(defun user-has-email-notifications-enabled-p (dn)
+  "Returns T if the user with the given DN has enabled email notifications"
+  (enable-email-notifications-p (settings-for-user dn)))
+
+(defun notify-user (dn &key subject message)
+  "Sends an email notification to the user with DN with the given SUBJECT and
+  MESSAGE, iff that user has not disabled email notifications"
+  (when (user-has-email-notifications-enabled-p dn)
+    (when-let ((user (find-user-by-dn dn)))
+      (send-email-notification
+       :to (mail user)
+       :subject subject
+       :message message))))
diff --git a/web/panettone/src/inline-markdown.lisp b/web/panettone/src/inline-markdown.lisp
new file mode 100644
index 000000000000..9948a629b378
--- /dev/null
+++ b/web/panettone/src/inline-markdown.lisp
@@ -0,0 +1,131 @@
+(in-package :panettone.inline-markdown)
+(declaim (optimize (safety 3)))
+
+(define-constant +inline-markup-types+
+  '(("~~" :del)
+    ("_"  :em)
+    ("*"  :em)
+    ("`"  :code))
+  :test #'equal)
+
+(defun next-token (mkdn &optional (escaped nil))
+  "Parses and returns the next token from the beginning of
+  an inline markdown string which is not altered. The resulting
+  tokens are either :normal (normal text), :special (syntactically
+  significant) or :escaped (escaped using \\). If the string is
+  empty, a pseudo-token named :endofinput is returned. Return value
+  is a list where the first element is the token type, the second
+  the token content and optionally the third the markup type."
+  ; special tokens are syntactically significant characters
+  ; or strings for our inline markdown subset. “normal” tokens
+  ; the strings in between
+  (let* ((special-toks #.'(cons (list "\\" :escape) +inline-markup-types+))
+         (toks (loop
+                 for tok in special-toks
+                 for pos = (search (car tok) mkdn)
+                 when pos collect (cons tok pos)))
+         (next-tok
+           (unless (null toks)
+             (reduce (lambda (a b) (if (< (cdr a) (cdr b)) a b)) toks))))
+    (cond
+      ; end of input
+      ((= (length mkdn) 0) (list :endofinput ""))
+      ; no special tokens, just return entire string
+      ((null next-tok) (list :normal mkdn))
+      ; special token, but not at the beginning of the string
+      ; so we return everything until the special token as
+      ; a string
+      ((> (cdr next-tok) 0) (list :normal (subseq mkdn 0 (cdr next-tok))))
+      ; \ at the beginning of the string: we get the next
+      ; token and mark it as escaped unless we are already
+      ; escaping in which case we just return the backslash
+      ; as a special token
+      ((eq (cadr (car next-tok)) :escape)
+       (if escaped
+         (list :special "\\")
+         (list :escaped
+               (next-token (subseq mkdn 1) t))))
+      ; any other special token at the beginning of the string
+      ; here we also pass the markup type as a third list element
+      ; to prevent unnecessesary lookups
+      (t (list :special
+               (subseq mkdn 0 (length (car (car next-tok))))
+               (cadr (car next-tok)))))))
+
+(defun token-length (tok-type tok-str)
+  "Returns the string length consumed by a call
+  to next-token returning the given token type and string."
+  (check-type tok-type symbol)
+  (if (eq tok-type :escaped)
+    ; backslash + length of escaped token
+    (progn
+      (check-type tok-str list)
+      (1+ (token-length (car tok-str) (cadr tok-str))))
+    (progn
+      (check-type tok-str string)
+      (length tok-str))))
+
+(defun write-tag (tag pos &optional (target *standard-output*))
+  "Wrapper around who:convert-tag-to-string-list to
+  only output a single :opening or :closing tag."
+  (check-type tag symbol)
+  (check-type pos symbol)
+  (let
+    ((index
+       (cond
+         ((eq pos :opening) 0)
+         ((eq pos :closing) 3)
+         (t (error 'simple-type-error)))))
+    (dolist
+      (tag-part (subseq
+                  (who:convert-tag-to-string-list tag nil nil nil)
+                  index (+ index 3)))
+      (write-string tag-part target))))
+
+(defun render-inline-markdown (s &optional (target *standard-output*) (in :normal))
+  "Render inline markdown, a subset of markdown safe to render
+  inside inline elements. The resulting html is directly written
+  to a specified stream or *standard-output* to integrate well
+  with cl-who."
+  (check-type s string)
+  (check-type target stream)
+  (loop
+    for (tok-type tok-str tok-markup) = (next-token s)
+    do (setq s (subseq s (token-length tok-type tok-str)))
+    when (eq tok-type :endofinput)
+    return ""
+    when (eq tok-type :normal)
+    do (write-string (who:escape-string tok-str) target)
+    when (eq tok-type :escaped)
+    do (progn
+         ; if normal tokens are escaped we treat the \ as if it were \\
+         ;
+         ; TODO(sterni): maybe also use the :normal behavior in :code except for #\`.
+         (when (eq (car tok-str) :normal)
+           (write-char #\\ target))
+         (write-string (who:escape-string (cadr tok-str)) target))
+    when (eq tok-type :special)
+    do (cond
+         ; we are on the outer level and encounter a special token:
+         ; render surrounding tags and call ourselves to render
+         ; inner content.
+         ((eq in :normal)
+          (progn
+            (write-tag tok-markup :opening target)
+            (setq s (render-inline-markdown s target tok-markup))
+            (write-tag tok-markup :closing target)))
+         ; we are on the inner level and encounter the token that initiated
+         ; our markup again, meaning we need to return to the outer level.
+         ; we return the remaining string to be consumed.
+         ((eq in tok-markup) (return s))
+         ; remaining case: we are on the inner level and encounter different markup.
+
+         ; we don't support nested markup for simplicity reasons, so instead we
+         ; just render any nested markdown tokens as if they were escaped. This
+         ; only eliminates the slight use case for nesting :em inside :del, but
+         ; shouldn't be too bad. As a side effect this is the precise behavior
+         ; we want for :code.
+         ;
+         ; TODO(sterni): maybe bring back the restart-based system which allowed
+         ;               to skip nested tokens if desired.
+         (t (write-string (who:escape-string tok-str) target)))))
diff --git a/web/panettone/src/irc.lisp b/web/panettone/src/irc.lisp
new file mode 100644
index 000000000000..2ab72a2e391e
--- /dev/null
+++ b/web/panettone/src/irc.lisp
@@ -0,0 +1,35 @@
+;;;; Using irccat to send IRC notifications
+
+(in-package :panettone.irc)
+
+(defun noping (s)
+  (format nil "~A~A~A"
+          (char s 0)
+          #\ZERO_WIDTH_SPACE
+          (subseq s 1)))
+
+(defun get-irccat-config ()
+  "Reads the IRCCATHOST and IRCCATPORT environment variables, and returns them
+as two values"
+  (destructuring-bind (host port)
+      (mapcar #'uiop:getenvp '("IRCCATHOST" "IRCCATPORT"))
+    (if (and host port)
+        (values host (parse-integer port))
+        (values "localhost" 4722))))
+
+(defun send-irc-notification (body &key channel)
+  "Sends BODY to the IRC channel CHANNEL (starting with #),
+if an IRCCat server is configured (using the IRCCATHOST and IRCCATPORT
+environment variables).
+May signal a condition if sending fails."
+  (multiple-value-bind (irchost ircport) (get-irccat-config)
+    (when irchost
+      (let ((socket (socket-connect irchost ircport)))
+        (unwind-protect
+             (progn
+               (format (socket-stream socket) "~@[~A ~]~A~A~%"
+                       channel
+                       #\ZERO_WIDTH_SPACE
+                       body)
+               (finish-output (socket-stream socket)))
+          (ignore-errors (socket-close socket)))))))
diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp
new file mode 100644
index 000000000000..4fa51026a086
--- /dev/null
+++ b/web/panettone/src/model.lisp
@@ -0,0 +1,421 @@
+(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))
+
+(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)))
+
+;;;
+;;; Schema
+;;;
+
+(defclass user-settings ()
+  ((user-dn :col-type string :initarg :user-dn :accessor user-dn)
+   (enable-email-notifications
+    :col-type boolean
+    :initarg :enable-email-notifications
+    :accessor enable-email-notifications-p
+    :initform t
+    :col-default t))
+  (:metaclass dao-class)
+  (:keys user-dn)
+  (:table-name user_settings)
+  (:documentation
+   "Panettone settings for an individual user DN"))
+
+(deftable (user-settings "user_settings")
+  (!dao-def))
+
+(defun settings-for-user (dn)
+  "Retrieve the settings for the user with the given DN, creating a new row in
+  the database if not yet present"
+  (or
+   (car
+    (query-dao
+     'user-settings
+     (:select '* :from 'user-settings :where (:= 'user-dn dn))))
+   (insert-dao (make-instance 'user-settings :user-dn dn))))
+
+(defun update-user-settings (settings &rest attrs)
+  "Update the fields of the settings for USER with the given ATTRS, which is a
+  plist of slot and value"
+  (check-type settings user-settings)
+  (when-let ((set-fields
+              (iter
+                (for slot in '(enable-email-notifications))
+                (for new-value = (getf attrs slot))
+                (appending
+                 (progn
+                   (setf (slot-value settings slot) new-value)
+                   (list slot new-value))))))
+    (execute
+     (sql-compile
+      `(:update user-settings
+        :set ,@set-fields
+        :where (:= user-dn ,(user-dn settings)))))))
+
+
+(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 has-created-at ()
+  ((created-at :col-type timestamp
+               :col-default (local-time:now)
+               :initarg :created-at
+               :accessor created-at))
+  (:metaclass dao-class))
+
+(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
+    ((obj has-created-at) &rest initargs &key &allow-other-keys)
+  (declare (ignore initargs))
+  (created-at->timestamp obj))
+
+(defclass issue (has-created-at)
+  ((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)
+   (events :type list :accessor issue-events)
+   (num-comments :type integer :accessor num-comments)
+   (status :col-type issue_status
+           :initarg :status
+           :accessor status
+           :initform :open
+           :col-default "open"))
+  (: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"))
+(defmethod cl-postgres:to-sql-string ((ts local-time:timestamp))
+  (cl-postgres:to-sql-string
+   (local-time:timestamp-to-unix ts)))
+
+(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"))))
+
+(deftable issue (!dao-def))
+
+(defclass issue-comment (has-created-at)
+  ((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))
+  (: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))
+
+(defclass issue-event (has-created-at)
+  ((id :col-type integer :col-identity t :initarg :id :accessor id)
+   (issue-id :col-type integer
+             :initarg :issue-id
+             :accessor issue-id)
+   (acting-user-dn :col-type string
+                   :initarg :acting-user-dn
+                   :accessor acting-user-dn)
+   (field :col-type (or string db-null)
+          :initarg :field
+          :accessor field)
+   (previous-value :col-type (or string db-null)
+                   :initarg :previous-value
+                   :accessor previous-value)
+   (new-value :col-type (or string db-null)
+              :initarg :new-value
+              :accessor new-value))
+  (:metaclass dao-class)
+  (:keys id)
+  (:table-name issue_events)
+  (:documentation "Events that have occurred for an issue.
+
+If a field has been changed on an issue, the SYMBOL-NAME of that slot will be in
+FIELD, its previous value will be formatted using ~A into PREVIOUS-VALUE, and
+its new value will be formatted using ~A into NEW-VALUE"))
+
+(deftable (issue-event "issue_events")
+  (!dao-def)
+  (!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade))
+
+(define-constant +all-tables+
+    '(issue
+      issue-comment
+      issue-event
+      user-settings)
+  :test #'equal)
+
+(defun ddl/create-tables ()
+  "Issue DDL to create all tables, if they don't already exist."
+  (dolist (table +all-tables+)
+    (unless (table-exists-p (dao-table-name table))
+      (create-table table))))
+
+(defun ddl/init ()
+  "Idempotently initialize 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))))
+
+(defmethod slot-unbound (cls (issue issue) (slot (eql 'events)))
+  (declare (ignore cls) (ignore slot))
+  (setf (issue-events issue) (issue-events (id issue))))
+
+(defmethod issue-events ((issue-id integer))
+  "Return a list of all events with the given ISSUE-ID, sorted oldest first.
+NOTE: This makes a database query, so be wary of N+1 queries"
+  (query-dao
+   'issue-event
+   (:order-by
+    (:select '*
+     :from 'issue-events
+     :where (:= 'issue-id issue-id))
+    (:asc 'created-at))))
+
+
+;;;
+;;; Writing
+;;;
+
+(defun record-issue-event
+    (issue-id &key
+                field
+                previous-value
+                new-value)
+  "Record in the database that the user identified by `AUTHN:*USER*' updated
+ISSUE-ID, and return the resulting `ISSUE-EVENT'. If no user is currently
+authenticated, warn and no-op"
+  (check-type issue-id (integer))
+  (check-type field (or null symbol))
+  (if authn:*user*
+      (insert-dao
+       (make-instance 'issue-event
+                      :issue-id issue-id
+                      :acting-user-dn (authn:dn authn:*user*)
+                      :field (symbol-name field)
+                      :previous-value (when previous-value
+                                        (format nil "~A" previous-value))
+                      :new-value (when new-value
+                                   (format nil "~A" new-value))))
+      (warn "Performing operation as unauthenticated user")))
+
+(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)
+  (let ((original-status (query (:select 'status
+                                 :from 'issues
+                                 :where (:= 'id issue-id))
+                                :single)))
+    (when (zerop (execute (:update 'issues
+                           :set 'status (cl-postgres:to-sql-string status)
+                           :where (:= 'id issue-id))))
+      (error 'issue-not-found :id issue-id))
+    (record-issue-event
+     issue-id
+     :field 'status
+     :previous-value (string-upcase original-status)
+     :new-value status)
+    (values)))
+
+(defun update-issue (issue &rest attrs)
+  "Update the fields of ISSUE with the given ATTRS, which is a plist of slot and
+value, and record events for the updates"
+  (let ((set-fields
+          (iter (for slot in '(subject body))
+            (for new-value = (getf attrs slot))
+            (appending
+             (let ((previous-value (slot-value issue slot)))
+               (when (and new-value (not (equalp
+                                          new-value
+                                          previous-value)))
+                 (record-issue-event (id issue)
+                                     :field slot
+                                     :previous-value previous-value
+                                     :new-value new-value)
+                 (setf (slot-value issue slot) new-value)
+                 (list slot new-value)))))))
+    (execute
+     (sql-compile
+      `(:update issues
+        :set ,@set-fields
+        :where (:= id ,(id issue)))))))
+
+(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)))
+
+(defun issue-commenter-dns (issue-id)
+  "Returns a list of all the dns of users who have commented on ISSUE-ID"
+  (query (:select 'author-dn :distinct
+          :from 'issue-comments
+          :where (:= 'issue-id issue-id))
+         :column))
+
+(defun issue-subscribers (issue-id)
+  "Returns a list of user DNs who should receive notifications for actions taken
+  on ISSUE-ID.
+
+Currently this is implemented as the author of issue plus all the users who have
+commented on the issue, but in the future we likely want to also allow
+explicitly subscribing to / unsubscribing from individual issues."
+  (let ((issue (get-issue issue-id)))
+    (adjoin (author-dn issue)
+            (issue-commenter-dns issue-id)
+            :test #'equal)))
+
+
+(comment
+ (connect-postgres)
+ (ddl/init)
+ (make-instance 'issue :subject "test")
+ (create-issue :subject "test"
+               :author-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi")
+
+ (issue-commenter-dns 1)
+ (issue-subscribers 1)
+
+ )
diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp
new file mode 100644
index 000000000000..3e6aa4a05f4f
--- /dev/null
+++ b/web/panettone/src/packages.lisp
@@ -0,0 +1,82 @@
+(defpackage panettone.util
+  (:use :cl :klatre)
+  (:import-from :alexandria :when-let)
+  (:export :integer-env))
+
+(defpackage panettone.css
+  (:use :cl :lass)
+  (:export :styles))
+
+(defpackage panettone.inline-markdown
+  (:use :cl)
+  (:import-from :alexandria :define-constant)
+  (:export :render-inline-markdown))
+
+(defpackage panettone.irc
+  (:nicknames :irc)
+  (:use :cl :usocket)
+  (:export :noping :send-irc-notification))
+
+(defpackage :panettone.authentication
+  (:nicknames :authn)
+  (:use :cl :panettone.util :klatre)
+  (:import-from :defclass-std :defclass/std)
+  (:import-from :alexandria :when-let :with-gensyms)
+  (:export
+   :*user* :*ldap*
+   :user :cn :dn :mail :displayname
+   :connect-ldap :find-user :find-user-by-dn :authenticate-user))
+
+(defpackage panettone.model
+  (:nicknames :model)
+  (:use :cl :panettone.util :klatre :postmodern :iterate)
+  (:import-from :alexandria :if-let :when-let :define-constant)
+  (:export
+   :connect-postgres :ddl/init :make-thread
+
+   :user-settings
+   :user-dn :enable-email-notifications-p :settings-for-user
+   :update-user-settings :enable-email-notifications
+
+   :issue :issue-comment :issue-event
+   :id :subject :body :author-dn :issue-id :status :created-at :acting-user-dn
+   :field :previous-value :new-value
+
+   :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status
+   :update-issue :delete-issue :issue-not-found
+
+   :issue-events
+
+   :issue-comments :num-comments :create-issue-comment
+   :issue-commenter-dns :issue-subscribers))
+
+(defpackage panettone.email
+  (:nicknames :email)
+  (:use :cl)
+  (:import-from :alexandria :when-let)
+  (:import-from :panettone.model
+   :settings-for-user :enable-email-notifications-p)
+  (:import-from :panettone.authentication
+   :find-user-by-dn :mail :displayname)
+  (:export
+   :*smtp-server* :*smtp-server-port* :*notification-from*
+   :*notification-from-display-name* :*notification-subject-prefix*
+   :notify-user :send-email-notification))
+
+(defpackage panettone
+  (:use :cl :klatre :easy-routes :iterate
+        :panettone.util
+        :panettone.authentication
+        :panettone.inline-markdown)
+  (:import-from :defclass-std :defclass/std)
+  (:import-from :alexandria :if-let :when-let :switch :alist-hash-table)
+  (:import-from :cl-ppcre :split)
+  (:import-from :bordeaux-threads :make-thread)
+  (:import-from
+   :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)
+  (:import-from :panettone.irc :send-irc-notification)
+  (:shadow :next)
+  (:export :start-pannetone :config :main))
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
new file mode 100644
index 000000000000..10d501d8aea9
--- /dev/null
+++ b/web/panettone/src/panettone.lisp
@@ -0,0 +1,687 @@
+(in-package :panettone)
+(declaim (optimize (safety 3)))
+
+(defvar *cheddar-url* "http://localhost:4238")
+
+(defgeneric render-markdown (markdown)
+  (:documentation
+   "Render the argument, or the elements of the argument, as markdown, and return
+   the same structure"))
+
+(defmethod render-markdown ((markdown string))
+  (cdr
+   (assoc :markdown
+          (cl-json:decode-json
+           (drakma:http-request
+            (concatenate 'string
+                         *cheddar-url*
+                         "/markdown")
+            :accept "application/json"
+            :method :post
+            :content-type "application/json"
+            :external-format-out :utf-8
+            :external-format-in :utf-8
+            :content (json:encode-json-to-string
+                      `((markdown . ,markdown)))
+            :want-stream t)))))
+
+(defmethod render-markdown ((markdown hash-table))
+  (alist-hash-table
+   (cl-json:decode-json
+    (drakma:http-request
+     (concatenate 'string
+                  *cheddar-url*
+                  "/markdown")
+     :accept "application/json"
+     :method :post
+     :content-type "application/json"
+     :external-format-out :utf-8
+     :external-format-in :utf-8
+     :content (json:encode-json-to-string markdown)
+     :want-stream t))))
+
+(defun markdownify-comment-bodies (comments)
+  "Convert the bodies of the given list of comments to markdown in-place using
+  Cheddar, and return nothing"
+  (let ((in (make-hash-table))
+        (comment-table (make-hash-table)))
+    (dolist (comment comments)
+      (when (typep comment 'model:issue-comment)
+        (setf (gethash (id comment) in) (body comment))
+        (setf (gethash (id comment) comment-table) comment)))
+    (let ((res (render-markdown in)))
+      (iter (for (comment-id markdown-body) in-hashtable res)
+        (let ((comment-id (parse-integer (symbol-name comment-id))))
+          (setf (slot-value (gethash comment-id comment-table)
+                            'model:body)
+                markdown-body)))))
+  (values))
+
+;;;
+;;; Views
+;;;
+
+(defvar *title* "Panettone")
+
+(setf (who:html-mode) :html5)
+
+(defun render/nav ()
+  (who:with-html-output (*standard-output*)
+    (:nav
+     (if (find (car (split "\\?" (hunchentoot:request-uri*) :limit 2))
+               (list "/" "/issues/closed")
+               :test #'string=)
+         (who:htm (:span :class "placeholder"))
+         (who:htm (:a :href "/" "All Issues")))
+     (if *user*
+         (who:htm
+          (:div :class "nav-group"
+           (:a :href "/settings" "Settings")
+           (:form :class "form-link log-out"
+                  :method "post"
+                  :action "/logout"
+                  (:input :type "submit" :value "Log Out"))))
+         (who:htm
+          (:a :href
+              (format nil
+                      "/login?original-uri=~A"
+                      (drakma:url-encode (hunchentoot:request-uri*)
+                                         :utf-8))
+              "Log In"))))))
+
+(defun author (object)
+  (find-user-by-dn (author-dn object)))
+
+(defun displayname-if-known (user)
+  (or (when user (displayname user))
+      "unknown"))
+
+(defmacro render ((&key
+                     (footer t)
+                     (header t))
+                  &body body)
+  `(who:with-html-output-to-string (*standard-output* nil :prologue t)
+     (:html
+      :lang "en"
+      (:head
+       (:title (who:esc *title*))
+       (:link :rel "stylesheet" :type "text/css" :href "/main.css")
+       (:meta :name "viewport"
+              :content "width=device-width,initial-scale=1"))
+      (:body
+       (:div
+        :class "content"
+        (when ,header
+          (who:htm
+           (render/nav)))
+        ,@body
+        (when ,footer
+          (who:htm
+           (:footer
+            (render/nav)))))))))
+
+(defun form-button (&key
+                      class
+                      input-class
+                      href
+                      label
+                      (method "post"))
+  (who:with-html-output (*standard-output*)
+    (:form :class class
+           :method method
+           :action href
+           (:input :type "submit"
+                   :class input-class
+                   :value label))))
+
+(defun render/alert (message)
+  "Render an alert box for MESSAGE, if non-null"
+  (check-type message (or null string))
+  (who:with-html-output (*standard-output*)
+    (when message
+      (who:htm (:div :class "alert" (who:esc message))))))
+
+(defun render/login (&key message (original-uri "/"))
+  (render (:footer nil :header nil)
+    (:div
+     :class "login-form"
+     (:header
+      (:h1 "Login"))
+     (:main
+      :class "login-form"
+      (render/alert message)
+      (:form
+       :method :post :action "/login"
+       (:input :type "hidden" :name "original-uri"
+               :value (who:escape-string original-uri))
+       (:div
+        (:label :for "username"
+                "Username")
+        (:input :type "text"
+                :name "username"
+                :id "username"
+                :placeholder "username"))
+       (:div
+        (:label :for "password"
+                "Password")
+        (:input :type "password"
+                :name "password"
+                :id "password"
+                :placeholder "password"))
+       (:input :type "submit"
+               :value "Submit"))))))
+
+(defun render/settings ()
+  (let ((settings (model:settings-for-user (dn *user*))))
+    (render ()
+      (:div
+       :class "settings-page"
+       (:header
+        (:h1 "Settings"))
+       (:form
+        :method :post :action "/settings"
+        (:div
+         (:label :class "checkbox"
+          (:input :type "checkbox"
+                  :name "enable-email-notifications"
+                  :id "enable-email-notifications"
+                  :checked (model:enable-email-notifications-p
+                            settings))
+          "Enable Email Notifications"))
+        (:div :class "form-group"
+         (:input :type "submit"
+                 :value "Save Settings")))))))
+
+(defun created-by-at (issue)
+  (check-type issue model:issue)
+  (who:with-html-output (*standard-output*)
+    (:span :class "created-by-at"
+           "Opened by "
+           (:span :class "username"
+                  (who:esc (displayname-if-known
+                             (author issue))))
+           " at "
+           (:span :class "timestamp"
+                  (who:esc
+                   (format-dottime (created-at issue)))))))
+
+(defun render/issue-list (&key issues)
+  (who:with-html-output (*standard-output*)
+    (:ol
+     :class "issue-list"
+     (dolist (issue issues)
+       (let ((issue-id (model:id issue)))
+         (who:htm
+          (:li
+           (:a :href (format nil "/issues/~A" issue-id)
+               (:p
+                (:span :class "issue-subject"
+                       (render-inline-markdown (subject issue))))
+               (:span :class "issue-number"
+                      (who:esc (format nil "#~A" issue-id)))
+               " - "
+               (created-by-at issue)
+               (let ((num-comments (length (issue-comments issue))))
+                 (unless (zerop num-comments)
+                   (who:htm
+                    (:span :class "comment-count"
+                           " - "
+                           (who:esc
+                            (format nil "~A comment~:p" num-comments))))))))))))))
+
+(defun render/index (&key issues)
+  (render ()
+    (:header
+     (:h1 "Issues")
+     (when *user*
+       (who:htm
+        (:a
+         :class "new-issue"
+         :href "/issues/new" "New Issue"))))
+    (:main
+     (:div
+      :class "issue-links"
+      (:a :href "/issues/closed" "View closed issues"))
+     (render/issue-list :issues issues))))
+
+(defun render/closed-issues (&key issues)
+  (render ()
+    (:header
+     (:h1 "Closed issues"))
+    (:main
+     (:div
+      :class "issue-links"
+      (:a :href "/" "View open isues"))
+     (render/issue-list :issues issues))))
+
+(defun render/issue-form (&optional issue message)
+  (let ((editing (and issue (id issue))))
+    (render ()
+      (:header
+       (:h1
+        (who:esc
+         (if editing "Edit Issue" "New Issue"))))
+      (:main
+       (render/alert message)
+       (:form :method "post"
+              :action (if editing
+                          (format nil "/issues/~A"
+                                  (id issue))
+                          "/issues")
+              :class "issue-form"
+              (:div
+               (:input :type "text"
+                       :id "subject"
+                       :name "subject"
+                       :placeholder "Subject"
+                       :value (when editing
+                                (who:escape-string
+                                  (subject issue)))))
+
+              (:div
+               (:textarea :name "body"
+                          :placeholder "Description"
+                          :rows 10
+                          (who:esc
+                           (when editing
+                             (body issue)))))
+
+              (:input :type "submit"
+                      :value
+                      (if editing
+                          "Save Issue"
+                          "Create Issue")))))))
+
+(defun render/new-comment (issue-id)
+  (who:with-html-output (*standard-output*)
+    (:form
+     :class "new-comment"
+     :method "post"
+     :action (format nil "/issues/~A/comments" issue-id)
+     (:div
+      (:textarea :name "body"
+                 :placeholder "Leave a comment"
+                 :rows 5))
+     (:input :type "submit"
+             :value "Comment"))))
+
+(defgeneric render/issue-history-item (item))
+
+(defmethod render/issue-history-item ((comment model:issue-comment))
+  (let ((fragment (format nil "comment-~A" (id comment))))
+    (who:with-html-output (*standard-output*)
+      (:li
+       :class "comment"
+       :id fragment
+       (:p (who:str (body comment)))
+       (:p
+        :class "comment-info"
+        (:span :class "username"
+               (who:esc
+                 (displayname-if-known (author comment)))
+               " at "
+               (:a :href (concatenate 'string "#" fragment)
+                   (who:esc (format-dottime (created-at comment))))))))))
+
+(defmethod render/issue-history-item ((event model:issue-event))
+  (let ((user (find-user-by-dn (acting-user-dn event))))
+    (who:with-html-output (*standard-output*)
+      (:li
+       :class "event"
+       :id
+       (who:esc (displayname-if-known user))
+       (if (string= (field event) "STATUS")
+           (who:htm
+            (who:esc
+             (switch ((new-value event) :test #'string=)
+               ("OPEN" " reopened ")
+               ("CLOSED" " closed ")))
+            " this issue ")
+           (who:htm
+            " changed the "
+            (who:esc (string-downcase (field event)))
+            " of this issue from \""
+            (who:esc (previous-value event))
+            "\" to \""
+            (who:esc (new-value event))
+            "\""))
+       " at "
+       (who:esc (format-dottime (created-at event)))))))
+
+(defun render/issue (issue)
+  (check-type issue model:issue)
+  (let ((issue-id (id issue))
+        (issue-status (status issue)))
+    (render ()
+      (:header
+       (:h1 (render-inline-markdown (subject issue)))
+       (:div :class "issue-number"
+             (who:esc (format nil "#~A" issue-id))))
+      (:main
+       (:div
+        :class "issue-info"
+        (created-by-at issue)
+
+        (when *user*
+          (who:htm
+           (when (string= (author-dn issue)
+                          (dn *user*))
+             (who:htm
+              (:a :class "edit-issue"
+                  :href (format nil "/issues/~A/edit"
+                                issue-id)
+                  "Edit")))
+           (form-button
+            :class "set-issue-status"
+            :href (format nil "/issues/~A/~A"
+                          issue-id
+                          (case issue-status
+                            (:open "close")
+                            (:closed "open")))
+            :input-class (case issue-status
+                           (:open "close-issue")
+                           (:closed "open-issue"))
+            :label (case issue-status
+                     (:open "Close")
+                     (:closed "Reopen"))))))
+       (:p (who:str (render-markdown (body issue))))
+       (let* ((comments (issue-comments issue))
+              (events (issue-events issue))
+              (history (merge 'list
+                              comments
+                              events
+                              #'local-time:timestamp<
+                              :key #'created-at)))
+         (markdownify-comment-bodies comments)
+         (who:htm
+          (:ol
+           :class "issue-history"
+           (dolist (item history)
+             (render/issue-history-item item))
+           (when *user*
+             (render/new-comment (id issue))))))))))
+
+(defun render/not-found (entity-type)
+  (render ()
+    (:h1 (who:esc entity-type) "Not Found")))
+
+;;;
+;;; HTTP handlers
+;;;
+
+(defun send-email-for-issue
+    (issue-id &key subject (message ""))
+  "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
+     (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)))))))
+
+(defun link-to-issue (issue-id)
+  (format nil "https://b.tvl.fyi/issues/~A" issue-id))
+
+(defun @auth-optional (next)
+  (let ((*user* (hunchentoot:session-value 'user)))
+    (funcall next)))
+
+(defun @auth (next)
+  (if-let ((*user* (hunchentoot:session-value 'user)))
+    (funcall next)
+    (hunchentoot:redirect
+     (format nil "/login?original-uri=~A"
+             (drakma:url-encode
+              (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)
+    (model: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)
+      (hunchentoot:redirect (or original-uri "/"))
+      (render/login :original-uri original-uri)))
+
+(defroute submit-login ("/login" :method :post)
+    (&post original-uri username password)
+  (if-let ((user (authenticate-user username password)))
+    (progn
+      (setf (hunchentoot:session-value 'user) user)
+      (hunchentoot:redirect (or original-uri "/")))
+    (render/login :message "Invalid credentials"
+                  :original-uri original-uri)))
+
+(defroute logout ("/logout" :method :post) ()
+  (hunchentoot:delete-session-value 'user)
+  (hunchentoot:redirect "/"))
+
+(defroute index ("/" :decorators (@auth-optional)) ()
+  (let ((issues (model:list-issues :status :open)))
+    (render/index :issues issues)))
+
+(defroute settings ("/settings" :method :get :decorators (@auth)) ()
+  (render/settings))
+
+(defroute save-settings ("/settings" :method :post :decorators (@auth))
+    (&post enable-email-notifications)
+  (let ((settings (model:settings-for-user (dn *user*))))
+    (model:update-user-settings
+     settings
+     'model:enable-email-notifications enable-email-notifications)
+    (render/settings)))
+
+(defroute handle-closed-issues
+    ("/issues/closed" :decorators (@auth-optional)) ()
+  (let ((issues (model:list-issues :status :closed)))
+    (render/closed-issues :issues issues)))
+
+(defroute new-issue ("/issues/new" :decorators (@auth)) ()
+  (render/issue-form))
+
+(defroute handle-create-issue
+    ("/issues" :method :post :decorators (@auth @txn))
+    (&post subject body)
+  (if (string= subject "")
+      (render/issue-form
+       (make-instance 'model:issue :subject subject :body body)
+       "Subject is required")
+      (let ((issue
+              (model:create-issue :subject subject
+                                  :body body
+                                  :author-dn (dn *user*))))
+        (send-irc-notification
+         (format nil
+                 "b/~A: \"~A\" opened by ~A - https://b.tvl.fyi/issues/~A"
+                 (id issue)
+                 subject
+                 (irc:noping (cn *user*))
+                 (id issue))
+         :channel (or (uiop:getenvp "ISSUECHANNEL")
+                      "##tvl-dev"))
+        (hunchentoot:redirect "/"))))
+
+(defroute show-issue
+    ("/issues/:id" :decorators (@auth-optional @handle-issue-not-found))
+    (&path (id 'integer))
+  (let* ((issue (model:get-issue id))
+         (*title* (format nil "~A | Panettone"
+                          (subject issue))))
+    (render/issue issue)))
+
+(defroute edit-issue
+    ("/issues/:id/edit" :decorators (@auth @handle-issue-not-found))
+    (&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)
+                   ;; NOTE: this should be a put, but we're all HTML forms
+                   ;; right now and those don't support PUT
+                   :method :post)
+    (&path (id 'integer) &post subject body)
+  (let ((issue (model:get-issue id)))
+    ;; only the original author can edit an issue
+    (if (string-equal (author-dn issue)
+                      (dn *user*))
+        (progn
+          (model:update-issue issue
+                              'model:subject subject
+                              'model:body body)
+          (hunchentoot:redirect (format nil "/issues/~A" id)))
+        (render/not-found "Issue"))))
+
+(defroute handle-create-comment
+    ("/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))))
+    (cond
+      ((string= body "")
+       (redirect-to-issue))
+      (:else
+       (model:create-issue-comment
+        :issue-id id
+        :body body
+        :author-dn (dn *user*))
+
+       (let ((issue (model:get-issue id)))
+         (send-email-for-issue
+          id
+          :subject (format nil "~A commented on b/~A: \"~A\""
+                           (displayname *user*)
+                           id
+                           (subject issue))
+          :message (format nil "~A~%~%~A"
+                           body
+                           (link-to-issue id))))
+       (redirect-to-issue)))))
+
+(defroute close-issue
+    ("/issues/:id/close" :decorators (@auth @handle-issue-not-found @txn)
+                         :method :post)
+    (&path (id 'integer))
+  (model:set-issue-status id :closed)
+  (let ((issue (model:get-issue id)))
+    (send-irc-notification
+     (format nil
+             "b/~A: \"~A\" closed by ~A - ~A"
+             id
+             (subject issue)
+             (irc:noping (cn *user*))
+             (link-to-issue id))
+     :channel (or (uiop:getenvp "ISSUECHANNEL")
+                  "##tvl-dev"))
+    (send-email-for-issue
+     id
+     :subject (format nil "b/~A: \"~A\" closed by ~A"
+                      id
+                      (subject issue)
+                      (dn *user*))
+     :message (link-to-issue id)))
+  (hunchentoot:redirect (format nil "/issues/~A" id)))
+
+(defroute open-issue
+    ("/issues/:id/open" :decorators (@auth)
+                        :method :post)
+    (&path (id 'integer))
+  (model:set-issue-status id :open)
+  (let ((issue (model:get-issue id)))
+    (send-irc-notification
+     (format nil
+             "b/~A: \"~A\" reopened by ~A - ~A"
+             id
+             (subject issue)
+             (irc:noping (cn *user*))
+             (link-to-issue id))
+     :channel (or (uiop:getenvp "ISSUECHANNEL")
+                  "##tvl-dev"))
+    (send-email-for-issue
+     id
+     :subject (format nil "b/~A: \"~A\" reopened by ~A"
+                      id
+                      (subject issue)
+                      (dn *user*))
+     :message (link-to-issue id)))
+  (hunchentoot:redirect (format nil "/issues/~A" id)))
+
+(defroute styles ("/main.css") ()
+  (setf (hunchentoot:content-type*) "text/css")
+  (apply #'lass:compile-and-write panettone.css:styles))
+
+(defvar *acceptor* nil
+  "Hunchentoot acceptor for Panettone's web server.")
+
+(defun migrate-db ()
+  "Migrate the database to the latest version of the schema"
+  (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)
+  (migrate-db)
+
+  (when session-secret
+    (setq hunchentoot:*session-secret* session-secret))
+
+  (setq hunchentoot:*session-max-time* (* 60 60 24 90))
+
+  (setq *acceptor*
+        (make-instance 'easy-routes:routes-acceptor :port port))
+  (hunchentoot:start *acceptor*))
+
+(defun main ()
+  (let ((port (integer-env "PANETTONE_PORT" :default 6161))
+        (ldap-port (integer-env "LDAP_PORT" :default 389))
+        (cheddar-url (uiop:getenvp "CHEDDAR_URL"))
+        (session-secret (uiop:getenvp "SESSION_SECRET")))
+    (when cheddar-url (setq *cheddar-url* cheddar-url))
+    (setq hunchentoot:*show-lisp-backtraces-p* nil)
+    (setq hunchentoot:*log-lisp-backtraces-p* nil)
+
+    (start-panettone :port port
+                     :ldap-port ldap-port
+                     :session-secret session-secret)
+
+    (sb-thread:join-thread
+     (find-if (lambda (th)
+                (string= (sb-thread:thread-name th)
+                         (format nil "hunchentoot-listener-*:~A" port)))
+              (sb-thread:list-all-threads)))))
+
+(comment
+ (setq hunchentoot:*catch-errors-p* nil)
+ ;; to setup an ssh tunnel to ldap+cheddar+irccat for development:
+ ;; ssh -NL 3899:localhost:389 -L 4238:localhost:4238 -L 4722:localhost:4722 whitby.tvl.fyi
+ (start-panettone :port 6161
+                  :ldap-port 3899
+                  :session-secret "session-secret")
+ )
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))