diff options
Diffstat (limited to 'web/panettone/src')
-rw-r--r-- | web/panettone/src/authentication.lisp | 202 | ||||
-rw-r--r-- | web/panettone/src/css.lisp | 131 | ||||
-rw-r--r-- | web/panettone/src/email.lisp | 49 | ||||
-rw-r--r-- | web/panettone/src/inline-markdown.lisp | 127 | ||||
-rw-r--r-- | web/panettone/src/irc.lisp | 35 | ||||
-rw-r--r-- | web/panettone/src/migrations/1-init-schema.lisp | 23 | ||||
-rw-r--r-- | web/panettone/src/migrations/3920286378-add-issue-tsv.lisp | 5 | ||||
-rw-r--r-- | web/panettone/src/migrations/3921488651-create-users-table.lisp | 6 | ||||
-rw-r--r-- | web/panettone/src/model.lisp | 368 | ||||
-rw-r--r-- | web/panettone/src/packages.lisp | 66 | ||||
-rw-r--r-- | web/panettone/src/panettone.lisp | 410 | ||||
-rw-r--r-- | web/panettone/src/static/search.png | bin | 0 -> 711 bytes | |||
-rw-r--r-- | web/panettone/src/util.lisp | 32 |
13 files changed, 1100 insertions, 354 deletions
diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp index 2051025753..496a0e0bd7 100644 --- a/web/panettone/src/authentication.lisp +++ b/web/panettone/src/authentication.lisp @@ -3,105 +3,121 @@ (defvar *user* nil "The currently logged-in user") -(defvar *ldap* nil - "The ldap connection") - -(defvar *ldap-host* "localhost" - "The host for the ldap connection") - -(defvar *ldap-port* 389 - "The port for the ldap connection") - (defclass/std user () ((cn dn mail displayname :type string))) -(defun connect-ldap (&key - (host "localhost") - (port 389)) - (setq *ldap-host* host - *ldap-port* port - *ldap* (ldap:new-ldap :host host :port port))) - -(defun reconnect-ldap () - (setq *ldap* (ldap:new-ldap - :host *ldap-host* - :port *ldap-port*))) - -(defmacro with-ldap ((&key (max-tries 1)) &body body) - "Execute BODY in a context where ldap connection errors trigger a reconnect -and a retry" - (with-gensyms (n try retry e) - `(flet - ((,try - (,n) - (flet ((,retry (,e) - (if (>= ,n ,max-tries) - (error ,e) - (progn - (reconnect-ldap) - (,try (1+ ,n)))))) - (handler-case - (progn - ,@body) - (end-of-file (,e) (,retry ,e)) - (trivial-ldap:ldap-connection-error (,e) (,retry ,e)))))) - (,try 0)))) - -(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 (*))) - (with-ldap () - (ldap:search - *ldap* - `(and (= objectClass organizationalPerson) - (or - (= cn ,username) - (= dn ,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 (*))) - (when-let ((ldap-entry (find-user/ldap username))) - (ldap-entry->user ldap-entry))) +;; Migrating user authentication to OAuth2 necessitates some temporary +;; workarounds while other parts of the panettone code are being +;; amended appropriately. + +(defun fake-dn (username) + "Users are no longer read directly from LDAP, but everything in +panettone is keyed on the DNs. This function constructs matching +'fake' DNs." + (format nil "cn=~A,ou=users,dc=tvl,dc=fyi" username)) (defun find-user-by-dn (dn) - (with-ldap () - (progn - (ldap:search *ldap* `(= objectClass organizationalPerson) - :base dn - :scope 'ldap:base) - (when-let ((ldap-entry (ldap:next-search-result *ldap*))) - (ldap-entry->user ldap-entry))))) + "Previously this function looked up users in LDAP based on their DN, +however panettone now does not have direct access to a user database. + +For most cases only the username is needed, which can be parsed out of +the user, however email addresses are temporarily not available." + (let ((username + (car (uiop:split-string (subseq dn 3) :separator '(#\,))))) + (make-instance + 'user + :dn dn + :cn username + :displayname username + :mail nil))) + +;; Implementation of standard OAuth2 authorisation flow. + +(defvar *oauth2-auth-endpoint* nil) +(defvar *oauth2-token-endpoint* nil) +(defvar *oauth2-client-id* nil) +(defvar *oauth2-client-secret* nil) + +(defvar *oauth2-redirect-uri* + (or (uiop:getenv "OAUTH2_REDIRECT_URI") + "https://b.tvl.fyi/auth")) (comment - (find-user-by-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi") + (setq *oauth2-redirect-uri* "http://localhost:6161/auth") ) -(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" - (when-let ((user (if (typep user-or-username 'user) user-or-username - (find-user user-or-username)))) - (let ((dn (dn user))) - (let ((code-sym - (nth-value 1 (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))))) +(defun initialise-oauth2 () + "Initialise all settings needed for OAuth2" + + (setq *oauth2-auth-endpoint* + (or *oauth2-auth-endpoint* + (uiop:getenv "OAUTH2_AUTH_ENDPOINT") + "https://auth.tvl.fyi/auth/realms/TVL/protocol/openid-connect/auth")) + + (setq *oauth2-token-endpoint* + (or *oauth2-token-endpoint* + (uiop:getenv "OAUTH2_TOKEN_ENDPOINT") + "https://auth.tvl.fyi/auth/realms/TVL/protocol/openid-connect/token")) + + (setq *oauth2-client-id* + (or *oauth2-client-id* + (uiop:getenv "OAUTH2_CLIENT_ID") + "panettone")) + + (setq *oauth2-client-secret* + (or *oauth2-client-secret* + (uiop:getenv "OAUTH2_CLIENT_SECRET") + (error "OAUTH2_CLIENT_SECRET must be set!")))) + +(defun auth-url () + (format nil "~A?response_type=code&client_id=~A&redirect_uri=~A" + *oauth2-auth-endpoint* + (drakma:url-encode *oauth2-client-id* :utf-8) + (drakma:url-encode *oauth2-redirect-uri* :utf-8))) + +(defun claims-to-user (claims) + (let ((username (cdr (assoc :preferred--username claims))) + (email (cdr (assoc :email claims)))) + (make-instance + 'user + :dn (fake-dn username) + :cn username + :mail email + ;; TODO(tazjin): Figure out actual displayName mapping in tokens. + :displayname username))) + +(defun fetch-token (code) + "Fetches the access token on completion of user authentication through +the OAuth2 endpoint and returns the resulting user object." + + (multiple-value-bind (body status) + (drakma:http-request *oauth2-token-endpoint* + :method :post + :parameters `(("grant_type" . "authorization_code") + ("client_id" . ,*oauth2-client-id*) + ("client_secret" . ,*oauth2-client-secret*) + ("redirect_uri" . ,*oauth2-redirect-uri*) + ("code" . ,code)) + :external-format-out :utf-8 + :want-stream t) + (if (/= status 200) + (error "Authentication failed: ~A (~A)~%" + (alexandria:read-stream-content-into-string body) + status) + + ;; Returned JWT contains username and email, we can populate + ;; all fields from that. + (progn + (setf (flexi-streams:flexi-stream-external-format body) :utf-8) + (let* ((response (cl-json:decode-json body)) + (access-token (cdr (assoc :access--token response))) + (payload (cadr (uiop:split-string access-token :separator '(#\.)))) + (claims (cl-json:decode-json-from-string + (base64:base64-string-to-string + ;; The JWT spec specifies that base64 strings + ;; embedded in jwts are *not* padded, but the common + ;; lisp base64 library doesn't know how to deal with + ;; that - we need to add those extra padding + ;; characters here. + (panettone.util:add-missing-base64-padding payload))))) + (claims-to-user claims)))))) diff --git a/web/panettone/src/css.lisp b/web/panettone/src/css.lisp index 5001d99fef..3bba2bb591 100644 --- a/web/panettone/src/css.lisp +++ b/web/panettone/src/css.lisp @@ -1,33 +1,9 @@ (in-package :panettone.css) (declaim (optimize (safety 3))) -(defparameter color/black - "rgb(24, 24, 24)") - -(defparameter color/light-gray - "#EEE") - -(defparameter color/gray - "#8D8D8D") - -(defparameter color/primary - "rgb(106, 154, 255)") - -(defparameter color/primary-light - "rgb(150, 166, 200)") - -(defparameter color/success - "rgb(168, 249, 166)") - -(defparameter color/success-2 - "rgb(168, 249, 166)") - -(defparameter color/failure - "rgb(247, 167, 167)") - (defun button (selector) `((,selector - :background-color ,color/success + :background-color "var(--success)" :padding "0.5rem" :text-decoration "none" :transition "box-shadow" "0.15s" "ease-in-out") @@ -42,11 +18,11 @@ (defparameter markdown-styles `((blockquote - :border-left "5px" "solid" ,color/light-gray + :border-left "5px" "solid" "var(--light)"-gray :padding-left "1rem" :margin-left "0rem") (pre - :overflow-x "scroll"))) + :overflow-x "auto"))) (defparameter issue-list-styles `((.issue-list @@ -60,7 +36,7 @@ :padding-bottom "1rem") ((li + li) - :border-top "1px" "solid" ,color/gray) + :border-top "1px" "solid" "var(--gray)") (a :text-decoration "none" @@ -70,20 +46,37 @@ :outline "none" (.issue-subject - :color ,color/primary))) + :color "var(--primary)"))) (.comment-count - :color ,color/gray))) + :color "var(--gray)") + + (.issue-links + :display "flex" + :flex-direction "row" + :align-items "center" + :justify-content "space-between" + :flex-wrap "wrap") + + (.issue-search + ((:and input (:= type "search")) + :padding "0.5rem" + :background-image "url('static/search.png')" + :background-position "10px 10px" + :background-repeat "no-repeat" + :background-size "1rem" + :padding-left "2rem" + :border "1px" "solid" "var(--gray)")))) (defparameter issue-history-styles `((.issue-history :list-style "none" - :border-top "1px" "solid" ,color/gray + :border-top "1px" "solid" "var(--gray)" :padding-top "1rem" :padding-left "2rem" (.comment-info - :color ,color/gray + :color "var(--gray)" :margin 0 :padding-top "1rem" @@ -94,16 +87,16 @@ ((:or .comment .event) :padding-top "1rem" :padding-bottom "1rem" - :border-bottom "1px" "solid" ,color/gray + :border-bottom "1px" "solid" "var(--gray)" (p :margin 0)) ((:and (:or .comment .event) :target) - :border-color ,color/primary + :border-color "var(--primary)" :border-bottom-width "3px") (.event - :color ,color/gray)))) + :color "var(--gray)")))) (defparameter form-styles `(((:or (:and input (:or (:= type "text") @@ -115,7 +108,7 @@ :border-top "none" :border-left "none" :border-right "none" - :border-bottom "1px" "solid" ,color/gray + :border-bottom "1px" "solid" "var(--gray)" :margin-bottom "1rem") (textarea @@ -138,7 +131,13 @@ ((:and input (:= type "submit") (:or :hover :active :focus)) - :box-shadow 0 0 0 0)))) + :box-shadow 0 0 0 0)) + + (.form-group + :margin-top "1rem") + + (label.checkbox + :cursor "pointer"))) (defparameter issue-styles `((.issue-info @@ -152,12 +151,12 @@ :flex 1) (.edit-issue - :background-color ,color/light-gray + :background-color "var(--light)"-gray :flex 0 :margin-right "0.5rem") (.close-issue - :background-color ,color/failure)))) + :background-color "var(--failure)")))) (defparameter styles `(,@form-styles @@ -168,7 +167,27 @@ (body :font-family "sans-serif" - :color ,color/black) + :color "var(--text)" + :background "var(--bg)" + :--text "rgb(24, 24, 24)" + :--bg "white" + :--gray "#8D8D8D" + :--primary "rgb(106, 154, 255)" + :--primary-light "rgb(150, 166, 200)" + :--success "rgb(168, 249, 166)" + :--failure "rgb(247, 167, 167)" + :--light-gray "#EEE") + + (:media "(prefers-color-scheme: dark)" + (body + :--text "rgb(240, 240, 240)" + :--bg "black" + :--gray "#8D8D8D" + :--primary "rgb(106, 154, 255)" + :--primary-light "rgb(150, 166, 200)" + :--success "rgb(14, 130, 11)" + :--failure "rgb(124, 14, 14)" + :--light-gray "#222")) (a :color "inherit") @@ -179,7 +198,7 @@ (header :display "flex" :align-items "center" - :border-bottom "1px" "solid" ,color/black + :border-bottom "1px" "solid" "var(--text)" :margin-bottom "1rem" (h1 @@ -187,30 +206,46 @@ :flex 1) (.issue-number - :color ,color/gray + :color "var(--gray)" :font-size "1.5rem")) (nav :display "flex" - :color ,color/gray - :justify-content "space-between") + :color "var(--gray)" + :justify-content "space-between" + + (.nav-group + :display "flex" + (>* + :margin-left "0.5rem"))) (footer - :border-top "1px" "solid" ,color/gray + :border-top "1px" "solid" "var(--gray)" :padding-top "1rem" :margin-top "1rem" - :color ,color/gray) + :color "var(--gray)") ,@(button '.new-issue) (.alert :padding "0.5rem" :margin-bottom "1rem" - :background-color ,color/failure) + :background-color "var(--failure)") (.login-form :max-width "300px" :margin "0 auto") (.created-by-at - :color ,color/gray))) + :color "var(--gray)") + + ;; screen-reader-only content + (.sr-only + :border 0 + :clip "rect(0 0 0 0)" + :height "1px" + :margin "-1px" + :overflow "hidden" + :padding 0 + :position "absolute" + :width "1px"))) diff --git a/web/panettone/src/email.lisp b/web/panettone/src/email.lisp new file mode 100644 index 0000000000..66ea299858 --- /dev/null +++ b/web/panettone/src/email.lisp @@ -0,0 +1,49 @@ +(in-package :panettone.email) +(declaim (optimize (safety 3))) + +(defvar *smtp-server* "localhost" + "The host for SMTP connections") + +(defvar *smtp-server-port* 2525 + "The port for SMTP connections") + +(defvar *notification-from* "tvlbot@tazj.in" + "The email address to send email notifications from") + +(defvar *notification-from-display-name* "Panettone" + "The Display Name to use when sending email notifications") + +(defvar *notification-subject-prefix* "[panettone]" + "String to prefix all email subjects with") + +(defun send-email-notification (&key to subject message) + "Sends an email to TO with the given SUBJECT and MESSAGE, using the current +values of `*smtp-server*', `*smtp-server-port*' and `*email-notification-from*'" + (let ((subject (if *notification-subject-prefix* + (format nil "~A ~A" + *notification-subject-prefix* + subject) + subject))) + (cl-smtp:send-email + *smtp-server* + *notification-from* + to + subject + message + :port *smtp-server-port* + :display-name *notification-from-display-name*))) + +(defun user-has-email-notifications-enabled-p (dn) + "Returns T if the user with the given DN has enabled email notifications" + (enable-email-notifications-p (settings-for-user dn))) + +(defun notify-user (dn &key subject message) + "Sends an email notification to the user with DN with the given SUBJECT and + MESSAGE, iff that user has not disabled email notifications" + (when (user-has-email-notifications-enabled-p dn) + (when-let* ((user (find-user-by-dn dn)) + (user-mail (mail user))) + (send-email-notification + :to user-mail + :subject subject + :message message)))) diff --git a/web/panettone/src/inline-markdown.lisp b/web/panettone/src/inline-markdown.lisp new file mode 100644 index 0000000000..e49293519b --- /dev/null +++ b/web/panettone/src/inline-markdown.lisp @@ -0,0 +1,127 @@ +(in-package :panettone.inline-markdown) +(declaim (optimize (safety 3))) + +(define-constant +inline-markup-types+ + '(("~~" :del) + ("*" :em) + ("`" :code)) + :test #'equal) + +(defun next-token (mkdn &optional (escaped nil)) + "Parses and returns the next token from the beginning of + an inline markdown string which is not altered. The resulting + tokens are either :normal (normal text), :special (syntactically + significant) or :escaped (escaped using \\). If the string is + empty, a pseudo-token named :endofinput is returned. Return value + is a list where the first element is the token type, the second + the token content and optionally the third the markup type." + ; special tokens are syntactically significant characters + ; or strings for our inline markdown subset. “normal” tokens + ; the strings in between + (let* ((special-toks #.'(cons (list "\\" :escape) +inline-markup-types+)) + (toks (loop + for tok in special-toks + for pos = (search (car tok) mkdn) + when pos collect (cons tok pos))) + (next-tok + (unless (null toks) + (reduce (lambda (a b) (if (< (cdr a) (cdr b)) a b)) toks)))) + (cond + ; end of input + ((= (length mkdn) 0) (list :endofinput "")) + ; no special tokens, just return entire string + ((null next-tok) (list :normal mkdn)) + ; special token, but not at the beginning of the string + ; so we return everything until the special token as + ; a string + ((> (cdr next-tok) 0) (list :normal (subseq mkdn 0 (cdr next-tok)))) + ; \ at the beginning of the string: we get the next + ; token and mark it as escaped unless we are already + ; escaping in which case we just return the backslash + ; as a special token + ((eq (cadr (car next-tok)) :escape) + (if escaped + (list :special "\\") + (list :escaped + (next-token (subseq mkdn 1) t)))) + ; any other special token at the beginning of the string + ; here we also pass the markup type as a third list element + ; to prevent unnecessesary lookups + (t (list :special + (subseq mkdn 0 (length (car (car next-tok)))) + (cadr (car next-tok))))))) + +(defun token-length (tok-type tok-str) + "Returns the string length consumed by a call + to next-token returning the given token type and string." + (check-type tok-type symbol) + (if (eq tok-type :escaped) + ; backslash + length of escaped token + (progn + (check-type tok-str list) + (1+ (token-length (car tok-str) (cadr tok-str)))) + (progn + (check-type tok-str string) + (length tok-str)))) + +(defun write-tag (tag pos &optional (target *standard-output*)) + "Wrapper around who:convert-tag-to-string-list to + only output a single :opening or :closing tag." + (check-type tag symbol) + (check-type pos symbol) + (let + ((index + (cond + ((eq pos :opening) 0) + ((eq pos :closing) 3) + (t (error 'simple-type-error))))) + (dolist + (tag-part (subseq + (who:convert-tag-to-string-list tag nil nil nil) + index (+ index 3))) + (write-string tag-part target)))) + +(defun render-inline-markdown (s &optional (target *standard-output*) (in :normal)) + "Render inline markdown, a subset of markdown safe to render + inside inline elements. The resulting html is directly written + to a specified stream or *standard-output* to integrate well + with cl-who." + (check-type s string) + (check-type target stream) + (loop + for (tok-type tok-str tok-markup) = (next-token s) + do (setq s (subseq s (token-length tok-type tok-str))) + when (eq tok-type :endofinput) + return "" + when (eq tok-type :normal) + do (write-string (who:escape-string tok-str) target) + when (eq tok-type :escaped) + do (progn + ; if normal tokens are escaped we treat the \ as if it were \\ + ; + ; TODO(sterni): maybe also use the :normal behavior in :code except for #\`. + (when (eq (car tok-str) :normal) + (write-char #\\ target)) + (write-string (who:escape-string (cadr tok-str)) target)) + when (eq tok-type :special) + do (cond + ; we are on the outer level and encounter a special token: + ; render surrounding tags and call ourselves to render + ; inner content. + ((eq in :normal) + (progn + (write-tag tok-markup :opening target) + (setq s (render-inline-markdown s target tok-markup)) + (write-tag tok-markup :closing target))) + ; we are on the inner level and encounter the token that initiated + ; our markup again, meaning we need to return to the outer level. + ; we return the remaining string to be consumed. + ((eq in tok-markup) (return s)) + ; remaining case: we are on the inner level and encounter different markup. + + ; we don't support nested markup for simplicity reasons, so instead we + ; just render any nested markdown tokens as if they were escaped. This + ; only eliminates the slight use case for nesting :em inside :del, but + ; shouldn't be too bad. As a side effect this is the precise behavior + ; we want for :code. + (t (write-string (who:escape-string tok-str) target))))) diff --git a/web/panettone/src/irc.lisp b/web/panettone/src/irc.lisp new file mode 100644 index 0000000000..2ab72a2e39 --- /dev/null +++ b/web/panettone/src/irc.lisp @@ -0,0 +1,35 @@ +;;;; Using irccat to send IRC notifications + +(in-package :panettone.irc) + +(defun noping (s) + (format nil "~A~A~A" + (char s 0) + #\ZERO_WIDTH_SPACE + (subseq s 1))) + +(defun get-irccat-config () + "Reads the IRCCATHOST and IRCCATPORT environment variables, and returns them +as two values" + (destructuring-bind (host port) + (mapcar #'uiop:getenvp '("IRCCATHOST" "IRCCATPORT")) + (if (and host port) + (values host (parse-integer port)) + (values "localhost" 4722)))) + +(defun send-irc-notification (body &key channel) + "Sends BODY to the IRC channel CHANNEL (starting with #), +if an IRCCat server is configured (using the IRCCATHOST and IRCCATPORT +environment variables). +May signal a condition if sending fails." + (multiple-value-bind (irchost ircport) (get-irccat-config) + (when irchost + (let ((socket (socket-connect irchost ircport))) + (unwind-protect + (progn + (format (socket-stream socket) "~@[~A ~]~A~A~%" + channel + #\ZERO_WIDTH_SPACE + body) + (finish-output (socket-stream socket))) + (ignore-errors (socket-close socket))))))) diff --git a/web/panettone/src/migrations/1-init-schema.lisp b/web/panettone/src/migrations/1-init-schema.lisp new file mode 100644 index 0000000000..3be6c4fcc0 --- /dev/null +++ b/web/panettone/src/migrations/1-init-schema.lisp @@ -0,0 +1,23 @@ +"Initialize the database schema from before migrations were added" + +(defun ddl/create-issue-status () + "Issue DDL to create the `issue-status' type, if it doesn't exist" + (unless (query (:select (:exists (:select 1 + :from 'pg_type + :where (:= 'typname "issue_status")))) + :single) + (query (sql-compile + `(:create-enum issue-status ,panettone.model:+issue-statuses+))))) + +(defun ddl/create-tables () + "Issue DDL to create all tables, if they don't already exist." + (dolist (table '(panettone.model:issue + panettone.model:issue-comment + panettone.model:issue-event + panettone.model:user-settings)) + (unless (table-exists-p (dao-table-name table)) + (create-table table)))) + +(defun up () + (ddl/create-issue-status) + (ddl/create-tables)) diff --git a/web/panettone/src/migrations/3920286378-add-issue-tsv.lisp b/web/panettone/src/migrations/3920286378-add-issue-tsv.lisp new file mode 100644 index 0000000000..2a965a7bba --- /dev/null +++ b/web/panettone/src/migrations/3920286378-add-issue-tsv.lisp @@ -0,0 +1,5 @@ +"Add tsvector for full-text search of issues" + +(defun up () + (query "ALTER TABLE issues ADD COLUMN tsv tsvector GENERATED ALWAYS AS (to_tsvector('english', subject || ' ' || body)) STORED") + (query "CREATE INDEX issues_tsv_index ON issues USING GIN (tsv);")) diff --git a/web/panettone/src/migrations/3921488651-create-users-table.lisp b/web/panettone/src/migrations/3921488651-create-users-table.lisp new file mode 100644 index 0000000000..2598ab101e --- /dev/null +++ b/web/panettone/src/migrations/3921488651-create-users-table.lisp @@ -0,0 +1,6 @@ +"Add a table to store information about users, load the initial set of users +from the authentication provider, and change fks for other tables" + +(defun up () + (panettone.model:create-table-if-not-exists + 'panettone.model:user)) diff --git a/web/panettone/src/model.lisp b/web/panettone/src/model.lisp index 300ee19b6b..a106e9479b 100644 --- a/web/panettone/src/model.lisp +++ b/web/panettone/src/model.lisp @@ -1,19 +1,106 @@ (in-package :panettone.model) (declaim (optimize (safety 3))) -(defun connect-postgres (&key - (host (or (uiop:getenvp "PGHOST") "localhost")) - (user (or (uiop:getenvp "PGUSER") "panettone")) - (password (or (uiop:getenvp "PGPASSWORD") "password")) - (database (or (uiop:getenvp "PGDATABASE") "panettone")) - (port (or (integer-env "PGPORT") 5432))) - "Initialize the global postgresql connection for Panettone" - (postmodern:connect-toplevel database user password host :port port)) +(setq pomo:*ignore-unknown-columns* t) + +(defvar *pg-spec* nil + "Connection spec for use with the with-connection macro. Needs to be +initialised at launch time.") + +(defun make-pg-spec () + "Construct the Postgres connection spec from the environment." + (list (or (uiop:getenvp "PGDATABASE") "panettone") + (or (uiop:getenvp "PGUSER") "panettone") + (or (uiop:getenvp "PGPASSWORD") "password") + (or (uiop:getenvp "PGHOST") "localhost") + + :port (or (integer-env "PGPORT") 5432) + :application-name "panettone" + :pooled-p t)) + +(defun prepare-db-connections () + "Initialises the connection spec used for all Postgres connections." + (setq *pg-spec* (make-pg-spec))) + +(defun connect-to-db () + "Connect using *PG-SPEC* at the top-level, for use during development" + (apply #'connect-toplevel + (loop for v in *pg-spec* + until (eq v :pooled-p) + collect v))) + +(defun pg-spec->url (&optional (spec *pg-spec*)) + (destructuring-bind (db user password host &key port &allow-other-keys) spec + (format nil + "postgres://~A:~A@~A:~A/~A" + user password host port db))) ;;; ;;; Schema ;;; +(defclass user () + ((sub :col-type uuid :initarg :sub :accessor sub + :documentation + "ID for the user in the authentication provider. Taken from the `:SUB' + field in the JWT when the user first logged in") + (username :col-type string :initarg :username :accessor username) + (email :col-type string :initarg :email :accessor email)) + (:metaclass dao-class) + (:keys sub) + (:table-name users) + (:documentation + "Panettone users. Uses an external authentication provider.")) + +(deftable (user "users") + (!dao-def)) + +(defclass user-settings () + ((user-dn :col-type string :initarg :user-dn :accessor user-dn) + (enable-email-notifications + :col-type boolean + :initarg :enable-email-notifications + :accessor enable-email-notifications-p + :initform t + :col-default t)) + (:metaclass dao-class) + (:keys user-dn) + (:table-name user_settings) + (:documentation + "Panettone settings for an individual user DN")) + +(deftable (user-settings "user_settings") + (!dao-def)) + +(defun settings-for-user (dn) + "Retrieve the settings for the user with the given DN, creating a new row in + the database if not yet present" + (or + (car + (query-dao + 'user-settings + (:select '* :from 'user-settings :where (:= 'user-dn dn)))) + (insert-dao (make-instance 'user-settings :user-dn dn)))) + +(defun update-user-settings (settings &rest attrs) + "Update the fields of the settings for USER with the given ATTRS, which is a + plist of slot and value" + (check-type settings user-settings) + (when-let ((set-fields + (iter + (for slot in '(enable-email-notifications)) + (for new-value = (getf attrs slot)) + (appending + (progn + (setf (slot-value settings slot) new-value) + (list slot new-value)))))) + (execute + (sql-compile + `(:update user-settings + :set ,@set-fields + :where (:= user-dn ,(user-dn settings))))))) + + (define-constant +issue-statuses+ '(:open :closed) :test #'equal) @@ -21,15 +108,6 @@ "Type specifier for the status of an `issue'" (cons 'member +issue-statuses+)) -(defun ddl/create-issue-status () - "Issue DDL to create the `issue-status' type, if it doesn't exist" - (unless (query (:select (:exists (:select 1 - :from 'pg_type - :where (:= 'typname "issue_status")))) - :single) - (query (sql-compile - `(:create-enum issue-status ,+issue-statuses+))))) - (defclass has-created-at () ((created-at :col-type timestamp :col-default (local-time:now) @@ -49,6 +127,9 @@ (declare (ignore initargs)) (created-at->timestamp obj)) +(defun keyword->str (kw) (string-downcase (symbol-name kw))) +(defun str->keyword (st) (alexandria:make-keyword (string-upcase st))) + (defclass issue (has-created-at) ((id :col-type serial :initarg :id :accessor id) (subject :col-type string :initarg :subject :accessor subject) @@ -61,7 +142,9 @@ :initarg :status :accessor status :initform :open - :col-default "open")) + :col-default "open" + :col-export keyword->str + :col-import str->keyword)) (:metaclass dao-class) (:keys id) (:table-name issues) @@ -131,22 +214,171 @@ its new value will be formatted using ~A into NEW-VALUE")) (!dao-def) (!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade)) -(define-constant +all-tables+ - '(issue - issue-comment - issue-event) - :test #'equal) +(defclass migration () + ((version + :col-type bigint + :primary-key t + :initarg :version + :accessor version) + (name :col-type string :initarg :name :accessor name) + (docstring :col-type string :initarg :docstring :accessor docstring) + (path :col-type string + :type pathname + :initarg :path + :accessor path + :col-export namestring + :col-import parse-namestring) + (package :type keyword :initarg :package :accessor migration-package)) + (:metaclass dao-class) + (:keys version) + (:table-name migrations) + (:documentation "Migration scripts that have been run on the database")) +(deftable migration (!dao-def)) + +;;; +;;; Utils +;;; + +(defun create-table-if-not-exists (name) + " Takes the name of a dao-class and creates the table identified by symbol by +executing all forms in its definition as found in the *tables* list, if it does +not already exist." + (unless (table-exists-p (dao-table-name name)) + (create-table name))) -(defun ddl/create-tables () - "Issue DDL to create all tables, if they don't already exist." - (dolist (table +all-tables+) - (unless (table-exists-p (dao-table-name table)) - (create-table table)))) +;;; +;;; Migrations +;;; -(defun ddl/init () - "Idempotently initialize the full database schema for Panettone" - (ddl/create-issue-status) - (ddl/create-tables)) +(defun ensure-migrations-table () + "Ensure the migrations table exists" + (unless (table-exists-p (dao-table-name 'migration)) + (create-table 'migration))) + +(define-build-time-var *migrations-dir* "migrations/" + "The directory where migrations are stored") + +(defun load-migration-docstring (migration-path) + "If the first form in the file pointed to by `migration-pathname` is + a string, return it, otherwise return NIL." + + (handler-case + (with-open-file (s migration-path) + (when-let ((form (read s))) + (when (stringp form) form))) + (t () nil))) + +(defun load-migration (path) + (let* ((parts (str:split #\- (pathname-name path) :limit 2)) + (version (parse-integer (car parts))) + (name (cadr parts)) + (docstring (load-migration-docstring path)) + (package (intern (format nil "MIGRATION-~A" version) + :keyword)) + (migration (make-instance 'migration + :version version + :name name + :docstring docstring + :path path + :package package))) + (uiop/package:ensure-package package + :use '(#:common-lisp + #:postmodern + #:panettone.model)) + (let ((*package* (find-package package))) + (load path)) + + migration)) + +(defun run-migration (migration) + (declare (type migration migration)) + (with-transaction () + (format t "Running migration ~A (version ~A)" + (name migration) + (version migration)) + (query + (sql-compile + `(:delete-from migrations + :where (= version ,(version migration))))) + (uiop:symbol-call (migration-package migration) :up) + (insert-dao migration))) + +(defun list-migration-files () + (remove-if-not + (lambda (pn) (string= "lisp" (pathname-type pn))) + (uiop:directory-files (util:->dir *migrations-dir*)))) + +(defun load-migrations () + (mapcar #'load-migration (list-migration-files))) + +(defun generate-migration (name &key documentation) + "Generate a new database migration with the given NAME, optionally +prepopulated with the given DOCUMENTATION. + +Returns the file that the migration is located at, as a `pathname'. Write Lisp +code in this migration file to define a function called `up', which will be run +in the context of a database transaction and should perform the migration." + (let* ((version (get-universal-time)) + (filename (format nil "~A-~A.lisp" + version + name)) + (pathname + (merge-pathnames filename *migrations-dir*))) + (with-open-file (stream pathname + :direction :output + :if-does-not-exist :create) + (when documentation + (format stream "~S~%~%" documentation)) + + (format stream "(defun up ()~%)")) + pathname)) + +(defun migrations-already-run () + "Query the database for a list of migrations that have already been run" + (query-dao 'migration (sql-compile '(:select * :from migrations)))) + +(define-condition migration-name-mismatch () + ((version :type integer :initarg :version) + (name-in-database :type string :initarg :name-in-database) + (name-in-code :type string :initarg :name-in-code)) + (:report + (lambda (cond stream) + (format stream "Migration mismatch: Migration version ~A has name ~S in the database, but we have name ~S" + (slot-value cond 'version) + (slot-value cond 'name-in-database) + (slot-value cond 'name-in-code))))) + +(defun migrate () + "Migrate the database, running all migrations that have not yet been run" + (ensure-migrations-table) + (format t "Running migrations from ~A...~%" *migrations-dir*) + (let* ((all-migrations (load-migrations)) + (already-run (migrations-already-run)) + (num-migrations-run 0)) + (iter (for migration in all-migrations) + (if-let ((existing (find-if (lambda (existing) + (= (version existing) + (version migration))) + already-run))) + (progn + (unless (string= (name migration) + (name existing)) + (restart-case + (error 'migration-name-mismatch + :version (version existing) + :name-in-database (name existing) + :name-in-code (name migration)) + (skip () + :report "Skip this migration" + (next-iteration)) + (run-and-overwrite () + :report "Run this migration anyway, overwriting the previous migration" + (run-migration migration)))) + (next-iteration)) + ;; otherwise, run the migration + (run-migration migration)) + (incf num-migrations-run)) + (format t "Ran ~A migration~:P~%" num-migrations-run))) ;;; ;;; Querying @@ -181,28 +413,35 @@ type `ISSUE-NOT-FOUND'." :where (:= 'id id)))) :single)) -(defun list-issues (&key status (with '(:num-comments))) +(defun list-issues (&key status search (with '(:num-comments))) "Return a list of all issues with the given STATUS (or all if nil), ordered by ID descending. If WITH contains `:NUM-COMMENTS' (the default) each issue will have the `num-comments' slot filled with the number of comments on that issue (to avoid N+1 queries)." - (let* ((condition (unless (null status) - `(:where (:= status $1)))) + (let* ((conditions + (and-where* + (unless (null status) + `(:= status $1)) + (when (str:non-blank-string-p search) + `(:@@ tsv (:websearch-to-tsquery ,search))))) (select (if (find :num-comments with) `(:select issues.* (:as (:count issue-comments.id) num-comments) - :from issues - :left-join issue-comments - :on (:= issues.id issue-comments.issue-id) - ,@condition - :group-by issues.id) - `(:select * :from issues ,@condition))) + :from issues + :left-join issue-comments + :on (:= issues.id issue-comments.issue-id) + :where ,conditions + :group-by issues.id) + `(:select * :from issues :where ,conditions))) + (order (if (str:non-blank-string-p search) + `(:desc (:ts-rank-cd tsv (:websearch-to-tsquery ,search))) + `(:desc id))) (query (sql-compile - `(:order-by ,select (:desc id))))) + `(:order-by ,select ,order)))) (with-column-writers ('num_comments 'num-comments) (query-dao 'issue query status)))) -(defmethod num-comments ((issue-id integer)) +(defmethod count-comments ((issue-id integer)) "Return the number of comments for the given ISSUE-ID." (query (:select (:count '*) @@ -240,7 +479,6 @@ NOTE: This makes a database query, so be wary of N+1 queries" :where (:= 'issue-id issue-id)) (:asc 'created-at)))) - ;;; ;;; Writing ;;; @@ -327,10 +565,44 @@ ISSUE-ID, which should be a plist of initforms, and return an instance of (error 'issue-not-found :id issue-id)) (insert-dao (apply #'make-instance 'issue-comment :issue-id issue-id attrs))) +(defun issue-commenter-dns (issue-id) + "Returns a list of all the dns of users who have commented on ISSUE-ID" + (query (:select 'author-dn :distinct + :from 'issue-comments + :where (:= 'issue-id issue-id)) + :column)) + +(defun issue-subscribers (issue-id) + "Returns a list of user DNs who should receive notifications for actions taken + on ISSUE-ID. + +Currently this is implemented as the author of issue plus all the users who have +commented on the issue, but in the future we likely want to also allow +explicitly subscribing to / unsubscribing from individual issues." + (let ((issue (get-issue issue-id))) + (adjoin (author-dn issue) + (issue-commenter-dns issue-id) + :test #'equal))) + + (comment - (connect-postgres) - (ddl/init) + (make-instance 'issue :subject "test") - (create-issue :subject "test" - :author-dn "cn=glittershark,ou=users,dc=tvl,dc=fyi") + + (with-connection *pg-spec* + (create-issue :subject "test" + :author-dn "cn=aspen,ou=users,dc=tvl,dc=fyi")) + + (issue-commenter-dns 1) + (issue-subscribers 1) + + ;; Creating new migrations + (setq *migrations-dir* (merge-pathnames "migrations/")) + (generate-migration "create-users-table" + :documentation "Add a table to store information about users") + (load-migrations) + + ;; Running migrations + (with-connection *pg-spec* + (migrate)) ) diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp index 1a8453055f..8e77c0ff2b 100644 --- a/web/panettone/src/packages.lisp +++ b/web/panettone/src/packages.lisp @@ -1,51 +1,95 @@ (defpackage panettone.util + (:nicknames :util) (:use :cl :klatre) (:import-from :alexandria :when-let) - (:export :integer-env)) + (:export + :integer-env :add-missing-base64-padding :and-where :and-where* + :define-build-time-var :->dir)) (defpackage panettone.css (:use :cl :lass) (:export :styles)) +(defpackage panettone.inline-markdown + (:use :cl) + (:import-from :alexandria :define-constant) + (:export :render-inline-markdown)) + +(defpackage panettone.irc + (:nicknames :irc) + (:use :cl :usocket) + (:export :noping :send-irc-notification)) + (defpackage :panettone.authentication (:nicknames :authn) (:use :cl :panettone.util :klatre) (:import-from :defclass-std :defclass/std) (:import-from :alexandria :when-let :with-gensyms) (:export - :*user* :*ldap* + :*user* + :auth-url + :fetch-token :user :cn :dn :mail :displayname - :connect-ldap :find-user :find-user-by-dn :authenticate-user)) + :find-user-by-dn + :initialise-oauth2)) (defpackage panettone.model (:nicknames :model) (:use :cl :panettone.util :klatre :postmodern :iterate) (:import-from :alexandria :if-let :when-let :define-constant) (:export - :connect-postgres :ddl/init + :prepare-db-connections + :migrate + :*pg-spec* + + :create-table-if-not-exists - :issue :issue-comment :issue-event + :user + :sub :username :email + + :user-settings + :user-dn :enable-email-notifications-p :settings-for-user + :update-user-settings :enable-email-notifications + + :issue :issue-comment :issue-event :migration :id :subject :body :author-dn :issue-id :status :created-at :acting-user-dn - :field :previous-value :new-value + :field :previous-value :new-value :+issue-statuses+ :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status - :update-issue :delete-issue :issue-not-found + :update-issue :delete-issue :issue-not-found :not-found-id :issue-events - :issue-comments :num-comments :create-issue-comment)) + :issue-comments :num-comments :create-issue-comment + :issue-commenter-dns :issue-subscribers)) + +(defpackage panettone.email + (:nicknames :email) + (:use :cl) + (:import-from :alexandria :when-let :when-let*) + (:import-from :panettone.model + :settings-for-user :enable-email-notifications-p) + (:import-from :panettone.authentication + :find-user-by-dn :mail :displayname) + (:export + :*smtp-server* :*smtp-server-port* :*notification-from* + :*notification-from-display-name* :*notification-subject-prefix* + :notify-user :send-email-notification)) (defpackage panettone (:use :cl :klatre :easy-routes :iterate :panettone.util - :panettone.authentication) + :panettone.authentication + :panettone.inline-markdown) (:import-from :defclass-std :defclass/std) (:import-from :alexandria :if-let :when-let :switch :alist-hash-table) (:import-from :cl-ppcre :split) + (:import-from :bordeaux-threads :make-thread) (:import-from :panettone.model :id :subject :body :author-dn :issue-id :status :created-at :field :previous-value :new-value :acting-user-dn - :issue-comments :num-comments :issue-events) + :*pg-spec*) + (:import-from :panettone.irc :send-irc-notification) (:shadow :next) - (:export :start-pannetone :config :main)) + (:export :start-panettone :config :main)) 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") ) diff --git a/web/panettone/src/static/search.png b/web/panettone/src/static/search.png new file mode 100644 index 0000000000..0fd78c6651 --- /dev/null +++ b/web/panettone/src/static/search.png Binary files differdiff --git a/web/panettone/src/util.lisp b/web/panettone/src/util.lisp index 9fd9ceaa79..4c3c4f1aa6 100644 --- a/web/panettone/src/util.lisp +++ b/web/panettone/src/util.lisp @@ -5,3 +5,35 @@ (when-let ((str (uiop:getenvp var))) (try-parse-integer str)) default)) + +(defun add-missing-base64-padding (s) + "Add any missing padding characters to the (un-padded) base64 string `S', such +that it can be successfully decoded by the `BASE64' package" + ;; I apologize + (let* ((needed-padding (mod (length s) 4)) + (pad-chars (if (zerop needed-padding) 0 (- 4 needed-padding)))) + (format nil "~A~v@{~A~:*~}" s pad-chars "="))) + +(defun and-where (clauses) + "Combine all non-nil clauses in CLAUSES into a single S-SQL WHERE form" + (let ((clauses (remove nil clauses))) + (if (null clauses) t + (reduce (lambda (x y) `(:and ,x ,y)) clauses)))) + +(defun and-where* (&rest clauses) + "Combine all non-nil clauses in CLAUSES into a single S-SQL WHERE form" + (and-where clauses)) + +(defmacro define-build-time-var + (name value-if-not-in-build &optional (doc nil)) + `(defvar ,name + (or (when-let ((package (find-package :build))) + (let ((sym (find-symbol ,(symbol-name name) package))) + (when (boundp sym) (symbol-value sym)))) + ,value-if-not-in-build) + ,doc)) + +(defun ->dir (dir) + (if (char-equal (uiop:last-char dir) #\/) + dir + (concatenate 'string dir "/"))) |