diff options
Diffstat (limited to 'web/panettone/src/panettone.lisp')
| -rw-r--r-- | web/panettone/src/panettone.lisp | 410 |
1 files changed, 256 insertions, 154 deletions
diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp index cef3572214..37d194d0f9 100644 --- a/web/panettone/src/panettone.lisp +++ b/web/panettone/src/panettone.lisp @@ -8,11 +8,10 @@ "Render the argument, or the elements of the argument, as markdown, and return the same structure")) -(defmethod render-markdown ((markdown string)) - (cdr - (assoc :markdown - (cl-json:decode-json - (drakma:http-request +(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") @@ -20,25 +19,19 @@ :method :post :content-type "application/json" :external-format-out :utf-8 - :external-format-in :utf-8 - :content (json:encode-json-to-string - `((markdown . ,markdown))) - :want-stream t))))) + :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 - (cl-json:decode-json - (drakma:http-request - (concatenate 'string - *cheddar-url* - "/markdown") - :accept "application/json" - :method :post - :content-type "application/json" - :external-format-out :utf-8 - :external-format-in :utf-8 - :content (json:encode-json-to-string markdown) - :want-stream t)))) + (request-markdown-from-cheddar markdown))) (defun markdownify-comment-bodies (comments) "Convert the bodies of the given list of comments to markdown in-place using @@ -63,7 +56,8 @@ (defvar *title* "Panettone") -(setf (who:html-mode) :html5) +(eval-when (:compile-toplevel :load-toplevel) + (setf (who:html-mode) :html5)) (defun render/nav () (who:with-html-output (*standard-output*) @@ -75,14 +69,16 @@ (who:htm (:a :href "/" "All Issues"))) (if *user* (who:htm - (:form :class "form-link log-out" - :method "post" - :action "/logout" - (:input :type "submit" :value "Log Out"))) + (: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" + "/auth?original-uri=~A" (drakma:url-encode (hunchentoot:request-uri*) :utf-8)) "Log In")))))) @@ -90,6 +86,10 @@ (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)) @@ -135,35 +135,26 @@ (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 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) @@ -171,11 +162,8 @@ (:span :class "created-by-at" "Opened by " (:span :class "username" - (who:esc - (or - (when-let ((author (author issue))) - (displayname author)) - "someone"))) + (who:esc (displayname-if-known + (author issue)))) " at " (:span :class "timestamp" (who:esc @@ -192,12 +180,12 @@ (:a :href (format nil "/issues/~A" issue-id) (:p (:span :class "issue-subject" - (who:esc (subject issue)))) + (render-inline-markdown (subject issue)))) (:span :class "issue-number" (who:esc (format nil "#~A" issue-id))) " - " (created-by-at issue) - (let ((num-comments (length (issue-comments issue)))) + (let ((num-comments (length (model:issue-comments issue)))) (unless (zerop num-comments) (who:htm (:span :class "comment-count" @@ -205,7 +193,21 @@ (who:esc (format nil "~A comment~:p" num-comments)))))))))))))) -(defun render/index (&key issues) +(defun render/issue-search (&key search) + (who:with-html-output (*standard-output*) + (:form + :method "get" + :class "issue-search" + (:input :type "search" + :name "search" + :title "Issue search query" + :value search) + (:input + :type "submit" + :value "Search Issues" + :class "sr-only")))) + +(defun render/index (&key issues search) (render () (:header (:h1 "Issues") @@ -217,17 +219,19 @@ (:main (:div :class "issue-links" - (:a :href "/issues/closed" "View closed issues")) + (:a :href "/issues/closed" "View closed issues") + (render/issue-search :search search)) (render/issue-list :issues issues)))) -(defun render/closed-issues (&key issues) +(defun render/closed-issues (&key issues search) (render () (:header (:h1 "Closed issues")) (:main (:div :class "issue-links" - (:a :href "/" "View open isues")) + (:a :href "/" "View open isues") + (render/issue-search :search search)) (render/issue-list :issues issues)))) (defun render/issue-form (&optional issue message) @@ -251,7 +255,8 @@ :name "subject" :placeholder "Subject" :value (when editing - (subject issue)))) + (who:escape-string + (subject issue))))) (:div (:textarea :name "body" @@ -292,33 +297,38 @@ (:p :class "comment-info" (:span :class "username" - (who:esc (displayname (author comment))) + (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)))) + (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 - (who:esc (displayname user)) - (if (string= (field event) "STATUS") - (who:htm - (who:esc - (switch ((new-value event) :test #'string=) - ("OPEN" " reopened ") - ("CLOSED" " closed "))) - " this issue ") - (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)) - "\"")) + :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))))))) @@ -328,7 +338,7 @@ (issue-status (status issue))) (render () (:header - (:h1 (who:esc (subject issue))) + (:h1 (render-inline-markdown (subject issue))) (:div :class "issue-number" (who:esc (format nil "#~A" issue-id)))) (:main @@ -359,30 +369,49 @@ (:open "Close") (:closed "Reopen")))))) (:p (who:str (render-markdown (body issue)))) - (let* ((comments (issue-comments issue)) - (events (issue-events 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) - (who:htm - (:ol - :class "issue-history" - (dolist (item history) - (render/issue-history-item item)) - (when *user* - (render/new-comment (id issue)))))))))) + (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"))) + (: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))) @@ -391,73 +420,97 @@ (if-let ((*user* (hunchentoot:session-value 'user))) (funcall next) (hunchentoot:redirect - (format nil "/login?original-uri=~A" + (format nil "/auth?original-uri=~A" (drakma:url-encode (hunchentoot:request-uri*) :utf-8))))) -(defun @txn (next) - (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 @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:id err)))))) + (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 auth-handler ("/auth" :method :get :decorators (@auth-optional)) () + (if-let ((code (hunchentoot:get-parameter "code"))) + (let ((user (fetch-token code))) + (setf (hunchentoot:session-value 'user) user) + (hunchentoot:redirect (or (hunchentoot:session-value '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))) + (when-let ((original-uri (hunchentoot:get-parameter "original-uri"))) + (setf (hunchentoot:session-value 'original-uri) original-uri)) + (hunchentoot:redirect (authn:auth-url))))) (defroute logout ("/logout" :method :post) () (hunchentoot:delete-session-value 'user) (hunchentoot:redirect "/")) -(defroute index ("/" :decorators (@auth-optional)) () - (let ((issues (model:list-issues :status :open))) - (render/index :issues issues))) +(defroute index ("/" :decorators (@auth-optional @db)) (&get search) + (let ((issues (model:list-issues :status :open + :search search))) + (render/index :issues issues + :search search))) + +(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)) () - (let ((issues (model:list-issues :status :closed))) - (render/closed-issues :issues issues))) + ("/issues/closed" :decorators (@auth-optional @db)) + (&get search) + (let ((issues (model:list-issues :status :closed + :search search))) + (render/closed-issues :issues issues + :search search))) (defroute new-issue ("/issues/new" :decorators (@auth)) () (render/issue-form)) (defroute handle-create-issue - ("/issues" :method :post :decorators (@auth @txn)) + ("/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") - (progn - (model:create-issue :subject subject - :body body - :author-dn (dn *user*)) - (hunchentoot:redirect "/")))) + (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 + (format nil "/issues/~A" (id issue)))))) (defroute show-issue - ("/issues/:id" :decorators (@auth-optional @handle-issue-not-found)) + ("/issues/:id" :decorators (@auth-optional @handle-issue-not-found @db)) (&path (id 'integer)) (let* ((issue (model:get-issue id)) (*title* (format nil "~A | Panettone" @@ -465,14 +518,14 @@ (render/issue issue))) (defroute edit-issue - ("/issues/:id/edit" :decorators (@auth @handle-issue-not-found)) + ("/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 @txn) + ("/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) @@ -490,7 +543,7 @@ (defroute handle-create-comment ("/issues/:id/comments" - :decorators (@auth @handle-issue-not-found @txn) + :decorators (@auth @handle-issue-not-found @db) :method :post) (&path (id 'integer) &post body) (flet ((redirect-to-issue () @@ -503,20 +556,65 @@ :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 @txn) + ("/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) + ("/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") () @@ -528,17 +626,15 @@ (defun migrate-db () "Migrate the database to the latest version of the schema" - (model:ddl/init)) + (pomo:with-connection *pg-spec* + (model:migrate))) -(defun start-panettone (&key port - (ldap-host "localhost") - (ldap-port 389) - postgres-params - session-secret) - (connect-ldap :host ldap-host - :port ldap-port) +(define-build-time-var *static-dir* "static/" + "Directory to serve static files from") - (apply #'model:connect-postgres postgres-params) +(defun start-panettone (&key port session-secret) + (authn:initialise-oauth2) + (model:prepare-db-connections) (migrate-db) (when session-secret @@ -547,12 +643,18 @@ (setq hunchentoot:*session-max-time* (* 60 60 24 90)) (setq *acceptor* - (make-instance 'easy-routes:routes-acceptor :port port)) + (make-instance 'easy-routes:easy-routes-acceptor :port port)) + + (push + (hunchentoot:create-folder-dispatcher-and-handler + "/static/" + (util:->dir *static-dir*)) + hunchentoot:*dispatch-table*) + (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)) @@ -560,9 +662,10 @@ (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) @@ -571,9 +674,8 @@ (comment (setq hunchentoot:*catch-errors-p* nil) - ;; to setup an ssh tunnel to ldap+cheddar for development: - ;; ssh -NL 3899:localhost:389 -L 4238:localhost:4238 whitby.tvl.fyi + ;; to setup an ssh tunnel to cheddar+irccat for development: + ;; ssh -N -L 4238:localhost:4238 -L 4722:localhost:4722 whitby.tvl.fyi (start-panettone :port 6161 - :ldap-port 3899 :session-secret "session-secret") ) |