diff options
Diffstat (limited to 'web/panettone')
| -rw-r--r-- | web/panettone/.envrc | 1 | ||||
| -rw-r--r-- | web/panettone/.gitignore | 1 | ||||
| -rw-r--r-- | web/panettone/OWNERS | 3 | ||||
| -rw-r--r-- | web/panettone/default.nix | 55 | ||||
| -rw-r--r-- | web/panettone/docker-compose.yml | 11 | ||||
| -rw-r--r-- | web/panettone/panettone.asd | 6 | ||||
| -rw-r--r-- | web/panettone/shell.nix | 15 | ||||
| -rw-r--r-- | web/panettone/src/.gitignore | 2 | ||||
| -rw-r--r-- | web/panettone/src/authentication.lisp | 115 | ||||
| -rw-r--r-- | web/panettone/src/css.lisp | 223 | ||||
| -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/model.lisp | 420 | ||||
| -rw-r--r-- | web/panettone/src/packages.lisp | 87 | ||||
| -rw-r--r-- | web/panettone/src/panettone.lisp | 650 | ||||
| -rw-r--r-- | web/panettone/src/util.lisp | 15 | ||||
| -rw-r--r-- | web/panettone/test/inline-markdown_test.lisp | 54 | ||||
| -rw-r--r-- | web/panettone/test/irc_test.lisp | 5 | ||||
| -rw-r--r-- | web/panettone/test/model_test.lisp | 13 | ||||
| -rw-r--r-- | web/panettone/test/package.lisp | 3 | ||||
| -rw-r--r-- | web/panettone/test/util_test.lisp | 9 |
22 files changed, 1899 insertions, 0 deletions
diff --git a/web/panettone/.envrc b/web/panettone/.envrc new file mode 100644 index 000000000000..be81feddb1a5 --- /dev/null +++ b/web/panettone/.envrc @@ -0,0 +1 @@ +eval "$(lorri direnv)" \ No newline at end of file diff --git a/web/panettone/.gitignore b/web/panettone/.gitignore new file mode 100644 index 000000000000..be303db03207 --- /dev/null +++ b/web/panettone/.gitignore @@ -0,0 +1 @@ +*.fasl diff --git a/web/panettone/OWNERS b/web/panettone/OWNERS new file mode 100644 index 000000000000..5ad475b1c7e3 --- /dev/null +++ b/web/panettone/OWNERS @@ -0,0 +1,3 @@ +aspen +tazjin +sterni diff --git a/web/panettone/default.nix b/web/panettone/default.nix new file mode 100644 index 000000000000..283f83499487 --- /dev/null +++ b/web/panettone/default.nix @@ -0,0 +1,55 @@ +{ depot, ... }: + +depot.nix.buildLisp.program { + name = "panettone"; + + deps = with depot.third_party.lisp; [ + bordeaux-threads + cl-json + cl-ppcre + cl-smtp + cl-who + defclass-std + drakma + easy-routes + hunchentoot + lass + local-time + postmodern + + depot.lisp.klatre + ]; + + srcs = [ + ./panettone.asd + ./src/packages.lisp + ./src/util.lisp + ./src/css.lisp + ./src/email.lisp + ./src/inline-markdown.lisp + ./src/authentication.lisp + ./src/model.lisp + ./src/irc.lisp + ./src/panettone.lisp + ]; + + tests = { + deps = with depot.third_party.lisp; [ + fiveam + ]; + + srcs = [ + ./test/package.lisp + ./test/model_test.lisp + ./test/inline-markdown_test.lisp + ./test/util_test.lisp + ]; + + expression = "(fiveam:run!)"; + }; + + brokenOn = [ + "ecl" # dependencies use dynamic cffi + "ccl" # The value NIL is not of the expected type STRING. when loading model.lisp + ]; +} diff --git a/web/panettone/docker-compose.yml b/web/panettone/docker-compose.yml new file mode 100644 index 000000000000..84723667e6b9 --- /dev/null +++ b/web/panettone/docker-compose.yml @@ -0,0 +1,11 @@ +version: '3.4' +services: + postgres: + image: postgres:11 + restart: always + environment: + POSTGRES_USER: panettone + POSTGRES_PASSWORD: password + POSTGRES_DB: panettone + ports: + - 127.0.0.1:5432:5432 diff --git a/web/panettone/panettone.asd b/web/panettone/panettone.asd new file mode 100644 index 000000000000..4d44e50fd3e8 --- /dev/null +++ b/web/panettone/panettone.asd @@ -0,0 +1,6 @@ +(asdf:defsystem "panettone" + :description "A simple issue tracker" + :serial t + :components ((:file "packages") + (:file "css") + (:file "pannetone"))) diff --git a/web/panettone/shell.nix b/web/panettone/shell.nix new file mode 100644 index 000000000000..483481ca9aa1 --- /dev/null +++ b/web/panettone/shell.nix @@ -0,0 +1,15 @@ +{ depot ? import ../.. { } }: + +with depot.third_party.nixpkgs; + +mkShell { + buildInputs = [ + docker-compose + postgresql + ]; + + PGPASSWORD = "password"; + PGHOST = "localhost"; + PGUSER = "panettone"; + PGDATABASE = "panettone"; +} diff --git a/web/panettone/src/.gitignore b/web/panettone/src/.gitignore new file mode 100644 index 000000000000..10aa5440d832 --- /dev/null +++ b/web/panettone/src/.gitignore @@ -0,0 +1,2 @@ +# I use this as the out-link for my local lisp dev env +sbcl diff --git a/web/panettone/src/authentication.lisp b/web/panettone/src/authentication.lisp new file mode 100644 index 000000000000..3ce07aa8d78d --- /dev/null +++ b/web/panettone/src/authentication.lisp @@ -0,0 +1,115 @@ +(in-package :panettone.authentication) + +(defvar *user* nil + "The currently logged-in user") + +(defclass/std user () + ((cn dn mail displayname :type string))) + +;; 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) + "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")) + +(defun initialise-oauth2 () + "Initialise all settings needed for OAuth2" + + (setq *oauth2-auth-endpoint* + (or (uiop:getenv "OAUTH2_AUTH_ENDPOINT") + "https://auth.tvl.fyi/auth/realms/TVL/protocol/openid-connect/auth")) + + (setq *oauth2-token-endpoint* + (or (uiop:getenv "OAUTH2_TOKEN_ENDPOINT") + "https://auth.tvl.fyi/auth/realms/TVL/protocol/openid-connect/token")) + + (setq *oauth2-client-id* + (or (uiop:getenv "OAUTH2_CLIENT_ID") + "panettone")) + + (setq *oauth2-client-secret* + (or (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 new file mode 100644 index 000000000000..aa753cb50fc5 --- /dev/null +++ b/web/panettone/src/css.lisp @@ -0,0 +1,223 @@ +(in-package :panettone.css) +(declaim (optimize (safety 3))) + +(defun button (selector) + `((,selector + :background-color "var(--success)" + :padding "0.5rem" + :text-decoration "none" + :transition "box-shadow" "0.15s" "ease-in-out") + + ((:and ,selector :hover) + :box-shadow "0.25rem" "0.25rem" "0" "0" "rgba(0,0,0,0.08)") + + ((:and ,selector (:or :active :focus)) + :box-shadow "0.1rem" "0.1rem" "0" "0" "rgba(0,0,0,0.05)" + :outline "none" + :border "none"))) + +(defparameter markdown-styles + `((blockquote + :border-left "5px" "solid" "var(--light)"-gray + :padding-left "1rem" + :margin-left "0rem") + (pre + :overflow-x "auto"))) + +(defparameter issue-list-styles + `((.issue-list + :list-style-type "none" + :padding-left 0 + + (.issue-subject + :font-weight "bold") + + (li + :padding-bottom "1rem") + + ((li + li) + :border-top "1px" "solid" "var(--gray)") + + (a + :text-decoration "none" + :display "block") + + ((:and a :hover) + :outline "none" + + (.issue-subject + :color "var(--primary)"))) + + (.comment-count + :color "var(--gray)"))) + +(defparameter issue-history-styles + `((.issue-history + :list-style "none" + :border-top "1px" "solid" "var(--gray)" + :padding-top "1rem" + :padding-left "2rem" + + (.comment-info + :color "var(--gray)" + :margin 0 + :padding-top "1rem" + + (a :text-decoration "none") + ((:and a :hover) + :text-decoration "underline")) + + ((:or .comment .event) + :padding-top "1rem" + :padding-bottom "1rem" + :border-bottom "1px" "solid" "var(--gray)" + + (p :margin 0)) + + ((:and (:or .comment .event) :target) + :border-color "var(--primary)" + :border-bottom-width "3px") + + (.event + :color "var(--gray)")))) + +(defparameter form-styles + `(((:or (:and input (:or (:= type "text") + (:= type "password"))) + textarea) + :width "100%" + :padding "0.5rem" + :outline "none" + :border-top "none" + :border-left "none" + :border-right "none" + :border-bottom "1px" "solid" "var(--gray)" + :margin-bottom "1rem") + + (textarea + :resize "vertical") + + ((:and input (:= type "submit")) + :-webkit-appearance "none" + :border "none" + :cursor "pointer" + :font-size "1rem") + + ,@(button '(:and input (:= type "submit"))) + + (.form-link + ((:and input (:= type "submit")) + :background-color "initial" + :color "inherit" + :padding 0 + :text-decoration "underline") + + ((:and input (:= type "submit") + (:or :hover :active :focus)) + :box-shadow 0 0 0 0)) + + (.form-group + :margin-top "1rem") + + (label.checkbox + :cursor "pointer"))) + +(defparameter issue-styles + `((.issue-info + :display "flex" + :justify-content "space-between" + :align-items "center" + + ,@(button '.edit-issue) + + (.created-by-at + :flex 1) + + (.edit-issue + :background-color "var(--light)"-gray + :flex 0 + :margin-right "0.5rem") + + (.close-issue + :background-color "var(--failure)")))) + +(defparameter styles + `(,@form-styles + ,@issue-list-styles + ,@issue-styles + ,@issue-history-styles + ,@markdown-styles + + (body + :font-family "sans-serif" + :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") + + (.content + :max-width "800px" + :margin "0 auto") + + (header + :display "flex" + :align-items "center" + :border-bottom "1px" "solid" "var(--text)" + :margin-bottom "1rem" + + (h1 + :padding 0 + :flex 1) + + (.issue-number + :color "var(--gray)" + :font-size "1.5rem")) + + (nav + :display "flex" + :color "var(--gray)" + :justify-content "space-between" + + (.nav-group + :display "flex" + (>* + :margin-left "0.5rem"))) + + (footer + :border-top "1px" "solid" "var(--gray)" + :padding-top "1rem" + :margin-top "1rem" + :color "var(--gray)") + + ,@(button '.new-issue) + + (.alert + :padding "0.5rem" + :margin-bottom "1rem" + :background-color "var(--failure)") + + (.login-form + :max-width "300px" + :margin "0 auto") + + (.created-by-at + :color "var(--gray)"))) diff --git a/web/panettone/src/email.lisp b/web/panettone/src/email.lisp new file mode 100644 index 000000000000..66ea299858d3 --- /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 000000000000..e49293519bf4 --- /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 000000000000..2ab72a2e391e --- /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/model.lisp b/web/panettone/src/model.lisp new file mode 100644 index 000000000000..c54a0ae474bf --- /dev/null +++ b/web/panettone/src/model.lisp @@ -0,0 +1,420 @@ +(in-package :panettone.model) +(declaim (optimize (safety 3))) + +(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))) + +;;; +;;; Schema +;;; + +(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) + +(deftype issue-status () + "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) + :initarg :created-at + :accessor created-at)) + (:metaclass dao-class)) + +(defun created-at->timestamp (object) + (assert (slot-exists-p object 'created-at)) + (unless (or (not (slot-boundp object 'created-at)) + (typep (slot-value object 'created-at) 'local-time:timestamp)) + (setf (slot-value object 'created-at) + (local-time:universal-to-timestamp (created-at object))))) + +(defmethod initialize-instance :after + ((obj has-created-at) &rest initargs &key &allow-other-keys) + (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) + (body :col-type string :initarg :body :accessor body :col-default "") + (author-dn :col-type string :initarg :author-dn :accessor author-dn) + (comments :type list :accessor issue-comments) + (events :type list :accessor issue-events) + (num-comments :type integer :accessor num-comments) + (status :col-type issue_status + :initarg :status + :accessor status + :initform :open + :col-default "open" + :col-export keyword->str + :col-import str->keyword)) + (:metaclass dao-class) + (:keys id) + (:table-name issues) + (:documentation + "Issues are the primary entity in the Panettone database. An issue is + reported by a user, has a subject and an optional body, and can be either + open or closed")) + +(defmethod cl-postgres:to-sql-string ((kw (eql :open))) + (cl-postgres:to-sql-string "open")) +(defmethod cl-postgres:to-sql-string ((kw (eql :closed))) + (cl-postgres:to-sql-string "closed")) +(defmethod cl-postgres:to-sql-string ((ts local-time:timestamp)) + (cl-postgres:to-sql-string + (local-time:timestamp-to-unix ts))) + +(defmethod initialize-instance :after + ((issue issue) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (unless (symbolp (status issue)) + (setf (status issue) + (intern (string-upcase (status issue)) + "KEYWORD")))) + +(deftable issue (!dao-def)) + +(defclass issue-comment (has-created-at) + ((id :col-type integer :col-identity t :initarg :id :accessor id) + (body :col-type string :initarg :body :accessor body) + (author-dn :col-type string :initarg :author-dn :accessor author-dn) + (issue-id :col-type integer :initarg :issue-id :accessor :user-id)) + (:metaclass dao-class) + (:keys id) + (:table-name issue_comments) + (:documentation "Comments on an `issue'")) +(deftable (issue-comment "issue_comments") + (!dao-def) + (!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade)) + +(defclass issue-event (has-created-at) + ((id :col-type integer :col-identity t :initarg :id :accessor id) + (issue-id :col-type integer + :initarg :issue-id + :accessor issue-id) + (acting-user-dn :col-type string + :initarg :acting-user-dn + :accessor acting-user-dn) + (field :col-type (or string db-null) + :initarg :field + :accessor field) + (previous-value :col-type (or string db-null) + :initarg :previous-value + :accessor previous-value) + (new-value :col-type (or string db-null) + :initarg :new-value + :accessor new-value)) + (:metaclass dao-class) + (:keys id) + (:table-name issue_events) + (:documentation "Events that have occurred for an issue. + +If a field has been changed on an issue, the SYMBOL-NAME of that slot will be in +FIELD, its previous value will be formatted using ~A into PREVIOUS-VALUE, and +its new value will be formatted using ~A into NEW-VALUE")) + +(deftable (issue-event "issue_events") + (!dao-def) + (!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade)) + +(define-constant +all-tables+ + '(issue + issue-comment + issue-event + user-settings) + :test #'equal) + +(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)))) + +(defun ddl/init () + "Idempotently initialize the full database schema for Panettone" + (ddl/create-issue-status) + (ddl/create-tables)) + +;;; +;;; Querying +;;; + +(define-condition issue-not-found (error) + ((id :type integer + :initarg :id + :reader not-found-id + :documentation "ID of the issue that was not found")) + (:documentation + "Error condition for when an issue requested by ID is not found")) + +(defun get-issue (id) + "Look up the 'issue with the given ID and return it, or signal a condition of +type `ISSUE-NOT-FOUND'." + (restart-case + (or (get-dao 'issue id) + (error 'issue-not-found :id id)) + (different-id (new-id) + :report "Use a different issue ID" + :interactive (lambda () + (format t "Enter a new ID: ") + (multiple-value-list (eval (read)))) + (get-issue new-id)))) + +(defun issue-exists-p (id) + "Returns `T' if an issue with the given ID exists" + (query + (:select (:exists (:select 1 + :from 'issues + :where (:= 'id id)))) + :single)) + +(defun list-issues (&key status (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)))) + (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))) + (query (sql-compile + `(:order-by ,select (:desc id))))) + (with-column-writers ('num_comments 'num-comments) + (query-dao 'issue query status)))) + +(defmethod count-comments ((issue-id integer)) + "Return the number of comments for the given ISSUE-ID." + (query + (:select (:count '*) + :from 'issue-comments + :where (:= 'issue-id issue-id)) + :single)) + +(defmethod slot-unbound (cls (issue issue) (slot (eql 'comments))) + (declare (ignore cls) (ignore slot)) + (setf (issue-comments issue) (issue-comments (id issue)))) + +(defmethod issue-comments ((issue-id integer)) + "Return a list of all comments with the given ISSUE-ID, sorted oldest first. +NOTE: This makes a database query, so be wary of N+1 queries" + (query-dao + 'issue-comment + (:order-by + (:select '* + :from 'issue-comments + :where (:= 'issue-id issue-id)) + (:asc 'created-at)))) + +(defmethod slot-unbound (cls (issue issue) (slot (eql 'events))) + (declare (ignore cls) (ignore slot)) + (setf (issue-events issue) (issue-events (id issue)))) + +(defmethod issue-events ((issue-id integer)) + "Return a list of all events with the given ISSUE-ID, sorted oldest first. +NOTE: This makes a database query, so be wary of N+1 queries" + (query-dao + 'issue-event + (:order-by + (:select '* + :from 'issue-events + :where (:= 'issue-id issue-id)) + (:asc 'created-at)))) + +;;; +;;; Writing +;;; + +(defun record-issue-event + (issue-id &key + field + previous-value + new-value) + "Record in the database that the user identified by `AUTHN:*USER*' updated +ISSUE-ID, and return the resulting `ISSUE-EVENT'. If no user is currently +authenticated, warn and no-op" + (check-type issue-id (integer)) + (check-type field (or null symbol)) + (if authn:*user* + (insert-dao + (make-instance 'issue-event + :issue-id issue-id + :acting-user-dn (authn:dn authn:*user*) + :field (symbol-name field) + :previous-value (when previous-value + (format nil "~A" previous-value)) + :new-value (when new-value + (format nil "~A" new-value)))) + (warn "Performing operation as unauthenticated user"))) + +(defun create-issue (&rest attrs) + "Insert a new issue into the database with the given ATTRS, which should be +a plist of initforms, and return an instance of `issue'" + (insert-dao (apply #'make-instance 'issue attrs))) + +(defun delete-issue (issue) + (delete-dao issue)) + +(defun set-issue-status (issue-id status) + "Set the status of the issue with the given ISSUE-ID to STATUS in the db. If +the issue doesn't exist, signals `issue-not-found'" + (check-type issue-id integer) + (check-type status issue-status) + (let ((original-status (query (:select 'status + :from 'issues + :where (:= 'id issue-id)) + :single))) + (when (zerop (execute (:update 'issues + :set 'status (cl-postgres:to-sql-string status) + :where (:= 'id issue-id)))) + (error 'issue-not-found :id issue-id)) + (record-issue-event + issue-id + :field 'status + :previous-value (string-upcase original-status) + :new-value status) + (values))) + +(defun update-issue (issue &rest attrs) + "Update the fields of ISSUE with the given ATTRS, which is a plist of slot and +value, and record events for the updates" + (let ((set-fields + (iter (for slot in '(subject body)) + (for new-value = (getf attrs slot)) + (appending + (let ((previous-value (slot-value issue slot))) + (when (and new-value (not (equalp + new-value + previous-value))) + (record-issue-event (id issue) + :field slot + :previous-value previous-value + :new-value new-value) + (setf (slot-value issue slot) new-value) + (list slot new-value))))))) + (execute + (sql-compile + `(:update issues + :set ,@set-fields + :where (:= id ,(id issue))))))) + +(defun create-issue-comment (&rest attrs &key issue-id &allow-other-keys) + "Insert a new issue comment into the database with the given ATTRS and +ISSUE-ID, which should be a plist of initforms, and return an instance of +`issue-comment'. If no issue exists with `ID' ISSUE-ID, signals +`issue-not-found'." + (unless (issue-exists-p issue-id) + (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 + (ddl/init) + (make-instance 'issue :subject "test") + (create-issue :subject "test" + :author-dn "cn=grfn,ou=users,dc=tvl,dc=fyi") + + (issue-commenter-dns 1) + (issue-subscribers 1) + + ) diff --git a/web/panettone/src/packages.lisp b/web/panettone/src/packages.lisp new file mode 100644 index 000000000000..4ff4c070f087 --- /dev/null +++ b/web/panettone/src/packages.lisp @@ -0,0 +1,87 @@ +(defpackage panettone.util + (:use :cl :klatre) + (:import-from :alexandria :when-let) + (:export :integer-env :add-missing-base64-padding)) + +(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* + :auth-url + :fetch-token + :user :cn :dn :mail :displayname + :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 + :prepare-db-connections + :ddl/init + :*pg-spec* + + :user-settings + :user-dn :enable-email-notifications-p :settings-for-user + :update-user-settings :enable-email-notifications + + :issue :issue-comment :issue-event + :id :subject :body :author-dn :issue-id :status :created-at :acting-user-dn + :field :previous-value :new-value + + :get-issue :issue-exists-p :list-issues :create-issue :set-issue-status + :update-issue :delete-issue :issue-not-found :not-found-id + + :issue-events + + :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.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 + :*pg-spec*) + (:import-from :panettone.irc :send-irc-notification) + (:shadow :next) + (:export :start-panettone :config :main)) diff --git a/web/panettone/src/panettone.lisp b/web/panettone/src/panettone.lisp new file mode 100644 index 000000000000..d87ac5ed4653 --- /dev/null +++ b/web/panettone/src/panettone.lisp @@ -0,0 +1,650 @@ +(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 + "/auth?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/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 "/auth?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 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) "/"))) + + (progn + (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 @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 + (format nil "/issues/~A" (id issue)))))) + +(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 session-secret) + (authn:initialise-oauth2) + (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)) + (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 + :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 cheddar+irccat for development: + ;; ssh -N -L 4238:localhost:4238 -L 4722:localhost:4722 whitby.tvl.fyi + (start-panettone :port 6161 + :session-secret "session-secret") + ) diff --git a/web/panettone/src/util.lisp b/web/panettone/src/util.lisp new file mode 100644 index 000000000000..2abedf7b8fbb --- /dev/null +++ b/web/panettone/src/util.lisp @@ -0,0 +1,15 @@ +(in-package :panettone.util) + +(defun integer-env (var &key default) + (or + (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 "="))) diff --git a/web/panettone/test/inline-markdown_test.lisp b/web/panettone/test/inline-markdown_test.lisp new file mode 100644 index 000000000000..bb907504368b --- /dev/null +++ b/web/panettone/test/inline-markdown_test.lisp @@ -0,0 +1,54 @@ +(in-package :panettone.tests) +(declaim (optimize (safety 3))) + +(defmacro inline-markdown-unit-test (name input expected) + `(test ,name + (is (equal + ,expected + (with-output-to-string (*standard-output*) + (render-inline-markdown ,input)))))) + +(inline-markdown-unit-test + inline-markdown-typical-test + "hello *world*, here is ~~no~~ `code`!" + "hello <em>world</em>, here is <del>no</del> <code>code</code>!") + +(inline-markdown-unit-test + inline-markdown-two-emphasize-types-test + "*stress* *this*" + "<em>stress</em> <em>this</em>") + +(inline-markdown-unit-test + inline-markdown-html-escaping-test + "<tag>öäü" + "<tag>öäü") + +(inline-markdown-unit-test + inline-markdown-nesting-test + "`inside code *anything* goes`, but also ~~*here*~~" + "<code>inside code *anything* goes</code>, but also <del>*here*</del>") + +(inline-markdown-unit-test + inline-markdown-escaping-test + "A backslash \\\\ shows: \\*, \\` and \\~~" + "A backslash \\ shows: *, ` and ~~") + +(inline-markdown-unit-test + inline-markdown-nested-escaping-test + "`prevent \\`code\\` from ending, but never stand alone \\\\`" + "<code>prevent `code` from ending, but never stand alone \\</code>") + +(inline-markdown-unit-test + inline-markdown-escape-normal-tokens-test + "\\Normal tokens \\escaped?" + "\\Normal tokens \\escaped?") + +(inline-markdown-unit-test + inline-markdown-no-unclosed-tags-test + "A tag, once opened, *must be closed" + "A tag, once opened, <em>must be closed</em>") + +(inline-markdown-unit-test + inline-markdown-unicode-safe + "Does Unicode 👨👨👧👦 break \\👩🏾🦰 tokenization?" + "Does Unicode 👨‍👨‍👧‍👦 break \\👩🏾‍🦰 tokenization?") diff --git a/web/panettone/test/irc_test.lisp b/web/panettone/test/irc_test.lisp new file mode 100644 index 000000000000..0224836cbc32 --- /dev/null +++ b/web/panettone/test/irc_test.lisp @@ -0,0 +1,5 @@ +(in-package :panettone.tests) +(declaim (optimize (safety 3))) + +(test noping-test + (is (not (equal "grfn" (panettone.irc:noping "grfn"))))) diff --git a/web/panettone/test/model_test.lisp b/web/panettone/test/model_test.lisp new file mode 100644 index 000000000000..e4cd78a65a43 --- /dev/null +++ b/web/panettone/test/model_test.lisp @@ -0,0 +1,13 @@ +(in-package :panettone.tests) +(declaim (optimize (safety 3))) + +(test initialize-issue-status-test + (let ((issue (make-instance 'model:issue :status "open"))) + (is (eq :open (model:status issue))))) + +(test initialize-issue-created-at-test + (let* ((time (get-universal-time)) + (issue (make-instance 'model:issue :created-at time))) + (is (local-time:timestamp= + (local-time:universal-to-timestamp time) + (model:created-at issue))))) diff --git a/web/panettone/test/package.lisp b/web/panettone/test/package.lisp new file mode 100644 index 000000000000..d2a2f974208e --- /dev/null +++ b/web/panettone/test/package.lisp @@ -0,0 +1,3 @@ +(defpackage :panettone.tests + (:use :cl :klatre :fiveam + :panettone.inline-markdown)) diff --git a/web/panettone/test/util_test.lisp b/web/panettone/test/util_test.lisp new file mode 100644 index 000000000000..ff52d916cb3a --- /dev/null +++ b/web/panettone/test/util_test.lisp @@ -0,0 +1,9 @@ +(in-package :panettone.tests) +(declaim (optimize (safety 3))) + +(test add-missing-base64-padding-test + (is (string= + "abcdef" + (base64:base64-string-to-string + (panettone.util:add-missing-base64-padding + "YWJjZGVm"))))) |