feat(web/panettone): The start of a very simple issue tracker r/1433

Initial commit for Panettone, a very simple issue tracker for TVL. In
its current state this launches a web server with authenticates with our
ldap server, and supports listing and creating issues via static html
pages and simple forms.

We've been needing an issue tracker for a while now, but none of the
options out there seem very good - or there are some good ones, but
they're AGPL licensed and we don't want to deal with them. Rather than
muck around with Trac or Bugzilla, we've decided to write our own.

Change-Id: I704f0996d15199329bbd5450f3d959046bf13973
Reviewed-on: https://cl.tvl.fyi/c/depot/+/1337
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>

6 files changed, 329 insertions, 3 deletions

diff --git a/ci-builds.nix b/ci-builds.nix
index 19723e4b30..921b6f335f 100644
--- a/ci-builds.nix
+++ b/ci-builds.nix
@@ -67,8 +67,12 @@ in lib.fix (self: {
     rapidcheck
   ] ++ builtins.attrValues lisp;
 
+  lisp = with depot.lisp; [
+    dns
+    klatre
+  ];
+
   various = with depot; [
-    lisp.dns
     nix.buildLisp.example
     nix.yants.tests
     tools.cheddar
@@ -76,6 +80,7 @@ in lib.fix (self: {
     web.cgit-taz
     web.todolist
     web.tvl
+    web.panettone
     (drvify "getBins-tests" nix.getBins.tests)
   ]
   ++ nix.runExecline.tests
diff --git a/lisp/klatre/klatre.lisp b/lisp/klatre/klatre.lisp
index 231e72b64f..b20d1ab528 100644
--- a/lisp/klatre/klatre.lisp
+++ b/lisp/klatre/klatre.lisp
@@ -73,7 +73,7 @@ separated by SEP."
 ;;; String handling
 ;;;
 
-(defconstant +dottime-format+
+(defparameter dottime-format
   '((:year 4) #\- (:month 2) #\- (:day 2)
     #\T
     (:hour 2) #\· (:min 2) "+00") ; TODO(grfn): Allow passing offset
@@ -83,7 +83,7 @@ separated by SEP."
   "Return TIMESTAMP formatted as dottime, using a +00 offset"
   (check-type timestamp local-time:timestamp)
   (local-time:format-timestring nil timestamp
-                                :format +dottime-format+
+                                :format dottime-format
                                 :timezone local-time:+utc-zone+))
 
 (comment
diff --git a/web/panettone/OWNERS b/web/panettone/OWNERS
new file mode 100644
index 0000000000..c5903d6489
--- /dev/null
+++ b/web/panettone/OWNERS
@@ -0,0 +1,4 @@
+inherited: true
+owners:
+  - glittershark
+  - tazjin
diff --git a/web/panettone/default.nix b/web/panettone/default.nix
new file mode 100644
index 0000000000..ae8127eb89
--- /dev/null
+++ b/web/panettone/default.nix
@@ -0,0 +1,20 @@
+{ depot, ... }:
+
+depot.nix.buildLisp.program {
+  name = "panettone";
+
+  deps = with depot.third_party.lisp; [
+    cl-prevalence
+    cl-who
+    defclass-std
+    hunchentoot
+    easy-routes
+    trivial-ldap
+
+    depot.lisp.klatre
+  ];
+
+  srcs = [
+    ./src/panettone.lisp
+  ];
+}
diff --git a/web/panettone/src/.gitignore b/web/panettone/src/.gitignore
new file mode 100644
index 0000000000..10aa5440d8
--- /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/panettone.lisp b/web/panettone/src/panettone.lisp
new file mode 100644
index 0000000000..f42a449b00
--- /dev/null
+++ b/web/panettone/src/panettone.lisp
@@ -0,0 +1,295 @@
+(defpackage panettone
+  (:use :cl :klatre :easy-routes)
+  (:import-from :defclass-std :defclass/std)
+  (:import-from :alexandria :if-let)
+  (:export :start-panettone :main))
+(in-package :panettone)
+
+(declaim (optimize (safety 3)))
+
+;;;
+;;; Data model
+;;;
+
+(defclass/std issue-comment ()
+  ((body :type string)
+   (author-dn :type string)))
+
+(defclass/std issue (cl-prevalence:object-with-id)
+  ((subject body :type string :std "")
+   (author-dn :type string)
+   (comments :std nil :type list :with-prefix)
+   (created-at :type integer
+               :std (get-universal-time))))
+
+(defclass/std user ()
+  ((cn dn mail displayname :type string)))
+
+;;;
+;;; LDAP integration
+;;;
+
+(defvar *ldap* nil
+  "The ldap connection")
+
+(defun connect-ldap ()
+  ;; TODO(grfn): make this configurable
+  (setq *ldap* (ldap:new-ldap :host "localhost"
+                              :port 3899)))
+
+(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 (*)))
+  (ldap:search
+   *ldap*
+   `(and (= objectClass organizationalPerson)
+         (= cn ,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 (*)))
+  (ldap-entry->user
+   (find-user/ldap username)))
+
+(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"
+  (let* ((user (if (typep user-or-username 'user) user-or-username
+                   (find-user user-or-username)))
+         (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))
+      (when (equalp code-sym 'trivial-ldap:success)
+        user))))
+
+;;;
+;;; Persistence
+;;;
+
+(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 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)
+  (setq *p-system* (cl-prevalence:make-prevalence-system data-dir))
+
+  (when (null (list-issues *p-system*))
+    (cl-prevalence:tx-create-id-counter *p-system*)))
+
+;;;
+;;; Views
+;;;
+
+(defvar *title* "Panettone")
+
+(setf (who:html-mode) :HTML5)
+
+(defmacro render (&body body)
+  `(who:with-html-output-to-string (*standard-output* nil :prologue t)
+     (:head
+      (:title (who:esc *title*)))
+     (:body ,@body)))
+
+(defun render/login (&optional message)
+  (render
+    (:h1 "Login")
+    (when message
+      (who:htm (:div.alert (who:esc message))))
+    (:form
+     :method :post :action "/login"
+     (: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/index (&key issues)
+  (render
+    (:h1 "Issues")
+    (:a :href "/issues/new" "New Issue")
+    (:ul
+     (loop for issue in issues
+           do (who:htm
+               (:li
+                (:a :href (format nil "/issues/~A" (cl-prevalence:get-id issue))
+                    (who:esc (subject issue)))))))))
+
+(defun render/new-issue ()
+  (render
+    (:h1 "New Issue")
+    (:form
+     :method :post :action "/issues"
+     (:div
+      (:label :for "subject" "Subject")
+      (:input :type :text
+              :id "subject"
+              :name "subject"
+              :placeholder "Subject"))
+
+     (:div
+      (:textarea :name "body"))
+
+     (:input :type :submit
+             :value "Create Issue"))))
+
+(defun render/issue (issue)
+  (check-type issue issue)
+  (render
+    (:h1 (who:esc (subject issue)))
+    (:div (who:esc (body issue)))))
+
+(defun render/not-found (entity-type)
+  (render
+    (:h1 (who:esc entity-type) "Not Found")))
+
+;;;
+;;; HTTP handlers
+;;;
+
+(defvar *user* nil)
+
+(defun @auth (next)
+  (if-let ((*user* (hunchentoot:session-value 'user)))
+    (funcall next)
+    (hunchentoot:redirect "/login")))
+
+(defroute login-form ("/login" :method :get) ()
+  (if (hunchentoot:session-value 'user)
+      (hunchentoot:redirect "/")
+      (render/login)))
+
+(defroute submit-login ("/login" :method :post)
+    (&post username password)
+  (if-let ((user (authenticate-user username password)))
+    (progn
+      (setf (hunchentoot:session-value 'user) user)
+      (hunchentoot:redirect "/"))
+    (render/login "Invalid credentials")))
+
+(defroute index ("/" :decorators (@auth)) ()
+  (let ((issues (list-issues *p-system*)))
+    (render/index :issues issues)))
+
+(defroute new-issue ("/issues/new" :decorators (@auth)) ()
+  (render/new-issue))
+
+(defroute handle-create-issue
+    ("/issues" :method :post :decorators (@auth))
+    (&post subject body)
+  (cl-prevalence:execute-transaction
+   (create-issue *p-system*
+                 'subject subject
+                 'body body
+                 'author-dn (dn *user*)))
+  (cl-prevalence:snapshot *p-system*)
+  (hunchentoot:redirect "/"))
+
+(defroute show-issue ("/issues/:id" :decorators (@auth))
+    (&path (id 'integer))
+  (handler-case
+      (render/issue (get-issue *p-system* id))
+    (issue-not-found (_)
+      (render/not-found "Issue"))))
+
+(defvar *acceptor* nil
+  "Hunchentoot acceptor for Panettone's web server.")
+
+(defun start-panettone (&key port data-dir)
+  (connect-ldap)
+  (initialize-persistence data-dir)
+
+  (setq *acceptor*
+        (make-instance 'easy-routes:routes-acceptor :port port))
+  (hunchentoot:start *acceptor*))
+
+(defun main ()
+  ;; TODO(grfn): Read config from env
+  (let ((port 6161)
+        (data-dir "/tmp/panettone"))
+    (start-panettone :port port
+                     :data-dir data-dir)
+    (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
+ (start-panettone :port 6161
+                  :data-dir "/tmp/panettone")
+ )