path: root/web/panettone/src/panettone.lisp

(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))

;;;
;;; Responses
;;;

(defun request-format ()
  "Returns the content type requested by the current hunchentoot request as a
symbol equal to either `:html' or `:json', defaulting to `:html' if not
specified."
  (eswitch ((hunchentoot:header-in* :accept) :test #'equal)
    ("application/json" :json)
    ("text/html" :html)
    ("*/*" :html)))

(defun format->mime (format)
  (ecase format
    (:json "application/json")
    (:html "text/html")))

(defmacro format-case (&rest clauses)
  "Execute the cdr of the element in CLAUSES whose car is equal to the current
request format, a symbol that can be either `:JSON' or `:HTML'"
  (let ((format (gensym "format")))
    `(let ((,format (request-format)))
       (setf (hunchentoot:content-type*) (format->mime ,format))
       (case ,format ,@clauses))))

(defmethod encode-json ((ts local-time:timestamp)
                        &optional (stream json:*json-output*))
  (encode-json (local-time:format-rfc3339-timestring
                nil ts)
               stream))

;;;
;;; Views
;;;

(defvar *title* "Panettone")
(setf (who:html-mode) :html5)

(defun render/nav ()
  (who:with-html-output (*standard-output*)
    (:nav
     (if (find (car (split "\\?" (hunchentoot:request-uri*) :limit 2))
               (list "/" "/issues/closed")
               :test #'string=)
         (who:htm (:span :class "placeholder"))
         (who:htm (:a :href "/" "All Issues")))
     (if *user*
         (who:htm
          (:div :class "nav-group"
           (:a :href "/settings" "Settings")
           (:form :class "form-link log-out"
                  :method "post"
                  :action "/logout"
                  (:input :type "submit" :value "Log Out"))))
         (who:htm
          (:a :href
              (format nil
                      "/login?original-uri=~A"
                      (drakma:url-encode (hunchentoot:request-uri*)
                                         :utf-8))
              "Log In"))))))

(defun author (object)
  (find-user-by-dn (author-dn object)))

(defun displayname-if-known (user)
  (or (when user (displayname user))
      "unknown"))

(defmacro render ((&key
                     (footer t)
                     (header t))
                  &body body)
  `(who:with-html-output-to-string (*standard-output* nil :prologue t)
     (:html
      :lang "en"
      (:head
       (:title (who:esc *title*))
       (:link :rel "stylesheet" :type "text/css" :href "/main.css")
       (:meta :name "viewport"
              :content "width=device-width,initial-scale=1"))
      (:body
       (:div
        :class "content"
        (when ,header
          (who:htm
           (render/nav)))
        ,@body
        (when ,footer
          (who:htm
           (:footer
            (render/nav)))))))))

(defun form-button (&key
                      class
                      input-class
                      href
                      label
                      (method "post"))
  (who:with-html-output (*standard-output*)
    (:form :class class
           :method method
           :action href
           (:input :type "submit"
                   :class input-class
                   :value label))))

(defun render/alert (message)
  "Render an alert box for MESSAGE, if non-null"
  (check-type message (or null string))
  (who:with-html-output (*standard-output*)
    (when message
      (who:htm (:div :class "alert" (who:esc message))))))

(defun render/login (&key message (original-uri "/"))
  (render (:footer nil :header nil)
    (:div
     :class "login-form"
     (:header
      (:h1 "Login"))
     (:main
      :class "login-form"
      (render/alert message)
      (:form
       :method :post :action "/login"
       (:input :type "hidden" :name "original-uri"
               :value (who:escape-string original-uri))
       (:div
        (:label :for "username"
                "Username")
        (:input :type "text"
                :name "username"
                :id "username"
                :placeholder "username"))
       (:div
        (:label :for "password"
                "Password")
        (:input :type "password"
                :name "password"
                :id "password"
                :placeholder "password"))
       (:input :type "submit"
               :value "Submit"))))))

(defun render/settings ()
  (let ((settings (model:settings-for-user (dn *user*))))
    (render ()
      (:div
       :class "settings-page"
       (:header
        (:h1 "Settings"))
       (:form
        :method :post :action "/settings"
        (:div
         (:label :class "checkbox"
          (:input :type "checkbox"
                  :name "enable-email-notifications"
                  :id "enable-email-notifications"
                  :checked (model:enable-email-notifications-p
                            settings))
          "Enable Email Notifications"))
        (:div :class "form-group"
         (:input :type "submit"
                 :value "Save Settings")))))))

(defun created-by-at (issue)
  (check-type issue model:issue)
  (who:with-html-output (*standard-output*)
    (:span :class "created-by-at"
           "Opened by "
           (:span :class "username"
                  (who:esc (displayname-if-known
                             (author issue))))
           " at "
           (:span :class "timestamp"
                  (who:esc
                   (format-dottime (created-at issue)))))))

(defun render/issue-list (&key issues)
  (who:with-html-output (*standard-output*)
    (:ol
     :class "issue-list"
     (dolist (issue issues)
       (let ((issue-id (model:id issue)))
         (who:htm
          (:li
           (:a :href (format nil "/issues/~A" issue-id)
               (:p
                (:span :class "issue-subject"
                       (render-inline-markdown (subject issue))))
               (:span :class "issue-number"
                      (who:esc (format nil "#~A" issue-id)))
               " - "
               (created-by-at issue)
               (let ((num-comments (length (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))))
    (who:with-html-output (*standard-output*)
      (:li
       :class "event"
       :id
       (who:esc (displayname-if-known 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))
            "\""))
       " 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 (issue-comments issue))
              (events (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))))))))))

(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*))
    (model:make-thread
     (lambda ()
       (dolist (user-dn (model:issue-subscribers issue-id))
         (when (not (equal (dn current-user) user-dn))
           (email:notify-user
            user-dn
            :subject subject
            :message message)))))))

(defun link-to-issue (issue-id)
  (format nil "https://b.tvl.fyi/issues/~A" issue-id))

(defun @auth-optional (next)
  (let ((*user* (hunchentoot:session-value 'user)))
    (funcall next)))

(defun @auth (next)
  (if-let ((*user* (hunchentoot:session-value 'user)))
    (funcall next)
    (hunchentoot:redirect
     (format nil "/login?original-uri=~A"
             (drakma:url-encode
              (hunchentoot:request-uri*)
              :utf-8)))))

(defun @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 @handle-issue-not-found (next)
  (handler-case (funcall next)
    (model:issue-not-found (err)
      (render/not-found
       (format nil "Issue #~A" (model:id err))))))

(defroute login-form ("/login" :method :get)
    (original-uri)
  (if (hunchentoot:session-value 'user)
      (hunchentoot:redirect (or original-uri "/"))
      (render/login :original-uri original-uri)))

(defroute submit-login ("/login" :method :post)
    (&post original-uri username password)
  (if-let ((user (authenticate-user username password)))
    (progn
      (setf (hunchentoot:session-value 'user) user)
      (hunchentoot:redirect (or original-uri "/")))
    (render/login :message "Invalid credentials"
                  :original-uri original-uri)))

(defroute logout ("/logout" :method :post) ()
  (hunchentoot:delete-session-value 'user)
  (hunchentoot:redirect "/"))

(defroute index ("/" :decorators (@auth-optional)) ()
  (let ((issues (model:list-issues :status :open)))
    (format-case
     (:html (render/index :issues issues))
     (:json (encode-json-to-string issues)))))

(defroute settings ("/settings" :method :get :decorators (@auth)) ()
  (render/settings))

(defroute save-settings ("/settings" :method :post :decorators (@auth))
    (&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)))

(defroute new-issue ("/issues/new" :decorators (@auth)) ()
  (render/issue-form))

(defroute handle-create-issue
    ("/issues" :method :post :decorators (@auth @txn))
    (&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-dev"))
        (hunchentoot:redirect "/"))))

(defroute show-issue
    ("/issues/:id" :decorators (@auth-optional @handle-issue-not-found))
    (&path (id 'integer))
  (let* ((issue (model:get-issue id))
         (*title* (format nil "~A | Panettone"
                          (subject issue))))
    (format-case
     (:html (render/issue issue))
     (:json (encode-json-to-string issue)))))

(defroute edit-issue
    ("/issues/:id/edit" :decorators (@auth @handle-issue-not-found))
    (&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)
                   ;; 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 @txn)
     :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 @txn)
                         :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-dev"))
    (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)
                        :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-dev"))
    (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"
  (model:ddl/init))

(defun start-panettone (&key port
                          (ldap-host "localhost")
                          (ldap-port 389)
                          postgres-params
                          session-secret)
  (connect-ldap :host ldap-host
                :port ldap-port)

  (apply #'model:connect-postgres postgres-params)
  (migrate-db)

  (when session-secret
    (setq hunchentoot:*session-secret* session-secret))

  (setq hunchentoot:*session-max-time* (* 60 60 24 90))

  (setq *acceptor*
        (make-instance 'easy-routes:routes-acceptor :port port))
  (hunchentoot:start *acceptor*))

(defun main ()
  (let ((port (integer-env "PANETTONE_PORT" :default 6161))
        (ldap-port (integer-env "LDAP_PORT" :default 389))
        (cheddar-url (uiop:getenvp "CHEDDAR_URL"))
        (session-secret (uiop:getenvp "SESSION_SECRET")))
    (when cheddar-url (setq *cheddar-url* cheddar-url))
    (setq hunchentoot:*show-lisp-backtraces-p* nil)
    (setq hunchentoot:*log-lisp-backtraces-p* nil)

    (start-panettone :port port
                     :ldap-port ldap-port
                     :session-secret session-secret)

    (sb-thread:join-thread
     (find-if (lambda (th)
                (string= (sb-thread:thread-name th)
                         (format nil "hunchentoot-listener-*:~A" port)))
              (sb-thread:list-all-threads)))))

(comment
 (setq hunchentoot:*catch-errors-p* nil)
 ;; to setup an ssh tunnel to ldap+cheddar+irccat for development:
 ;; ssh -NL 3899:localhost:389 -L 4238:localhost:4238 -L 4722:localhost:4722 whitby.tvl.fyi
 (start-panettone :port 6161
                  :ldap-port 3899
                  :session-secret "session-secret")
 )