diff options
| -rw-r--r-- | ci-builds.nix | 7 | ||||
| -rw-r--r-- | lisp/klatre/klatre.lisp | 4 | ||||
| -rw-r--r-- | web/panettone/OWNERS | 4 | ||||
| -rw-r--r-- | web/panettone/default.nix | 20 | ||||
| -rw-r--r-- | web/panettone/src/.gitignore | 2 | ||||
| -rw-r--r-- | web/panettone/src/panettone.lisp | 295 |
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") + ) |