web.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)

(defparameter *num-submitters* 8)
(defparameter *SESSION-MAX-TIME* 86400)
(defparameter *default-site-num* 25)
(defparameter *default-handler* 'default-handler)
(defparameter *recent-size* 5)

(defparameter *default-options* (make-instance 'options :numsites 25))

(defparameter *docklet-link* "javascript:location.href=\"http://reddit.com/submit?url=\"+encodeURIComponent(location.href)+\"&title=\"+encodeURIComponent(document.title)")
(defparameter *docklet-onclick* "window.alert(\"Drag this link to your toolbar or right-click and choose Add to Favorites.\"); return false")

(defparameter *rewrite-for-session-urls* nil)

(defmacro with-html (&body body)
  `(with-html-output-to-string (*standard-output* nil :prologue t :indent nil)
     ,@body))

;;TODO fix multiple eval of params
(defmacro with-parameters (params &body body)
  `(let (,@(mapcar  (lambda (x) `(,(first x) (or (post-parameter ,(second x))
                                                 (get-parameter ,(second x))))) params))
     ,@body))

(defparameter *callbacks* (make-hash-table :test 'equal))

(defmacro define-callback (name args &body body)
  `(setf (gethash ,(string-downcase (string name)) *callbacks*)
         (lambda ()
           (let (,@(mapcar (lambda (x) `(,x (or (post-parameter ,(string-downcase (string x)))
                                                (get-parameter ,(string-downcase (string x))))))
                           args))
             ,@body))))

(defmacro pbox (name &body body)
  `(with-html-output (*standard-output*)
     (:div :class "pboxwrap"
           (:table :class "pbox"
                   (:tr (:td :nowrap t :class "pboxhead" ,name))
                   (:tr (:td :class "pboxbody" ,@body))))))

(defmacro hbar (text)
  `(with-html-output (*standard-output*)
     (:div :class "headbar" (:span :style "font-weight: bold;"  (esc ,text)))))

(defmacro prof-head (head)
  `(with-html-output (*standard-output*)
     (:tr (:td :nowrap t :colspan "3" :class "headbar" (:h1 :class "nomargin" ,head)))))

(defun check-parameters ()
  (with-parameters ((action "action"))
    (when-bind (fn (gethash action *callbacks*))
      (funcall fn))))

(defun ajax-op ()
  (with-parameters ((action "action"))
    (when-bind (fn (gethash action *callbacks*))
      (funcall fn))))

(defun set-session-cookie (iden &optional mem)
  (log-message* "set cookie to: ~a" iden)
  (set-cookie "reddit-session" :value iden
              :path "/"
              :expires (when mem (2weeks))))

(defun reset-session-cookies ()
  (set-cookie "mod" :path "/" :value "")
  (set-cookie "click" :path "/" :value "")
  (set-cookie "hide" :path "/" :value ""))

(defun check-cookies ()
  "Create a new session. Check for an existing session cookie,
  create one if it doesn't exists."
  (start-session)
  ;;see if the user has a previous session
  (with-web-db
    (let ((session-iden (cookie-in "reddit-session")))
      (when (and session-iden
                 (not (string= session-iden ""))
                 (not (session-value :user-id)))
        (log-message* "cookies is: ~a" session-iden)
        (when-bind (id (valid-cookie session-iden))
          (setf (session-value :user-id) id))))
    (reset-session-cookies)
    ;;user data needs to be reloaded because of karma change
    ;;options needs to be reloaded because the user options
    ;;object isn't updated when the options change
    (if (uid)
        (with-accessors ((userobj user-obj)
                         (options user-options)) (info)
          (update-instance-from-records userobj)
          (update-instance-from-records options)))))
  
(defun uid ()
  (and (ignore-errors *session*)
       (session-value :user-id)))

(defun info ()
  (get-info (uid)))

(defun logged-in-p ()
  (uid))

(defun options ()
  (or (when-bind (info (info))
        (user-options info))
      *default-options*))
  
(defun userobj ()
  (when-bind (info (info))
    (user-obj info)))

(defmacro with-main ((&key (menu "empty") (right-panel) (rss-url)) &body body)
  `(with-html
     (:html 
      (:head 
       (:meta :http-equiv "Content-Type" :content "text/html; charset=UTF-8")
       (:title "reddit - what's new online")
       (:script :src "/static/prototype.js" :language "javascript" :type "text/javascript" "")
       (:script :language "javascript" (str (if (logged-in-p) "var logged = true" "var logged= false")))
       (:script :src "/static/logic.js" :language "javascript" :type "text/javascript" "")
       (:link :rel "stylesheet" :href "/static/styles.css" :type "text/css")
       (:link :rel "shortcut icon" :href "/static/favicon.ico")
       (when ,rss-url
         (htm (:link :rel "alternate" :type "application/rss+xml" :title "RSS" :href ,rss-url))))
      ;;(htm (:link :rel "alternate" :type "text/xml" :title "RSS" :href ,rss-url))))
      (:body
       (:table :id "topbar" :cellpadding "0"
               (:tr 
                (:td :rowspan "2" (:a :href "/"  (:img :style "vertical-align: bottom; border: 0" :src "/static/redditheader.gif")))
                (:td :colspan "2" :width "100%" :class "topmenu menu" (menu-panel)))
               (:tr (:td :valign "bottom" :width "100%" (:div :id "topstrip" ,menu))
                    (:td :valign "bottom" :nowrap t (search-area))))
       (:div :id "right" ,right-panel)
       (:div :id "main" ,@body)
       (when ,rss-url
         (htm
          (:div :id "footer" (str "A") (:a :class "feed" :href ,rss-url "FEED") (str "is available."))))))))

(defmacro reddit-page ((&key (cache-key nil) (exp 0) (menu "empty") require-login right-panel rss-url) &body body)
  (let ((ck (gensym)))
    `(progn
       (check-cookies)
       (check-parameters)
       (let ((,ck ,cache-key))
         (if (and ,require-login
                  (not (logged-in-p)))
             (with-main (:menu ,menu :right-panel ,right-panel :rss-url ,rss-url)
               (:p :class "error" "please log in before continuing"))
             (if ,ck
                 (cached (,ck ,exp) (with-main (:menu ,menu :right-panel ,right-panel :rss-url ,rss-url) ,@body))
                 (with-main (:menu ,menu :right-panel ,right-panel :rss-url ,rss-url) ,@body)))))))

(defmacro idstr (name)
  `(format nil ,(conc name "~a") id))

(defun redirect-url (url)
  (setf (header-out "Location")
        url
        (return-code *reply*)
        +http-moved-permanently+)
  (throw 'tbnl-handler-done nil))

(defun user-link (name)
  (with-html-output (*standard-output*)
    (:a :href (conc "/user/" name) (esc name))))

(defun search-area ()
  (with-parameters ((query "q"))
    (with-html-output (*standard-output*)
      (:form :class "nomargin" :style "margin-left: 10px" :action "/search" :method "GET"
             (:input :class "txt" :style "vertical-align: bottom" :type "text" :name "q" :value (str (esc-quote query)))
             (:button :class "btn" :type "submit" "search")))))

(define-callback submit (id url title fuser save to message)
  (let ((id (or (sanitize id 'int)
                (article-id-from-url url))))
    (with-web-db
      ;;submit
      (when (and url title (not id))
        (when-bind (article (insert-article title url (uid) (session-remote-addr *session*) fuser))
          (log-message* "SUBMITTED: ~a" (article-title article))
          (when (and save (info))
            (setf (user-saved (info) (article-id article)) t)
            (save-site (uid) (article-id article)))
          (setf (user-liked (info) (article-id article)) :like)
          (ac-update *cached-new*)
          (setf id (article-id article)
                (session-value :submitted) t)))
      ;;recommend
      (when (and id (> (length to) 0))
        (when-bind* ((info (get-info (uid)))
                     (to (decode-aliases to info))
                     (email (user-emai (userobj)))) 
          (log-message* "EMAIL: ~a" to)
          (send-recommendation (uid) id (session-remote-addr *session*) to email
                               (and (> (length message) 0) (shorten-str message 500)))
          (setf (session-value :sent) t))))))

(defun login (user pass &optional mem)
  (with-web-db 
    (when-bind (id (valid-login-p user pass))
      (setf (session-value :user-id) id)
      (set-session-cookie (cookie-str user pass) mem)
      id)))

(define-callback register (user pass mem)
  (with-web-db
    (with-html-output (*standard-output*)
      (and user pass
           (let ((userid (valid-user-p user)))
             (if (and userid (not (fake-user-p user)))
                 (format nil "baduser")
                 (progn
                   (log-message* "REGISTER: ~a" user)
                   (add-user user nil pass (and *session* (session-remote-addr *session*)))
                   (login user pass mem)
                   (htm (format nil "~a (~a)" (user-name (userobj)) (user-karma (userobj)))))))))))


(define-callback login (user pass mem)
  (with-html-output (*standard-output*)
    (if (login user pass mem)
        (htm (format nil "~a (~a)" (user-name (userobj)) (user-karma (userobj))))
        (htm (str "invalid")))))

(define-callback logout ()
  (with-html
    (log-message* "LOGOUT: ~a" (uid))
    (remove-info (uid))
    (setf (session-value :user-id) nil)
    (set-session-cookie nil)))


(define-callback options (pro dem vis limit frame)
  (with-web-db
    (let ((options (options)))
      (with-accessors ((v options-visible)
                       (p options-promoted)
                       (d options-demoted)
                       (n options-numsites)
                       (u options-userid)
                       (f options-frame)) options
        (setf v (not (null vis))
              p (not (null pro))
              d (not (null dem))
              n (sanitize limit 'int)
              u (uid)
              f (not (null frame)))
        (update-records-from-instance options)))))

(define-callback frame (frame)
  (with-web-db
    (ignore-errors
      (when-bind (options (options))
        (setf (options-frame options) (not (null frame)))
        (update-records-from-instance options)))))

(define-callback sendpass (email)
  (with-web-db
    (let ((info (login-from-email email)))
      (when info
        (send-login-info email (first info) (second info))))))

(defun options-panel ()
  (let ((options (session-value :display-opts)))
    (pbox "display"
      (:form :method "get" :action (script-name) :class "nomargin"
             (:input :type "hidden" :name "action" :value "options")
             (:table :style "border-collapse: collapse: cell-padding-top: 3px;" :width "100%"
                     (when (logged-in-p)
                       (htm
                        (:tr (:td (:input :class "check" :type "checkbox" :name "pro" :checked (first options)))
                             (:td :nowrap t "promoted sites"))
                        (:tr (:td (:input :class "check" :type "checkbox" :name "dem" :checked (second options)))
                             (:td :nowrap t "demoted sites"))
                        (:tr (:td (:input :class "check" :type "checkbox" :name "hidden" :checked (third options)))
                             (:td :nowrap t "hidden sites"))))
                     (:tr (:td (:input :class "check" :type "checkbox" :name "24hrs" :checked (fourth options)))
                          (:td :nowrap t "from today"))
                     (:tr (:td :colspan "2" (:select :name "limit"
                                                     (:option :selected (eql (fifth options) 10) :value "10" "10")
                                                     (:option :selected (eql (fifth options) 25) :value "25" "25")
                                                     (:option :selected (eql (fifth options) 50) :value "50" "50")) " sites"))
                     (:tr (:td :colspan "2" :align "center" (:input :class "btn" :type "submit" :value "Apply"))))))))

(defun login-panel ()
  (pbox "login/register"
    (:form :id "logform" :class "nomargin"
           (:table :style "border-collapse: collapse"
                   (:tr (:td :colspan "2"  "username:"))
                   (:tr (:td :colspan "2" (:input :id "loguser" :class "txt" :name "user" :type "text" :size 15)))
                   (:tr (:td :colspan "2" "password:"))
                   (:tr (:td :colspan "2" (:input :id "logpass" :class "txt" :name "pass" :type "password" :size 15)))
                   (:tr (:td :colspan "2" (:input :id "logmem" :type "checkbox" :name "mem" "remember me")))
                   (:tr (:td :colspan "2" (:span :id "logerror" :class "error" "")))
                   (:tr (:td (:input :id "logbtn" :class "btn" :type "submit" :value "Login" :onclick "login(); return false"))
                        (:td (:input :class "btn" :type "submit" :value "Register" :onclick "register(); return false")))
                   (:tr (:td :nowrap t :colspan "2" :align "center" :class "little" (:a :href "/password" "what's my password?")))))))


(defun right-panel-main ()
  (with-html-output (*standard-output*)
    (unless (logged-in-p) (login-panel))))

(define-callback uemail (email)
  (with-web-db
    (with-html-output (*standard-output*)
      (if (user-from-email email)
          (htm (format nil "inuse"))
          (progn
            (let ((user (userobj)))
              (setf (user-emai user) email)
              (update-records-from-instance user)))))))

(define-callback upass (oldpass newpass)
  (with-web-db
    (with-html-output (*standard-output*)
      (when (change-password (uid) oldpass newpass)
        (htm (format nil "update"))))))

(define-callback delete (id)
  (with-web-db
    (with-html-output-to-string (*standard-output* nil)
      (remove-article (uid) id))))

(define-callback close (id)
  (with-web-db
    (with-html-output-to-string (*standard-output* nil)
      (when-bind* ((id (sanitize id 'int))
                   (info (info)))
        (if (user-closed info id)
            (progn
              (setf (user-closed info id) nil)
              (unclose-site-sql (uid) id))
            (progn
              (setf (user-closed info id) t)
              (close-site-sql (uid) id)))))))

(define-callback mod (id dir)
  (let ((id (sanitize id 'int))
        (dir (sanitize dir 'int)))
    (when-bind (info (info))
      (if (zerop dir)
          (progn
            (setf (user-liked info id) nil)
            (unlike-and-mod (uid) id (session-remote-addr *session*)))
          (progn
            (setf (user-liked info id) (if (plusp dir) :like :dislike))
            (like-and-mod (uid) id (plusp dir) (session-remote-addr *session*)))))))
   
(define-callback save (id)
  (with-web-db
    (when-bind* ((id (sanitize id 'int))
                 (info (info)))
      (unless (user-saved info id)
        (setf (user-saved info id) t)
        (save-site (uid) id)))))

(define-callback unsave (id)
  (with-web-db
    (when-bind (info (info))
      (setf (user-saved info id) nil)
      (unsave-site (uid) (sanitize id 'int)))))

(define-callback checkurl (url)
  (let ((at (check-url url)))
    (with-html-output-to-string (*standard-output* nil)
      (when at (str at)))))

(define-callback ualias (name val)
  (with-web-db
    (when-bind (info (info))
      (if val
          (progn
            (setf (user-alias info name) val)
            (set-alias (uid) name val))
          (progn
            (remhash name (user-info-alias info))
            (remove-alias (uid) name))))))

(defun site-link (id title url &optional clicked)
  (with-html-output (*standard-output*)
    (:a :id (idstr "title") :class (if clicked "title click" "title norm")
        :href url
        :onmousedown (makestr "return rwt(this," id ")") 
        :onrightclick (makestr "return rwt(this," id ")") 
        (str (escape-string-minimal title)))
    (:span :class "little" (fmt " (~a)" (tl-domain url)))))

(defun save-link (id saved)
  (with-html-output (*standard-output*)
    (if saved
        (htm (:a :class "bylink" :href (format nil "javascript:unsave(~a)" id) "unsave"))
        (htm (:a :class "bylink" :href (format nil "javascript:save(~a)" id) "save")))))

(defun hide-link (id closed)
  (with-html-output (*standard-output*)
    (if closed
        (htm (:a :class "bylink" :href (format nil "javascript:hideSite(~a)" id)  "unhide"))
        (htm (:a :class "bylink" :href (format nil "javascript:hideSite(~a)" id) "hide")))))

(defun print-articles (articles &optional (offset 0) savepage draw-close (draw-number t) (draw-share t))
  (with-html-output (*standard-output*)
    (loop for article in articles
       for x = (1+ offset) then (1+ x) do
       (with-accessors ((id article-id)
                        (title article-title)
                        (url article-url)
                        (pop article-pop)
                        (date article-date)
                        (subid article-submitterid)
                        (sn article-sn)) article
         (let* ((info (info))
                (clicked (and info (user-clicked info id)))
                (mod (and info (user-liked info id)))
                (closed (and info (user-closed info id)))
                (saved (and info (user-saved info id))))
           (htm 
            (:tr :id (idstr "site")
                 (if draw-number
                     (htm 
                      (:td :valign "top" :class "numbercol" :rowspan "2" (fmt "~a." x)))
                     (htm (:td :rowspan "2")))
                 (:td :valign "top" :rowspan "3" (button-area mod id))
                 (:td :colspan "2" :id (idstr "titlerow")
                      :class "evenRow" (site-link id title url clicked)))
            (:tr
             (:td :valign "top" :class "wide little"
                  (:span :id (idstr "score") (fmt "~a point~:p" (or pop 0)))
                  (htm (fmt " posted ~a ago by " (age-str date)))
                  (user-link sn)
                  (fmt " ")
                  (when (logged-in-p)
                    (when (or savepage (not saved))
                      (htm (:span :id (idstr "save") (save-link id saved))))
                    (when draw-share
                      (htm (:a :href (makestr "/share?id=" id) :class "bylink" "share")))
                    (when draw-close (hide-link id closed))
                    (when (= subid (uid))
                      (htm (:span :id (idstr "delete")
                                  (:a
                                   :href (format nil "javascript:deleteSite(~a)" id)
                                   :class "bylink"
                                   "delete")))))))
            (:tr (:td :colspan "5" :class "spacing"))))))))

(defun expand-button (id)
  (with-html-output (*standard-output*)
    (:div :id (idstr "ex") :class "expand" :onclick (format nil "expand(~a)" id))))

(defun button-area (mod id)
  (with-html-output (*standard-output* nil)
    (:div :id (idstr "up")
          :class (if (eq mod :like) "arrow upmod" "arrow up")
          :onclick (makestr "javascript:mod("id", 1)") " ")
    (:div :id (idstr "down")
          :class (if (eq mod :dislike) "arrow downmod" "arrow down")
          :onclick (makestr "javascript:mod("id", 0)"))))

(defun site-table (articles limit offset nextoff &optional savepage draw-closed searchpage)
  (with-html-output (*standard-output* nil :indent t)
    (if articles
        (htm
         (:table :id "siteTable" ;;:border "1"
                 (print-articles articles offset savepage draw-closed)
                 (when (eql (length articles) limit)
                   (let ((params (if searchpage
                                     `(("offset" . ,nextoff)
                                       ("q" . ,(get-parameter "q")))
                                     `(("offset" . ,nextoff)))))
                     (htm
                      (:tr (:td :colspan "4" (:a :href (create-url (script-name) params)
                                                 "View More"))))))))
        (htm (:span :class "error" "There are no sites that match your request")))))

(defun front-page-site-table (sort)
  (with-web-db
    (with-parameters ((offset "offset"))
      (setf offset (or (sanitize offset 'int) 0))
      (multiple-value-bind (articles nextoff)
          (get-sites-user (uid) (options-numsites (options)) offset sort)
        (site-table articles (options-numsites (options)) offset nextoff nil t)))))

(defun search-site-table ()
  (with-parameters ((offset "offset")
                    (query "q"))
    (setf offset (or (sanitize offset 'int) 0))
    (with-web-db
      (multiple-value-bind (articles nextoff)
          (get-search-sites (uid) query (options-numsites (options)) offset)
        (site-table articles (options-numsites (options)) offset nextoff nil nil t)))))

(defun page-search ()
  (with-web-db
    (reddit-page (:menu (top-menu (browse-menu)) :right-panel (right-panel-main))
      (search-site-table))))
               
(defun draw-boxes (pop growth)
  (with-html-output (*standard-output* nil :indent t)
    (:table :class "popbox" (:tr (:td :class "poppop" :width  pop)
                                 (:td :class "popgrowth" :width  growth)))))

(defun page-password ()
  (reddit-page (:menu (top-menu (browse-menu))
                      :right-panel (unless (logged-in-p) (login-panel)))
    (:h2 "what's my password?")
    (:p "enter your email below to receive your login information")
    (:span :class "error" :id "status" "")
    (:form :id "passform"
           (:table
            (:tr (:td "email:") 
                 (:td (:input :type "text" :id "email"))
                 (:td (:input :type "submit" :class "btn" :value "email me"
                              :onclick "sendpass(); return false")))))))

(defun menu-panel ()
  (with-html-output (*standard-output*)
    (if (logged-in-p)
        (htm          
         (format t "~a (~a) |" (user-name (userobj)) (user-karma (userobj)))
         (:a :href (conc "/user/" (user-name (userobj))) "profile") (str "|"))
        (htm
         (str "want to join? register in seconds |")))
    (:a :href "/submit" "submit") (str "|")
    (:a :href "/help/help.html" "faq") (str "|")
    (:a :href "/blog/index.html" "blog") (str "|")
    (:a :href "mailto:feedback@reddit.com" "feedback")
    (when (logged-in-p)
      (htm (str "|") (:a :href "javascript:logout()" "logout")))))

(defun top-menu (menu &optional selected)
  (with-html-output (*standard-output*)
    (loop for (sym title url) in menu do
         (htm
          (:a :class (if (eql sym selected)
                         "sel-menu-item"
                         "menu-item")
              :href url
              (esc title))))))

(defun browse-menu ()
  (let ((default '((:front "hottest" "/hot")
                   (:new "newest" "/new")
                   (:pop "top all-time" "/pop")
                   (:topsub "top submitters" "/topsub"))))
    (if (logged-in-p)
        (append default '((:saved "saved" "/saved")))
        default)))

(defun contacts-table ()
  (with-html-output (*standard-output*)
    (:table
     :id "contactlst"
     (let ((aliases (user-info-alias (info))))
       (if aliases
           (maphash #'(lambda (name val)
                        (htm
                         (:tr (:td (:a :style "font-size: normal; color: #336699"
                                       :href "#" :onclick "sendrow(this); return false" "add"))
                              (:td (esc name)) (:td :width "100%" (esc val))
                              (:td (:a :href "#" :onclick "editrow(this); return false" "edit"))
                              (:td (:a :href "#" :onclick "removerow(this); return false" "delete")))))
                    aliases)
           "")))))
           
(defun bottom-submit ()
  (with-html-output (*standard-output*)
    (:div :id "sharetoggle" :class "menu collapse r" (:a :id "sharelink" :href "javascript:shareon()" "share"))
    (:div :id "share" :style "display: none"
          (:table
           (:tr
            (:td :align "right" "from")
            (:td (let ((email (user-emai (userobj))))
                   (if email
                       (htm (:span :id "email" :class "gray" (esc email)))
                       (htm (:span :class "error" "you will not be able to send email until you set your own email address by clicking the profile link at the top of the page"))))))
           (:tr 
            (:td :align "right" "to")
            (:td (:input :type "text" :id "to" :name "to" :size 60)))
           (:tr 
            (:td) (:td :id "contoggle" :class "menu collapse r" (:a :id "conlink" :href "javascript:contactson()" "contacts")))
           (:tr :id "contacts" :style "display: none"
                (:td)
                (:td (contacts-table)
                     (:span :class "menu" (:a :href "javascript:addrow()" "add contact"))))
           (:tr 
            (:td :valign "top" :align "right" "message")
            (:td (:textarea :id "personal" :name "message" :rows "2" :cols "60" "")))))
    (:div :style "margin: 10px 0 20px 0"
          (:button :class "btn" :type "submit" "send")
          (:span :id "status" :class "error" ""))
    (:span :class "menu" "submit and share links faster with the " (:a :href "/help/docklet.html" "spreddit docklet"))))

(defun page-submit ()
  (with-parameters ((id "id") (url "url") (title "title"))
    (reddit-page (:menu (top-menu (browse-menu)) :require-login t :right-panel (right-panel-main))
      (let ((id (or (sanitize id 'int)
                    (article-id-from-url url))))
        (htm
         (:script :src "/static/contacts.js" :language "javascript" :type "text/javascript" "")
         (:form
          :onsubmit "return chksub()" :action (script-name) :method "post" :class "meat"
          (:input :type "hidden" :name "action" :value "submit")
          (:input :type "hidden" :name "id" :value id)
          (let ((article (get-article-sn id)))
            (cond
              ;;invalid id
              ((and id (not article))
               (htm (:span :class "error" "that site does not exist")))
              ;;valid id - share
              (article
               (htm 
                (:h1 "share")
                (:span :class "error"
                       (str
                        (cond ((session-value :submitted)
                               (setf (session-value :submitted) nil)
                               "your submission was successful")
                              (url
                               "this site has already been submitted")
                              (t ""))))
                (when (session-value :sent)
                  (htm (:br) (:span :class "error" "your recommendations have been delivered"))
                  (setf (session-value :sent) nil))
                (:table
                 (print-articles (list article) 0 nil nil nil nil)))
               (bottom-submit))
              ;;no id - submit   page
              (t
               (htm
                (:h1 "submit")
                (:div :id "wtf"
                      (:table
                       (:tr (:td :align "right" "url")
                            (:td (:input :id "url" :name "url" :type "text" :value url :size 60))
                            (:td :id "urlerr" :class "error"))
                       (:tr (:td :align "right" "title")
                            (:td (:input :id "title" :name "title" :style (unless title "color: gray")
                                         :value (if title (esc-quote title) "Enter a title, or click submit to find one automatically.")
                                         :onfocus (unless title "clearTitle(this)") :type "text" :size 60))
                            (:td :id "titleerr" :class "error"))
                       (:tr (:td) (:td (:input :id "save" :name "save" :type "checkbox") "add to my saved sites")))))
               (bottom-submit))))))))))

(defun use-frame ()
  (and (uid)
       (ignore-errors
         (options-frame (options)))))
      
(defun load-link (id)
  (with-web-db
    (let ((article (get-article id)))
      (if article
          (progn
            (when-bind (info (info))
              (setf (user-clicked info (article-id article)) t))
            (view-link (uid) (article-id article) (ignore-errors (session-remote-addr *session*)))
            (if (use-frame)
                (reddit-frame article)
                (redirect-url (article-url article))))
          (reddit-page (:menu (top-menu (browse-menu)) :right-panel (right-panel-main))
            (:span :class "error" "that article does not exist."))))))

(defun viewlink ()
  (with-parameters ((id "id"))
    (load-link (sanitize id 'int))))

(defun lucky ()
  (let* ((n (random 10))
         (source (if (< n 5)
                     (get-articles 50 0 :front)
                     (get-articles 50 0 :new)))
         (filter (if (< n 8)
                     (lambda (a) (>= (article-pop a) 2))
                     #'identity))
         (info (info)))
    (article-id
     (or (and (uid) info
              (find-if #'(lambda (a) (and (funcall filter a)
                                          (not (user-clicked info (article-id a)))))
                       source))
         (elt source (random (length source)))))))

(defun page-lucky ()
  (load-link (lucky)))

(defun wrap-static-file (path)
  (reddit-page (:cache-key (unless (logged-in-p) (key-str (script-name)))
                           :exp 60
                           :menu (top-menu (browse-menu))
                           :right-panel (unless (logged-in-p) (login-panel))
                           :rss-url (and (string= path "/home/reddit/reddit/web/blog/index.html") "http://reddit.com/blog/atom.xml"))
    (with-open-file (in path :direction :input)
      (loop for line = (read-line in nil) 
         while line do
         (format t "~a~%" line)))))

(defun default-handler ()
  (let ((path (and (> (length (script-name)) 1)
                   (conc "/home/reddit/reddit/web/" (subseq (script-name) 1)))))
    (if (and path (probe-file path))
        (wrap-static-file path)
        (page-default))))



(macrolet ((page-main (name selected &optional rss-url)
             `(defun ,name ()
                (with-parameters ((offset "offset"))
                  (with-web-db
                    (reddit-page (:cache-key (unless (logged-in-p) (key-str ',name offset))
                                             :exp 60
                                             :menu (top-menu (browse-menu) ,selected)
                                             :right-panel (right-panel-main)
                                             :rss-url ,rss-url)
                      (front-page-site-table ,selected)))))))

  (page-main page-front :front "http://reddit.com/rss/hot")
  (page-main page-pop :pop "http://reddit.com/rss/pop")
  (page-main page-new :new "http://reddit.com/rss/new"))

(defun page-default ()
  (page-front))

(defun page-saved ()
  (if (logged-in-p)
      (reddit-page (:menu (top-menu (browse-menu) :saved))
        (with-web-db
          (profile-site-table (uid) :saved)))
      (page-default)))

(defun page-submitters ()
  (reddit-page (:cache-key (key-str (and (logged-in-p) (user-name (userobj)) "topsub"))
                           :exp 60
                           :menu (top-menu (browse-menu) :topsub)
                           :right-panel (unless (logged-in-p) (login-panel)))
    (with-web-db
      (let ((today (top-submitters *num-submitters* :day))
            (week (top-submitters *num-submitters* :week))
            (all (top-submitters *num-submitters* nil)))
        (htm
         (hbar "top submitters today")
         (:table
          (loop for (name karma change) in today do
               (htm (:tr (:td :class "black" (user-link name) (format t " (~a)" karma))
                         (:td (format t "+~a" change))))))
         (hbar "top submitters this week")
         (:table
          (loop for (name karma change) in week do
               (htm (:tr (:td :class "black" (user-link name) (format t " (~a)" karma))
                         (:td (format t "+~a" change))))))
         (hbar "top submitters all-time")
         (:table
          (loop for (name karma change) in all do
               (htm (:tr (:td :class "black" (user-link name) (format t " (~a)" karma)))))))))))

(defun page-blog ()
  (redirect "/blog/index.html"))

(defun page-help ()
  (redirect "/help/help.html"))

(defun page-test ()
  t)

(setq *dispatch-table*
      (nconc
       (list (create-static-file-dispatcher-and-handler
              "/favicon.ico"
              (make-pathname :directory "/home/reddit/reddit/web/" :name "favicon" :type "ico" :version nil
                             :defaults (load-time-value *load-pathname*))
              "image/x-icon"))
       (mapcar (lambda (args)
                 (apply #'create-prefix-dispatcher args))
               '(("/rss/new" rss-new)
                 ("/rss/hot" rss-hot)
                 ("/rss/pop" rss-pop)
                 ("/viewlink" viewlink)
                 ("/browse" page-default)
                 ("/submit" page-submit)
                 ("/hot" page-front)
                 ("/pop" page-pop)
                 ("/new" page-new)
                 ("/saved" page-saved)
                 ("/topsub" page-submitters)
                 ("/search" page-search)
                 ("/aop" ajax-op)
                 ("/test" page-test)
                 ("/logout" logout)
                 ("/share" page-submit)
                 ("/password" page-password)
                 ("/lucky" page-lucky)
                 ("/user/" page-user)
                 ("/toolbar" reddit-toolbar)))
       (list (create-static-file-dispatcher-and-handler
              "/blog/atom.xml" "/home/reddit/reddit/web/blog/atom.xml" "text/xml"))
       (mapcar (lambda (args)
                 (apply #'create-regex-dispatcher args))
               '(("/blog/.+" default-handler)
                 ("/blog/?" page-blog)
                 ("/help/.+" default-handler)
                 ("/help/?" page-help)))
       (list #'default-dispatcher)))