mirror of
https://github.com/reddit-archive/reddit1.0.git
synced 2026-04-16 06:18:27 +02:00
167 lines
8.3 KiB
Common Lisp
167 lines
8.3 KiB
Common Lisp
;;;; Copyright 2018 Reddit, Inc.
|
|
;;;;
|
|
;;;; Permission is hereby granted, free of charge, to any person obtaining a copy of
|
|
;;;; this software and associated documentation files (the "Software"), to deal in
|
|
;;;; the Software without restriction, including without limitation the rights to
|
|
;;;; use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
|
|
;;;; of the Software, and to permit persons to whom the Software is furnished to do
|
|
;;;; so, subject to the following conditions:
|
|
;;;;
|
|
;;;; The above copyright notice and this permission notice shall be included in all
|
|
;;;; copies or substantial portions of the Software.
|
|
;;;;
|
|
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
|
;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
|
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
|
;;;; SOFTWARE.
|
|
|
|
(in-package :reddit)
|
|
|
|
(defun saved-panel (name)
|
|
(let ((sites (saved-sites (valid-user-p name))))
|
|
(pbox (fmt "~a's saved sites" name)
|
|
(:table
|
|
(loop for (id title url) in sites do
|
|
(htm (:tr (:td (site-link id title url)))))))))
|
|
|
|
(defun date-string (sql-date)
|
|
(destructuring-bind (year month day) (split "-" sql-date)
|
|
(format nil "~a ~a, ~a" (month-name (parse-integer month)) day year)))
|
|
|
|
(defmacro left-el (l)
|
|
`(with-html-output(*standard-output*)
|
|
(:td :nowrap t :class "profline" ,l)))
|
|
|
|
(defmacro prof-row (l r)
|
|
`(with-html-output (*standard-output*)
|
|
(:tr (left-el ,l)
|
|
(:td :style "padding-bottom: 5px" :nowrap t (esc ,r)))))
|
|
|
|
(defun me (name)
|
|
(and (logged-in-p)
|
|
(string= name (user-name (userobj)))))
|
|
|
|
(defun base-info-panel (name)
|
|
(destructuring-bind ((karma date) (total up down)) (list (basic-info name) (user-stats name))
|
|
(setf karma (or karma "0"))
|
|
(with-html-output (*standard-output*)
|
|
(:div :class "meat"
|
|
(user-heading name :basic)
|
|
(:table
|
|
(prof-row "karma:" karma)
|
|
(prof-row "member since:" (date-string date))
|
|
(when (me name)
|
|
(prof-row "email:" (or (user-email name) "not entered - see the update panel below"))))
|
|
(hbar "stats")
|
|
(:table
|
|
(prof-row "total submissions:" total)
|
|
(prof-row "sites promoted:" up)
|
|
(prof-row "sites demoted:" down))
|
|
(when (me name)
|
|
(with-accessors ((limit options-numsites)
|
|
(visible options-visible)
|
|
(promoted options-promoted)
|
|
(demoted options-demoted)
|
|
(frame options-frame)) (options)
|
|
(htm
|
|
(hbar "options")
|
|
(:table :id "options" :style "border-collapse: collapse;"
|
|
(:tr (left-el "open reddit links in a frame:")
|
|
(:td (:input :name "frame" :type "checkbox" :checked frame)))
|
|
(:tr (left-el "make my profile visible to other users:")
|
|
(:td (:input :name "vis" :type "checkbox" :checked visible)))
|
|
(:tr (left-el "show me sites I've promoted:")
|
|
(:td (:input :name "pro" :type "checkbox" :checked promoted)))
|
|
(:tr (left-el "show me sites I've demoted:")
|
|
(:td (:input :name "dem" :type "checkbox" :checked demoted)))
|
|
(:tr (left-el "number of sites to display at once:")
|
|
(:td (:select :name "limit"
|
|
(:option :selected (= limit 10) :value "10" "10")
|
|
(:option :selected (= limit 25) :value "25" "25")
|
|
(:option :selected (= limit 50) :value "50" "50")))
|
|
(:td (:input :type "submit" :class "btn" :value "save"
|
|
:onclick "options()")))
|
|
(:tr (:td :class "error" :id "optstat")))
|
|
(hbar "update")
|
|
(:table :style "border-collapse: collapse;"
|
|
(:tr (left-el "email:")
|
|
(:td (:input :id "upemail" :type "text"))
|
|
(:td (:input :type "submit" :class "btn" :value "update" :onclick "uemail()")))
|
|
(:tr (:td) (:td :colspan "2" :id "upemailerr" :class "error"))
|
|
(:tr (left-el "current password:")
|
|
(:td (:input :id "upcur" :type "password")))
|
|
(:tr (left-el "new password:")
|
|
(:td (:input :id "upnew" :type "password")))
|
|
(:tr (left-el "verify password:")
|
|
(:td (:input :id "upver" :type "password"))
|
|
(:td (:input :type "submit" :class "btn" :value "update" :onclick "upass()")))
|
|
(:tr (:td) (:td :colspan "2" :id "uppasserr" :class "error"))))))))))
|
|
|
|
(defun user-menu (username)
|
|
(let ((prefix (conc "/user/" username)))
|
|
(mapcar #'(lambda (name)
|
|
(list (intern (string-upcase name) :keyword) name (conc prefix "/" name)))
|
|
(cond
|
|
((me username) '("basic" "submitted" "hidden" "promoted" "demoted"))
|
|
((profile-visible (valid-user-p username)) '("basic" "saved" "submitted" "hidden" "promoted" "demoted"))
|
|
(t '("basic" "submitted"))))))
|
|
|
|
(defun user-heading (user &optional selected)
|
|
(with-html-output (*standard-output*)
|
|
(let ((menu (user-menu user)))
|
|
(htm
|
|
(:div :id "usermenu" (:span :class "username" (esc user))
|
|
(loop for (sym title url) in menu do
|
|
(htm
|
|
(:a :class (when (eql sym selected) "sel-user")
|
|
:href url
|
|
(esc title)))))))))
|
|
|
|
(defun right-panel-user (user page)
|
|
(with-html-output (*standard-output*)
|
|
(unless (logged-in-p) (login-panel))))
|
|
|
|
(defun profile-site-table (profid display)
|
|
(with-parameters ((offset "offset"))
|
|
(setf offset (or (sanitize offset 'int) 0))
|
|
(multiple-value-bind (articles nextoff)
|
|
(get-sites-profile (uid) profid (options-numsites (options)) offset display)
|
|
(site-table articles (options-numsites (options)) offset
|
|
nextoff (and (eql display :saved)
|
|
(logged-in-p)
|
|
(= (uid) profid))
|
|
(eql display :hidden)))))
|
|
|
|
|
|
(defun profile-page (name display)
|
|
(with-html-output (*standard-output*)
|
|
(:div :class "meat"
|
|
(if (or (profile-visible (valid-user-p name)) (eql display :submitted) (me name))
|
|
(htm
|
|
(user-heading name display)
|
|
(profile-site-table (valid-user-p name) display))
|
|
(htm (:span :class "error" "this page of the user's profile is not public"))))))
|
|
|
|
(defun user-panel (user page &optional me)
|
|
(case page
|
|
(:submitted (profile-page user :submitted))
|
|
(:promoted (profile-page user :promoted))
|
|
(:demoted (profile-page user :demoted))
|
|
(:saved (profile-page user :saved))
|
|
(:hidden (profile-page user :hidden))
|
|
(t (base-info-panel user))))
|
|
|
|
(defun page-user ()
|
|
(multiple-value-bind (user page) (decode-user-url (script-name))
|
|
(let ((user (valid-user-p user :return-sn t)))
|
|
(if user
|
|
(let ((page (sanitize page 'sym '(:basic :saved :promoted :submitted :hidden :demoted))))
|
|
(reddit-page (:menu (top-menu (browse-menu))
|
|
:right-panel (right-panel-user user page))
|
|
(user-panel user page (and (logged-in-p) (string= (user-name (userobj)) user)))))
|
|
(reddit-page ()
|
|
(:span :class "error" "That user does not exist"))))))
|