about summary refs log tree commit diff
path: root/web/panettone/src/panettone.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'web/panettone/src/panettone.lisp')
-rw-r--r--web/panettone/src/panettone.lisp691
1 files changed, 691 insertions, 0 deletions
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp
new file mode 100644
index 000000000000..bef5b018e465
--- /dev/null
+++ b/web/panettone/src/panettone.lisp
@@ -0,0 +1,691 @@
+(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"))
+
+(defun request-markdown-from-cheddar (input)
+  "Send the CL value INPUT encoded as JSON to cheddar's
+  markdown endpoint and return the decoded response."
+  (let ((s (drakma:http-request
+            (concatenate 'string
+                         *cheddar-url*
+                         "/markdown")
+            :accept "application/json"
+            :method :post
+            :content-type "application/json"
+            :external-format-out :utf-8
+            :content (json:encode-json-to-string input)
+            :want-stream t)))
+    (setf (flexi-streams:flexi-stream-external-format s) :utf-8)
+    (cl-json:decode-json s)))
+
+(defmethod render-markdown ((markdown string))
+  (cdr (assoc :markdown
+              (request-markdown-from-cheddar
+               `((markdown . ,markdown))))))
+
+(defmethod render-markdown ((markdown hash-table))
+  (alist-hash-table
+   (request-markdown-from-cheddar markdown)))
+
+(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")
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (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 (model: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)))
+        (fragment (format nil "event-~A" (id event))))
+    (who:with-html-output (*standard-output*)
+      (:li
+       :class "event"
+       :id fragment
+       (who:esc (displayname-if-known user))
+       (switch ((field event) :test #'string=)
+         ("STATUS"
+          (who:htm
+           (who:esc
+            (switch ((new-value event) :test #'string=)
+              ("OPEN" " reopened ")
+              ("CLOSED" " closed ")))
+           " this issue "))
+         ("BODY" (who:htm " updated the body of this issue"))
+         (t
+          (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 (model:issue-comments issue))
+              (events (model:issue-events issue))
+              (history (merge 'list
+                              comments
+                              events
+                              #'local-time:timestamp<
+                              :key #'created-at)))
+         (markdownify-comment-bodies comments)
+         (when (or history *user*)
+           (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*))
+    (bordeaux-threads:make-thread
+     (lambda ()
+       (pomo:with-connection *pg-spec*
+         (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 @db (next)
+  "Decorator for handlers that use the database, wrapped in a transaction."
+  (pomo:with-connection *pg-spec*
+    (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:not-found-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 @db)) ()
+  (let ((issues (model:list-issues :status :open)))
+    (render/index :issues issues)))
+
+(defroute settings ("/settings" :method :get :decorators (@auth @db)) ()
+  (render/settings))
+
+(defroute save-settings ("/settings" :method :post :decorators (@auth @db))
+    (&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 @db)) ()
+  (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 @db))
+    (&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"))
+        (hunchentoot:redirect "/"))))
+
+(defroute show-issue
+    ("/issues/:id" :decorators (@auth-optional @handle-issue-not-found @db))
+    (&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 @db))
+    (&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 @db)
+                   ;; 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 @db)
+     :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 @db)
+                         :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"))
+    (send-email-for-issue
+     id
+     :subject (format nil "b/~A: \"~A\" closed by ~A"
+                      id
+                      (subject issue)
+                      (displayname *user*))
+     :message (link-to-issue id)))
+  (hunchentoot:redirect (format nil "/issues/~A" id)))
+
+(defroute open-issue
+    ("/issues/:id/open" :decorators (@auth @db)
+                        :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"))
+    (send-email-for-issue
+     id
+     :subject (format nil "b/~A: \"~A\" reopened by ~A"
+                      id
+                      (subject issue)
+                      (displayname *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"
+  (pomo:with-connection *pg-spec*
+    (model:ddl/init)))
+
+(defun start-panettone (&key port
+                          (ldap-host "localhost")
+                          (ldap-port 389)
+                          session-secret)
+  (connect-ldap :host ldap-host
+                :port ldap-port)
+
+  (model:prepare-db-connections)
+  (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)
+
+    (format t "launched panettone on port ~A~%" port)
+
+    (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")
+ )