From fa01f515e278d3b8d0c8af20d0668fb7baa98d6a Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Tue, 21 Jul 2020 18:59:25 -0400 Subject: [PATCH] feat(web/panettone): The start of a very simple issue tracker 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 --- ci-builds.nix | 7 +- lisp/klatre/klatre.lisp | 4 +- web/panettone/OWNERS | 4 + web/panettone/default.nix | 20 +++ web/panettone/src/.gitignore | 2 + web/panettone/src/panettone.lisp | 295 +++++++++++++++++++++++++++++++ 6 files changed, 329 insertions(+), 3 deletions(-) create mode 100644 web/panettone/OWNERS create mode 100644 web/panettone/default.nix create mode 100644 web/panettone/src/.gitignore create mode 100644 web/panettone/src/panettone.lisp diff --git a/ci-builds.nix b/ci-builds.nix index 19723e4b3..921b6f335 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 231e72b64..b20d1ab52 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 000000000..c5903d648 --- /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 000000000..ae8127eb8 --- /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 000000000..10aa5440d --- /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 000000000..f42a449b0 --- /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") + )