felixfoertsch/reddit1.0
1
0
Fork 0
mirror of https://github.com/reddit-archive/reddit1.0.git synced 2026-04-16 06:18:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
Steve Huffman
2018-03-28 20:38:26 -07:00
committed by Steve Huffman
commit bb4fbdb587
27 changed files with 4180 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
LICENSE Normal file
View File

@@ -0,0 +1,21 @@
MIT License
Copyright (c) 2018 Reddit
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.

69
autocompute.lisp Normal file
View File

@@ -0,0 +1,69 @@
;;;; 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 get-processes (name)
(remove-if-not #'(lambda (x) (string= name (mp:process-name x)))
(mp:all-processes)))
(defun destroy-processes (name)
(dolist (p (get-processes name))
(mp:destroy-process p)))
(defclass ac ()
((name
:initarg :name
:initform (error "must specify a name")
:reader ac-name)
(process
:reader ac-process)
(val
:initform nil
:reader ac-val)
(period
:initarg :period
:initform (error "must specify a period")
:accessor ac-period)
(fn
:initarg :fn
:initform (error "must specify a function")
:accessor ac-fn)
(lock
:initform (mp:make-lock)
:accessor ac-lock)))
(defmethod initialize-instance :after ((auto ac) &key)
(destroy-processes (ac-name auto))
(setf (slot-value auto 'process)
(mp:make-process
#'(lambda ()
(loop
(mp:with-lock-held ((ac-lock auto))
(setf (slot-value auto 'val)
(funcall (ac-fn auto))))
(sleep (ac-period auto))))
:name (ac-name auto))))
(defmethod ac-update ((auto ac))
(mp:with-lock-held ((ac-lock auto))
(setf (slot-value auto 'val)
(funcall (ac-fn auto)))))

67
classify.lisp Normal file
View File

@@ -0,0 +1,67 @@
;;;; 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 *base-dir* #p"/home/reddit/data/")
(defparameter *user-dir* #p"/home/reddit/data/users/")
(defparameter *site-dir* #p"/home/reddit/data/sites/")
(defparameter *lynx* #p"/usr/local/bin/lynx")
(defparameter *classify* #p"/home/reddit/reddit/crm/classify.crm")
(defparameter *learn* #p"/home/reddit/reddit/crm/learn.crm")
(defun user-good-path (id)
(merge-pathnames (make-pathname :name (format nil "good~a" id)
:type "css")
*user-dir*))
(defun user-bad-path (id)
(merge-pathnames (make-pathname :name (format nil "bad~a" id)
:type "css")
*user-dir*))
(defun site-path (id)
(merge-pathnames (make-pathname :name (format nil "site~a" id))
*site-dir*))
(defun download-site (id url)
(let ((sp (site-path id)))
(ext:run-program *lynx* (list "-dump" url)
:output sp
:if-output-exists :supersede)))
(defun learn-site (userid siteid type)
(let ((ufile (namestring (if (eql type :good) (user-good-path userid) (user-bad-path userid))))
(sfile (site-path siteid)))
(and (probe-file sfile)
(ext:run-program *learn* (list ufile)
:input sfile))))
(defun classify-site (userid siteid)
(let ((gfile (namestring (user-good-path userid)))
(bfile (namestring (user-bad-path userid)))
(sfile (site-path siteid)))
(and (probe-file gfile)
(probe-file bfile)
(probe-file sfile)
(elt '(:good :bad :unknown)
(ext:process-exit-code
(ext:run-program *classify* (list gfile bfile)
:input sfile))))))

49
conditions.lisp Normal file
View File

@@ -0,0 +1,49 @@
;;;; 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)
(define-condition invalid-user ()
((username :initarg :username :reader username)
(password :initarg :password :reader password)))
(define-condition article-exists ()
((id :initarg :id :reader id)
(url :initarg :url :reader url)
(title :initarg :title :reader title)))
(define-condition article-submitted ()
((id :initarg :id :reader id)
(url :initarg :url :reader url)
(title :initarg :title :reader title)))
(define-condition check-article-title ()
((title :initarg :title :reader title)))
(define-condition user-exists ()
((username :initarg :username :reader username)))
(define-condition incorrect-password ()
nil)
(define-condition password-changed ()
nil)

51
cookiehash.lisp Normal file
View File

@@ -0,0 +1,51 @@
;;;; 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 *secret* "blargo")
(defun iso-time ()
(let ((itime (format-time nil (get-time) :format :iso)))
(subseq itime 0 (position #\, itime))))
(defun hashstr (str)
(byte-array-to-hex-string (digest-sequence :sha256 (ascii-string-to-byte-array str))))
(defun cookie-str (sn pass)
(let ((time (iso-time)))
(makestr sn "," time ","
(hashstr (makestr time sn pass *secret*)))))
(defun valid-cookie (str)
"returns the userid for cookie if valid, otherwise nil"
(when (= (count #\, str :test #'char=) 2)
(when-bind* ((sn (subseq str 0 (position #\, str :test #'char=)))
(time (subseq str (+ 1 (length sn)) (position #\, str :from-end t :test #'char=)))
(hash (subseq str (+ (length sn) (length time) 2)))
(pass (user-pass sn)))
(when (string= hash (hashstr (makestr time sn pass *secret*)))
(user-id (get-user sn))))))

95
crc.lisp Normal file
View File

@@ -0,0 +1,95 @@
;;; table-driven crc32 implementation, after rfc1952
;;;
;;; This runs with very little consing in CMUCL.
;;;
;;; Written by R. Matthew Emerson <rme@acm.org> in August 1999,
;;; and placed in the public domain.
#|
;;; initial-contents of *crc-table* were computed with this function:
(defconstant *crc-polynomial* #xedb88320)
(defun make-crc-table ()
(dotimes (i 256)
(let ((c i))
(dotimes (k 8)
(if (= 1 (logand c 1))
(setf c (logxor (ash c -1) *crc-polynomial*))
(setf c (ash c -1))))
(if (zerop (mod i 6)) (terpri))
(format t "#x~8,'0x " c))))
|#
(defconstant *crc-table*
(make-array
256
:element-type '(unsigned-byte 32)
:initial-contents
'(#x00000000 #x77073096 #xEE0E612C #x990951BA #x076DC419 #x706AF48F
#xE963A535 #x9E6495A3 #x0EDB8832 #x79DCB8A4 #xE0D5E91E #x97D2D988
#x09B64C2B #x7EB17CBD #xE7B82D07 #x90BF1D91 #x1DB71064 #x6AB020F2
#xF3B97148 #x84BE41DE #x1ADAD47D #x6DDDE4EB #xF4D4B551 #x83D385C7
#x136C9856 #x646BA8C0 #xFD62F97A #x8A65C9EC #x14015C4F #x63066CD9
#xFA0F3D63 #x8D080DF5 #x3B6E20C8 #x4C69105E #xD56041E4 #xA2677172
#x3C03E4D1 #x4B04D447 #xD20D85FD #xA50AB56B #x35B5A8FA #x42B2986C
#xDBBBC9D6 #xACBCF940 #x32D86CE3 #x45DF5C75 #xDCD60DCF #xABD13D59
#x26D930AC #x51DE003A #xC8D75180 #xBFD06116 #x21B4F4B5 #x56B3C423
#xCFBA9599 #xB8BDA50F #x2802B89E #x5F058808 #xC60CD9B2 #xB10BE924
#x2F6F7C87 #x58684C11 #xC1611DAB #xB6662D3D #x76DC4190 #x01DB7106
#x98D220BC #xEFD5102A #x71B18589 #x06B6B51F #x9FBFE4A5 #xE8B8D433
#x7807C9A2 #x0F00F934 #x9609A88E #xE10E9818 #x7F6A0DBB #x086D3D2D
#x91646C97 #xE6635C01 #x6B6B51F4 #x1C6C6162 #x856530D8 #xF262004E
#x6C0695ED #x1B01A57B #x8208F4C1 #xF50FC457 #x65B0D9C6 #x12B7E950
#x8BBEB8EA #xFCB9887C #x62DD1DDF #x15DA2D49 #x8CD37CF3 #xFBD44C65
#x4DB26158 #x3AB551CE #xA3BC0074 #xD4BB30E2 #x4ADFA541 #x3DD895D7
#xA4D1C46D #xD3D6F4FB #x4369E96A #x346ED9FC #xAD678846 #xDA60B8D0
#x44042D73 #x33031DE5 #xAA0A4C5F #xDD0D7CC9 #x5005713C #x270241AA
#xBE0B1010 #xC90C2086 #x5768B525 #x206F85B3 #xB966D409 #xCE61E49F
#x5EDEF90E #x29D9C998 #xB0D09822 #xC7D7A8B4 #x59B33D17 #x2EB40D81
#xB7BD5C3B #xC0BA6CAD #xEDB88320 #x9ABFB3B6 #x03B6E20C #x74B1D29A
#xEAD54739 #x9DD277AF #x04DB2615 #x73DC1683 #xE3630B12 #x94643B84
#x0D6D6A3E #x7A6A5AA8 #xE40ECF0B #x9309FF9D #x0A00AE27 #x7D079EB1
#xF00F9344 #x8708A3D2 #x1E01F268 #x6906C2FE #xF762575D #x806567CB
#x196C3671 #x6E6B06E7 #xFED41B76 #x89D32BE0 #x10DA7A5A #x67DD4ACC
#xF9B9DF6F #x8EBEEFF9 #x17B7BE43 #x60B08ED5 #xD6D6A3E8 #xA1D1937E
#x38D8C2C4 #x4FDFF252 #xD1BB67F1 #xA6BC5767 #x3FB506DD #x48B2364B
#xD80D2BDA #xAF0A1B4C #x36034AF6 #x41047A60 #xDF60EFC3 #xA867DF55
#x316E8EEF #x4669BE79 #xCB61B38C #xBC66831A #x256FD2A0 #x5268E236
#xCC0C7795 #xBB0B4703 #x220216B9 #x5505262F #xC5BA3BBE #xB2BD0B28
#x2BB45A92 #x5CB36A04 #xC2D7FFA7 #xB5D0CF31 #x2CD99E8B #x5BDEAE1D
#x9B64C2B0 #xEC63F226 #x756AA39C #x026D930A #x9C0906A9 #xEB0E363F
#x72076785 #x05005713 #x95BF4A82 #xE2B87A14 #x7BB12BAE #x0CB61B38
#x92D28E9B #xE5D5BE0D #x7CDCEFB7 #x0BDBDF21 #x86D3D2D4 #xF1D4E242
#x68DDB3F8 #x1FDA836E #x81BE16CD #xF6B9265B #x6FB077E1 #x18B74777
#x88085AE6 #xFF0F6A70 #x66063BCA #x11010B5C #x8F659EFF #xF862AE69
#x616BFFD3 #x166CCF45 #xA00AE278 #xD70DD2EE #x4E048354 #x3903B3C2
#xA7672661 #xD06016F7 #x4969474D #x3E6E77DB #xAED16A4A #xD9D65ADC
#x40DF0B66 #x37D83BF0 #xA9BCAE53 #xDEBB9EC5 #x47B2CF7F #x30B5FFE9
#xBDBDF21C #xCABAC28A #x53B39330 #x24B4A3A6 #xBAD03605 #xCDD70693
#x54DE5729 #x23D967BF #xB3667A2E #xC4614AB8 #x5D681B02 #x2A6F2B94
#xB40BBE37 #xC30C8EA1 #x5A05DF1B #x2D02EF8D)))
(defun update-crc (crc buf)
(declare (type (unsigned-byte 32) crc)
(type (simple-array (unsigned-byte 8)) buf)
(optimize speed))
(setf crc (logxor crc #xffffffff))
(dotimes (n (length buf))
(let ((i (logand #xff (logxor crc (aref buf n)))))
(setf crc (logxor (aref *crc-table* i) (ash crc -8)))))
(logxor crc #xffffffff))
(defun crc (buf)
(update-crc 0 buf))
(defun crc-str (str)
(crc (string-bytes str)))
(defun string-bytes (str)
(map 'vector #'char-code str))
;;; output should be #xCBF43926
(defun test-crc ()
(let ((a (make-array 9 :element-type '(unsigned-byte 8)
:initial-contents '(#x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39))))
(crc a)))

419
data.lisp Normal file
View File

@@ -0,0 +1,419 @@
;;;; 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 *max-emails* 100)
(defparameter *mod-window* (make-duration :day 2))
(defparameter *min-mod-karma* 0)
(defparameter *min-karma* 10)
(defvar *database-type* :postgresql)
(defvar *database-name* "reddit")
(defvar *database-user* "pgsql")
(defvar *database-server* "")
(defvar *database-password* "pgcwip42:")
(defparameter *conn-spec* `(,*database-server* ,*database-name* ,*database-user* ,*database-password*))
(defmacro with-web-db (&body body)
`(with-database (*default-database* *conn-spec* :pool t :database-type *database-type*)
,@body))
(connect *conn-spec* :database-type *database-type* :if-exists :old)
(setf *default-caching* nil)
(locally-enable-sql-reader-syntax)
(defmacro when-valid ((&key userid articleid targetid ip) &body body)
`(and (or (not ,userid) (and (get-user ,userid)
(not (neuterd ,userid))))
(or (not ,targetid) (and (get-user ,targetid)
(not (neuterd ,targetid))))
(or (not ,articleid) (get-article ,articleid))
(or (not ,ip) (not (neuterd ,ip)))
(progn ,@body)))
;;--------------------------- users ----------------------------
(defun user-pass (sn)
(car (select [password] :from [users] :where [= sn [screenname]] :flatp t)))
(defun get-user (name-or-id)
(typecase name-or-id
(string (car (select 'user :where [= (string-downcase name-or-id) [lower [screenname]]] :flatp t )))
(integer (car (select 'user :where [= name-or-id [id]] :flatp t )))))
(defun valid-login-p (sn pass)
"Returns user id if the user's password is correct and NIL otherwise"
(and sn pass
(car (select [id] :from [users]
:where [and [= [lower [screenname]] (string-downcase sn)]
[= [password] pass]]
:flatp t))))
(defun valid-user-p (name-or-id &key return-sn)
(typecase name-or-id
(string (car (select (if return-sn [screenname] [id])
:from [users]
:where [= (string-downcase name-or-id) [lower [screenname]]]
:flatp t )))
(integer (car (select (if return-sn [screenname] [id])
:from [users]
:where [= name-or-id [id]]
:flatp t )))))
(defun fake-user-p (name-or-id)
(let ((id (valid-user-p name-or-id)))
(and id (< id 0))))
(defun change-fake (name &optional newname)
(let ((newname (or newname name)))
(if (valid-user-p newname)
(change-fake name (concatenate 'string newname "2"))
(update-records [users] :attributes '(screenname) :values (list newname)
:where [= [lower [screenname]] (string-downcase name)]
))))
(defun add-user-sql (name email pass ip &optional neg)
"Adds a user to the database. Updates the userid sequences. neg
indicates whether the userid should be negative (not a
registered user)"
(let ((id (if neg
(- (sequence-next[userid]))
(sequence-next[userid]))))
(insert-records :into [users] :values (list id name email pass 0 [current_timestamp] ip))
id))
(defun add-user (name email pass ip &optional fake)
"adds a user to the database - this is for real users and the
'fake' users by alexis and steve"
;when someone tries to register - check for a fake username
(cond ((and fake (not (valid-user-p name)))
(add-user-sql name email pass ip t))
((and (not fake) (fake-user-p name))
(change-fake name)
(add-user name email pass ip))
((valid-user-p name) (signal 'user-exists :username name))
(t (add-user-sql name email pass ip))))
;;--------------------------- article --------------------------
(defun get-article-sn (id-or-url)
(when id-or-url
(typecase id-or-url
(integer (car (select 'article-with-sn :where [= id-or-url [id]] :flatp t)))
(string (car (select 'article-with-sn :where [= id-or-url [url]] :flatp t))))))
(defun get-article (id-or-url)
(when id-or-url
(typecase id-or-url
(integer (car (select 'article :where [= id-or-url [id]] :flatp t)))
(string (car (select 'article :where [= id-or-url [url]] :flatp t))))))
(defun insert-article (title url submitter ip &optional fuser)
"Insert an article into the datebase and give user credit for
it. If the artciles already exists, boost the orig submitter's
karma."
(and title url submitter ip (not (article-id-from-url url))
(progn
;;handle fake user names
(when fuser
(if (fake-user-p fuser)
(setf submitter (valid-user-p fuser))
(progn
(when (not (valid-user-p fuser))
(add-user fuser [null] [null] ip t)
(setf submitter (valid-user-p fuser))))))
;;add http:// to urls if required
(when-valid (:userid submitter :ip ip)
(setf url (add-http url))
(let ((article (or (get-article (article-id-from-url url))
(make-instance 'article :id (sequence-next "articleid") :url url
:title title :date (get-time) :submitterid submitter))))
(update-records-from-instance article)
(like-and-mod submitter (article-id article) t ip)
article)))))
(defun remove-article (userid articleid)
(ignore-errors
(delete-records :from [articles]
:where [and [= [id] articleid]
[= [submitter] userid]])))
;;--------------------------- neuter ---------------------------
(defun neuterd (id-or-ip)
(typecase id-or-ip
(string (car (select 'neuter :where [= id-or-ip [ip]] :flatp t)))
(integer (car (select 'neuter :where [= id-or-ip [userid]] :flatp t)))))
;;------------------------- options ----------------------------
(defun get-user-options (userid)
(or (car (select 'options :where [= userid [userid]] :flatp t))
(make-instance 'options :userid userid :promoted t :demoted nil :numsites 25 :visible nil :frame nil)))
(defun profile-visible (userid)
(options-visible (get-user-options userid)))
;;---------------------------- sessions ------------------------------
(defun session-uid (iden)
(car (select [userid] :from [sessions] :where [= iden [iden]] :flatp t )))
(defun remember-session-sql (id iden &optional ip)
"Erase an old session for this userid, and add a new one"
(ignore-errors
(insert-records :into [sessions]
:av-pairs `(([userid] ,id) ([iden] ,iden) ([ip] ,ip) (date ,[current_date])))))
(defun remove-old-sessions ()
(delete-records :from [sessions]
:where [< [date] [- [current_date]
(sql-expression :string "interval '2 weeks'")]]))
;;----------------------------- mod-user -------------------------------
(defun check-and-mod-user (userid articleid ip amount)
(let ((article (get-article articleid)))
(and (not (= userid (article-submitterid article))) ;can't mod yourself
(time< (time- (get-time) *mod-window*) ;only mod within 3 days of submission
(article-date article))
(> (or (user-karma (get-user userid)) 0)
*min-karma*)
(mod-user userid (article-submitterid article) articleid ip amount))))
(defun get-mod-user (userid targetid articleid)
(car (select 'moduser :where [and [= [userid] userid]
[= [target] targetid]
[= [article] articleid]]
:flatp t)))
(defun mod-user (userid targetid articleid ip amount)
(when (and userid targetid articleid ip amount)
(let ((moduser (or (get-mod-user userid targetid articleid )
(make-instance 'moduser :userid userid :targetid targetid :articleid articleid))))
(log-message* "MOD-USER: userid: ~a target: ~a article: ~a ip: ~a amount: ~a"
userid targetid articleid ip amount)
(setf (moduser-amount moduser) amount
(moduser-date moduser) (get-time)
(moduser-ip moduser) ip)
(update-records-from-instance moduser))))
;;--------------------------- mod-article -----------------------------
(defun ip-modded-site (ip articleid)
(car (select 'modarticle :where [and [= ip [ip]] [= articleid [article]]] :flatp t)))
(defun check-and-mod-article (userid articleid ip amount)
(mod-article userid articleid ip amount))
(defun get-mod-article (userid articleid)
(car (select 'modarticle :where [and [= [userid] userid]
[= [article] articleid]]
:flatp t)))
(defun mod-article (userid articleid ip amount)
(and userid articleid ip amount
(let ((modarticle (or (get-mod-article userid articleid)
(make-instance 'modarticle :userid userid :articleid articleid))))
(log-message* "MOD-ARTICLE: userid: ~a article: ~a ip: ~a amount: ~a"
userid articleid ip amount)
(setf (modarticle-amount modarticle) amount
(modarticle-ip modarticle) ip
(modarticle-date modarticle) (get-time))
(update-records-from-instance modarticle))))
;;--------------------------- click on a link ----------------------------
(defun view-link (userid articleid ip)
(and articleid ip
(when-valid (:userid userid :articleid articleid :ip ip)
(let ((click (make-instance 'click :userid userid :articleid articleid :ip ip)))
(log-message* "CLICK user: ~a article: ~a ip: ~a" userid articleid ip)
(update-records-from-instance click)))))
(defun user-clicked-p (userid articleid)
(not (null (select 1
:from [clicks]
:where [and [= userid [userid]]
[= articleid [article]]]
:limit 1))))
;;--------------------------- like-site ---------------------------
(defun get-like-site (userid articleid)
(car (select 'like :where [and [= userid [userid]] [= articleid [article]]] :flatp t)))
(defun like-site (userid articleid liked)
"Inserts or updates a user's liking of a site."
(log-message* "LIKE user: ~a article: ~a like: ~a" userid articleid liked)
(and userid articleid
(let ((like (or (get-like-site userid articleid)
(make-instance 'like :userid userid :articleid articleid))))
(setf (like-date like) (get-time)
(like-like like) liked)
(update-records-from-instance like))))
(defun unlike-site (userid articleid)
(and userid articleid
(progn
(log-message* "UNLIKE user: ~a article: ~a" userid articleid)
(when-bind (like (get-like-site userid articleid))
(delete-instance-records like)))))
(defun like-site-user (userid articleid)
(when-bind (like (get-like-site userid articleid))
(if (like-like like) :like :dislike)))
(defun like-and-mod (userid articleid liked ip)
(when-valid (:userid userid :articleid articleid :ip ip)
(like-site userid articleid liked)
(check-and-mod-article userid articleid ip (if liked 1 -1))
(check-and-mod-user userid articleid ip (if liked 1 -1))))
(defun unlike-and-mod (userid articleid ip)
(when-valid (:userid userid :articleid articleid :ip ip)
(unlike-site userid articleid)
(check-and-mod-article userid articleid ip 0)
(check-and-mod-user userid articleid ip 0)))
;;-------------------------- aliases -------------------------------
(defun get-alias (userid name)
(car (select 'alias :where [and [= [userid] userid] [= name [name]]] :flatp t)))
(defun set-alias (userid name val)
(and userid (> (length name) 0) (> (length val) 0)
(let ((alias (or (get-alias userid name)
(make-instance 'alias :userid userid))))
(setf (alias-name alias) name
(alias-val alias) val)
(update-records-from-instance alias))))
(defun remove-alias (userid name)
(and userid name
(when-bind (alias (get-alias userid name))
(delete-instance-records alias))))
(defun basic-info (sn)
(car (select [karma] [signupdate]
:from [users]
:where [and [= (string-downcase sn) [lower [screenname]]]]
:result-types '(t :int) :flatp t )))
(defun user-stats (sn-or-id)
(let ((id (valid-user-p sn-or-id)))
(list
(car (select [count [id]] :from [articles]
:where [= [submitter] id]
:flatp t
:result-types '(t)))
(car (select [count [article]] :from [like_site]
:where [and [= id [userid]]
[= [liked] [true]]]
:flatp t
:result-types '(t)))
(car (select [count [article]] :from [like_site]
:where [and [= id [userid]]
[= [liked] [false]]]
:flatp t
:result-types '(t))))))
(defun user-email (name-or-id)
(let ((id (valid-user-p name-or-id)))
(car (select [email] :from [users] :where [= [id] id] :flatp t ))))
(defun change-password (id oldpass newpass)
(when (select 1 :from [users] :where [and [= [id] id] [= [password] oldpass]])
(update-records [users]
:av-pairs `((password ,newpass))
:where [= [id] id])
t))
(defun user-from-email (email)
(car (select [id] :from [users]
:where [= (string-downcase email) [lower [email]]]
:flatp t )))
(defun change-email (id email)
(if (valid-user-p id)
(update-records [users]
:av-pairs `((email ,email))
:where [= [id] id]
)))
(defun karma (id)
(or
(car (select [karma] :from [users] :where [= id [id]] :flatp t :result-types '(:int)
))
0))
(defun login-from-email (email)
(car (select [screenname] [password]
:from [users]
:where [= (string-downcase email) [email]]
:flatp t )))
;;top submitters
(defun top-submitters(num timespan)
(if (member timespan '(:day :week))
(select [screenname] [users karma] [sum [amount]] :from '([users] [mod_user])
:where [and [= [target] [id]]
[> [karma] 0]
[> [mod_user date]
[- [current_timestamp]
(case timespan
(:day (sql-expression :string "interval '1 day'"))
(:week (sql-expression :string "interval '1 week'")))]]]
:group-by (sql-expression :string "screenname, users.karma")
:order-by `((,[sum [amount]] desc))
:limit num)
(select [screenname] [karma] :from [users]
:where [> [karma] 0]
:order-by `((,[karma] desc))
:limit num)))
(defun valid-email (userid ip dest)
(and userid ip dest
(< (car (select [count [userid]] :from [emails]
:where [and [or [= userid [userid]]
[= ip [ip]]]
[> [date] [- [current_timestamp]
(sql-expression :string "interval '1 day'")]]]
:flatp t ))
*max-emails*)))
(defun email-sent (userid articleid ip dest)
(insert-records :into [emails]
:av-pairs `((userid ,userid)
(articleid ,articleid)
(ip ,ip)
(dest ,dest)
(date ,[current_timestamp]))
))
(defun get-all (userid)
(mapcar #'length
(list (select [*] :from [like_site] :where [= [userid] userid])
(select [*] :from [closed_sites] :where [= [userid] userid])
(select [*] :from [saved_sites] :where [= [userid] userid])
(select [*] :from [clicks] :where [= [userid] userid]))))

120
frame.lisp Normal file
View File

@@ -0,0 +1,120 @@
;;;; 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 *frame-height* "30px")
(defun reddit-frame (article)
(with-html-output-to-string (*standard-output* nil :prologue "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" :indent t)
(:html
(:head
(:title (esc (article-title article))))
(:frameset
:framespacing 0 :rows (makestr *frame-height* ", 100%")
(:frame :frameborder 0 :scrolling "no" :src (makestr "/toolbar?id=" (article-id article)))
(:frame :frameborder 0 :src (article-url article))))))
(defun reddit-toolbar ()
(with-parameters ((id "id"))
(let* ((article (get-article (sanitize id 'int)))
(modded (and (get-info (uid)) (user-liked (get-info (uid)) (article-id article))))
(id (article-id article)))
(with-html-output-to-string (*standard-output* nil :prologue t)
(:head
(:link :rel "stylesheet" :href "/static/framestyle.css" :type "text/css")
(:script :src "/static/cookie.js" :language "javascript" :type "text/javascript" "")
(:script :src "/static/psrs.js" :language "javascript" :type "text/javascript" "")
(:script :language "javascript" (str (if (logged-in-p) "var logged = true" "var logged= false")))
(:script :src "/static/mod.js" :language "javascript" :type "text/javascript" "")
(:script :src "/static/frame.js" :language "javascript" :type "text/javascript" ""))
(:body
(:form :name "log" :onsubmit "$(\"logbtn\").onclick(); return false"
(:table
:style (makestr "height: " *frame-height* "; border-bottom: 1px solid black")
(:tr
:id "killed" :style "display: none" :class "menu"
(:td :nowrap t
"after reloading, this frame will not be shown again. click "
(:a :href "javascript:unkill()" "here") " to undo.")
(:td :width "100%"))
(:tr
:id "main"
(:td
(:a :target "_parent" :href "/" (:img :style "border: none" :src "/static/littlehead.png"
:alt "reddit.com" :title "reddit.com")))
(:td
(:div :id (idstr "up")
:class (if (eq modded :like) "arrow upmod" "arrow up")
:onclick (makestr "javascript:mod("id", 1)") " "))
(:td "like")
(:td :nowrap t
(:div :id (idstr "down")
:class (if (eq modded :dislike) "arrow downmod" "arrow down")
:onclick (makestr "javascript:mod("id", 0)")))
(:td "dislike")
(:td :id "left" :style "padding-left: 10px" :class "menu" :nowrap t
;;(str "&nbsp;")
(:a :target "_parent" :href (makestr "/recommend?id=" id) "share")
(str "|")
(:a :target "_parent" :href "/lucky" "i'm feeling serendipitous"))
(:td :id "err" :style "text-align: right" :class "error" :width "100%")
(:td :id "middle" :nowrap t :style "display: none"
;;username box
(:input :id "usrtxt" :type "text" :style "color: gray" :class "txt" :size 10
:value "username" :autocomplete "off" :onfocus "swapel(\"usrtxt\", \"usr\")")
(:input :id "usr" :type "text" :class "txt" :size 10)
;;password box
(:input :id "passtxt" :type "text" :style "color: gray" :class "txt" :size 10
:value "password" :autocomplete "off" :onfocus "swapel(\"passtxt\", \"pass\")")
(:input :id "pass" :name "pass" :type "password" :class "txt" :size 10)
;;verify password
(:input :id "vertxt" :type "text" :style "color: gray" :class "txt" :size 12
:value "verify password" :autocomplete "off" :onfocus "swapel(\"vertxt\", \"ver\")")
(:input :id "ver" :type "password" :class "txt" :size 12)
;;remember me
(:input :id "rem" :name "rem" :type "checkbox")
(:label :id "remlbl" :for "rem" "keep me logged in")
;;login register cancel buttons
(:button :id "logbtn" :class "btn" :type "submit" :onclick "login(); return false;" "login")
(:button :class "btn" :onclick "cancel(); return false" "cancel"))
(if (logged-in-p)
(htm
(:td :id "logmenu" :class "menu" :nowrap t
(format t "~a (~a) |" (user-name (userobj)) (user-karma (userobj)))
(:a :href (conc "/user/" (user-name (userobj))) :target "_parent" "profile")
(str "|")
(:a :href "javascript:logout()" "logout")))
(htm
(:td :id "menu" :class "menu" :nowrap t
(:a :href "javascript:showlogin()" "login")
(str "|")
(:a :href "javascript:showreg()" "register"))))
(:td
:id "buttons" :nowrap t
(:a :target "_parent" :href "/help/help.html"
(:img :style "border: none" :src "/static/help.png"
:alt "help" :title "help"))
(:a :target "_parent" :href (article-url article)
(:img :style "border: none" :src "/static/breakout.png"
:alt "open without frame" :title "open without frame"))
(:img :style "cursor: pointer" :src "/static/kill.png"
:alt "permanently close this frame" :title "permanently close this frame"
:onclick "kill()"))))))))))

69
mail.lisp Normal file
View File

@@ -0,0 +1,69 @@
;;;; 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 *mail-prog* "/usr/bin/mail")
(defparameter *user* "ZG1haWw=")
(defparameter *pass* "Ymxhcmc=")
(defparameter *mail-server* "216.55.162.13")
(defun send-reddit-email (to from subject message)
(mp:make-process
#'(lambda ()
(ignore-errors
(send-email *mail-server* from to subject message :username *user* :password *pass*)))))
(defun info-email-body (user password)
(with-output-to-string (s)
(format s "Your login information for http://reddit.com is:~%~%")
(format s "~4tUsername: ~a~%" user)
(format s "~4tPassword: ~a~%~%" password)
(format s "Thank you for using reddit.com!")))
(defun send-login-info (to user pass)
(send-reddit-email to "reddit@reddit.com" "reddit.com login information"
(info-email-body user pass)))
(defun recommend-email-body (from title link &optional personal)
(with-output-to-string (s)
(format s "This email was sent to you by: ~a~%~%" from)
(if personal
(format s "~a~%~%" personal)
(format s "A user at reddit.com thought you would find this link interesting:~%~%"))
(format s "~a~%" title)
(format s "~a~%~%" link)
(format s "Check out http://reddit.com to see what's new online today!~%~%")
(format s "If you have any questions regarding this email direct them to feedback@reddit.com")))
(defun send-recommendation (userid articleid ip addresses from personal)
(let* ((tl (site-tl articleid))
(title (first tl))
(url (second tl))
(sub (format nil "reddit.com: ~a" title))
(body (recommend-email-body from title url personal)))
(dolist (to (cond ((listp addresses)
addresses)
((atom addresses) (list addresses))))
(when (valid-email userid ip to)
(send-reddit-email to from sub body)
(email-sent userid articleid ip to)))))

129
memcached.lisp Normal file
View File

@@ -0,0 +1,129 @@
;;;; 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 *STORED* "STORED")
(defparameter *NOTSTORED* "NOT_STORED")
(defparameter *END* "END")
(defparameter *DELETED* "DELETED")
(defparameter *NOTFOUND* "NOT_FOUND")
(defparameter *OK* "OK")
(defparameter *ERROR* "ERROR")
(defparameter *CLIENTERROR* "CLIENT_ERROR")
(defparameter *SERVERERROR* "SERVER_ERROR")
(defparameter *VALUE* "VALUE")
(defparameter *cache* (make-hash-table :test 'equal))
(defmacro cached ((key &optional (exp 0)) &body body)
(let ((k (gensym)))
`(let ((,k ,key))
(or (mc-get ,k)
(let ((val (progn ,@body)))
(mc-set ,k val ,exp)
val)))))
;;TODO more servers
(defun get-stream ()
(ignore-errors
(sys:make-fd-stream (ext:connect-to-inet-socket "127.0.0.1" 11211)
:input t :output t
:buffering :none
:auto-close t)))
(defun mc-write-str (str stream)
(write-string str stream)
(write-char #\Return stream)
(write-char #\Newline stream))
(defun mc-read-str (stream &optional len)
;(force-output stream)
(if len
;;read len bytes in as few reads as possible
(let ((val (read stream)))
(read-char stream) (read-char stream)
val)
;;everything else is read as one line
(let ((str (read-line stream)))
(subseq str 0 (1- (length str))))))
;;TODO locking!
(defun mc-store (cmd key val &optional (exp 0))
(with-open-stream (s (get-stream))
(when s
(let ((cmd-str (case cmd
(:add "add")
(:replace "replace")
(t "set")))
(val-str (with-output-to-string (s) (prin1 val s))))
(mc-write-str (format nil "~a ~a ~a ~a ~a" cmd-str key 0 exp (length val-str)) s)
(mc-write-str val-str s)
(let ((response (mc-read-str s)))
(cond
((string= *STORED* response) :STORED)
((string= *NOTSTORED* response) :NOTSTORED)
(t response)))))))
(defun mc-set (key val &optional (exp 0))
(mc-store :set key val exp))
(defun mc-add (key val &optional (exp 0))
(mc-store :add key val exp))
(defun mc-replace (key val &optional (exp 0))
(mc-store :replace key val exp))
(defun parse-value (value-str)
(let* ((s1 (position #\space value-str :start 6))
(s2 (position #\space value-str :start (1+ s1)))
(key (subseq value-str 6 s1))
(flags (parse-integer (subseq value-str (1+ s1) s2)))
(len (parse-integer (subseq value-str (1+ s2)))))
(list key flags len)))
(defun mc-read-val (stream)
(let ((response (mc-read-str stream)))
(when (string= response "VALUE" :end1 (min (length response) 5))
(destructuring-bind (key flags len) (parse-value response)
(values
(mc-read-str stream len)
key flags)))))
(defun mc-get (key)
(with-open-stream (stream (get-stream))
(when stream
(mc-write-str (format nil "get ~a" key) stream)
(let ((val (mc-read-val stream)))
(when val
;;read END
(mc-read-str stream)
val)))))
(defun mc-delete (key &optional (time 0))
(with-open-stream (stream (get-stream))
(when stream
(mc-write-str (format nil "delete ~a ~a" key time) stream)
(let ((response (mc-read-str stream)))
(cond
((string= response *DELETED*) :DELETED)
((string= response *NOTFOUND*) :NOTFOUND)
(t response))))))

693
old.lisp Normal file
View File

@@ -0,0 +1,693 @@
;;;; 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.
(defun all-articles ()
(query "select articles.id, url, title, pop, screenname from articles, users where articles.submitter = users.id"
:result-types '(t t t t t)
:field-names nil))
;;TODO consider defaults
(defun get-articles (&key (limit 25) offset sort-by time-frame threshold)
(query
(with-output-to-string (s)
(format s "select articles.id, url, title, pop, sum(amount) as growth, screenname, articles.date from articles, mod_article, users where articles.id = mod_article.article and submitter = users.id")
(when threshold (format s " and pop > ~a" threshold))
(case time-frame
(:day (format s " and articles.date > timestamp current_timestamp - interval '1 day'"))
(:week (format s " and articles.date > timestamp current_timestamp - interval '1 week'")))
(format s " group by articles.id, url, title, pop, screenname, articles.date")
(case sort-by
(:pop (format s " order by pop desc, articles.date desc"))
(:growth (format s " order by growth desc, articles.date desc"))
(t (format s " order by articles.date desc")))
(when limit (format s " limit ~a" limit))
(when offset (format s " offset ~a" offset)))
:result-types '(t t t t t t t t)))
(defun mod-frame ()
(with-parameters ((article "article"))
(let ((url (article-url article)))
(if url
(with-html
(:html
(:frameset :rows "50, *"
(:frame :src (conc "/lisp/reddit/mod?article=" article) :scrolling "no")
(:frame :src url))))
(redirect "/lisp/reddit")))))
(defun mod-panel ()
(with-parameters ((article "article") (mod "mod"))
(with-html
(if mod
(progn
(htm (:span "Your moderation has been recored"))
(mod-article (user-val 'id) article mod))
(htm (:form :method "get" :action (script-name)
(:table
(:tr (loop for x from -5 to 5 do
(htm (:td :align "center" (str x))))
(:td :rowspan "2" (:input :type "submit" :value "Moderate"))
(:tr (loop for x from -5 to 5 do
(htm (:td :align "center" (:input :type "radio" :name "mod" :value (str x)))))))
(:input :type "hidden" :name "article" :value article))))))))
(defun get-articles (userid limit offset sort-by time-frame &optional threshold)
(query
(with-output-to-string (s)
(format s "select articles.id, title, pop, sum(amount) as growth, screenname, seconds(articles.date), ~a"
(if userid (format nil "mod_amount(~a, articles.id)" userid) 0))
(format s "from articles, mod_article, users where articles.id = mod_article.article and submitter = users.id")
(when threshold (format s " and pop > ~a" threshold))
(case time-frame
(:day (format s " and mod_article.date > current_timestamp - interval '1 day'"))
(:week (format s " and mod_article.date > current_timestamp - interval '1 week'")))
(format s " group by articles.id, url, title, pop, screenname, articles.date")
(case sort-by
(:pop (format s " order by pop desc, articles.date desc"))
(:growth (format s " order by growth desc, articles.date desc"))
(t (format s " order by articles.date desc")))
(when offset (format s " offset ~a" offset))
(when limit (format s " limit ~a" limit)))
:result-types '(:int t t t t :int :int)))
(defun link-or-text (sym csym title link)
(with-html-output (*standard-output*)
(if (eql sym csym)
(htm (esc title))
(htm (:a :href link (esc title))))))
(defun mod-article-sql-str (user articleid ip amount)
(with-output-to-string (s)
(format s "insert into mod_article(~a, article, amount, effamount, date, ip) "
(typecase user
(string "sessionid")
(integer "userid")))
(format s "values ('~a', ~a, ~a, ~a, current_timestamp, '~a')"
user articleid amount amount ip)))
;((= 1 (length (session-value 'recent))) "oneRow")
;((= x 0) "topRow")
;((< x (1- (length (session-value 'recent)))) "midRow")
;((= x (1- (length (session-value 'recent)))) "botRow"))
;"evenRow")
(case time-frame
(:day (format s " and mod_article.date > current_timestamp - interval '1 day'"))
(:week (format s " and mod_article.date > current_timestamp - interval '1 week'")))
(format s " group by articles.id, url, title, pop, screenname, articles.date")
(case sort-by
(:pop (format s " order by pop desc, articles.date desc"))
(:growth (format s " order by growth desc, articles.date desc"))
(t (format s " order by articles.date desc")))
(when offset (format s " offset ~a" offset))
(when limit (format s " limit ~a" limit)))
(defun topic-link (topic)
(with-html-output(*standard-output*)
(:a :class "userlink" :href (create-url "/" (replace-alist (get-parameters) `(("topic" . ,topic)))) (esc topic))))
(defun topics-panel ()
(let ((topics (get-topics)))
(pbox "Topics"
(:table
(loop for topic in topics do
(htm
(:tr (:td (topic-link topic)))))))))
(defun star-panel ()
(with-html-output (*standard-output*)
(dotimes (i 4)
(:div
(defun get-articles (userid limit offset sort-by)
(query
(with-output-to-string (s)
(format s "select articles.id, title, url, pop, sum(amount) as growth, screenname, seconds(articles.date), ~a"
(if userid (format nil "mod_amount(~a, articles.id)" userid) 0))
(format s " from articles, mod_article, users")
(format s " where articles.id = mod_article.article and submitter = users.id")
;default is growth
;(when topic
;(format s " and topics.name = '~a'" topic))
(case sort-by
(:pop)
(:date)
(t (format s " and mod_article.date > current_timestamp - interval '1 day'")))
(format s " group by articles.id, url, title, pop, screenname, articles.date")
;default is growth
(case sort-by
(:pop (format s " order by pop desc"))
(:date (format s " order by articles.date desc"))
(t (format s " order by growth desc, articles.date desc")))
(when offset (format s " offset ~a" offset))
(when limit (format s " limit ~a" limit)))
:result-types '(:int t t t t t :int :int)))
(defun recent-articles ()
(let ((articles (get-articles-lst (user-val 'id) (session-value 'recent))))
(when articles
(setf *test* (session-value 'recent))
(with-html-output (*standard-output*)
(:tr (:td "Recently Viewed:"))
(print-articles articles t)))))
(defun add-recent (id)
(if (session-value 'recent)
(setf (session-value 'recent) (add-rlist id (session-value 'recent) *recent-size*))
(setf (session-value 'recent) (list id))))
(defun remove-recent (id)
(when (session-value 'recent)
(setf (session-value 'recent) (remove id (session-value 'recent)))))
(defun table-link (sym csym url title)
(with-html-output (*standard-output*)
(if (or (and (null csym)
(eql sym :growth))
(eql sym csym))
(htm
(esc title))
(htm
(:a :class "tablelink" :href url (esc title))))))
(defun table-controls (&optional (selected :front))
(with-html-output (*standard-output*)
(table-link :front selected "/hot" "Hottest")
" | "
(table-link :prom selected "/prom" "Recently Promoted")
" | "
(table-link :new selected "/new" "Newest")
" | "
(table-link :pop selected "/pop" "Most Popular (all-time)")))
(defun rate-area (modded id)
(with-html-output (*standard-output* nil :indent t)
(:div :class "mod" (unless modded
(htm
(:a :href (create-url (script-name) (replace-alist (get-parameters)
`(("action" . "mod")
("mod" . "cool")
("id" . ,id))))))))))
(define-callback mod (id mod)
(let ((id (sanitize id 'int))
(mod (sanitize mod 'sym '(:cool :uncool))))
(when (and id mod)
(moderate id mod)
(redirect (script-name)))))
(defun moderate (id mod)
(setf (session-value 'last-id) id)
(let ((modamount (if (member (user-val 'id) '(0 2)) (+ (random 4) 2) 1)))
(case mod
(:cool (mod-article (user-val 'id) id modamount (session-remote-addr *session*))n
(setf (gethash id (session-value :modded-articles)) modamount))
(:uncool (mod-article (user-val 'id) id (- modamount) (session-remote-addr *session*))
(setf (gethash id (session-value :modded-articles)) (- modamount))))))
(defun submit-panel ()
(with-parameters ((url "url") (title "title") (ref "ref"))
(with-html-output (*standard-output*)
(typecase (session-value 'submit)
(article-submitted
(htm (:p "Your submission was successful")
(:p (site-link (id (session-value 'submit)) (title (session-value 'submit)) url)))
(setf (session-value 'submit) nil))
(article-exists
(htm (:p :class "error" "That site has already been submitted")
(:p (site-link (id (session-value 'submit)) (title (session-value 'submit)) url)))
(setf (session-value 'submit) nil))
(t
(if (logged-in-p)
(let ((ctitle (session-value 'submit)))
(htm (:div :id "contentPanel"
(:form :method "post" :action (script-name)
(:h2 "Submit")
(:input :type "hidden" :name "action" :value "submit")
(:input :type "hidden" :name "ref" :value (referer))
(:table
(when (member (user-val 'id) '(0 2 64))
(htm
(:tr (:td :align "right" "Screenname:")
(:td (:input :name "fuser" :type "text" :size 60 :value (esc (user-val 'name)))))))
(:tr (:td :align "right" "URL:")
(:td (:input :name "url" :type "text" :value (esc (or url "")) :size 60)))
(:tr (:td :align "right" "Title:")
(:td (:input :name "title" :type "text" :value (esc (or
(when ctitle (title ctitle))
title "")) :size 60)))
(when ctitle
(htm
(:tr (:td) (:td :class "error" "Please verify this title, or enter one of your own"))))
;(:tr (:td :align "right" "Description:") (:td (:textarea :name "description" :rows 5 :cols 60 "")))
(:tr (:td) (:td (:input :type "submit" :value "Submit")))))
(esc "Drag this link to your toolbar to submit links faster: ")
(:a :href "javascript:location.href=\"http://reddit.com/submit?url=\"+encodeURIComponent(location.href)+\"&amp;title=\"+encodeURIComponent(document.title)"
:onclick "window.alert(\"Drag this link to your toolbar or right-click and choose Add to Favorites.\"); return false" "post on Reddit")))
(setf (session-value 'submit) nil))
(htm (:p "Please log in before submitting."))))))))
(define-callback submit (url title fuser)
(handler-bind ((check-article-title (lambda (c) (setf (session-value 'submit) c)))
(article-exists (lambda (c) (setf (session-value 'submit) c)))
(article-submitted (lambda (c) (setf (session-value 'submit) c))))
(let ((userid (user-val 'id)))
(when (or (not fuser)
(member userid '(0 2 64)))
(insert-article title url description userid (session-remote-addr *session*) fuser)))))
(defun req-site-info (userid siteid pro-p dem-p hidden-p)
"Returns a list of the following properties: modded-p,
saved-p, :good/:bad. If the site shouldn't be displayed,
returns nil."
(unless (and userid (site-closed-p-sql userid siteid))
(let ((goodbad :good)) ;(if (< (site-prob userid siteid) *prob-threshold*)
;:bad :good)))
(when (or (eql type :both)
(eql type goodbad))
(list
(or (mod-amount-sql userid siteid) 0)
(when (> userid -1)
(site-saved-p-sql userid siteid))
goodbad)))))
(defun print-articles (articles &optional (offset 0) savepage)
(with-html-output (*standard-output*)
(loop for (id title url pop submitter seconds modded saved closed goodbad) in articles
for x = (1+ offset) then (1+ x) do
(htm
(:tr :id (idstr "site")
(:td :valign "top" :class "numbercol" (fmt "~a." x))
(:td :rowspan "3" :valign "top" (rate-area modded id pop) (rate-area modded id pop t))
(:td :colspan "2" :id (idstr "title") :class "evenRow"
;(case goodbad
;(:good (htm (:span :style "color:green" "*")))
;(:bad (htm (:span :style "color:red" "*")))
;(t (log-message* "~a" goodbad)))
(site-link id title url))
(when (logged-in-p)
(htm
(:td :id (idstr "close") :class "evenRow"
:align "right"
:valign "top" (close-button id closed)))))
(:tr (:td)
(:td (expand-button id))
(:td :valign "top" :class "wide little"
(str " by ") (user-link submitter) (fmt " ~a ago with " (age-str seconds))
(:span :id (idstr "pop") (esc (pop-text pop))) (str " ")
(when (and (logged-in-p)
(or savepage
(not saved)))
(htm (:span :id (idstr "save") (save-link id saved))))))
(:tr (:td (:input :type "hidden" :id (idstr "descr")
:value (format nil "This is a lame description of ~a" (esc title))))
(:td :colspan "3" :class "wide" :id (idstr "info")))
(:tr (:td :colspan "3" :class "spacing"))))))
(defun page-test ()
(let ((count (or (session-value :count) 0))
(time (if (> (get-universal-time) (+ 10 (or (session-value :time) 0)))
(get-universal-time)
(session-value :time))))
(handle-if-modified-since time)
(setf (session-value :count) (1+ count))
(with-html-output (*standard-output*)
(setf (header-out "Last-Modified") (rfc-1123-date time))
(setf (session-value :time) time)
(format nil "compute time: ~a<br/>session-time: ~a<br/>header time: ~a<br/>count: ~a"
(rfc-1123-date time) (rfc-1123-date (session-value :time))(header-in "If-Modified-Since") count))))
(defun page-test ()
(let ((count (or (session-value :count) 0))
(time (if (> (get-universal-time) (+ 10 (or (session-value :time) 0)))
(get-universal-time)
(session-value :time))))
(handle-if-modified-since time)
(setf (session-value :count) (1+ count))
(with-html-output (*standard-output*)
(setf (header-out "Last-Modified") (rfc-1123-date time))
(setf (session-value :time) time)
(format nil "compute time: ~a<br/>session-time: ~a<br/>header time: ~a<br/>count: ~a"
(rfc-1123-date time) (rfc-1123-date (session-value :time))(header-in "If-Modified-Since") count))))
(defun get-articles (&optional (limit 25) (offset 0) (sort :front) (today nil))
(select [articles id] [title] [url] [sum [amount]] [screenname] (sql-operation 'function "seconds" [articles date])
:from '([articles] [users] [mod_article])
:where [and [= [articles id] [article]]
[= [submitter] [users id]]
(if (eql sort :front) [> [pop] *min-front-page-pop*] t)
(if today [> [articles date] [- [current_timestamp] (sql-expression :string "interval '1 day'")]] t)]
:group-by (sql-expression :string "articles.id, title, url, pop, screenname, articles.date")
:order-by (case sort
(:pop `((,[sum [amount]] desc)))
(:new '(([articles date] desc)))
(:prom `((,[max [mod_article date]] desc)))
(t `((,[- [sum [amount]]
[/ (sql-operation 'function "seconds" [articles date])
3600]] desc))))
:offset offset
:limit limit
:result-type '(:int t t t t t)))
(defun profile-sites (userid limit offset display)
"display can be :saved :hidden :submitted :promoted :demoted"
(select [articles id] [title] [url] [sum [amount]] [screenname] (sql-operation 'function "seconds" [articles date])
:from '([articles] [users] [mod_article])
:where [and [= [articles id] [article]]
[= [users id] [submitter]]
(case display
(:saved [and [= userid [saved_sites userid]]
[= [articles id] [saved_sites article]]])
(:hidden [and [= userid [closed_sites userid]]
[= [articles id] [closed_sites article]]])
(:submitted [= [submitter] userid])
(:promoted [> [select [amount] :from [mod_article]
:where [and [= [userid] userid]
[= [article] [articles id]]]
:limit 1]
0])
(:demoted [< [select [amount] :from [mod_article]
:where [and [= [userid] userid]
[= [article] [articles id]]]
:limit 1]
0]))]
:group-by (sql-expression :string "articles.id, title, url, pop, screenname, articles.date")
:order-by '(([articles date] desc))
:offset offset
:limit limit
:result-type '(:int t t t t t)))
function modup(id, up, down) {
var ra = document.getElementById("rate" + id);
ra.innerHTML = "<div class='arrow aup'></div>" +
"<a class='arrow adown' href='javascript:moddown(" + id + "," + up + "," + down + ")'></a>";
modsite(id, 1, up + 1, down);
}
function moddown(id, up, down) {
var ra = document.getElementById("rate" + id);
ra.innerHTML = "<a class='arrow aup' href='javascript:modup(" + id + "," + up + "," + down + ")'></a>" +
"<div class='arrow adown'></div>";
modsite(id, -1, up, down + 1);
}
function modsite(id, dir, up, down) {
var pop = document.getElementById("pop" + id);
var percent = Math.round(100 * up / (up + down));
pop.innerHTML = "[" + percent + "% of " + (up + down) + "] ";
pop.className = "little highlight";
new Ajax.Request('/aop', {parameters: "action=mod&id="+id+"&dir="+dir});
}
function expand(id) {
var info = document.getElementById("info" + id);
var button = document.getElementById("ex" + id);
info.appendChild(infoPanel(id));
//info.className = "info wide";
button.className = "collapse";
button.onclick = function(){collapse(id)};
}
function collapse(id) {
var info = document.getElementById("info" + id);
var button = document.getElementById("ex" + id);
info.innerHTML = "";
//info.className = "wide"
button.className = "expand";
button.onclick = function(){expand(id)};
}
function infoPanel (id) {
var descr = document.getElementById("descr" + id);
var info = document.createElement("div");
info.className = "info";
var ddiv = document.createElement("div");
ddiv.style.marginBottom = "4px";
ddiv.innerHTML = descr.value;
info.appendChild(ddiv);
var ldiv = document.createElement("div");
var links = new Array("edit title", "editTitle(" + id + ")",
"edit description", "editDesc(" + id + ")");
for (i = 0; i < links.length; i++) {
ldiv.appendChild(createLink(links[i], links[++i]));
if (i < links.length - 1) ldiv.appendChild(document.createTextNode(" | "));
}
ldiv.className = "little gray";
info.appendChild(ldiv);
return info;
}
function createLink (text, fn) {
var a = document.createElement("a");
a.href = "javascript:" + fn;
a.innerHTML = text;
return a;
}
function editTitle (id) {
var titlerow = document.getElementById("titlerow" + id);
var title = document.getElementById("title" + id);
if (!title) return;
var oldtitle = title.innerHTML;
oldtitles[id] = titlerow.innerHTML;
titlerow.innerHTML = "";
var titlebox = textBox(oldtitle);
titlebox.style.marginRight = "3px";
titlerow.appendChild(titlebox);
var savebtn = button("save",
function () {
titlerow.innerHTML = oldtitles[id];
oldtitles[id] = null;
var title = document.getElementById("title" + id);
title.innerHTML = titlebox.value;
});
savebtn.style.marginRight = "3px";
var canbtn = button("cancel",
function () {
titlerow.innerHTML = oldtitles[id];
oldtitles[id] = null;
});
titlerow.appendChild(savebtn);
titlerow.appendChild(canbtn);
}
function textBox(text) {
var box = document.createElement("input");
box.type = "text";
box.value = text;
box.size = 40;
return box;
}
function button(text, fn) {
var btn = document.createElement("input");
btn.type = "submit";
btn.value = text;
btn.onclick = fn;
btn.className = "btn";
return btn;
}
function createCookie(name,value,days)
{
if (days)
{
var date = new Date();
date.setTime(date.getTime()+(days*24*60*60*1000));
var expires = "; expires="+date.toGMTString();
}
else var expires = "";
document.cookie = name+"="+value+expires+"; path=/";
}
function readCookie(name)
{
var nameEQ = name + "=";
var ca = document.cookie.split(';');
for(var i=0;i < ca.length;i++)
{
var c = ca[i];
while (c.charAt(0)==' ') c = c.substring(1,c.length);
if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
}
return null;
}
function eraseCookie(name)
{
createCookie(name,"",-1);
}
(defun page-wtf ()
(reddit-page (:menu (top-menu (browse-menu)) :right-panel (right-panel-main))
(:div :class "meat"
(with-parameters ((id "id"))
;;There has got to be a better way than (or blah '(nil nil))
(destructuring-bind ((title url) others) (list (or (site-tl id) '(nil nil)) (get-wtf-site id))
(if (and title url)
(let* ((mywtf (get-wtf-user (user-val 'id) id))
(reason (and mywtf (wtf-reason mywtf)))
(other (not (member reason `("lame" "duplicate" "bad link" "spam") :test #'string=))))
(htm
(:h1 "report site")
(:h2 (esc title))
(when (logged-in-p)
(htm
(:p (hbar "reason for karmic retribution"))
(when reason (htm (:span :class "error" "you have reported this link")))
(:form :class "nomargin" :id "repform" :onsubmit (makestr "wtf("id"); return false")
(:table
(:tr
(:td (:input :class "radio" :type "radio"
:value "lame" :name "reason"
:checked (or (not reason) (string= reason "lame")) "lame"))
(:td (:input :class "radio" :type "radio"
:value "duplicate" :name "reason"
:checked (string= reason "duplicate") "duplicate"))
(:td (:input :class "radio" :type "radio"
:value "bad link" :name "reason"
:checked (string= reason "bad link") "bad link"))
(:td (:input :class "radio" :type "radio"
:value "spam" :name "reason"
:checked (string= reason "spam") "spam"))
(:td (:input :class "radio" :type "radio"
:value "other" :name "reason"
:checked (and reason other) :id "radother" "other"))
(:td (:input :type "text" :name "desc"
:value (and other reason) :onfocus "focusother()"))
(:td (:button :class "btn" :type "submit" "save"))
(:td (:button :class "btn" :onclick (makestr "unwtf("id"); return false") "remove"))
(:td :class "error" :id (idstr "repstatus") " "))))))
(:p (hbar "previous reasons"))
(:table
(loop for wtf in others do
(htm
(:tr
(:td :class "reptable little" (esc (print-date (wtf-date wtf))))
(:td :class "reptable" (user-link (user-name (wtf-user wtf))))
(:td :class "reptable" (esc (wtf-reason wtf)))))))))
(htm (:span :class "error" "that site does not exist"))))))))
function wtf(id) {
var status = document.getElementById("repstatus"+id);
var form = document.getElementById("repform");
var radother = document.getElementById("radother");
if(radother.checked && form.desc.value == "") {
status.innerHTML = "enter a reason";
return false;
}
status.innerHTML = "saving...";
new Ajax.Request('/aop', {parameters: "action=wtf&id="+id+"&"+Form.serialize(form),
onComplete:function(r){window.location.reload()}});
}
;;----------------------------- wtf site ------------------------------
(defun get-wtf-user (userid site)
(car (select 'wtf :where [and [= userid [userid]]
[= site [article]]]
:flatp t )))
(defun get-wtf-site (site)
"Returns the number of dupes, the number of bads, and a list of
the others."
(select 'wtf :where [= [article] site] :order-by `(([date] desc)) :flatp t ))
(defun wtf (userid site reason)
(and userid site reason
(let ((wtf (or (get-wtf-user userid site)
(make-instance 'wtf :userid userid :articleid site))))
(log-message* "WTF user: ~a site: ~a reason: ~a" userid site reason)
(setf (wtf-reason wtf) (shorten-str reason 250)
(wtf-date wtf) (get-time))
(update-records-from-instance wtf))))
(defun remove-wtf (userid site)
(when-bind (wtf (get-wtf-user userid site))
(log-message* "UNWTF userid: ~a article: ~a" userid site)
(delete-instance-records wtf)))
(defun wtf-and-mod (userid articleid reason ip)
(when-valid (:userid userid :articleid articleid :ip ip)
(if reason
(progn
(wtf userid articleid reason)
(like-site userid articleid nil)
(check-and-mod-article userid articleid ip -1)
(check-and-mod-user userid articleid ip -1))
(progn
(remove-wtf userid articleid)
(check-and-mod-article userid articleid ip 0)
(check-and-mod-user userid articleid ip 0)))))
(define-callback wtf (id reason desc)
(let ((id (sanitize id 'int)))
(cond ((member reason '("lame" "duplicate" "bad link" "spam") :test #'string=)
(wtf-and-mod (user-val 'id) id reason (session-remote-addr *session*)))
((and (string= reason "other") (> (length desc) 0))
(wtf-and-mod (user-val 'id) id desc (session-remote-addr *session*))))))
(define-callback unwtf (id)
(let ((id (sanitize id 'int)))
(wtf-and-mod (user-val 'id) id nil (session-remote-addr *session*))))
function toggle(id, cl) {
var toggle = document.getElementById("tog" + id);
var dir;
if (toggle.className == "star yellow") {
if (cl || CLICKS[id]) {
toggle.className = "star gray";
setStarCookie(id, "g");
}
else {
toggle.className = "star clear";
setStarCookie(id, "c");
}
dir = 0;
}
else {
toggle.className = "star yellow";
setStarCookie(id, "y");
dir = 1;
}
new Ajax.Request('/aop', {parameters: "action=mod&id="+id+"&dir="+dir});
}

60
options.lisp Normal file
View File

@@ -0,0 +1,60 @@
;;;; 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 user-options (id)
"Returns a user's options"
(mapcar #'(lambda (val sym) (cons sym val))
(or (mapcar #'(lambda (arg)
(cond ((numberp arg) arg)
((string= "t" arg) t)
(t nil)))
(and id
(car (select [visible] [promoted] [demoted] [numsites]
:from [options]
:where [= [userid] id]
:flatp t))))
'(nil t nil 25))
'(:visible :promoted :demoted :numsites)))
(defun sql-bool (bool)
(if bool [true] [false]))
(defun set-user-options (id vis pro dem numsites)
"Sets a user's options"
(let ((options `((visible ,(sql-bool vis))
(promoted ,(sql-bool pro))
(demoted ,(sql-bool dem))
(numsites ,numsites))))
(if (select [userid] :from [options] :where [= [userid] id])
(update-records [options]
:av-pairs options
:where [= [userid] id])
(insert-records :into [options]
:av-pairs (cons `(userid ,id) options)))))
(defun user-vis-p (userid)
(string= "t" (car (select [visible] :from [options]
:where [= [userid] userid]
:flatp t))))

31
packages.lisp Normal file
View File

@@ -0,0 +1,31 @@
;;;; 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 #:cl-user)
(defpackage #:reddit
(:use #:cl
#:tbnl
#:cl-ppcre
#:trivial-http
#:cl-who
#:clsql-user
#:cl-smtp
#:ironclad))

45
recommend.lisp Normal file
View File

@@ -0,0 +1,45 @@
;;;; 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 *email-scanner* (create-scanner "^\\w*[+-._\\w]*\\w@\\w[-._\\w]*\\w\\.\\w{2,3}$"))
(defparameter *token-scanner* (create-scanner "[,;\\s]+"))
(defun is-email (str)
(scan-to-strings *email-scanner* str))
(defun tokens (str)
(split *token-scanner* str))
(defun email-lst (rcpts info &optional emails expanded)
(cond ((consp rcpts)
(email-lst (cdr rcpts) info (email-lst (car rcpts) info emails expanded) (push (car rcpts) expanded)))
((is-email rcpts)
(pushnew rcpts emails :test #'string=))
((not (member rcpts expanded :test #'string=))
(email-lst (tokens (user-alias info rcpts)) info emails (push rcpts expanded)))
(t emails)))
(defun decode-aliases (str info)
(email-lst (tokens str) info))
(defun reformat-aliases (str)
(format nil "~{~a~^, ~}" (delete-duplicates (tokens str) :test #'string=)))

38
reddit.asd Normal file
View File

@@ -0,0 +1,38 @@
;;;; Silly emacs, this is -*- Lisp -*- (or thereabouts)
(in-package #:cl-user)
(defpackage #:reddit-system
(:use #:asdf #:cl))
(in-package #:reddit-system)
(defsystem reddit
:depends-on (:tbnl
:cl-ppcre
:trivial-http
:cl-who
:clsql
:clsql-postgresql
:cl-smtp
:ironclad)
:components ((:file "packages")
(:file "cookiehash" :depends-on ("packages" "data"))
(:file "recommend" :depends-on ("packages" "user-info"))
(:file "frame" :depends-on ("packages" "web"))
(:file "autocompute" :depends-on ("packages"))
(:file "user-info" :depends-on ("data" "packages"))
(:file "web" :depends-on ("packages" "mail" "recommend" "data" "util" "mail" "rss" "memcached" "sites" "view-defs" "user-info" "cookiehash"))
(:file "data" :depends-on ("packages" "view-defs" "util"))
(:file "view-defs" :depends-on ("packages"))
(:file "mail" :depends-on ("packages"))
(:file "util" :depends-on ("packages"))
(:file "search" :depends-on ("packages"))
;;(:file "options" :depends-on ("packages" "data"))
(:file "memcached" :depends-on ("packages" "crc"))
(:file "crc" :depends-on ("packages"))
(:file "rss" :depends-on ("memcached" "packages" "sites"))
(:file "sites" :depends-on ("packages" "data" "util" "search" "autocompute" "user-info"))
(:file "mail" :depends-on ("packages" "data"))
(:file "user-panel" :depends-on ("data" "packages" "web" "sites"))))

61
rss.lisp Normal file
View File

@@ -0,0 +1,61 @@
;;;; 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 rss-sites (rssurl siteurl name sort)
(let ((sites (get-articles-cached 25 0 sort)))
(with-html-output-to-string (*standard-output* nil)
(format t "<?xml version='1.0' encoding='UTF-8'?>")
(format t "<rdf:RDF xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#' xmlns='http://purl.org/rss/1.0/'>")
(:channel :|rdf:about| rssurl
(:title (esc (conc "reddit.com: " name)))
(:link (esc siteurl))
(:description "what's new on the web")
(:items
(format t "<rdf:Seq>")
(loop for article in sites do
(with-accessors ((title article-title)
(url article-url)) article
(htm (:|rdf:li| :|rdf:resource| (escape-string url)))))
(format t "</rdf:Seq>")))
(loop for article in sites do
(with-accessors ((title article-title)
(url article-url)) article
(htm
(:item :|rdf:about| (escape-string url)
(:title (esc title))
(:link (esc url))))))
(format t "</rdf:RDF>"))))
(defun rss-hot ()
(setf (content-type) "text/xml")
(cached ("rsshot" 900)
(rss-sites "http://reddit.com/rss/hot" "http://reddit.com/" "hottest" :front)))
(defun rss-new ()
(setf (content-type) "text/xml")
(cached ("rssnew" 900)
(rss-sites "http://reddit.com/rss/new" "http://reddit.com/new" "newest" :new)))
(defun rss-pop ()
(setf (content-type) "text/xml")
(cached ("rsspop" 900)
(rss-sites "http://reddit.com/rss/pop" "http://reddit.com/pop" "top all-time" :pop)))

31
scraper.lisp Normal file
View File

@@ -0,0 +1,31 @@
;;;; 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 *delicious-url* "http://del.icio.us/popular/")
(defparameter *delicious-scanner* (create-scanner "(?s)<div class=\"post\">.+?<a href=\"([^\"]+)\">([^<]+)</a>.+?by <a href=\"[^\"]+\">(\\w+?)</a>.+?>and ([\\d]+)"))
(defun delicious-articles (&optional (ending ""))
(let ((articles))
(do-register-groups (url title poster pop)
(*delicious-scanner* (website-string (concatenate 'string *delicious-url* ending)))
(push (list title url pop poster) articles))
(nreverse articles)))

59
search.lisp Normal file
View File

@@ -0,0 +1,59 @@
;;;; 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 search-char (c)
"T if c is an a letter, number, or '"
(or (alphanumericp c)
(member c '(#\' #\space #\"))))
(defmacro rra (rex new str)
"Make regex-replace-all lest awkward to type"
`(regex-replace-all ,rex ,str ,new))
(defun to-search-str (str)
"Formats the incoming str into a valid tsearch string"
(rra "(?i) or | " "|"
(rra "\\s+$" ""
(rra "^\\s+" ""
(rra "(?i) and " "&"
(rra "\\s+" " "
(rra "\\\"" "'"
(remove-if-not #'search-char str))))))))
(defun search-sites (str &optional (limit 25) (offset 0))
(when (> (length str) 0)
(let ((q (format nil "to_tsquery('default', ~a)" (sql (to-search-str str)))))
(select 'article-with-sn
:where (sql-expression :string (format nil "idxfti @@ ~a" q))
:order-by `((,(sql-expression :string (format nil "rank(idxfti, ~a)" q)) desc)
(,[articles_sn date] desc))
:offset offset
:limit limit
:flatp t))))

199
sites.lisp Normal file
View File

@@ -0,0 +1,199 @@
;;;; 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 *min-front-page-pop* 2)
(defparameter *prob-threshold* .7)
(defparameter *hot-factor* 2000)
(destroy-processes "cached-hot")
(destroy-processes "cached-new")
(destroy-processes "cached-pop")
(defun get-articles (&optional (limit 25) (offset 0) (sort :front))
(select 'article-with-sn
:where (if (eql sort :front) [> [pop] *min-front-page-pop*] t)
:order-by (case sort
(:pop '(([pop] desc)))
(:new '(([articles_sn date] desc)))
(t `(;;(,(sql-operation 'function "recent_pop" [id]) desc)
(,[- [pop]
[/ (sql-operation 'function "seconds" [date]) *hot-factor*]] desc))))
:offset offset
:limit limit
:flatp t
:caching nil))
(defparameter *cached-hot* (make-instance 'ac :name "cached-hot" :period 30
:fn #'(lambda () (with-web-db (get-articles 500 0 :front)))))
(defparameter *cached-new* (make-instance 'ac :name "cached-new" :period 30
:fn #'(lambda () (with-web-db (get-articles 500 0 :new)))))
(defparameter *cached-pop* (make-instance 'ac :name "cached-pop" :period 30
:fn #'(lambda () (with-web-db (get-articles 500 0 :pop)))))
;;(defparameter *cached-hot* nil)
;;(defparameter *cached-new* nil)
;;(defparameter *cached-pop* nil)
(defun get-articles-cached (&optional (limit 25) (offset 0) (sort :front))
(let ((val (case sort
(:front (and *cached-hot* (ac-val *cached-hot*)))
(:new (and *cached-new* (ac-val *cached-new*)))
(:pop (and *cached-pop* (ac-val *cached-pop*))))))
(if (> (+ offset limit) (length val))
(get-articles limit offset sort)
(subseq val offset (+ offset limit)))))
(defun profile-sites (userid limit offset display)
"display can be :saved :hidden :submitted :promoted :demoted"
(select 'article-with-sn
:where (case display
(:saved [and [= userid [saved_sites userid]]
[= [articles_sn id] [saved_sites article]]])
(:hidden [and [= userid [closed_sites userid]]
[= [articles_sn id] [closed_sites article]]])
(:submitted [= [submitter] userid])
(:promoted [and [= [like_site userid] userid]
[= [like_site article] [articles_sn id]]
[= [like_site liked] [true]]])
(:demoted [and [= [like_site userid] userid]
[= [like_site article] [articles_sn id]]
[= [like_site liked] [false]]]))
;;:group-by (sql-expression :string "articles.id, title, url, pop, screenname, articles.date")
:order-by '(([articles_sn date] desc))
:offset offset
:limit limit
:flatp t))
(defun site-tl (articleid)
"Returns the title and link for a particlular site."
(car (select [title] [url] :from [articles]
:where [= [id] articleid]
:flatp t
)))
;;close sites
(defun unclose-site-sql (userid articleid)
(unless (or (null userid)
(null articleid))
(delete-records :from [closed_sites] :where [and [= userid [userid]]
[= articleid [article]]] )))
(defun close-site-sql (userid articleid)
(ignore-errors
(unless (or (null userid)
(null articleid))
(insert-records :into [closed_sites] :values (list userid articleid)))))
(defun site-closed-p-sql (userid articleid)
(and userid articleid
(car (select [article] :from [closed_sites]
:where [and [= userid [userid]]
[= articleid [article]]]
:flatp t
))))
(defun update-site-url (articleid url)
(ignore-errors
(update-records [articles] :attributes '(url) :values (list url) :where [= [id] articleid] )))
(defun update-nytimes-url (articleid url)
(when (and (nytimes-link-p url)
(not (good-nytimes-p url)))
(let ((newurl (good-nytimes url)))
(when newurl
(update-site-url articleid newurl)))))
;;similar urls
(defun similar-urls (url)
(select [id] [url] :from [articles] :where [like [url] (format nil "%~a%" url)] ))
(defun article-id-from-url (url)
(when (> (length url) 0)
(let ((url (base-url url)))
(some #'(lambda (site)
(when (string= (base-url (second site)) url)
(first site)))
(similar-urls url)))))
;;saved sites
(defun save-site (userid articleid)
(unless (or (null userid)
(null articleid))
(ignore-errors
(insert-records :into [saved_sites] :values (list userid articleid)))))
(defun saved-sites (userid)
(select [articles id] [title] [url] :from '([articles] [saved_sites])
:where [and [= [userid] userid]
[= [articles id] [article]]] ))
(defun unsave-site (userid articleid)
(ignore-errors
(delete-records :from [saved_sites] :where [and [= [userid] userid]
[= [article] articleid]] )))
;;check-url
(defun check-url (url)
"Returns the title for this url."
(let* ((url (add-http url))
(article (get-article-sn (article-id-from-url url))))
(or (and article (article-title article)) (website-title url))))
(defun display-site-p (uinfo articleid)
"Given an article-info and the option parameters, decide
whether the site should be display."
(with-slots (promoted demoted numsites) (user-options uinfo)
(and (or promoted (not (eq (user-liked uinfo articleid) :like)))
(or demoted (not (eq (user-liked uinfo articleid) :dislike)))
(not (user-closed uinfo articleid)))))
(defun filter-sites (userinfo articles)
(remove-if-not #'(lambda (article) (display-site-p userinfo (article-id article))) articles))
(defun get-sites-user (userid limit offset sort)
"Gets the next limit sites starting from offset that the user
don't find offensive."
(let ((userinfo (get-info userid)))
(do* ((sites nil (append sites cursites))
(offset offset (+ offset limit))
(usites (get-articles-cached limit offset sort)
(get-articles-cached limit offset sort))
(cursites (if userinfo (filter-sites userinfo usites) usites)
(if userinfo (filter-sites userinfo usites) usites)))
((or (null usites)
(>= (+ (length cursites) (length sites)) limit))
(if (and (null sites) (null cursites))
nil
(let ((final (subseq (append sites cursites) 0 (min limit (+ (or (length sites) 0)
(or (length cursites) 0))))))
(values final
(+ (or (position (car (last final)) usites) 0) offset 1))))))))
(defun get-sites-profile (userid profid limit offset display)
(let ((sites (profile-sites profid limit offset display)))
(values sites (+ offset (length sites)))))
(defun get-search-sites (userid query limit offset)
(let ((sites (search-sites query limit offset)))
(values sites (+ offset (length sites)))))

187
tok-file.lisp Normal file
View File

@@ -0,0 +1,187 @@
;;;; 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)
;;TODO - write a pathname macro such that it'll define these functions
;;with an &optional parameter for the pathname
;;TODO - lock resources that will be accessed by multiple threads -
;;user data and site data
(defparameter *base-dir* #p"/home/reddit/data/")
(defparameter *max-users* 2)
(defparameter *max-sites* 100)
(defvar *site-tokens* (make-hash-table))
(defvar *user-tokens* (make-hash-table))
(defun site-pathname (articleid)
"Returns the pathname for a site datafile."
(merge-pathnames (make-pathname :name (format nil "site~a" articleid))
*base-dir*))
(defun user-pathname (userid type)
"Returns the pathname for userid's file. Type should be :good
or :bad."
(merge-pathnames (make-pathname :name (format nil "user~a~a" userid
(case type
(:good "g")
(:bad "b")
(t (error "good or bad" )))))
*base-dir*))
(defun write-site-tokens (articleid tokens)
"Writes the list of tokens to a file."
(with-open-file (out (site-pathname articleid)
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(when out
(print tokens out))))
(defun read-site-tokens (articleid)
"Reads the list of tokens from a file."
(with-open-file (in (site-pathname articleid)
:direction :input
:if-does-not-exist nil)
(when in
(read in))))
(defun download-site (id url)
(ignore-errors
(write-site-tokens id (tokens-url url))))
(defun write-hash-table (path ht)
"Writes ht to path with a newline between keys and values."
(with-open-file (out path
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(when out
(loop for key being the hash-keys in ht using (hash-value val) do
(print key out)
(print val out)))))
(defun read-hash-table (path)
"Reads alternating keys and vals from path and returns a
hashtable."
(with-open-file (in path
:direction :input
:if-does-not-exist nil)
(when in
(let ((ht (make-hash-table)))
(loop
for key = (read in nil nil)
for val = (read in nil nil)
while (and key val) do
(setf (gethash key ht) val))
ht))))
(defun write-user-tokens (userid goodht badht)
"Writes the user's good/bad tokens to their respective files."
(write-hash-table (user-pathname userid :good) goodht)
(write-hash-table (user-pathname userid :bad) badht))
(defun read-user-tokens (userid)
"Reads a user's good/bad tokens from their respective files."
(list
(or (read-hash-table (user-pathname userid :good)) (make-hash-table))
(or (read-hash-table (user-pathname userid :bad)) (make-hash-table))))
;;TODO functions to write for a specific user, or write all users
(defmacro max-size-hash (name maxsize read-fn &optional write-fn)
"Defines a closure keeps a hashtable under a max size,
populating it with read-fn when required."
`(let ((max ,maxsize)
(fn ,read-fn)
(wfn ,write-fn)
(viewed nil)
(ht (make-hash-table)))
(defun ,name (key)
(multiple-value-bind (data exists) (or (gethash key ht) (funcall fn key) )
(when data
(setf viewed (cons key (remove key viewed)))
(when (> (length viewed) max)
(let ((l (car (last viewed))))
;;write user data
(when wfn
(let ((udata (gethash l ht)))
(funcall wfn l (first udata) (second udata))))
(remhash l ht)
(setf viewed (remove l viewed :from-end t))))
(unless exists
(setf (gethash key ht) data))
data)))))
(max-size-hash user-data 10 #'read-user-tokens #'write-user-tokens)
(max-size-hash site-data 100 #'read-site-tokens)
(defun flag-site (userid articleid goodbad)
"Adds a site's tokens to a user's good/bad table."
(let ((userht (case goodbad
(:good (first (user-data userid)))
(:bad (second (user-data userid)))
(t (error "good or bad"))))
(sdata (site-data articleid)))
(loop for token in sdata do
(setf (gethash token userht) (1+ (gethash token userht 0))))))
(defun token-prob (token goodht badht)
"The probability that a token is good. .01 == max bad, .99 ==
max good."
(let ((g (gethash token goodht 0))
(b (gethash token badht 0))
(gsize (max 1 (hash-table-count goodht)))
(bsize (max 1 (hash-table-count badht))))
(if (>= (+ g b) 5)
(max .01
(min .99 (float (/ (min 1 (/ g gsize))
(+ (min 1 (/ g gsize))
(min 1 (/ b bsize)))))))
.5)))
(defun most-interesting (tokens goodht badht)
"Returns a list of the 15 most interesting (token . prob) pairs
where interesting is the distance from .5 of prob."
(let ((probs (sort
(mapcar #'(lambda (token)
(cons token (token-prob token goodht badht)))
tokens)
#'> :key #'(lambda (x) (abs (- .5 (cdr x)))))))
(subseq probs 0 (min 15 (length probs)))))
(defun combine-probs (probs)
"Returns the combination of probabilities in prob."
(max .01
(min .99
(let ((prod (apply #'* probs)))
(/ prod (+ prod (apply #'* (mapcar #'(lambda (x)
(- 1 x))
probs))))))))
(defun site-prob (userid articleid)
"Returns the probability that userid thinks articleid is good."
(let ((sdata (site-data articleid))
(udata (user-data userid)))
(combine-probs (mapcar #'(lambda (x) (cdr x))
(most-interesting sdata (first udata) (second udata))))))

79
tokenizer.lisp Normal file
View File

@@ -0,0 +1,79 @@
;;;; 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 *body* (create-scanner "(?s)(?i)<body [^>]*>(.*)</body"))
(defparameter *tag* (create-scanner "(?s)<[^>]+?>"))
(defun html-body (html)
(register-groups-bind (body) (*body* html)
body))
(defparameter *min-length* 2)
(defparameter *max-length* 25)
(defun tokens-html-stream (str)
(let ((tokens) (token))
(loop for c = (read-char str nil)
while c do
(if (wordchar c)
(progn
(push c token))
(progn
(when (and (>= (length token) *min-length*)
(<= (length token) *max-length*))
(push (maketok (reverse token)) tokens))
(setf token nil)
(cond
((char= c #\<) (readtag str))
((char= c #\&) (skipescape str))))))
tokens))
(defun readtag (str)
;;eventually read some tags
(skiptag str))
(defun skiptag (str)
(ignore-until str #\>))
(defun skipescape (str)
(ignore-until str #\;))
(defun ignore-until (str e)
(do ((c (read-char str nil nil) (read-char str nil nil)))
((or (not c) (eql c e)))))
(defun wordchar (c) (or (alpha-char-p c) (member c '(#\- #\' #\$ #\!))))
(defun whitechar (c) (member c '(#\Return #\Newline #\Space #\Tab)))
(defun maketok (chars)
(intern (string-downcase (list->string chars)) :keyword))
(defun list->string (lst)
(map 'string #'(lambda (x) x) lst))
(defun tokens-url (url)
(with-open-stream (in (website-stream url))
(remove-duplicates (tokens-html-stream in))))

38
updatedata.lisp Normal file
View File

@@ -0,0 +1,38 @@
;;;; 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 update-pop ()
(query "update articles set pop = site_pop(id)"))
(defun update-karma ()
(query "update users set karma = karma(id)"))
(defun update-avg ()
(query "update users set avgpop = avg_pop(id"))
(defun populate-likes ()
(with-transaction (:database (db))
(loop for (userid article amount) in (select [userid] [article] [amount] :from [mod_article] :database (db)) do
(like-site userid article (plusp amount)))))

106
user-info.lisp Normal file
View File

@@ -0,0 +1,106 @@
;;;; 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)
(defmacro userinfo (info sym &optional article)
(case sym
(id `(user-info-id ,info))
(user `(user-info-obj ,info))
(saved (if article
`(gethash ,article (user-info-saved ,info))
`(user-info-saved ,info)))
(closed (if article
`(gethash ,article (user-info-closed ,info))
`(user-info-closed ,info)))
(clicked (if article
`(gethash ,article (user-info-clicked ,info))
`(user-info-clicked ,info)))
(liked (if article
`(gethash ,article (user-info-liked ,info))
`(user-info-liked ,info)))
;;article == name
(alias (if article
`(gethash ,article (user-info-alias ,info))
`(user-info-alias ,info)))))
(defmacro user-saved (info articleid)
`(userinfo ,info saved ,articleid))
(defmacro user-clicked (info articleid)
`(userinfo ,info clicked ,articleid))
(defmacro user-closed (info articleid)
`(userinfo ,info closed ,articleid))
(defmacro user-liked (info articleid)
`(userinfo ,info liked ,articleid))
(defmacro user-alias (info name)
`(userinfo ,info alias ,name))
(defclass user-info ()
((id :initarg :id :initform (error "must specify an id"))
(user :accessor user-obj)
(options :accessor user-options)
(saved :reader user-info-saved :initform (make-hash-table))
(closed :reader user-info-closed :initform (make-hash-table))
(clicked :reader user-info-clicked :initform (make-hash-table))
(liked :reader user-info-liked :initform (make-hash-table))
(alias :reader user-info-alias :initform (make-hash-table :test 'equal))))
(defun make-user-info (id)
(when-bind (userobj (get-user id))
(let ((info (make-instance 'user-info :id id)))
(with-slots (user options) info
(setf user userobj
options (get-user-options id))
(loop for articleid in
(select [article] :from [saved_sites] :where [= [userid] id] :flatp t) do
(setf (user-saved info articleid) t))
(loop for articleid in
(select [article] :from [clicks] :where [= [userid] id] :flatp t) do
(setf (user-clicked info articleid) t))
(loop for articleid in
(select [article] :from [closed_sites] :where [= [userid] id] :flatp t) do
(setf (user-closed info articleid) t))
(loop for (articleid liked) in
(select [article] [liked] :from [like_site] :where [= [userid] id] :flatp t) do
(setf (user-liked info articleid) (if (string= liked "t") :like :dislike)))
(loop for (name val) in
(select [name] [val] :from [alias] :where [= [userid] id] :flatp t) do
(setf (user-alias info name) val)))
info)))
;;------------------------- user store ----------------------------
(defvar *user-info* (make-hash-table))
(defun load-info (id)
(when-bind (info (make-user-info id))
(log-message* "LOAD INFO: ~a" id)
(setf (gethash id *user-info*) info)))
(defun get-info (id)
(or
(gethash id *user-info*)
(load-info id)))
(defun remove-info (id)
(remhash id *user-info*))

166
user-panel.lisp Normal file
View File

@@ -0,0 +1,166 @@
;;;; 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"))))))

203
util.lisp Normal file
View File

@@ -0,0 +1,203 @@
;;;; 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 *title* (create-scanner "(?s)(?i)<title>(.+?)</title>"))
(defparameter *toplevel* (create-scanner "https?://(?:www.)?([^/]*)"))
(defun website-stream (url)
(third (http-get url)))
(defun website-string (url)
(let ((in (third (http-get url))))
(with-output-to-string (s)
(when in
(loop for line = (read-line in nil)
while line do (format s "~a~%" line))
(close in))
s)))
(defun website-title (url)
(log-message* "downloading title for ~a" url)
(ignore-errors
(register-groups-bind (title) (*title* (website-string url))
(remove #\Newline (remove #\Return title)))))
(defun tl-domain (url)
(ignore-errors
(register-groups-bind (tl-dom) (*toplevel* url)
tl-dom)))
(defun replace-alist (alist newlist)
(remove nil
(append newlist
(mapcar #'(lambda (param)
(unless (assoc (car param) newlist)
param))
alist))))
(defun create-url (base params)
(with-output-to-string (s)
(format s "~a?" base)
(loop for param in params
for x = 0 then (1+ x) do
(when (> x 0) (format s "&"))
(format s "~a=~a" (car param) (cdr param)))))
(defun minutes (seconds)
(floor (/ seconds 60)))
(defun hours (seconds)
(floor (/ seconds 3600)))
(defun days (seconds)
(floor (/ seconds 86400)))
(defun age-str (date)
(multiple-value-bind (usec second minute hour day month year) (decode-time date)
(let* ((utime (encode-universal-time second minute hour day month year))
(seconds (- (get-universal-time) utime)))
(cond ((< seconds 7199) (format nil "~a minute~:p" (minutes seconds)))
((< seconds 86400) (format nil "~a hour~:p" (hours seconds)))
(t (format nil "~a day~:p" (days seconds)))))))
(defun sanitize (in type &optional valid-inputs)
(when in
(case type
(int (parse-integer in :junk-allowed t))
(string (if valid-inputs
(when (member in valid-inputs :test #'string=) in)
in))
(sym (let ((ustr (intern (string-upcase in) :keyword)))
(if valid-inputs
(when (member ustr valid-inputs) ustr)
ustr))))))
(defun add-rlist (val lst size)
(if (member val lst)
lst
(cons val (subseq lst 0 (1- size)))))
;;user url
(defparameter *user-url* "/user/([^/]+)/?([^/]*)")
(defun decode-user-url (url)
(register-groups-bind (name fn) (*user-url* url)
(values name fn)))
;;cookies
(defun 2weeks ()
(+ (get-universal-time) 1209600))
(defun -2weeks ()
(- (get-universal-time) 1209600))
(defun 5minutes ()
(+ (get-universal-time) 300))
(defun set-cookie-list (name lst)
(set-cookie name :value (format nil "~{~a~^:~}" lst)
:expires (2weeks)))
(defun add-to-cookie-list (val name lst)
(let ((lst (if (member val lst)
lst
(cons val lst))))
(set-cookie-list name lst)
lst))
(defun get-cookie-list (name)
(mapcar #'(lambda (val) (sanitize val 'int))
(split ":" (cookie-in name))))
;;ny times link
(defparameter *userland* "rssuserland")
(defparameter *goodnytimes* "(?s)<a href=\\\"(http://www.nytimes.com[^\\\"]+?userland[^\\\"]+?)\\\"")
(defparameter *nytimes* "http://www.nytimes.com")
(defun good-nytimes-p (url)
(scan *userland* url))
(defun nytimes-link-p (url)
(not (mismatch *nytimes* url :end2 (length *nytimes*))))
(defun nytimes-genlink-website (url)
(website-string (conc "http://nytimes.blogspace.com/genlink?q=" url)))
(defun good-nytimes (url)
(ignore-errors
(register-groups-bind (goodurl) (*goodnytimes* (nytimes-genlink-website url))
goodurl)))
(defun nytimes-safe-url (url)
(if (and (nytimes-link-p url)
(not (good-nytimes-p url)))
(or (good-nytimes url)
url)
url))
;;important part of urls
(defparameter *baseurl* (create-scanner "(?:https?://)?(?:www.)?([^#]*)"))
(defun base-url (url)
"Removes the http://www and any anchors from a url."
(let ((burl (ignore-errors
(register-groups-bind (burl) (*baseurl* url)
(or burl
url)))))
(when burl
(if (char= #\/ (char burl (1- (length burl))))
(subseq burl 0 (1- (length burl)))
burl))))
(defun add-http (url)
"Add http:// to a url if http:// or https:// isn't already present."
(or (and (mismatch "http://" url :end2 7)
(mismatch "https://" url :end2 8)
(concatenate 'string "http://" url))
url))
(defun makestr (&rest args)
(format nil "~{~a~}" args))
(defun key-str (&rest args)
"Returns a string representation of the arguements with no spaces."
(substitute #\_ #\space (format nil "~{~a~^-~}" args)))
(defun esc-quote (str)
"Returns a string with ' escaped."
(escape-string str :test #'(lambda (c) (char= c #\'))))
(defun shorten-str (str len)
(subseq str 0 (min len (length str))))
(defmacro when-bind ((var expr) &body body)
`(let ((,var ,expr))
(when ,var
,@body)))
(defmacro when-bind* (binds &body body)
(if (null binds)
`(progn ,@body)
`(let (,(car binds))
(if ,(caar binds)
(when-bind* ,(cdr binds) ,@body)))))

270
view-defs.lisp Normal file
View File

@@ -0,0 +1,270 @@
;;;; 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)
;;user
(def-view-class user ()
((id
:db-kind :key
:type integer
:reader user-id)
(screenname
:type string
:reader user-name)
(email
:type string
:accessor user-emai)
(karma
:type integer
:reader user-karma)
(signupdate
:type wall-time
:reader user-date)
(ip
:type string
:reader user-ip))
(:base-table users))
(defmethod user-karma ((u user))
(or (slot-value u 'karma) 0))
;;article
(def-view-class article ()
((id
:db-kind :key
:type integer
:initarg :id
:accessor article-id)
(url
:type string
:accessor article-url
:initarg :url)
(title
:type string
:accessor article-title
:initarg :title)
(date
:type wall-time
:accessor article-date
:initarg :date)
(submitterid
:column submitter
:type integer
:accessor article-submitterid
:initarg :submitterid)
(submitter
:db-kind :join
:db-info (:join-class user :home-key submitterid :foreign-key id :set nil)
:reader article-submitter)
(pop
:type integer
:reader article-pop))
(:base-table articles))
(def-view-class article-with-sn (article)
((screenname
:reader article-sn
:type string))
(:base-table articles_sn))
;;wtf
(def-view-class wtf ()
((userid
:db-kind :key
:type integer
:initarg :userid
:accessor wtf-userid)
(user
:db-kind :join
:db-info (:join-class user :home-key userid :foreign-key id :set nil)
:reader wtf-user)
(article
:db-kind :key
:type integer
:initarg :articleid
:accessor wtf-articleid)
(reason
:type (string 250)
:initarg :reason
:accessor wtf-reason)
(date
:type wall-time
:initarg :date
:accessor wtf-date)))
;;click
(def-view-class click ()
((userid
:type integer
:initarg :userid
:accessor click-userid)
(article
:type integer
:initarg :articleid
:accessor click-articleid)
(date
:type wall-time
:initarg :date
:initform (get-time)
:accessor click-date)
(ip
:type string
:initarg :ip
:accessor click-ip))
(:base-table clicks))
;;like_site
(def-view-class like ()
((userid
:db-kind :key
:type integer
:initarg :userid
:accessor like-userid)
(article
:db-kind :key
:type integer
:initarg :articleid
:accessor like-articleid)
(date
:type wall-time
:initarg :date
:accessor like-date)
(liked
:type boolean
:initarg :like
:accessor like-like))
(:base-table like_site))
;;mod_user
(def-view-class moduser ()
((userid
:db-kind :key
:type integer
:initarg :userid
:accessor moduser-userid)
(article
:db-kind :key
:type integer
:initarg :articleid
:accessor moduser-articleid)
(target
:db-kind :key
:type integer
:initarg :targetid
:accessor moduser-targetid)
(date
:type wall-time
:initarg :date
:accessor moduser-date)
(ip
:type string
:initarg :ip
:accessor moduser-ip)
(amount
:type integer
:initarg :amount
:accessor moduser-amount))
(:base-table mod_user))
;;mod_article
(def-view-class modarticle ()
((userid
:db-kind :key
:type integer
:initarg :userid
:accessor modarticle-userid)
(article
:db-kind :key
:type integer
:initarg :articleid
:accessor modarticle-articleid)
(date
:type wall-time
:initarg :date
:accessor modarticle-date)
(ip
:type string
:initarg :ip
:accessor modarticle-ip)
(amount
:type integer
:initarg :amount
:accessor modarticle-amount))
(:base-table mod_article))
;;neuter
(def-view-class neuter ()
((userid
:type integer
:initarg :userid
:accessor neuter-userid)
(ip
:type :string
:initarg :ip
:accessor neuter-ip))
(:base-table neuter))
;;options
(def-view-class options ()
((userid
:db-kind :key
:type integer
:initarg :userid
:accessor options-userid)
(numsites
:type integer
:initarg :numsites
:accessor options-numsites)
(promoted
:type boolean
:initarg :promoted
:accessor options-promoted)
(demoted
:type boolean
:initarg :demoted
:accessor options-demoted)
(visible
:type boolean
:initarg :visible
:accessor options-visible)
(frame
:type boolean
:initarg :frame
:accessor options-frame))
(:base-table options))
;;alias
(def-view-class alias ()
((userid
:db-kind :key
:type integer
:initarg :userid
:accessor alias-userid)
(name
:db-kind :key
:type string
:initarg :name
:accessor alias-name)
(val
:type string
:initarg :val
:accessor alias-val))
(:base-table alias))

825
web.lisp Normal file
View File

@@ -0,0 +1,825 @@
;;;; 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)+\"&amp;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)))