4 files changed, 321 insertions, 0 deletions
diff --git a/web/panettone/OWNERS b/web/panettone/OWNERS
new file mode 100644
index 000000000000..c5903d648988
--- /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 000000000000..ae8127eb891e
--- /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 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/panettone.lisp b/web/panettone/src/panettone.lisp
new file mode 100644
index 000000000000..f42a449b00ae
--- /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")
+ )