summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xscripts/cronic54
-rw-r--r--scripts/dailyimgupload.py157
-rw-r--r--scripts/s3upload.py50
-rw-r--r--src/site.clj2956
-rwxr-xr-xsrc/utils.clj9
5 files changed, 1762 insertions, 1464 deletions
diff --git a/scripts/cronic b/scripts/cronic
new file mode 100755
index 0000000..80f1cad
--- /dev/null
+++ b/scripts/cronic
@@ -0,0 +1,54 @@
+#!/bin/bash
+
+# Cronic v2 - cron job report wrapper
+# Copyright 2007 Chuck Houpt. No rights reserved, whatsoever.
+# Public Domain CC0: http://creativecommons.org/publicdomain/zero/1.0/
+
+set -eu
+
+OUT=/tmp/cronic.out.$$
+ERR=/tmp/cronic.err.$$
+TRACE=/tmp/cronic.trace.$$
+LOGDIR=/var/log/cronic
+
+set +e
+"$@" >$OUT 2>$TRACE
+RESULT=$?
+set -e
+
+PATTERN="^${PS4:0:1}\\+${PS4:1}"
+if grep -aq "$PATTERN" $TRACE
+then
+ ! grep -av "$PATTERN" $TRACE > $ERR
+else
+ ERR=$TRACE
+fi
+
+if [ $RESULT -ne 0 -o -s "$ERR" ]
+ then
+ echo "Cronic detected failure or error output for the command:"
+ echo "$@"
+ echo
+ echo "RESULT CODE: $RESULT"
+ echo
+ echo "ERROR OUTPUT:"
+ cat "$ERR"
+ echo
+ echo "STANDARD OUTPUT:"
+ cat "$OUT"
+ if [ $TRACE != $ERR ]
+ then
+ echo
+ echo "TRACE-ERROR OUTPUT:"
+ cat "$TRACE"
+ fi
+fi
+
+# sbostler: write log for all job runs
+SCRIPT=$(basename $1)
+OUTLOG=$(date +"$LOGDIR/$SCRIPT.%Y-%m-%d__%T.log")
+cat "$OUT" > $OUTLOG
+
+rm -f "$OUT"
+rm -f "$ERR"
+rm -f "$TRACE"
diff --git a/scripts/dailyimgupload.py b/scripts/dailyimgupload.py
new file mode 100644
index 0000000..186614d
--- /dev/null
+++ b/scripts/dailyimgupload.py
@@ -0,0 +1,157 @@
+import ctypes
+import datetime
+import os
+import platform
+import shutil
+import sys
+import traceback
+import s3upload
+
+
+def freespace(p):
+ """
+ FROM: http://atlee.ca/blog/2008/02/23/getting-free-diskspace-in-python/
+ http://stackoverflow.com/questions/51658/cross-platform-space-remaining-on-volume-using-python
+ Returns the number of free bytes on the drive that ``p`` is on
+ """
+ if platform.system() == 'Windows':
+ free_bytes = ctypes.c_ulonglong(0)
+ ctypes.windll.kernel32.GetDiskFreeSpaceExW(ctypes.c_wchar_p(p), None, None, ctypes.pointer(free_bytes))
+ return free_bytes.value
+ else:
+ s = os.statvfs(p)
+ return s.f_bsize * s.f_bavail
+
+def directory_size(path):
+ """
+ FROM: http://stackoverflow.com/questions/1392413/calculating-a-directory-size-using-python
+ """
+ total_size = 0.0
+ for dirpath, dirnames, filenames in os.walk(path):
+ for f in filenames:
+ fp = os.path.join(dirpath, f)
+ total_size += os.path.getsize(fp)
+ return total_size
+
+def parse_date_dir(d, date_fmt):
+ if not os.path.exists(d):
+ raise ValueError('%s does not exist' % d)
+ if not os.path.isdir(d):
+ raise ValueError('%s is not a directory' % d)
+ return datetime.datetime.strptime(os.path.basename(d), date_fmt)
+
+def is_date_dir(d, date_fmt):
+ try:
+ parse_date_dir(d, date_fmt)
+ return True
+ except ValueError:
+ return False
+
+def get_directory_list(path, date_fmt='%Y%m%d'):
+ parse_func = lambda d: parse_date_dir(d, date_fmt)
+ subdirs = [os.path.join(path, child) for child in os.listdir(path)]
+ datedirs = [d for d in subdirs if is_date_dir(d, date_fmt)]
+ return sorted(datedirs, key=parse_func)
+
+
+def upload_dirs_until_free(path, target_free_mbs, dryrun):
+ starting_freespace = float(freespace(path))
+ dirs_uploaded = 0
+ files_uploaded = 0
+ cur_freespace = starting_freespace
+ reclaimed_space = 0.0
+ error = False
+ directory_list = get_directory_list(path)
+
+ if not directory_list:
+ print "Target directory %s has no subdirectories!" % path
+ sys.exit(1)
+
+ print "Target directory: %s" % path
+ print "Starting freespace: %.02f MBs" % (starting_freespace / 1024 / 1024)
+ print "Target freespace: %.02f MBs" % target_free_mbs
+ print "Image subdirectories: %s" % len(directory_list)
+
+ if dryrun:
+ print
+ print '!!! Doing dryrun -- current free space will be estimated !!!'
+
+ print
+ try:
+ for dir_to_upload in directory_list:
+ if cur_freespace >= target_free_mbs * 1024 * 1024:
+ break
+
+ dir_size = directory_size(dir_to_upload)
+ print 'Uploading %s (%.02f MBs)' % (dir_to_upload, dir_size / 1024 / 1024)
+
+ res = s3upload.do_upload(dir_to_upload, verbose=False, dryrun=dryrun)
+ files_uploaded += res['files_uploaded']
+ print "%s files uploaded in %.02fs" % (res['files_uploaded'], res['sec_elapsed'])
+
+ dirs_uploaded += 1
+ reclaimed_space += dir_size
+
+ if not dryrun:
+ print "Deleting %s" % dir_to_upload
+ shutil.rmtree(dir_to_upload)
+
+ if dryrun:
+ cur_freespace += dir_size
+ else:
+ cur_freespace = float(freespace(path))
+ print "%.02f MBs now free" % (cur_freespace / 1024 / 1024)
+ print
+
+ except Exception:
+ print "An unexpected error occured!"
+ error = True
+ traceback.print_exc()
+
+ print "---------------------------------------"
+ if error:
+ pass
+ else:
+ pass
+ print "Finished successfully" if not error else "!!! Terminated abnormally !!!"
+ print "Current free space: %.02f MBs" % (cur_freespace / 1024 / 1024)
+ print "Reclaimed space: %.02f MBs" % (reclaimed_space / 1024 / 1024)
+ print "Directories uploaded: %s" % dirs_uploaded
+ print "Files uploaded: %s" % files_uploaded
+
+
+if __name__ == '__main__':
+ if not 4 <= len(sys.argv) <= 5:
+ print "usage: dailyimgupload.py workingdir path megabytes [dryrun]"
+ sys.exit(1)
+
+ wd = sys.argv[1]
+ if not os.path.isdir(wd):
+ print "Invalid working directory: %s" % wd
+ sys.exit(1)
+ print "Switching working directory to %s" % wd
+ os.chdir(wd)
+
+ path = sys.argv[2]
+ if not os.path.isdir(path):
+ print "invalid image directory: %s" % path
+ sys.exit(1)
+
+ mbs = sys.argv[3]
+ try:
+ target_free_mbs = float(mbs)
+ except ValueError:
+ print "invalid number of megabytes: %s" % mbs
+ sys.exit(1)
+
+ if len(sys.argv) == 5:
+ dryrun = sys.argv[4]
+ if dryrun in ('true', 'false'):
+ dryrun = dryrun == 'true'
+ else:
+ print "invalid dry run argument: %s (must be either 'true' or 'false')" % dryrun
+ sys.exit(1)
+ else:
+ dryrun = True
+
+ upload_dirs_until_free(path, target_free_mbs, dryrun)
diff --git a/scripts/s3upload.py b/scripts/s3upload.py
index 724561c..e761ea5 100644
--- a/scripts/s3upload.py
+++ b/scripts/s3upload.py
@@ -9,19 +9,28 @@ CONN = None
AWS_ACCESS_KEY_ID = 'AKIAIOP42NFKLLJXEGJQ'
AWS_SECRET_ACCESS_KEY = '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'
BUCKET_NAME = 'dumpfm'
-COUNTER = 0
+
+def get_or_initialize_aws_connection():
+ global CONN
+ if not CONN:
+ print "Initializing AWS connection with ID %s, bucket %s" % (AWS_ACCESS_KEY_ID,
+ BUCKET_NAME)
+ CONN = S3.AWSAuthConnection(AWS_ACCESS_KEY_ID, AWS_SECRET_ACCESS_KEY)
+ return CONN
+
def retry_func(f, count):
try:
f()
+ except KeyboardInterrupt:
+ raise
except:
if count <= 1: raise
else:
print 'Error! retrying %s more time(s)' % (count - 1)
retry_func(f, count - 1)
-def upload_file(path):
- global COUNTER
+def upload_file(path, verbose=True, dryrun=False):
path = os.path.normpath(path)
if path == '.' or not os.path.isfile(path):
return
@@ -34,35 +43,44 @@ def upload_file(path):
path = path.replace('\\', '/') # Windows hack
start = time.time()
def do_upload():
- CONN.put(BUCKET_NAME, path, S3.S3Object(filedata),
+ conn = get_or_initialize_aws_connection()
+ conn.put(BUCKET_NAME, path, S3.S3Object(filedata),
{'x-amz-acl': 'public-read', 'Content-Type': content_type})
- retry_func(do_upload, 3)
+
+ if not dryrun:
+ retry_func(do_upload, 3)
ms_took = (time.time() - start) * 1000
- print "uploaded %s (%0.0fms) (%sKB)" % (path, ms_took, size / 1024)
- COUNTER += 1
+ if verbose:
+ print "uploaded %s (%0.0fms) (%sKB)" % (path, ms_took, size / 1024)
+ return 1
-def upload_directory(path):
+def upload_directory(path, verbose=True, dryrun=False):
+ counter = 0
for f in sorted(os.listdir(path)):
subpath = os.path.join(path, f)
if os.path.isdir(subpath):
- upload_directory(subpath)
+ counter += upload_directory(subpath, verbose=verbose, dryrun=dryrun)
else:
- upload_file(subpath)
+ counter += upload_file(subpath, verbose=verbose, dryrun=dryrun)
+ return counter
-def do_upload(path):
- global CONN
- CONN = S3.AWSAuthConnection(AWS_ACCESS_KEY_ID, AWS_SECRET_ACCESS_KEY)
+def do_upload(path, verbose=True, dryrun=False):
+ counter = 0
start = time.time()
if os.path.isdir(path):
- upload_directory(path)
+ counter += upload_directory(path, verbose=verbose, dryrun=dryrun)
else:
- upload_file(path)
+ counter += upload_file(path, verbose=verbose, dryrun=dryrun)
s_took = (time.time() - start)
- print "uploaded %s files in %0.0fs" % (COUNTER, s_took)
+
+ if verbose:
+ print "uploaded %s files in %0.0fs" % (counter, s_took)
+ return { 'sec_elapsed': s_took,
+ 'files_uploaded': counter }
if __name__ == "__main__":
diff --git a/src/site.clj b/src/site.clj
index 6f97c81..161f0d5 100644
--- a/src/site.clj
+++ b/src/site.clj
@@ -1,1445 +1,1511 @@
-(ns pichat
- (:import java.lang.System
- java.text.SimpleDateFormat
- java.util.Date
- java.io.File
- javax.imageio.ImageIO
- javax.servlet.http.Cookie
- org.antlr.stringtemplate.StringTemplateGroup)
- (:use clojure.xml
- clojure.contrib.command-line
- clojure.contrib.duck-streams
- clojure.contrib.json.write
- clojure.contrib.seq-utils
- clojure.contrib.sql
- clojure.contrib.str-utils
- clojure.contrib.def
- clojure.contrib.pprint
- config
- admin
- compojure
- email
- fame
- utils
- cookie-login
- session-sweeper
- feed
- rooms
- tags
- scheduled-agent
- user)
- (:require redis))
-
-; Create image directories if they don't exist.
-(.mkdir (new File *image-directory*))
-(.mkdir (new File *avatar-directory*))
-
-
-;; Logging
-
-; is there a better way to do this or am i insane for introducing state? just wanna do
-; (let [log (debug-log)]
-; (log "something")
-; (log "something else")
-; (log)) ; gets log array for output to template
-(defn make-debug-logger
- ([] (make-debug-logger (new java.util.ArrayList)))
- ([log]
- (fn
- ([] (to-array log))
- ([s] (make-debug-logger (.add log s))))))
-
-(defn make-time-logger
- ([] (make-time-logger (new java.util.ArrayList)))
- ([log]
- (fn
- ([] (to-array log));
- ([f & args]
- (let [start (.getTime (new Date))
- ret (apply f args)
- log-string (str f ": " (- (.getTime (new Date)) start) " msecs" )]
- (.add log log-string)
- ret)))))
-
-;; Output
-
-(defn strip-empty-vals [m]
- (into {} (filter (fn [[k v]] (non-empty-string? v)) m)))
-
-(defn process-message-for-json [d]
- (assoc d :created_on (.getTime (d :created_on))))
-
-(defn message-room-link [m]
- (if (= (:key m) "dumpfm")
- "http://dump.fm/chat"
- (format "http://%s.dump.fm" (:key m))))
-
-(defn process-message-for-output [d]
- (escape-html-deep
- (strip-empty-vals
- (if (contains? d :created_on)
- (assoc d
- :created_on (format-timestamp (d :created_on))
- :roomlink (message-room-link d))
- d))))
-
-(defn new-messages [room ts]
- (reverse (take-while #(.after (% :created_on) ts)
- @(room :messages))))
-
-(defn new-favs [nick ts]
- (filter #(.after (:added %) ts)
- (get @fav-map nick [])))
-
-(defn process-user [u]
- (stringify-and-escape (strip-empty-vals u)))
-
-(defn process-directory-listing [d]
- (stringify-and-escape
- (strip-empty-vals d)))
-
-(defn prepare-user-list [room sort?]
- (let [users (vals @(room :users))]
- (map process-user (if sort?
- (sort-by (fn [u] (.toLowerCase (:nick u))) users)
- users))))
-
-(defn updates [nick room ts]
- {"users" (prepare-user-list room false) ; Sorting is done on client
- "messages" (map process-message-for-json
- (new-messages room ts))
- "favs" (new-favs nick ts)})
-
-
-(defn fetch-public-message-by-id [m-id]
- (let [msg (tags/fetch-dump-by-id m-id)]
- (if (and msg (not (:admin_only msg)))
- msg)))
-
-;; User-id/nick cache
-;; I keep needing to grab user-id from a nick so I thought I'd cache them
-;; @timb: I just duplicated this in the user-info map :(
-;; we should reconcile our user caches
-(def user-id-cache (ref {}))
-(def *user-id-cache-size* 500)
-
-(defn user-id-from-nick [nick]
- (let [nick (lower-case nick)
- found (@user-id-cache nick)]
- (if found
- found
- (let [query (str "SELECT user_id FROM users WHERE lower(nick) = ?")
- res (first (do-select [query nick]))]
- (if (nil? res)
- nil
- (let [found (res :user_id)]
- (dosync
- (if (> (count @user-id-cache) *user-id-cache-size*) (ref-set user-id-cache {}))
- (alter user-id-cache assoc nick found))
- found))))))
-
-;; Login code
-
-(defn session-map-from-db
- [user-info]
- {:user_id (user-info :user_id)
- :nick (user-info :nick)
- :is_admin (user-info :is_admin)
- :avatar (user-info :avatar)})
-
-(defn session-assoc-from-db
- [user-info]
- (session-assoc
- :user_id (user-info :user_id)
- :nick (user-info :nick)
- :email (user-info :email)
- :is_admin (user-info :is_admin)
- :avatar (user-info :avatar)
- :password_login true))
-
-;; login-token functions
-
-(defn logged-in?
- "Test whether user is logged in by presence of nick key in session.
- (Apply to request map)"
- [{session :session}]
- (contains? session :nick))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; Login-token version history
-;
-; v0: Format: nick%expiry%token-hash
-; Date: Mists of dump antiquity
-;
-; v1: Format: v1%nick%expiry%token-hash
-; Date: 2010/04/24
-; Note: Contains same information as v0, but created under the
-; wildcard domain (i.e. ".dump.fm") so that logins work
-; across all subdomains.
-
-(defn encode-login-token [nick hash expiry]
- (let [token-hash (sha1-hash hash expiry)]
- (str "v1%" nick "%" expiry "%" token-hash)))
-
-(defn- parse-login-vec [v]
- (try [(aget v 1) (Long/parseLong (aget v 2)) (aget v 3)]
- (catch NumberFormatException _ nil)))
-
-(defn parse-login-token [token]
- ; If users have multiple login-cookies across different domains
- ; (i.e. both "dump.fm" and ".dump.fm"), token will be a vector
- ; instead of a string.
- (if (not (string? token))
- (some identity (map parse-login-token token))
- (let [v (.split token "\\%")]
- (if (and (= (alength v) 4) (= (aget v 0) "v1"))
- (parse-login-vec v)))))
-
-(defn read-login-token [token]
- (if-let [[nick expiry token-hash] (parse-login-token token)]
- (if (>= expiry (System/currentTimeMillis))
- (let [db-info (fetch-nick nick)
- computed-hash (sha1-hash (db-info :hash) expiry)]
- (if (= token-hash computed-hash)
- (select-keys db-info [:user_id :nick :email :is_admin :avatar]))))))
-
-(defn make-login-token
- [{nick :nick hash :hash}]
- (let [expiration (ms-in-future *login-token-expiry*)
- token (encode-login-token nick hash expiration)]
- (set-cookie *login-token-key* token
- :expires (gmt-string (new Date expiration))
- :domain *cookie-domain*)))
-
-;; Landing
-
-(defn landing [session]
- (redirect-to "/chat"))
-
-(defn log-login [user_id ip]
- ;; i'm using do-cmds here because update-values can't deal with stuff like 'last_login = now()'
- (let [query (format "UPDATE users SET last_ip = '%s'::cidr, last_login = now() WHERE user_id = %s" (str ip) (str user_id))]
- (do-cmds query))
-)
-
-(defn login [session params cookies request]
- (let [nick (or (params :nick) "")
- hash (or (params :hash) "")
- remember-me (= (params :rememberme) "yes")
- db-user (authorize-nick-hash nick hash)
- login-cookie (if remember-me
- (make-login-token db-user)
- (clear-login-token *login-token-key*))
- ip (get-ip request)]
- (if db-user
- (do
- (log-login (db-user :user_id) ip)
- [(session-assoc-from-db db-user)
- login-cookie
- (resp-success "OK")]
- )
- (resp-error "BAD_LOGIN"))))
-
-(defn logout [session]
- [(session-dissoc :nick :user_id :is_admin :avatar)
- (set-cookie *login-token-key* "dummy"
- :expires "Thu, 01-Jan-1970 00:00:01 GMT"
- :domain *cookie-domain*)
- (redirect-to "http://dump.fm/")])
-
-;; Registration
-
-(def muted-ips-query "
-SELECT DISTINCT
- last_ip
-FROM users
-WHERE user_id IN
- (SELECT user_id FROM mutes
- WHERE (set_on + duration) > now()
- AND NOT cancelled)")
-
-(defn get-ip-str [db-ip]
- (first (.split (.getValue db-ip) "/")))
-
-
-(defn ip-recently-muted? [ip]
- (let [muted-ips (set (map (comp get-ip-str :last_ip)
- (do-select [muted-ips-query])))]
- (contains? muted-ips ip)))
-
-(def *reserved-nicks-path* "docs/reserved_nicks.txt")
-(def *reserved-nicks-refresh-period-sec* 300)
-
-(defn load-invalid-nicks []
- (set (read-lines *reserved-nicks-path*)))
-
-(def reserved-nicks
- (scheduled-agent load-invalid-nicks
- *reserved-nicks-refresh-period-sec*
- (load-invalid-nicks)))
-
-(defn nick-reserved? [nick]
- (let [query "SELECT * FROM users WHERE LOWER(nick) = ? LIMIT 1"]
- (or (contains? (poll reserved-nicks) nick)
- (> (count (do-select [query (lower-case nick)])) 0))))
-
-(defn register [session params request]
- (let [nick (or (params :nick) "")
- email (or (params :email) "")
- hash (or (params :hash) "")
- ip (get-ip request)
- invalid-nick-reason (is-invalid-nick? nick)]
- (cond invalid-nick-reason (resp-error invalid-nick-reason)
- (nick-reserved? nick) (resp-error "NICK_TAKEN")
- (ip-recently-muted? ip) (resp-error "RECENTLY_MUTED")
- :else (do
- (do-insert :users
- [:nick :hash :email]
- [nick hash email])
- (let [db-user (fetch-nick nick)
- user_id (db-user :user_id)
- query (format "UPDATE users SET created_ip = '%s'::cidr WHERE user_id = %s" (str ip) (str user_id))]
- (try (send-registration-email nick email)
- (catch Exception e nil))
- (do-cmds query) ; timb: doing this update query rather than using previous insert because jdbc
- ; can't figure out how to convert to cidr on prepared statements
- [(session-assoc-from-db db-user)
- (resp-success "OK")])))))
-
-;; Fav scores
-
-(def *score-query* "
-SELECT u.user_id,
- u.nick,
- COUNT(*) AS cnt
-FROM tags t,
- messages m,
- users u
-WHERE t.message_id = m.message_id
- AND m.user_id != t.user_id
- AND m.user_id = u.user_id
-GROUP BY u.user_id, u.nick
-ORDER BY cnt DESC
-")
-
-(defn build-score-list []
- (let [res (vec (do-select [*score-query*]))]
- {:list res
- :map (zipmap (map :nick res) (map :cnt res))}))
-
-(def *scores-refresh-period-sec* (* 29 60))
-
-(def *user-scores*
- (scheduled-agent build-score-list
- *scores-refresh-period-sec*
- []))
-
-(def *piece-map*
- (zipmap
- [:pawn :knight :bishop :rook :queen :king :skull]
- ["&#9823;" "&#9822;" "&#9821;" "&#9820;" "&#9819;" "&#9818;" "&#9760;"]))
-
-(defn score-to-piece [score]
- (cond (= score -1) :skull
- (= score 0) :pawn
- (< score 50) :knight
- (< score 150) :bishop
- (< score 300) :rook
- (< score 1000) :queen
- :else :king))
-
-(def score-to-entity (comp *piece-map* score-to-piece))
-
-(defn lookup-score [nick]
- (if (= (lower-case nick) "scottbot")
- -1
- (let [scores (:map (poll *user-scores*))]
- (get scores nick 0))))
-
-(defn get-user-ranking [offset num]
- (if-let [ranking (:list (poll *user-scores*))]
- (let [cnt (count ranking)]
- (subvec ranking
- (min cnt (* offset num))
- (min cnt (* (inc offset) num))))))
-
-
-;; Profile
-
-(defn pull-random-dump-images [dumps num]
- (take num
- (shuffle
- (set (apply concat
- (map
- (comp take-images :content)
- dumps))))))
-
-(defn profile
- ([session profile-nick] (profile session profile-nick "profile"))
- ([session profile-nick template]
- (if-let [user-info (fetch-nick profile-nick)]
- (let [st (fetch-template template session)
- profile-nick (:nick user-info) ; Update to get right casing
- nick (session :nick)
- logger (make-time-logger)
- is-home (and nick (= nick profile-nick))
- score (lookup-score profile-nick)
- dumps (logger tags/fetch-dumps
- :user-tag-id (:user_id session)
- :nick profile-nick
- :limit 10)
- imgs (pull-random-dump-images dumps 5)]
- (do
- (.setAttribute st "is_home" is-home)
- (doseq [a [:nick :avatar :contact :bio]]
- (let [v (user-info a)]
- (.setAttribute st (name a)
- (if (non-empty-string? v) (escape-html v)))))
- (.setAttribute st "score" (comma-format score))
- (.setAttribute st "score_ent" (score-to-entity score))
- (if (not (empty? imgs))
- (.setAttribute st "imgs" imgs))
- (.setAttribute st "debug_log_items" (logger))
- (.toString st)))
- (resp-error "NO_USER"))))
-
-(defn update-user-db [user-id attr val]
- (with-connection *db*
- (update-values "users" ["user_id = ?" user-id] {attr val})))
-
-(defn update-avatar [session url]
- (update-user-db (session :user_id) "avatar" url)
- [(session-assoc :avatar url)
- (resp-success url)])
-
-(defn update-profile [session params]
- (let [user-id (session :user_id)
- attr (params :attr)
- val (params :val)
- attr-set #{"avatar" "contact" "bio"}]
- (cond (not user-id) (resp-error "MUST_LOGIN")
- (not (and user-id attr val)) (resp-error "BAD_REQUEST")
- (not (contains? attr-set attr)) (resp-error "BAD_REQUEST")
- (= attr "avatar") (update-avatar session val)
- :else (do (update-user-db user-id attr val)
- (resp-success "OK")))))
-
-;; Generic Handler
-
-(defn generic-profile-handler [session nick date msg-id
- func redirecter unknown]
- (if-let [user-info (fetch-nick nick)]
- ;; If a valid msg-id is provided, the date is ignored.
- ;; This makes urls such as /user/bogus/5 valid.
- (cond msg-id (if-let [msg-id (maybe-parse-int msg-id)]
- (func session user-info nil msg-id)
- (redirecter user-info))
- ;; If an invalid date is provided, we redirect to the user's first favs page.
- date (if-let [date (parse-yyyy-mm-dd-date date)]
- (func session user-info date nil)
- (redirecter user-info))
- :else (func session user-info nil nil))
- (unknown)))
-
-;; User log
-
-(defn build-mini-profile [user-info]
- (let [st (fetch-template-fragment "mini_profile")
- nick (user-info :nick)
- score (lookup-score nick)]
- (doseq [a [:nick :avatar :contact :bio]]
- (let [v (user-info a)]
- (.setAttribute st (name a)
- (if (non-empty-string? v) (escape-html v)))))
- (doto st
- (.setAttribute "score" (comma-format score))
- (.setAttribute "score_ent" (score-to-entity score))
- (.toString))))
-
-;; The next-page link is generated by retrieving one additional dump,
-;; and creating a link from its date and message id.
-(defn log-next-page-link [last-msg]
- (format "/%s/%s/%s"
- (:nick last-msg)
- (format-yyyy-mm-dd (:created_on last-msg))
- (:message_id last-msg)))
-
-(defn user-log [session user-info date msg-id]
- (let [st (fetch-template "userlog" session)
- logger (make-time-logger)
- raw-dumps (tags/fetch-dumps
- :nick (:nick user-info)
- :user-tag-id (:user_id session)
- :msg-id msg-id
- :date (if msg-id nil date)
- :limit (inc *dumps-per-page*))
- back-dumps (if (or date msg-id)
- (tags/fetch-dumps
- :nick (:nick user-info)
- :msg-id msg-id
- :date (if msg-id nil date)
- :limit (inc *dumps-per-page*)
- :direction :forward))
- dumps (map process-message-for-output (take *dumps-per-page* raw-dumps))]
- (.setAttribute st "nick" (:nick user-info))
- (.setAttribute st "is_home" (= (:nick user-info) (:nick session)))
- (.setAttribute st "mini_profile" (build-mini-profile user-info))
- (if (> (count dumps) 0)
- (.setAttribute st "dumps" dumps))
- (.setAttribute st "prev"
- (if back-dumps
- (cond
- (> (count back-dumps) *dumps-per-page*) (log-next-page-link (last back-dumps))
- (> (count back-dumps) 1) (format "/%s/log" (:nick user-info))
- :else nil)))
- (if (> (count raw-dumps) *dumps-per-page*)
- (.setAttribute st "next" (log-next-page-link (last raw-dumps))))
- (.setAttribute st "debug_log_items" (logger))
- (.toString st)))
-
-(defn user-log-handler [session nick date msg-id]
- (generic-profile-handler session nick date msg-id
- user-log
- (fn [u] (redirect-to (str "/" (:nick u))))
- #(resp-error "NO_USER")))
-
-;; Who faved me
-
-(def popular-dumps-qry "
-select u.nick, u.avatar, r.key, m.message_id, m.content, m.created_on, count(*) as count,
- array_agg(u2.nick) as user_nicks,
- array_agg(u2.avatar) as user_avs,
- array_agg(t.created_on) as favtime,
- (select exists (select 1 from tags
- where tag = 'favorite' and user_id = ? and message_id = m.message_id)) as favorited
-from users u, messages m, rooms r, tags t, users u2
-where lower(u.nick) = lower(?)
-and u.user_id = m.user_id and m.message_id = t.message_id
-and m.room_id = r.room_id and m.is_image = true and r.admin_only = false
-and t.tag = 'favorite' and t.user_id != u.user_id
-and t.user_id = u2.user_id
-group by u.nick, u.avatar, r.key, m.message_id, m.content, m.created_on
-order by count desc limit ? offset ?")
-
-(def num-popular-dumps 40)
-
-(defn get-popular-dumps [nick user-id]
- (for [d (do-select [popular-dumps-qry user-id nick 40 0])]
- (let [fav-nicks (.getArray (:user_nicks d))]
- (assoc d
- :favers (sort-by :t (comp #(* -1 %) compare)
- (map (fn [n a t] (if (non-empty-string? a)
- {:nick n :avatar a :t t}
- {:nick n :t t}))
- fav-nicks
- (.getArray (:user_avs d))
- (.getArray (:favtime d))))
- :user_nicks nil :user_avs nil :favtime nil))))
-
-(defn popular [session profile-nick]
- (if-let [user-info (fetch-nick profile-nick)]
- (let [st (fetch-template "popular" session)
- profile-nick (:nick user-info)
- raw-dumps (get-popular-dumps profile-nick (or (:user_id session) -1))
- dumps (map process-message-for-output raw-dumps)]
- (.setAttribute st "nick" profile-nick)
- (.setAttribute st "mini_profile" (build-mini-profile user-info))
- (.setAttribute st "dumps" dumps)
- (.toString st))
- (resp-error "NO_USER")))
-
-;; Directory
-
-(def *per-directory-page* 25)
-
-(defn process-directory-entry [entry]
- (let [score (lookup-score (:nick entry))]
- (assoc (stringify-and-escape entry)
- "score_ent" (score-to-entity score)
- "score" score)))
-
-(def directory-cache-ttl (minutes 10))
-(def memoized-lookup-recent-posts-tagless
- (ttl-memoize lookup-recent-posts-tagless directory-cache-ttl))
-
-
-(defn add-recent-posts [user-id users]
- (if-not (empty? users)
- (let [f (if user-id lookup-recent-posts lookup-recent-posts-tagless)
- res (f user-id (map :user_id users))]
- (for [u users]
- (merge u (find-first #(= (:user_id u) (:user_id %)) res))))))
-
-(defn get-directory-info [user-id offset]
- (map process-directory-entry
- (add-recent-posts user-id
- (get-user-ranking offset *per-directory-page*))))
-
-(defn directory [session offset]
- (let [st (fetch-template "directory" session)
- users (get-directory-info (:user_id session) offset)]
- (.setAttribute st "users" users)
- (cond (= offset 0) (.setAttribute st "prev" false)
- (= offset 1) (.setAttribute st "prev" "")
- :else (.setAttribute st "prev" (str "/" (dec offset))))
- (if (> offset 0)
- (.setAttribute st "cur" offset))
- (.setAttribute st "next" (str "/" (inc offset)))
- (.toString st)))
-
-;; Single posts
-
-(defn single-message [session nick-from-url id-from-url]
- (if-let [user-info (fetch-nick nick-from-url)]
- (if-let [message (fetch-public-message-by-id id-from-url)]
- ; error if nick in url doesn't match the nick who posted the message from the id in url
- ; this prevents people from scraping all the content by incrementing the id in the url
- (if (= (user-info :user_id) (message :user_id))
- (let [st (fetch-template "single_message" session)
- message (tags/add-favorited-flag message session)
- message (tags/remove-tags-for-output message)]
- (.setAttribute st "dump" (process-message-for-output message))
- (.toString st))
- (resp-error "NO_MESSAGE"))
- (resp-error "NO_MESSAGE"))
- (resp-error "NO_USER")))
-
-
-;; Chat
-
-(defn validate-room-access [room-key session]
- (if-let [room (lookup-room room-key)]
- (or (not (room :admin_only))
- (is-vip? session))))
-
-(def default-room-template "chat")
-
-(defn lookup-room-template [session room-key template]
- (or (fetch-template (str "rooms/" (or template room-key)) session)
- (fetch-template (str "rooms/" default-room-template) session)))
-
-(defn chat [session room template]
- (if-let [st (lookup-room-template session (:key room) template)]
- (let [now (System/currentTimeMillis)
- nick (session :nick)
- raw-msgs (reverse (tags/fetch-dumps :room (:key room)
- :image-only false
- :user-tag-id (:user_id session)
- :hide-vip false
- :limit (:history_size room)))
- message-list (to-array (map process-message-for-output raw-msgs))]
- (if nick
- (dosync
- (login-user (user-struct-from-session session) room)))
- (doto st
- (.setAttribute "users" (prepare-user-list room true))
- (.setAttribute "messages" message-list)
- (.setAttribute "roomkey" (room :key))
- (.setAttribute "isadminroom" (room :admin_only))
- (.setAttribute "json_room_key" (json-str (room :key)))
- (.setAttribute "json_user_nick" (if nick (json-str nick) "null"))
- (.setAttribute "roomname" (room :name))
- (.setAttribute "dis" (= (room :name) "dis"))
- (.setAttribute "timestamp" now))
- (.toString st))
- [404 "UNKNOWN PAGE"]))
-
-(defn validated-chat
- ([session room-key] (validated-chat session room-key nil))
- ([session room-key template]
- (let [room-key (if (= (lower-case room-key) "www") *default-room* room-key)]
- (if (validate-room-access room-key session)
- (chat session (lookup-room room-key) template)
- (resp-error "UNKNOWN_ROOM")))))
-
-(defn refresh [session params room]
- (dosync
- (let [now (System/currentTimeMillis)
- old-ts (new Date (maybe-parse-long (params :since) now))
- nick (session :nick)
- users (room :users)]
- (if nick
- (if-let [user-info (@users nick)]
- ; Incorporate avatar updates
- (commute users assoc nick (merge user-info {:last-seen now
- :avatar (session :avatar)}))
- (commute users assoc nick (user-struct-from-session session))))
- (resp-success (assoc (updates nick room old-ts)
- :timestamp now)))))
-
-(defn validated-refresh [session params]
- (let [room-key (params :room)
- room (lookup-room room-key)]
- (if (validate-room-access room-key session)
- (refresh session params room)
- (resp-error "UNKNOWN_ROOM"))))
-
-;; admins can post arbitrary html if wrapped in <safe>
-;; this is temporary so that i can test generating html messages
-(defn validated-content [content session]
- (if (.startsWith content "<safe>")
- (if (is-vip? session)
- (str content)
- (str "<unsafe>" content "</unsafe>"))
- (str content)))
-
-(defn msg-db [user-id room-id content]
- (let [msg-type (classify-msg content)
- is-image (boolean (#{:image :mixed} msg-type))
- is-text (boolean (#{:mixed :text} msg-type))
- qry (str "INSERT INTO messages (user_id, room_id, content, is_image, is_text) "
- "VALUES (?, ?, ?, ?, ?) RETURNING message_id")]
- (with-connection *db*
- ((first (do-select [qry user-id room-id content is-image is-text]))
- :message_id))))
-
-(defn msg [session params]
- (let [user-id (session :user_id)
- mute (get (poll *active-mutes*) user-id)
- nick (session :nick)
- room-key (params :room)
- room (lookup-room room-key)
- content (.trim (params :content))]
- (cond (not room) (resp-error "BAD_ROOM")
- (not nick) (resp-error "NOT_LOGGED_IN")
- mute (resp-error (format-mute mute))
- :else
- (let [content (validated-content content session)
- msg-id (msg-db user-id (room :room_id) content)]
- (dosync
- (if (not (contains? (ensure (room :users)) nick))
- (login-user (user-struct-from-session session) room))
- (add-message (build-msg nick content msg-id) room))
- (resp-success msg-id)))))
-
-
-(defn validated-msg [session params request]
- (cond
- (not (validate-room-access (params :room) session)) (resp-error "UNKNOWN_ROOM")
- :else (msg session params)))
-
-;; Browser
-
-;; TODO: make work for all rooms
-(defn browser [session]
- (let [room (lookup-room *default-room*)
- now (System/currentTimeMillis)
- nick (session :nick)
- st (fetch-template "browser" session)]
- (if nick
- (dosync
- (login-user (user-struct-from-session session) room)))
- (let [user-list (prepare-user-list room false)]
- (.setAttribute st "users" user-list))
- (.setAttribute st "roomkey" (room :key))
- (.setAttribute st "isadminroom" (room :admin_only))
- (.setAttribute st "json_room_key" (json-str (room :key)))
- (.setAttribute st "json_user_nick" (if nick (json-str nick) "null"))
- (.setAttribute st "roomname" (room :name))
- (.setAttribute st "timestamp" now)
- (.toString st)))
-
-
-;; Chat Log
-
-(defn log [session room offset params]
- (let [roomkey (room :key)
- st (fetch-template "log" session)
- logger (make-time-logger)
- offset (maybe-parse-int offset 0)
- dump-offset (* offset *dumps-per-page*)
- image-only (and (not (room :admin_only))
- (not= (params :show) "all"))
- raw-dumps (logger tags/fetch-dumps-by-room :room-id (room :room_id)
- :image-only image-only
- :amount (+ 1 *dumps-per-page*)
- :offset dump-offset)
- dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
- ;; json-tags (for [dump dumps :when (not (empty? (dump :tags)))]
- ;; (json-str {"id" (dump :message_id) "tags" (dump :tags) }))
- dumps (map tags/remove-tags-for-output dumps)
- dumps (logger doall (map process-message-for-output dumps))]
- (if (> (count raw-dumps) *dumps-per-page*)
- (.setAttribute st "next" (inc offset)))
- (if (not= offset 0)
- (.setAttribute st "prev" (max (dec offset) 0)))
- (.setAttribute st "dumps" dumps)
- (if (default-room? roomkey)
- (.setAttribute st "roomkey" "")
- (.setAttribute st "roomkey" (str roomkey ".")))
- (.setAttribute st "roomname" (room :name))
- (.setAttribute st "debug_log_items" (logger))
- (.toString st)))
-
-(defn validated-log [session room-key offset params]
- (let [room-key (if (= (lower-case room-key) "www") "dumpfm" room-key)]
- (if (validate-room-access room-key session)
- (log session (lookup-room room-key) offset params)
- (resp-error "UNKNOWN_ROOM"))))
-
-;; Hiscore test... redis test...
-
-(defn redis-ids-test [period]
- (let [reddis-server {:host "127.0.0.1" :port 6379 :db 0}
- ids (redis/with-server reddis-server
- (redis/zrevrange (str "hiscore:" period) 0 -1))
- ids (map maybe-parse-int ids)]
- ids))
-
-(defn hiscore-test [session params period]
- (let [st (fetch-template "hiscore_test" session)
- dumps (tags/fetch-dumps-by-ids (redis-ids-test period))
- dumps (map tags/add-favorited-flag dumps (repeat session))
- dumps (map tags/add-fav-count dumps)
- dumps (reverse (sort-by :favcount dumps))
- dumps (map tags/remove-tags-for-output dumps)
- dumps (map process-message-for-output dumps)]
- (.setAttribute st "dumps" dumps)
- (.toString st)))
-
-
-
-;; Altars
-
-;; if :nick is in params, will fetch only altars by that nick
-;; next page links look like /altars/message-id and select <= message_id order desc
-;; prev page links look like /altars/-message-id and select > message_id order asc
-(defn altar-log [session params]
- (let [id (params :id)
- nick (params :nick)
- user-id (if nick (user-id-from-nick nick) nil)
- template (if user-id "altar_user_log" "altar_log")
- st (fetch-template template session)
- raw-dumps (tags/fetch-altars :message-id id :amount (+ 1 *dumps-per-page*) :user-id user-id)
- dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
- dumps (map tags/remove-tags-for-output dumps)
- dumps (map process-message-for-output dumps)]
- (.setAttribute st "dumps" dumps)
- (.setAttribute st "nick" nick)
- (if (> (count raw-dumps) *dumps-per-page*)
- (.setAttribute st "next" ((last raw-dumps) :message_id)))
- (if id
- (.setAttribute st "prev" ((first raw-dumps) :message_id)))
- (.toString st)))
-
-;; Tags
-
-(defn undecoded-url-piece [url position]
- "Get nth thing out of a url path.
- For example, (undecoded-url-piece 'http://example.com/a/b/c?foo' 2) will return 'c'"
- (let [path-without-domain (nth (re-find #"//[^/]+/(.+)" url) 1)]
- (nth (re-split #"/|\?" path-without-domain) position)))
-
-(defn add-tag [user msg tag]
- (try
- (do-insert "tags"
- ["user_id" "message_id" "tag"]
- [(:user_id user) (msg :message_id) tag])
- (if (and (= tag "favorite")
- (not (= (msg :nick) (user :nick))))
- (insert-fav-notification! (msg :nick)
- (user :nick)
- (user :avatar)
- (msg :content)))
- true
- ; catch error when inserting duplicate tags
- (catch Exception e false)))
-
-
-(defn validated-add-tag [session params]
- (if (session :nick)
- (let [nick (session :nick)
- user-id (session :user_id)
- user-admin? (session :admin-only)
- msg-id (params :message_id)
- tag (validate-tag (params :tag))
- msg (fetch-message-by-id msg-id)
- access (or (is-vip? session)
- (not (:admin-only msg)))]
- (cond (not msg) (resp-error "NO_MSG")
- (not access) (resp-error "NO_MSG")
- (not tag) (resp-error "NO_TAG")
- :else (if (add-tag session msg tag)
- (resp-success "OK")
- (resp-error "TAG_EXISTS_ALREADY_OR_SOMETHING_ELSE_IS_FUCKED"))))
- (resp-error "NO_USER")))
-
-(defn remove-tag [user-id message-id tag]
- (let [query "user_id = ? AND message_id = ? AND lower(tag) = ?"]
- (do-delete "tags" [query user-id (maybe-parse-int message-id) (normalize-tag-for-db (.toLowerCase tag))])
- (resp-success "OK")))
-
-(defn validated-remove-tag [session params]
- (if (session :nick)
- (remove-tag (session :user_id) (params :message_id) (params :tag))
- (resp-error "NO_USER")))
-
-;; message-user-id: get messages posted by this user
-;; tag-user-id: get messages tagged by this user
-(defnk tagged-dumps-template [session params tags url page-title info-bar
- :message-user-id false
- :tag-user-id false
- :logger (make-time-logger)
- :include-vip false]
- (let [st (fetch-template "tagged_dumps" session)
- offset (maybe-parse-int (params :offset) 0)
- dump-offset (* offset *dumps-per-page*)
- raw-dumps (logger tags/fetch-dumps-by-tag :tags tags
- :image-only false
- :amount (+ 1 *dumps-per-page*)
- :offset dump-offset
- :message-user-id message-user-id
- :tag-user-id tag-user-id
- :include-vip include-vip)
- dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
- dumps (map tags/remove-tags-for-output dumps)
- dumps (logger doall (map process-message-for-output dumps))]
- (.setAttribute st "dumps" dumps)
- (.setAttribute st "infobar" info-bar)
- (.setAttribute st "page_title" page-title)
- (.setAttribute st "page_url" url)
- (if (not= offset 0)
- (.setAttribute st "prev" (format "/%s/%s" url (max 0 (dec offset)))))
- (if (> (count raw-dumps) *dumps-per-page*)
- (.setAttribute st "next" (format "/%s/%s" url (inc offset))))
- (.setAttribute st "debug_log_items" (logger))
- (.toString st)))
-
-;; gotta parse tag intersections myself because +'s get decoded into spaces
-;; there's probably a less hacky way to do this
-(defn tagged-dumps-by-nick [session params url]
- (let [nick (params :nick)
- user-id (user-id-from-nick nick)
- user-info (fetch-nick nick)
- info-bar (build-mini-profile user-info)
- tags (map url-decode (re-split #"\+" (undecoded-url-piece url 2)))
- url (str nick "/tag/" (str-join "+" (map url-encode tags)))
- page-title (str "dumps " nick " tagged as '" (escape-html (str-join "' and '" tags)) "'")]
- (tagged-dumps-template session params tags url page-title info-bar :tag-user-id user-id)))
-
-(defn tagged-dumps [session params url]
- (let [tags (map url-decode (re-split #"\+" (undecoded-url-piece url 1)))
- url (str "tag/" (str-join "+" (map url-encode tags)))
- page-title (str "dumps tagged as '" (escape-html (str-join "' and '" tags)) "'")]
- (tagged-dumps-template session params tags url page-title "")))
-
-(defn favorites-next-page-link [nick last-msg]
- (format "/%s/favorites/%s/%s"
- nick
- (format-yyyy-mm-dd (:tagged_on last-msg))
- (:message_id last-msg)))
-
-(defn favorites [session user-info date msg-id]
- (let [st (fetch-template "tagged_dumps" session)
- logger (make-time-logger)
- raw-dumps (tags/fetch-tagged-dumps
- :nick (:nick user-info)
- :user-tag-id (:user_id session)
- :msg-id msg-id
- :date (if msg-id nil date)
- :limit (inc *dumps-per-page*))
- back-dumps (if (or date msg-id)
- (tags/fetch-tagged-dumps
- :nick (:nick user-info)
- :msg-id msg-id
- :date (if msg-id nil date)
- :limit (inc *dumps-per-page*)
- :direction :forward))
- dumps (map process-message-for-output (butlast raw-dumps))]
- (.setAttribute st "prev"
- (if back-dumps
- (cond
- (> (count back-dumps) *dumps-per-page*) (favorites-next-page-link (:nick user-info)
- (last back-dumps))
- (> (count back-dumps) 1) (format "/%s/favorites" (:nick user-info))
- :else nil)))
- (if (> (count raw-dumps) *dumps-per-page*)
- (.setAttribute st "next" (favorites-next-page-link (:nick user-info) (last raw-dumps))))
- (.setAttribute st "dumps" dumps)
- (.setAttribute st "infobar" (build-mini-profile user-info))
- (.setAttribute st "page_title" (format "%s'S FAVS" (:nick user-info)))
- (.setAttribute st "debug_log_items" (logger))
- (.toString st)))
-
-(defn favorites-handler [session nick date msg-id]
- (generic-profile-handler session nick date msg-id
- favorites
- (fn [u] (redirect-to (format "/%s/favorites" (:nick u))))
- #(resp-error "NO_USER")))
-
-(defn json-favorites [session params]
- (let [nick (params :nick)
- user-id (user-id-from-nick nick)
- raw-favs (tags/fetch-tagged-dumps :nick nick
- :limit 50)
- favs (reduce (fn [m fav] (assoc m (str (fav :message_id)) (fav :content))) {} raw-favs)]
- (str "RawFavs=" (json-str favs))))
-
-(defn search-query [num-tokens]
- (str "select
- url from image_urls
- where url ilike " (str-join " and url ilike " (take num-tokens (repeat "?"))) "
- order by last_posted desc
- limit 200;"))
-
-;; note: _ is a wildcard in a postgres 'like' query...
-(defn search-replace-weird-chars [token]
- (str (.replaceAll token "[^A-Za-z0-9\\-.=+]" "_"))
-)
-
-;; timb: this can be called with a callback or not...
-;;
-;; dump.fm/cmd/search/foo -> [result, result]
-;; cons: can only be ajax get'd from the same domain
-;;
-;; dump.fm/cmd/search/foo?callback=someFunc -> someFunc([result, result])
-;; cons: has to use a <script> tag. seems to freeze browser until results returned
-;;
-(defn json-search [undecoded-url-searchterms params]
- (let [tokens (map url-decode (re-split #"\+" undecoded-url-searchterms))
- tokens (map search-replace-weird-chars tokens)
- tokens (map #(str "%" %1 "%") tokens)
- query (search-query (count tokens))
- rows (do-select (vec (concat [query] tokens)))]
- (if (:callback params)
- (str (:callback params) "(" (json-str rows) ")")
- (json-str rows))))
-
-
-;; Local testing
-
-(def random-posts
- ["http://24.media.tumblr.com/tumblr_l41x4eLWZm1qzon5ko1_400.png hi"
- "lol http://29.media.tumblr.com/tumblr_l3o3wuRFpM1qawuaao1_500.jpg"
- "http://dump.fm/images/20100819/1282199186063-dumpfm-timb-dump.stone.logo.gif http://teamassignment.com/images/getmesomemore.jpg http://26.media.tumblr.com/tumblr_l7kro0os531qaajkio1_500.gif"])
-
-(defn make-random-post! []
- (msg {:user_id 1
- :nick "scottbot"
- :avatar "http://i.imgur.com/isKqZ.gif"}
- {:room "dumpfm"
- :content (rand-elt random-posts)}))
-
-(def random-poster
- (scheduled-agent make-random-post! 5 nil))
-
-;; Account resets
-
-(defn reset-request-page [session]
- (.toString (fetch-template "req_reset" session)))
-
-(defn reset-request! [session {nick :nick}]
- (if-let [info (fetch-nick nick)]
- (let [nick (info :nick) ; get correct casing
- email (info :email)
- hash (info :hash)
- ts (System/currentTimeMillis)
- token (reset-token nick hash ts)
- link (reset-link nick token ts)]
- (do (send-reset-email nick email link)
- (resp-success "OK")))
- (resp-error "NO_NICK")))
-
-(defn reset-page [session params]
- (let [st (fetch-template "reset" session)
- nick (params :nick)
- ts (maybe-parse-long (params :ts) 0)
- token (params :token)
- valid (valid-reset-link? nick token ts)]
- (if (and (zero? ts)
- (nil? nick)
- (nil? token))
- (reset-request-page session)
- (do
- (.setAttribute st "valid_request" valid)
- (.setAttribute st "nick" nick)
- (when valid
- (.setAttribute st "link" (reset-link nick token ts)))
- (.toString st)))))
-
-(defn reset-account! [session params]
- (let [nick (params :nick)
- ts (maybe-parse-long (params :ts) 0)
- token (params :token)
- hash (params :hash)]
- (if (and (valid-reset-link? nick token ts) hash)
- (let [info (fetch-nick nick)]
- (update-nick-hash nick hash)
- [(session-assoc-from-db info)
- (redirect-to "http://dump.fm/")])
- [200 "BAD_REQUEST"])))
-
-;; Upload
-
-(def max-avatar-dimensions [800 800])
-(def max-avatar-size (kbytes 500))
-
-(defn is-file-too-big? [f limit]
- (if (> (.length f) limit)
- (str "FILE_TOO_BIG " limit)))
-
-(defn invalid-image-dimensions? [f [max-width max-height]]
- (try
- (let [i (ImageIO/read f)
- height (.getHeight i)
- width (.getWidth i)]
- (if (or (> width max-width)
- (> height max-height))
- (str "INVALID_RESOLUTION " max-width " " max-height)))
- (catch Exception _ "INVALID_IMAGE")))
-
-(defn format-filename [s nick]
- (let [spaceless (.replace s \space \-)
- nick-clean (re-gsub #"[^A-Za-z0-9]" "" nick)
- subbed (re-gsub #"[^\w.-]" "" spaceless)]
- (str-join "-" [(System/currentTimeMillis) "dumpfm" nick-clean subbed])))
-
-(defn image-url-from-file [dir date file]
- (str-join "/" [*server-url* dir date (.getName file)]))
-
-(defn validate-upload-file [f room]
- (or (is-file-too-big? f (:max_file_size room))
- (invalid-image-dimensions? f [(:max_image_width room)
- (:max_image_height room)])))
-
-(defn validate-avatar-file [f]
- (or (is-file-too-big? f max-avatar-size)
- (invalid-image-dimensions? f max-avatar-dimensions)))
-
-
-; Upload notes:
-; The webcam code doesn't feature an error handler,
-; so all upload responses not equal to "OK" are considered
-; errors.
-; The upload code doesn't use jQuery.ajax, and doesn't JSON-eval
-; responses. Therefore, return strings should not be JSON-encoded.
-
-(defn do-upload [session image room]
- (if-let [err (validate-upload-file (image :tempfile) room)]
- (resp-error err)
- (let [filename (format-filename (:filename image) (session :nick))
- date (today)
- dest (open-file [*image-directory* date] filename)
- url (image-url-from-file "images" date dest)
- msg-id (msg-db (session :user_id) (room :room_id) url)
- msg (struct message-struct (session :nick) url (new Date) msg-id)]
- (do
- (dosync
- (add-message msg room))
- (copy (:tempfile image) dest)
- [200 "OK"]))))
-
-(defn upload [session params request]
- (let [room-key (params :room)
- nick (session :nick)
- user-id (session :user_id)
- image (params :image)
- mute (get (poll *active-mutes*) user-id)
- has-access (validate-room-access room-key session)]
- (cond (not nick) [200 "NOT_LOGGED_IN"]
- (not image) [200 "INVALID_REQUEST"]
- mute [200 (format-mute mute)]
- (not has-access) [200 "UNKNOWN_ROOM"]
- :else (do-upload session image (lookup-room room-key)))))
-
-(defn upload-photo [session params]
- (let [room-key (params :room)
- nick "~photobot"
- user-id (rooms/fetch-or-create-bot-id! nick)
- image (params :image)]
- (do-upload {:is_admin true :nick nick :user_id user-id} image (lookup-room room-key))))
-
-;; N.B. -- Upload responses aren't JSON-evaluated
-(defn do-upload-avatar [session image]
- (let [filename (format-filename (:filename image) (session :nick))
- date (today)
- dest (open-file [*avatar-directory* date] filename)
- url (image-url-from-file "avatars" date dest)]
- (do
- (copy (:tempfile image) dest)
- (update-user-db (session :user_id) "avatar" url)
- [(session-assoc :avatar url)
- [200 url]])))
-
-(defn upload-avatar [session params]
- (let [image (params :image)]
- (cond (not image) [200 "INVALID_REQUEST"]
- (not (session :nick)) [200 "NOT_LOGGED_IN"]
- :else (if-let [err (validate-avatar-file (:tempfile image))]
- [200 err]
- (do-upload-avatar session image)))))
-
-(defn serve-meme [session meme]
- (if-let [st (fetch-template meme session)]
- (let [now (System/currentTimeMillis)]
- (.setAttribute st "timestamp" now)
- (.toString st))
- (unknown-page)))
-
-(defn hall-of-fame [session]
- (let [st (fetch-template "fame" session)
- msgs (add-user-favs-to-msgs (poll hall-results)
- (session :user_id))]
- (.setAttribute st "dumps" (map process-message-for-output msgs))
- (.toString st)))
-
-;; MGMT logic
-
-(def mgmt-pw "idontgetit")
-
-(defn mgmt [session pw]
- (if (= (and pw (lower-case pw)) mgmt-pw)
- (validated-chat session "mgmt" "chat")
- (validated-chat session "mgmt")))
-
-;; Compojure Routes
-
-(defn serve-static [dir path]
- (if (= path "")
- (redirect-to "http://dump.fm")
- (serve-file dir path)))
-
-(defroutes static
- (GET "/static/*" (serve-static "static" (params :*)))
- (GET "/images/*" (serve-static *image-directory* (params :*)))
- (GET "/avatars/*" (serve-static *avatar-directory* (params :*)))
-;; irl
- (GET "/irl" (redirect-to "/irl/"))
- (GET "/irl/" (serve-static "static/319" "index.html"))
- (GET "/irl/*" (serve-static "static/319" (params :*)))
- (GET "/irl2" (redirect-to "/irl2/"))
- (GET "/irl2/" (serve-static "static/319" "res.html"))
- (GET "/irl2/*" (serve-static "static/319" (params :*)))
- (GET "/irlhell" (redirect-to "/irhell/"))
- (GET "/irhell" (redirect-to "/irhell/"))
- (GET "/irhell/" (serve-static "static/319" "irhell.html"))
- (GET "/irhell/*" (serve-static "static/319" (params :*))))
-
-
-
-(defroutes pichat
- (GET "http://:sub.dump.fm/" (validated-chat session (params :sub)))
- (GET "http://:sub.dump.fm/chat" (validated-chat session (params :sub)))
- (GET "http://:sub.dump.fm/chat" (validated-chat session (params :sub) (params :t)))
- (GET "/:room/chat" (validated-chat session (params :room)))
- (GET "/chat" (validated-chat session *default-room*))
- (GET "/chat/:t" (validated-chat session *default-room* (params :t)))
-
- (GET "http://:sub.dump.fm/log" (validated-log session (params :sub) "0" params))
- (GET "http://:sub.dump.fm/log/:offset" (validated-log session (params :sub) (params :offset) params))
- (GET "/log" (validated-log session *default-room* "0" params))
- (GET "/log/:offset" (validated-log session *default-room* (params :offset) params))
- (GET "/r/:room/log" (validated-log session (params :room) "0" params))
- (GET "/r/:room/log/:offset" (validated-log session (params :room) (params :offset) params))
-
- (GET "/favicon.ico" (serve-static "static" "favicon.ico"))
- (GET "/u/:nick" (redirect-to (str "/" (params :nick))))
- (GET "/u/:nick/" (redirect-to (str "/" (params :nick))))
- (GET "/u/:nick/tag/:tag" (tagged-dumps-by-nick session params (request-url request)))
- (GET "/u/:nick/tag/:tag/:offset" (tagged-dumps-by-nick session params (request-url request)))
- (GET "/u/:nick/favorites" (redirect-to (format "/%s/favorites" (params :nick))))
- (GET "/u/:nick/favorites/:offset" (redirect-to (format "/%s/favorites" (params :nick))))
- (GET "/json/:nick/favorites" (json-favorites session params))
-
- ; have to put this route after favs
- (GET "/u/:nick/:offset" (redirect-to (str "/" (params :nick))))
-
- (GET "/p/:nick/:postid" (single-message session (params :nick) (params :postid)))
-
- ;; TODO: delete GET routes very shortly
- (GET "/login" (login session params cookies request))
- (POST "/login" (login session params cookies request))
- (GET "/logout" (logout session))
- (POST "/logout" (logout session))
- (GET "/register" (serve-static "static" "register.html"))
- (GET "/registerdis" (serve-static "static" "registerdis.html"))
- (GET "/browser" (browser session))
- (GET "/refresh" (validated-refresh session params))
- (GET "/tag/:tag" (tagged-dumps session params (request-url request)))
- (GET "/tag/:tag/:offset" (tagged-dumps session params (request-url request)))
- (POST "/cmd/tag/add" (validated-add-tag session params))
- (POST "/cmd/tag/rm" (validated-remove-tag session params))
-
- ;; Altars
- (GET "/altars" (altar-log session params))
- (GET "/altars/" (altar-log session params))
- (GET "/altars/:id" (if (maybe-parse-int (params :id) false)
- (altar-log session params)
- (redirect-to (str "/" (params :id) "/altars")))) ;; redirect /altars/timb to /timb/altars
-
- ;; testing
- (GET "/test/hiscores" (hiscore-test session params "week"))
- (GET "/test/hiscores/alltime" (hiscore-test session params "all"))
- (GET "/test/hiscores/day" (hiscore-test session params "day"))
- (GET "/test/hiscores/week" (hiscore-test session params "week"))
- (GET "/test/hiscores/month" (hiscore-test session params "month"))
-
- (GET "/mgmt" (mgmt session nil))
- (GET "/mgmt/:pw" (mgmt session (:pw params)))
-
- ;; Events
-; (GET "/event" (event-page session))
-; (GET "/event/proxy" (image-proxy session params request))
-; (POST "/event/submit" (submit! session params request))
-
- ;; Fullscreen
- (GET "/fullscreen" (serve-meme session "fullscreen"))
-
- ;; TODO: add form tokens for all destructive actions
- (POST "/msg" (validated-msg session params request))
- (POST "/submit-registration" (register session params request))
- (POST "/update-profile" (update-profile session params))
- (GET "/directory" (directory session 0))
- (GET "/directory/:offset"
- (directory session (maybe-parse-int (params :offset) 0)))
- (GET "/reset-request" (reset-request-page session))
- (POST "/reset-request" (reset-request! session params))
- (GET "/reset" (reset-page session params))
- (POST "/reset" (reset-account! session params))
-
- ;; Admin stuff (should be own route?)
- (GET "/debug" (debug-page session flash))
- (POST "/debug" (debug-commmand! session params))
- (GET "/mutes" (show-mutes session))
- (GET "/roomlist" (show-rooms session))
- (POST "/mute" (mute! session params))
- (POST "/cancel-mute" (handle-cancel-mute! session params))
- (GET "/profile-test/:t" (profile session "ryder" (params :t)))
- (GET "/reports" (list-reports-dir session))
- (GET "/reports/:file" (show-report session (params :file)))
-
- (GET "/cmd/search/:searchterm" (json-search (undecoded-url-piece (request-url request) 2) params))
- (GET "/search" (serve-template "search_files" session))
-
- ;; Memes
- (GET "/m/:m" (serve-meme session (params :m)))
- (GET "/hall" (hall-of-fame session))
-
- ;; Store
- (GET "/stickers" (serve-static "static" "sticker.html"))
-
- ;; Footer pages
- (GET "/about_us" (serve-template "about_us" session))
- (GET "/goodies" (serve-template "goodies" session))
- (GET "/help" (serve-template "help" session))
- (GET "/privacy" (serve-template "privacy" session))
- (GET "/terms" (serve-template "terms" session))
- (GET "/error/ie" (serve-template "error_ie" session))
-
- ;; Put username routes below all others in priority
- (GET "/:nick" (profile session (params :nick)))
- (GET "/:nick/" (profile session (params :nick)))
- (GET "/:nick/altars" (altar-log session params))
- (GET "/:nick/altars/" (altar-log session params))
- (GET "/:nick/altars/:id" (altar-log session params))
- (GET "/:nick/tag/:tag" (tagged-dumps-by-nick session params (request-url request)))
- (GET "/:nick/tag/:tag/:offset" (tagged-dumps-by-nick session params (request-url request)))
- (GET "/:nick/favorites" (favorites-handler session (params :nick) nil nil))
- (GET "/:nick/favorites/" (favorites-handler session (params :nick) nil nil))
- (GET "/:nick/favorites/:date" (favorites-handler session (params :nick) (params :date) nil))
- (GET "/:nick/favorites/:date/" (favorites-handler session (params :nick) (params :date) nil))
- (GET "/:nick/favorites/:date/:msg" (favorites-handler session (params :nick) (params :date) (params :msg)))
- (GET "/:nick/favs" (favorites-handler session (params :nick) nil nil))
- (GET "/:nick/favs/:date" (favorites-handler session (params :nick) (params :date) nil))
- (GET "/:nick/favs/:date/:msg" (favorites-handler session (params :nick) (params :date) (params :msg)))
- (GET "/:nick/popular" (popular session (params :nick)))
- (GET "/:nick/log" (user-log-handler session (params :nick) nil nil))
- (GET "/:nick/log/" (user-log-handler session (params :nick) nil nil))
- (GET "/:nick/:date" (user-log-handler session (params :nick) (params :date) nil))
- (GET "/:nick/:date/" (user-log-handler session (params :nick) (params :date) nil))
- (GET "/:nick/:date/:msg" (user-log-handler session (params :nick) (params :date) (params :msg)))
-
- (GET "/" (landing session))
- (ANY "*" (unknown-page)))
-
-(defroutes multipart
- (POST "/upload/message" (upload session params request))
- (POST "/upload/photo" (upload-photo session params))
- (POST "/upload/avatar" (upload-avatar session params)))
-
-;; Add jpeg to list
-(def mimetypes
- {"css" "text/css"
- "gif" "image/gif"
- "gz" "application/gzip"
- "htm" "text/html"
- "html" "text/html"
- "jpg" "image/jpeg"
- "jpeg" "image/jpeg"
- "js" "text/javascript"
- "pdf" "application/pdf"
- "png" "image/png"
- "svg" "image/svg+xml"
- "swf" "application/x-shockwave-flash"
- "txt" "text/plain"
- "xml" "text/xml"
- "zip" "application/zip"})
-
-(decorate static
- (with-mimetypes {:mimetypes mimetypes}))
-
-(def *session-cookie-params* {:type :memory
- :expires (* 60 60)
- :domain *cookie-domain*})
-
-(decorate pichat
- (with-mimetypes {:mimetypes mimetypes})
- (with-cookie-login (comp not logged-in?) make-login-token read-login-token)
- (with-session *session-cookie-params*))
-
-(decorate multipart
- (with-mimetypes {:mimetypes mimetypes})
- (with-cookie-login (comp not logged-in?) make-login-token read-login-token)
- (with-session *session-cookie-params*)
- (with-multipart))
-
-
-;;; Startup Code
-
-(defn start-server [port]
- (run-server {:port port
- :nio true}
- "/static/*" (servlet static)
- "/images/*" (servlet static)
- "/avatars/*" (servlet static)
- "/irl" (servlet static)
- "/irl2" (servlet static)
- "/irl/*" (servlet static)
- "/irl2/*" (servlet static)
- "/irhell" (servlet static)
- "/irhell/*" (servlet static)
- "/upload/*" (servlet multipart)
- "/*" (servlet pichat)))
-
-(defn parse-command-args
- "Parses command-line arguments. First arg is script name,
- second arg is port number (defaults to 8080)."
- ([script] {:port 8080})
- ([script port] {:port (Integer/parseInt port)}))
-
-(def options
- (apply parse-command-args *command-line-args*))
-
-(load-rooms!)
-(start! reserved-nicks)
-(def server (start-server (options :port)))
-(start! *active-mutes*)
-
-; Delay the following to reduce start-load
-(Thread/sleep 15000)
-(start! *user-scores*)
-
-(start-user-flusher!)
-(start-session-pruner!)
-(start! hall-results)
-
-;; Scott 2010/8/30: disable feeds to test impact on server load
-;; (and see if anyone notices)
-;; (if (= *server-url* "http://dump.fm")
-;; (do (start! feed-downloader)
-;; (start! feed-inserter)))
-
-
-;(if (not= *server-url* "http://dump.fm")
-; (start! random-poster))
-
+(ns pichat
+ (:import java.lang.System
+ java.text.SimpleDateFormat
+ java.util.Date
+ java.io.File
+ javax.imageio.ImageIO
+ javax.servlet.http.Cookie
+ org.antlr.stringtemplate.StringTemplateGroup)
+ (:use clojure.xml
+ clojure.contrib.command-line
+ clojure.contrib.duck-streams
+ clojure.contrib.json.write
+ clojure.contrib.seq-utils
+ clojure.contrib.sql
+ clojure.contrib.str-utils
+ clojure.contrib.def
+ clojure.contrib.pprint
+ config
+ admin
+ compojure
+ email
+ fame
+ utils
+ cookie-login
+ session-sweeper
+ feed
+ rooms
+ tags
+ scheduled-agent
+ user)
+ (:require redis))
+
+; Create image directories if they don't exist.
+(.mkdir (new File *image-directory*))
+(.mkdir (new File *avatar-directory*))
+
+
+;; Logging
+
+; is there a better way to do this or am i insane for introducing state? just wanna do
+; (let [log (debug-log)]
+; (log "something")
+; (log "something else")
+; (log)) ; gets log array for output to template
+(defn make-debug-logger
+ ([] (make-debug-logger (new java.util.ArrayList)))
+ ([log]
+ (fn
+ ([] (to-array log))
+ ([s] (make-debug-logger (.add log s))))))
+
+(defn make-time-logger
+ ([] (make-time-logger (new java.util.ArrayList)))
+ ([log]
+ (fn
+ ([] (to-array log));
+ ([f & args]
+ (let [start (.getTime (new Date))
+ ret (apply f args)
+ log-string (str f ": " (- (.getTime (new Date)) start) " msecs" )]
+ (.add log log-string)
+ ret)))))
+
+;; Output
+
+(defn strip-empty-vals [m]
+ (into {} (filter (fn [[k v]] (non-empty-string? v)) m)))
+
+(defn process-message-for-json [d]
+ (assoc d :created_on (.getTime (d :created_on))))
+
+(defn message-room-link [m]
+ (if (= (:key m) "dumpfm")
+ "http://dump.fm/chat"
+ (format "http://%s.dump.fm" (:key m))))
+
+(defn process-message-for-output [d]
+ (escape-html-deep
+ (strip-empty-vals
+ (if (contains? d :created_on)
+ (assoc d
+ :created_on (format-timestamp (d :created_on))
+ :roomlink (message-room-link d))
+ d))))
+
+(defn new-messages [room ts]
+ (reverse (take-while #(.after (% :created_on) ts)
+ @(room :messages))))
+
+(defn new-favs [nick ts]
+ (filter #(.after (:added %) ts)
+ (get @fav-map nick [])))
+
+(defn process-user [u]
+ (stringify-and-escape (strip-empty-vals u)))
+
+(defn process-directory-listing [d]
+ (stringify-and-escape
+ (strip-empty-vals d)))
+
+(defn prepare-user-list [room sort?]
+ (let [users (vals @(room :users))]
+ (map process-user (if sort?
+ (sort-by (fn [u] (.toLowerCase (:nick u))) users)
+ users))))
+
+(defn updates [nick room ts]
+ {"users" (prepare-user-list room false) ; Sorting is done on client
+ "messages" (map process-message-for-json
+ (new-messages room ts))
+ "favs" (new-favs nick ts)})
+
+(defn count-messages-by-nick [nick image-only]
+ (let [query (str "SELECT COUNT(*)
+ FROM messages m, users u, rooms r
+ WHERE m.user_id = u.user_id AND u.nick = ?
+ AND r.room_id = m.room_id AND r.admin_only = false "
+ (if image-only "AND m.is_image = true " ""))]
+ (do-count [query nick])))
+
+(defn fetch-messages-by-nick
+ ([nick image-only] (fetch-messages-by-nick nick image-only 0))
+ ([nick image-only offset]
+ (let [query (str "SELECT m.content, m.created_on, m.message_id, u.nick, u.avatar, r.key
+ FROM messages m, users u, rooms r
+ WHERE m.user_id = u.user_id AND u.nick = ?
+ AND r.room_id = m.room_id AND r.admin_only = false "
+ (if image-only "AND m.is_image = true " "")
+ "ORDER BY created_on DESC
+ LIMIT ? OFFSET ?")]
+ (do-select [query nick *dumps-per-page* offset]))))
+
+(defn fetch-message-by-id [m-id]
+ (let [query "SELECT m.message_id, m.content, m.created_on, m.user_id,
+ u.nick, u.avatar, r.key, r.admin_only
+ FROM messages m, users u, rooms r
+ WHERE m.user_id = u.user_id
+ AND r.room_id = m.room_id
+ AND m.message_id = ?"]
+ (first (do-select [query (maybe-parse-int m-id -1)]))))
+
+(defn fetch-public-message-by-id [m-id]
+ (let [msg (tags/fetch-dump-by-id m-id)]
+ (if (and msg (not (:admin_only msg)))
+ msg)))
+
+;; User-id/nick cache
+;; I keep needing to grab user-id from a nick so I thought I'd cache them
+;; @timb: I just duplicated this in the user-info map :(
+;; we should reconcile our user caches
+(def user-id-cache (ref {}))
+(def *user-id-cache-size* 500)
+
+(defn user-id-from-nick [nick]
+ (let [nick (lower-case nick)
+ found (@user-id-cache nick)]
+ (if found
+ found
+ (let [query (str "SELECT user_id FROM users WHERE lower(nick) = ?")
+ res (first (do-select [query nick]))]
+ (if (nil? res)
+ nil
+ (let [found (res :user_id)]
+ (dosync
+ (if (> (count @user-id-cache) *user-id-cache-size*) (ref-set user-id-cache {}))
+ (alter user-id-cache assoc nick found))
+ found))))))
+
+;; Login code
+
+(defn session-map-from-db
+ [user-info]
+ {:user_id (user-info :user_id)
+ :nick (user-info :nick)
+ :is_admin (user-info :is_admin)
+ :avatar (user-info :avatar)})
+
+(defn session-assoc-from-db
+ [user-info]
+ (session-assoc
+ :user_id (user-info :user_id)
+ :nick (user-info :nick)
+ :email (user-info :email)
+ :is_admin (user-info :is_admin)
+ :avatar (user-info :avatar)
+ :password_login true))
+
+;; login-token functions
+
+(defn logged-in?
+ "Test whether user is logged in by presence of nick key in session.
+ (Apply to request map)"
+ [{session :session}]
+ (contains? session :nick))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Login-token version history
+;
+; v0: Format: nick%expiry%token-hash
+; Date: Mists of dump antiquity
+;
+; v1: Format: v1%nick%expiry%token-hash
+; Date: 2010/04/24
+; Note: Contains same information as v0, but created under the
+; wildcard domain (i.e. ".dump.fm") so that logins work
+; across all subdomains.
+
+(defn encode-login-token [nick hash expiry]
+ (let [token-hash (sha1-hash hash expiry)]
+ (str "v1%" nick "%" expiry "%" token-hash)))
+
+(defn- parse-login-vec [v]
+ (try [(aget v 1) (Long/parseLong (aget v 2)) (aget v 3)]
+ (catch NumberFormatException _ nil)))
+
+(defn parse-login-token [token]
+ ; If users have multiple login-cookies across different domains
+ ; (i.e. both "dump.fm" and ".dump.fm"), token will be a vector
+ ; instead of a string.
+ (if (not (string? token))
+ (some identity (map parse-login-token token))
+ (let [v (.split token "\\%")]
+ (if (and (= (alength v) 4) (= (aget v 0) "v1"))
+ (parse-login-vec v)))))
+
+(defn read-login-token [token]
+ (if-let [[nick expiry token-hash] (parse-login-token token)]
+ (if (>= expiry (System/currentTimeMillis))
+ (let [db-info (fetch-nick nick)
+ computed-hash (sha1-hash (db-info :hash) expiry)]
+ (if (= token-hash computed-hash)
+ (select-keys db-info [:user_id :nick :email :is_admin :avatar]))))))
+
+(defn make-login-token
+ [{nick :nick hash :hash}]
+ (let [expiration (ms-in-future *login-token-expiry*)
+ token (encode-login-token nick hash expiration)]
+ (set-cookie *login-token-key* token
+ :expires (gmt-string (new Date expiration))
+ :domain *cookie-domain*)))
+
+;; Landing
+
+(defn landing [session]
+ (redirect-to "/chat"))
+
+(defn log-login [user_id ip]
+ ;; i'm using do-cmds here because update-values can't deal with stuff like 'last_login = now()'
+ (let [query (format "UPDATE users SET last_ip = '%s'::cidr, last_login = now() WHERE user_id = %s" (str ip) (str user_id))]
+ (do-cmds query))
+)
+
+(defn login [session params cookies request]
+ (let [nick (or (params :nick) "")
+ hash (or (params :hash) "")
+ remember-me (= (params :rememberme) "yes")
+ db-user (authorize-nick-hash nick hash)
+ login-cookie (if remember-me
+ (make-login-token db-user)
+ (clear-login-token *login-token-key*))
+ ip (get-ip request)]
+ (if db-user
+ (do
+ (log-login (db-user :user_id) ip)
+ [(session-assoc-from-db db-user)
+ login-cookie
+ (resp-success "OK")]
+ )
+ (resp-error "BAD_LOGIN"))))
+
+(defn logout [session]
+ [(session-dissoc :nick :user_id :is_admin :avatar)
+ (set-cookie *login-token-key* "dummy"
+ :expires "Thu, 01-Jan-1970 00:00:01 GMT"
+ :domain *cookie-domain*)
+ (redirect-to "http://dump.fm/")])
+
+;; Registration
+
+(def muted-ips-query "
+SELECT DISTINCT
+ last_ip
+FROM users
+WHERE user_id IN
+ (SELECT user_id FROM mutes
+ WHERE (set_on + duration) > now()
+ AND NOT cancelled)")
+
+(defn get-ip-str [db-ip]
+ (first (.split (.getValue db-ip) "/")))
+
+
+(defn ip-recently-muted? [ip]
+ (let [muted-ips (set (map (comp get-ip-str :last_ip)
+ (do-select [muted-ips-query])))]
+ (contains? muted-ips ip)))
+
+(def *reserved-nicks-path* "docs/reserved_nicks.txt")
+(def *reserved-nicks-refresh-period-sec* 300)
+
+(defn load-invalid-nicks []
+ (set (read-lines *reserved-nicks-path*)))
+
+(def reserved-nicks
+ (scheduled-agent load-invalid-nicks
+ *reserved-nicks-refresh-period-sec*
+ (load-invalid-nicks)))
+
+(defn nick-reserved? [nick]
+ (let [query "SELECT * FROM users WHERE LOWER(nick) = ? LIMIT 1"]
+ (or (contains? (poll reserved-nicks) nick)
+ (> (count (do-select [query (lower-case nick)])) 0))))
+
+(defn register [session params request]
+ (let [nick (or (params :nick) "")
+ email (or (params :email) "")
+ hash (or (params :hash) "")
+ ip (get-ip request)
+ invalid-nick-reason (is-invalid-nick? nick)]
+ (cond invalid-nick-reason (resp-error invalid-nick-reason)
+ (nick-reserved? nick) (resp-error "NICK_TAKEN")
+ (ip-recently-muted? ip) (resp-error "RECENTLY_MUTED")
+ :else (do
+ (do-insert :users
+ [:nick :hash :email]
+ [nick hash email])
+ (let [db-user (fetch-nick nick)
+ user_id (db-user :user_id)
+ query (format "UPDATE users SET created_ip = '%s'::cidr WHERE user_id = %s" (str ip) (str user_id))]
+ (try (send-registration-email nick email)
+ (catch Exception e nil))
+ (do-cmds query) ; timb: doing this update query rather than using previous insert because jdbc
+ ; can't figure out how to convert to cidr on prepared statements
+ [(session-assoc-from-db db-user)
+ (resp-success "OK")])))))
+
+;; Fav scores
+
+(def *score-query* "
+SELECT u.user_id,
+ u.nick,
+ COUNT(*) AS cnt
+FROM tags t,
+ messages m,
+ users u
+WHERE t.message_id = m.message_id
+ AND m.user_id != t.user_id
+ AND m.user_id = u.user_id
+GROUP BY u.user_id, u.nick
+ORDER BY cnt DESC
+")
+
+(defn build-score-list []
+ (let [res (vec (do-select [*score-query*]))]
+ {:list res
+ :map (zipmap (map :nick res) (map :cnt res))}))
+
+(def *scores-refresh-period-sec* (* 29 60))
+
+(def *user-scores*
+ (scheduled-agent build-score-list
+ *scores-refresh-period-sec*
+ []))
+
+(def *piece-map*
+ (zipmap
+ [:pawn :knight :bishop :rook :queen :king :skull]
+ ["&#9823;" "&#9822;" "&#9821;" "&#9820;" "&#9819;" "&#9818;" "&#9760;"]))
+
+(defn score-to-piece [score]
+ (cond (= score -1) :skull
+ (= score 0) :pawn
+ (< score 50) :knight
+ (< score 150) :bishop
+ (< score 300) :rook
+ (< score 1000) :queen
+ :else :king))
+
+(def score-to-entity (comp *piece-map* score-to-piece))
+
+(defn lookup-score [nick]
+ (if (= (lower-case nick) "scottbot")
+ -1
+ (let [scores (:map (poll *user-scores*))]
+ (get scores nick 0))))
+
+(defn get-user-ranking [offset num]
+ (if-let [ranking (:list (poll *user-scores*))]
+ (let [cnt (count ranking)]
+ (subvec ranking
+ (min cnt (* offset num))
+ (min cnt (* (inc offset) num))))))
+
+
+;; Profile
+
+(defn pull-random-dump-images [dumps num]
+ (take num
+ (shuffle
+ (set (apply concat
+ (map
+ (comp take-images :content)
+ dumps))))))
+
+(defn count-dumps-posted [nick]
+ (:count
+ (first
+ (do-select ["select count(*) from messages m, users u
+ where m.user_id = u.user_id and lower(u.nick) = ?
+ and m.is_image = true" (.toLowerCase nick)]))))
+
+(defn count-dumps-user-faved [nick]
+ (:count
+ (first
+ (do-select ["select count(distinct(m.message_id)) from users u, tags t, messages m
+ where lower(u.nick) = ? and u.user_id = t.user_id
+ and t.tag = 'favorite'
+ and t.message_id = m.message_id and m.is_image = true"
+ (.toLowerCase nick)]))))
+
+(defn profile
+ ([session profile-nick] (profile session profile-nick "profile"))
+ ([session profile-nick template]
+ (if-let [user-info (fetch-nick profile-nick)]
+ (let [st (fetch-template template session)
+ profile-nick (:nick user-info) ; Update to get right casing
+ nick (session :nick)
+ logger (make-time-logger)
+ is-home (and nick (= nick profile-nick))
+ score (lookup-score profile-nick)
+ dumps (logger tags/fetch-dumps
+ :user-tag-id (:user_id session)
+ :nick profile-nick
+ :limit 10)
+ imgs (pull-random-dump-images dumps 5)]
+ (do
+ (.setAttribute st "is_home" is-home)
+ (doseq [a [:nick :avatar :contact :bio]]
+ (let [v (user-info a)]
+ (.setAttribute st (name a)
+ (if (non-empty-string? v) (escape-html v)))))
+ (.setAttribute st "score" (comma-format score))
+ (.setAttribute st "score_ent" (score-to-entity score))
+ (if (not (empty? imgs))
+ (.setAttribute st "imgs" imgs))
+ (.setAttribute st "debug_log_items" (logger))
+ (.toString st)))
+ (resp-error "NO_USER"))))
+
+(defn update-user-db [user-id attr val]
+ (with-connection *db*
+ (update-values "users" ["user_id = ?" user-id] {attr val})))
+
+(defn update-avatar [session url]
+ (update-user-db (session :user_id) "avatar" url)
+ [(session-assoc :avatar url)
+ (resp-success url)])
+
+(defn update-profile [session params]
+ (let [user-id (session :user_id)
+ attr (params :attr)
+ val (params :val)
+ attr-set #{"avatar" "contact" "bio"}]
+ (cond (not user-id) (resp-error "MUST_LOGIN")
+ (not (and user-id attr val)) (resp-error "BAD_REQUEST")
+ (not (contains? attr-set attr)) (resp-error "BAD_REQUEST")
+ (= attr "avatar") (update-avatar session val)
+ :else (do (update-user-db user-id attr val)
+ (resp-success "OK")))))
+
+;; Generic Handler
+
+(defn generic-profile-handler [session nick date msg-id
+ func redirecter unknown]
+ (if-let [user-info (fetch-nick nick)]
+ ;; If a valid msg-id is provided, the date is ignored.
+ ;; This makes urls such as /user/bogus/5 valid.
+ (cond msg-id (if-let [msg-id (maybe-parse-int msg-id)]
+ (func session user-info nil msg-id)
+ (redirecter user-info))
+ ;; If an invalid date is provided, we redirect to the user's first favs page.
+ date (if-let [date (parse-yyyy-mm-dd-date date)]
+ (func session user-info date nil)
+ (redirecter user-info))
+ :else (func session user-info nil nil))
+ (unknown)))
+
+;; User log
+
+(defn build-mini-profile [user-info]
+ (let [st (fetch-template-fragment "mini_profile")
+ nick (user-info :nick)
+ score (lookup-score nick)]
+ (doseq [a [:nick :avatar :contact :bio]]
+ (let [v (user-info a)]
+ (.setAttribute st (name a)
+ (if (non-empty-string? v) (escape-html v)))))
+ (doto st
+ (.setAttribute "score" (comma-format score))
+ (.setAttribute "score_ent" (score-to-entity score))
+ (.toString))))
+
+;; The next-page link is generated by retrieving one additional dump,
+;; and creating a link from its date and message id.
+(defn log-next-page-link [last-msg]
+ (format "/%s/%s/%s"
+ (:nick last-msg)
+ (format-yyyy-mm-dd (:created_on last-msg))
+ (:message_id last-msg)))
+
+(defn user-log [session user-info date msg-id]
+ (let [st (fetch-template "userlog" session)
+ logger (make-time-logger)
+ raw-dumps (tags/fetch-dumps
+ :nick (:nick user-info)
+ :user-tag-id (:user_id session)
+ :msg-id msg-id
+ :date (if msg-id nil date)
+ :limit (inc *dumps-per-page*))
+ back-dumps (if (or date msg-id)
+ (tags/fetch-dumps
+ :nick (:nick user-info)
+ :msg-id msg-id
+ :date (if msg-id nil date)
+ :limit (inc *dumps-per-page*)
+ :direction :forward))
+ dumps (map process-message-for-output (take *dumps-per-page* raw-dumps))]
+ (.setAttribute st "nick" (:nick user-info))
+ (.setAttribute st "is_home" (= (:nick user-info) (:nick session)))
+ (.setAttribute st "mini_profile" (build-mini-profile user-info))
+ (if (> (count dumps) 0)
+ (.setAttribute st "dumps" dumps))
+ (.setAttribute st "prev"
+ (if back-dumps
+ (cond
+ (> (count back-dumps) *dumps-per-page*) (log-next-page-link (last back-dumps))
+ (> (count back-dumps) 1) (format "/%s/log" (:nick user-info))
+ :else nil)))
+ (if (> (count raw-dumps) *dumps-per-page*)
+ (.setAttribute st "next" (log-next-page-link (last raw-dumps))))
+ (.setAttribute st "debug_log_items" (logger))
+ (.toString st)))
+
+(defn user-log-handler [session nick date msg-id]
+ (generic-profile-handler session nick date msg-id
+ user-log
+ (fn [u] (redirect-to (str "/" (:nick u))))
+ #(resp-error "NO_USER")))
+
+;; Who faved me
+
+(def popular-dumps-qry "
+select u.nick, u.avatar, r.key, m.message_id, m.content, m.created_on, count(*) as count,
+ array_agg(u2.nick) as user_nicks,
+ array_agg(u2.avatar) as user_avs,
+ array_agg(t.created_on) as favtime,
+ (select exists (select 1 from tags
+ where tag = 'favorite' and user_id = ? and message_id = m.message_id)) as favorited
+from users u, messages m, rooms r, tags t, users u2
+where lower(u.nick) = lower(?)
+and u.user_id = m.user_id and m.message_id = t.message_id
+and m.room_id = r.room_id and m.is_image = true and r.admin_only = false
+and t.tag = 'favorite' and t.user_id != u.user_id
+and t.user_id = u2.user_id
+group by u.nick, u.avatar, r.key, m.message_id, m.content, m.created_on
+order by count desc limit ? offset ?")
+
+(def num-popular-dumps 40)
+
+(defn get-popular-dumps [nick user-id]
+ (for [d (do-select [popular-dumps-qry user-id nick 40 0])]
+ (let [fav-nicks (.getArray (:user_nicks d))]
+ (assoc d
+ :favers (sort-by :t (comp #(* -1 %) compare)
+ (map (fn [n a t] (if (non-empty-string? a)
+ {:nick n :avatar a :t t}
+ {:nick n :t t}))
+ fav-nicks
+ (.getArray (:user_avs d))
+ (.getArray (:favtime d))))
+ :user_nicks nil :user_avs nil :favtime nil))))
+
+(defn popular [session profile-nick]
+ (if-let [user-info (fetch-nick profile-nick)]
+ (let [st (fetch-template "popular" session)
+ profile-nick (:nick user-info)
+ raw-dumps (get-popular-dumps profile-nick (or (:user_id session) -1))
+ dumps (map process-message-for-output raw-dumps)]
+ (.setAttribute st "nick" profile-nick)
+ (.setAttribute st "mini_profile" (build-mini-profile user-info))
+ (.setAttribute st "dumps" dumps)
+ (.toString st))
+ (resp-error "NO_USER")))
+
+;; Directory
+
+(def *per-directory-page* 25)
+
+(defn process-directory-entry [entry]
+ (let [score (lookup-score (:nick entry))]
+ (assoc (stringify-and-escape entry)
+ "score_ent" (score-to-entity score)
+ "score" score)))
+
+(defn recent-posts-query [user-id]
+ (format "
+SELECT u.user_id, u.nick, u.avatar,
+ m.content, m.message_id%s
+FROM users u
+LEFT JOIN messages m on m.message_id =
+ (SELECT message_id FROM messages
+ WHERE user_id = u.user_id
+ AND is_image
+ AND room_id IN (SELECT room_id from rooms where admin_only = false)
+ ORDER BY created_on desc LIMIT 1)
+WHERE u.user_id = ANY(?)"
+ (if user-id
+ (format
+ ",
+ EXISTS (SELECT 1 FROM tags
+ WHERE tag = 'favorite' AND user_id = %s AND message_id = m.message_id) AS favorited"
+ user-id)
+ ", false AS favorited")))
+
+(defn lookup-recent-posts [user-tag-id user-ids]
+ (do-select [(recent-posts-query user-tag-id)
+ (sql-array "int" user-ids)]))
+
+(defn lookup-recent-posts-tagless [user-tag-id user-ids]
+ (do-select [(recent-posts-query nil)
+ (sql-array "int" user-ids)]))
+
+(def directory-cache-ttl (minutes 10))
+(def memoized-lookup-recent-posts-tagless
+ (ttl-memoize lookup-recent-posts-tagless directory-cache-ttl))
+
+
+(defn add-recent-posts [user-id users]
+ (if-not (empty? users)
+ (let [f (if user-id lookup-recent-posts lookup-recent-posts-tagless)
+ res (f user-id (map :user_id users))]
+ (for [u users]
+ (merge u (find-first #(= (:user_id u) (:user_id %)) res))))))
+
+(defn get-directory-info [user-id offset]
+ (map process-directory-entry
+ (add-recent-posts user-id
+ (get-user-ranking offset *per-directory-page*))))
+
+(defn directory [session offset]
+ (let [st (fetch-template "directory" session)
+ users (get-directory-info (:user_id session) offset)]
+ (.setAttribute st "users" users)
+ (cond (= offset 0) (.setAttribute st "prev" false)
+ (= offset 1) (.setAttribute st "prev" "")
+ :else (.setAttribute st "prev" (str "/" (dec offset))))
+ (if (> offset 0)
+ (.setAttribute st "cur" offset))
+ (.setAttribute st "next" (str "/" (inc offset)))
+ (.toString st)))
+
+;; Single posts
+
+(defn single-message [session nick-from-url id-from-url]
+ (if-let [user-info (fetch-nick nick-from-url)]
+ (if-let [message (fetch-public-message-by-id id-from-url)]
+ ; error if nick in url doesn't match the nick who posted the message from the id in url
+ ; this prevents people from scraping all the content by incrementing the id in the url
+ (if (= (user-info :user_id) (message :user_id))
+ (let [st (fetch-template "single_message" session)
+ message (tags/add-favorited-flag message session)
+ message (tags/remove-tags-for-output message)]
+ (.setAttribute st "dump" (process-message-for-output message))
+ (.toString st))
+ (resp-error "NO_MESSAGE"))
+ (resp-error "NO_MESSAGE"))
+ (resp-error "NO_USER")))
+
+
+;; Chat
+
+(defn validate-room-access [room-key session]
+ (if-let [room (lookup-room room-key)]
+ (or (not (room :admin_only))
+ (is-vip? session))))
+
+(def default-room-template "chat")
+
+(defn lookup-room-template [session room-key template]
+ (or (fetch-template (str "rooms/" (or template room-key)) session)
+ (fetch-template (str "rooms/" default-room-template) session)))
+
+(defn chat [session room template]
+ (if-let [st (lookup-room-template session (:key room) template)]
+ (let [now (System/currentTimeMillis)
+ nick (session :nick)
+ raw-msgs (reverse (tags/fetch-dumps :room (:key room)
+ :image-only false
+ :user-tag-id (:user_id session)
+ :hide-vip false
+ :limit (:history_size room)))
+ message-list (to-array (map process-message-for-output raw-msgs))]
+ (if nick
+ (dosync
+ (login-user (user-struct-from-session session) room)))
+ (doto st
+ (.setAttribute "users" (prepare-user-list room true))
+ (.setAttribute "messages" message-list)
+ (.setAttribute "roomkey" (room :key))
+ (.setAttribute "isadminroom" (room :admin_only))
+ (.setAttribute "json_room_key" (json-str (room :key)))
+ (.setAttribute "json_user_nick" (if nick (json-str nick) "null"))
+ (.setAttribute "roomname" (room :name))
+ (.setAttribute "dis" (= (room :name) "dis"))
+ (.setAttribute "timestamp" now))
+ (.toString st))
+ [404 "UNKNOWN PAGE"]))
+
+(defn validated-chat
+ ([session room-key] (validated-chat session room-key nil))
+ ([session room-key template]
+ (let [room-key (if (= (lower-case room-key) "www") *default-room* room-key)]
+ (if (validate-room-access room-key session)
+ (chat session (lookup-room room-key) template)
+ (resp-error "UNKNOWN_ROOM")))))
+
+(defn refresh [session params room]
+ (dosync
+ (let [now (System/currentTimeMillis)
+ old-ts (new Date (maybe-parse-long (params :since) now))
+ nick (session :nick)
+ users (room :users)]
+ (if nick
+ (if-let [user-info (@users nick)]
+ ; Incorporate avatar updates
+ (commute users assoc nick (merge user-info {:last-seen now
+ :avatar (session :avatar)}))
+ (commute users assoc nick (user-struct-from-session session))))
+ (resp-success (assoc (updates nick room old-ts)
+ :timestamp now)))))
+
+(defn validated-refresh [session params]
+ (let [room-key (params :room)
+ room (lookup-room room-key)]
+ (if (validate-room-access room-key session)
+ (refresh session params room)
+ (resp-error "UNKNOWN_ROOM"))))
+
+;; admins can post arbitrary html if wrapped in <safe>
+;; this is temporary so that i can test generating html messages
+(defn validated-content [content session]
+ (if (.startsWith content "<safe>")
+ (if (is-vip? session)
+ (str content)
+ (str "<unsafe>" content "</unsafe>"))
+ (str content)))
+
+(defn msg-db [user-id room-id content]
+ (let [msg-type (classify-msg content)
+ is-image (boolean (#{:image :mixed} msg-type))
+ is-text (boolean (#{:mixed :text} msg-type))
+ qry (str "INSERT INTO messages (user_id, room_id, content, is_image, is_text) "
+ "VALUES (?, ?, ?, ?, ?) RETURNING message_id")]
+ (with-connection *db*
+ ((first (do-select [qry user-id room-id content is-image is-text]))
+ :message_id))))
+
+(defn msg [session params]
+ (let [user-id (session :user_id)
+ mute (get (poll *active-mutes*) user-id)
+ nick (session :nick)
+ room-key (params :room)
+ room (lookup-room room-key)
+ content (.trim (params :content))]
+ (cond (not room) (resp-error "BAD_ROOM")
+ (not nick) (resp-error "NOT_LOGGED_IN")
+ mute (resp-error (format-mute mute))
+ :else
+ (let [content (validated-content content session)
+ msg-id (msg-db user-id (room :room_id) content)]
+ (dosync
+ (if (not (contains? (ensure (room :users)) nick))
+ (login-user (user-struct-from-session session) room))
+ (add-message (build-msg nick content msg-id) room))
+ (resp-success msg-id)))))
+
+
+(defn validated-msg [session params request]
+ (cond
+ (not (validate-room-access (params :room) session)) (resp-error "UNKNOWN_ROOM")
+ :else (msg session params)))
+
+;; Browser
+
+;; TODO: make work for all rooms
+(defn browser [session]
+ (let [room (lookup-room *default-room*)
+ now (System/currentTimeMillis)
+ nick (session :nick)
+ st (fetch-template "browser" session)]
+ (if nick
+ (dosync
+ (login-user (user-struct-from-session session) room)))
+ (let [user-list (prepare-user-list room false)]
+ (.setAttribute st "users" user-list))
+ (.setAttribute st "roomkey" (room :key))
+ (.setAttribute st "isadminroom" (room :admin_only))
+ (.setAttribute st "json_room_key" (json-str (room :key)))
+ (.setAttribute st "json_user_nick" (if nick (json-str nick) "null"))
+ (.setAttribute st "roomname" (room :name))
+ (.setAttribute st "timestamp" now)
+ (.toString st)))
+
+
+;; Chat Log
+
+(defn log [session room offset params]
+ (let [roomkey (room :key)
+ st (fetch-template "log" session)
+ logger (make-time-logger)
+ offset (maybe-parse-int offset 0)
+ dump-offset (* offset *dumps-per-page*)
+ image-only (and (not (room :admin_only))
+ (not= (params :show) "all"))
+ raw-dumps (logger tags/fetch-dumps-by-room :room-id (room :room_id)
+ :image-only image-only
+ :amount (+ 1 *dumps-per-page*)
+ :offset dump-offset)
+ dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
+ ;; json-tags (for [dump dumps :when (not (empty? (dump :tags)))]
+ ;; (json-str {"id" (dump :message_id) "tags" (dump :tags) }))
+ dumps (map tags/remove-tags-for-output dumps)
+ dumps (logger doall (map process-message-for-output dumps))]
+ (if (> (count raw-dumps) *dumps-per-page*)
+ (.setAttribute st "next" (inc offset)))
+ (if (not= offset 0)
+ (.setAttribute st "prev" (max (dec offset) 0)))
+ (.setAttribute st "dumps" dumps)
+ (if (default-room? roomkey)
+ (.setAttribute st "roomkey" "")
+ (.setAttribute st "roomkey" (str roomkey ".")))
+ (.setAttribute st "roomname" (room :name))
+ (.setAttribute st "debug_log_items" (logger))
+ (.toString st)))
+
+(defn validated-log [session room-key offset params]
+ (if-vip
+ (let [room-key (if (= (lower-case room-key) "www") "dumpfm" room-key)]
+ (if (validate-room-access room-key session)
+ (log session (lookup-room room-key) offset params)
+ (resp-error "UNKNOWN_ROOM")))
+ (redirect-to "http://dump.fm")))
+
+;; Hiscore test... redis test...
+
+(defn redis-ids-test [period]
+ (let [reddis-server {:host "127.0.0.1" :port 6379 :db 0}
+ ids (redis/with-server reddis-server
+ (redis/zrevrange (str "hiscore:" period) 0 -1))
+ ids (map maybe-parse-int ids)]
+ ids))
+
+(defn hiscore-test [session params period]
+ (let [st (fetch-template "hiscore_test" session)
+ dumps (tags/fetch-dumps-by-ids (redis-ids-test period))
+ dumps (map tags/add-favorited-flag dumps (repeat session))
+ dumps (map tags/add-fav-count dumps)
+ dumps (reverse (sort-by :favcount dumps))
+ dumps (map tags/remove-tags-for-output dumps)
+ dumps (map process-message-for-output dumps)]
+ (.setAttribute st "dumps" dumps)
+ (.toString st)))
+
+
+
+;; Altars
+
+;; if :nick is in params, will fetch only altars by that nick
+;; next page links look like /altars/message-id and select <= message_id order desc
+;; prev page links look like /altars/-message-id and select > message_id order asc
+(defn altar-log [session params]
+ (let [id (params :id)
+ nick (params :nick)
+ user-id (if nick (user-id-from-nick nick) nil)
+ template (if user-id "altar_user_log" "altar_log")
+ st (fetch-template template session)
+ raw-dumps (tags/fetch-altars :message-id id :amount (+ 1 *dumps-per-page*) :user-id user-id)
+ dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
+ dumps (map tags/remove-tags-for-output dumps)
+ dumps (map process-message-for-output dumps)]
+ (.setAttribute st "dumps" dumps)
+ (.setAttribute st "nick" nick)
+ (if (> (count raw-dumps) *dumps-per-page*)
+ (.setAttribute st "next" ((last raw-dumps) :message_id)))
+ (if id
+ (.setAttribute st "prev" ((first raw-dumps) :message_id)))
+ (.toString st)))
+
+;; Tags
+
+(defn undecoded-url-piece [url position]
+ "Get nth thing out of a url path.
+ For example, (undecoded-url-piece 'http://example.com/a/b/c?foo' 2) will return 'c'"
+ (let [path-without-domain (nth (re-find #"//[^/]+/(.+)" url) 1)]
+ (nth (re-split #"/|\?" path-without-domain) position)))
+
+(defn add-tag [user msg tag]
+ (try
+ (do-insert "tags"
+ ["user_id" "message_id" "tag"]
+ [(:user_id user) (msg :message_id) tag])
+ (if (and (= tag "favorite")
+ (not (= (msg :nick) (user :nick))))
+ (insert-fav-notification! (msg :nick)
+ (user :nick)
+ (user :avatar)
+ (msg :content)))
+ true
+ ; catch error when inserting duplicate tags
+ (catch Exception e false)))
+
+
+(defn validated-add-tag [session params]
+ (if (session :nick)
+ (let [nick (session :nick)
+ user-id (session :user_id)
+ user-admin? (session :admin-only)
+ msg-id (params :message_id)
+ tag (validate-tag (params :tag))
+ msg (fetch-message-by-id msg-id)
+ access (or (is-vip? session)
+ (not (:admin-only msg)))]
+ (cond (not msg) (resp-error "NO_MSG")
+ (not access) (resp-error "NO_MSG")
+ (not tag) (resp-error "NO_TAG")
+ :else (if (add-tag session msg tag)
+ (resp-success "OK")
+ (resp-error "TAG_EXISTS_ALREADY_OR_SOMETHING_ELSE_IS_FUCKED"))))
+ (resp-error "NO_USER")))
+
+(defn remove-tag [user-id message-id tag]
+ (let [query "user_id = ? AND message_id = ? AND lower(tag) = ?"]
+ (do-delete "tags" [query user-id (maybe-parse-int message-id) (normalize-tag-for-db (.toLowerCase tag))])
+ (resp-success "OK")))
+
+(defn validated-remove-tag [session params]
+ (if (session :nick)
+ (remove-tag (session :user_id) (params :message_id) (params :tag))
+ (resp-error "NO_USER")))
+
+;; message-user-id: get messages posted by this user
+;; tag-user-id: get messages tagged by this user
+(defnk tagged-dumps-template [session params tags url page-title info-bar
+ :message-user-id false
+ :tag-user-id false
+ :logger (make-time-logger)
+ :include-vip false]
+ (let [st (fetch-template "tagged_dumps" session)
+ offset (maybe-parse-int (params :offset) 0)
+ dump-offset (* offset *dumps-per-page*)
+ raw-dumps (logger tags/fetch-dumps-by-tag :tags tags
+ :image-only false
+ :amount (+ 1 *dumps-per-page*)
+ :offset dump-offset
+ :message-user-id message-user-id
+ :tag-user-id tag-user-id
+ :include-vip include-vip)
+ dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session))
+ dumps (map tags/remove-tags-for-output dumps)
+ dumps (logger doall (map process-message-for-output dumps))]
+ (.setAttribute st "dumps" dumps)
+ (.setAttribute st "infobar" info-bar)
+ (.setAttribute st "page_title" page-title)
+ (.setAttribute st "page_url" url)
+ (if (not= offset 0)
+ (.setAttribute st "prev" (format "/%s/%s" url (max 0 (dec offset)))))
+ (if (> (count raw-dumps) *dumps-per-page*)
+ (.setAttribute st "next" (format "/%s/%s" url (inc offset))))
+ (.setAttribute st "debug_log_items" (logger))
+ (.toString st)))
+
+;; gotta parse tag intersections myself because +'s get decoded into spaces
+;; there's probably a less hacky way to do this
+(defn tagged-dumps-by-nick [session params url]
+ (let [nick (params :nick)
+ user-id (user-id-from-nick nick)
+ user-info (fetch-nick nick)
+ info-bar (build-mini-profile user-info)
+ tags (map url-decode (re-split #"\+" (undecoded-url-piece url 2)))
+ url (str nick "/tag/" (str-join "+" (map url-encode tags)))
+ page-title (str "dumps " nick " tagged as '" (escape-html (str-join "' and '" tags)) "'")]
+ (tagged-dumps-template session params tags url page-title info-bar :tag-user-id user-id)))
+
+(defn tagged-dumps [session params url]
+ (let [tags (map url-decode (re-split #"\+" (undecoded-url-piece url 1)))
+ url (str "tag/" (str-join "+" (map url-encode tags)))
+ page-title (str "dumps tagged as '" (escape-html (str-join "' and '" tags)) "'")]
+ (tagged-dumps-template session params tags url page-title "")))
+
+(defn favorites-next-page-link [nick last-msg]
+ (format "/%s/favorites/%s/%s"
+ nick
+ (format-yyyy-mm-dd (:tagged_on last-msg))
+ (:message_id last-msg)))
+
+(defn favorites [session user-info date msg-id]
+ (let [st (fetch-template "tagged_dumps" session)
+ logger (make-time-logger)
+ raw-dumps (tags/fetch-tagged-dumps
+ :nick (:nick user-info)
+ :user-tag-id (:user_id session)
+ :msg-id msg-id
+ :date (if msg-id nil date)
+ :limit (inc *dumps-per-page*))
+ back-dumps (if (or date msg-id)
+ (tags/fetch-tagged-dumps
+ :nick (:nick user-info)
+ :msg-id msg-id
+ :date (if msg-id nil date)
+ :limit (inc *dumps-per-page*)
+ :direction :forward))
+ dumps (map process-message-for-output (butlast raw-dumps))]
+ (.setAttribute st "prev"
+ (if back-dumps
+ (cond
+ (> (count back-dumps) *dumps-per-page*) (favorites-next-page-link (:nick user-info)
+ (last back-dumps))
+ (> (count back-dumps) 1) (format "/%s/favorites" (:nick user-info))
+ :else nil)))
+ (if (> (count raw-dumps) *dumps-per-page*)
+ (.setAttribute st "next" (favorites-next-page-link (:nick user-info) (last raw-dumps))))
+ (.setAttribute st "dumps" dumps)
+ (.setAttribute st "infobar" (build-mini-profile user-info))
+ (.setAttribute st "page_title" (format "%s'S FAVS" (:nick user-info)))
+ (.setAttribute st "debug_log_items" (logger))
+ (.toString st)))
+
+(defn favorites-handler [session nick date msg-id]
+ (generic-profile-handler session nick date msg-id
+ favorites
+ (fn [u] (redirect-to (format "/%s/favorites" (:nick u))))
+ #(resp-error "NO_USER")))
+
+(defn json-favorites [session params]
+ (let [nick (params :nick)
+ user-id (user-id-from-nick nick)
+ raw-favs (tags/fetch-tagged-dumps :nick nick
+ :limit 50)
+ favs (reduce (fn [m fav] (assoc m (str (fav :message_id)) (fav :content))) {} raw-favs)]
+ (str "RawFavs=" (json-str favs))))
+
+(defn search-query [num-tokens]
+ (str "select
+ url from image_urls
+ where url ilike " (str-join " and url ilike " (take num-tokens (repeat "?"))) "
+ order by last_posted desc
+ limit 200;"))
+
+;; note: _ is a wildcard in a postgres 'like' query...
+(defn search-replace-weird-chars [token]
+ (str (.replaceAll token "[^A-Za-z0-9\\-.=+]" "_"))
+)
+
+;; timb: this can be called with a callback or not...
+;;
+;; dump.fm/cmd/search/foo -> [result, result]
+;; cons: can only be ajax get'd from the same domain
+;;
+;; dump.fm/cmd/search/foo?callback=someFunc -> someFunc([result, result])
+;; cons: has to use a <script> tag. seems to freeze browser until results returned
+;;
+(defn json-search [undecoded-url-searchterms params]
+ (let [tokens (map url-decode (re-split #"\+" undecoded-url-searchterms))
+ tokens (map search-replace-weird-chars tokens)
+ tokens (map #(str "%" %1 "%") tokens)
+ query (search-query (count tokens))
+ rows (do-select (vec (concat [query] tokens)))]
+ (if (:callback params)
+ (str (:callback params) "(" (json-str rows) ")")
+ (json-str rows))))
+
+
+;; Local testing
+
+(def random-posts
+ ["http://24.media.tumblr.com/tumblr_l41x4eLWZm1qzon5ko1_400.png hi"
+ "lol http://29.media.tumblr.com/tumblr_l3o3wuRFpM1qawuaao1_500.jpg"
+ "http://dump.fm/images/20100819/1282199186063-dumpfm-timb-dump.stone.logo.gif http://teamassignment.com/images/getmesomemore.jpg http://26.media.tumblr.com/tumblr_l7kro0os531qaajkio1_500.gif"])
+
+(defn make-random-post! []
+ (msg {:user_id 1
+ :nick "scottbot"
+ :avatar "http://i.imgur.com/isKqZ.gif"}
+ {:room "dumpfm"
+ :content (rand-elt random-posts)}))
+
+(def random-poster
+ (scheduled-agent make-random-post! 5 nil))
+
+;; Account resets
+
+(defn reset-request-page [session]
+ (.toString (fetch-template "req_reset" session)))
+
+(defn reset-request! [session {nick :nick}]
+ (if-let [info (fetch-nick nick)]
+ (let [nick (info :nick) ; get correct casing
+ email (info :email)
+ hash (info :hash)
+ ts (System/currentTimeMillis)
+ token (reset-token nick hash ts)
+ link (reset-link nick token ts)]
+ (do (send-reset-email nick email link)
+ (resp-success "OK")))
+ (resp-error "NO_NICK")))
+
+(defn reset-page [session params]
+ (let [st (fetch-template "reset" session)
+ nick (params :nick)
+ ts (maybe-parse-long (params :ts) 0)
+ token (params :token)
+ valid (valid-reset-link? nick token ts)]
+ (if (and (zero? ts)
+ (nil? nick)
+ (nil? token))
+ (reset-request-page session)
+ (do
+ (.setAttribute st "valid_request" valid)
+ (.setAttribute st "nick" nick)
+ (when valid
+ (.setAttribute st "link" (reset-link nick token ts)))
+ (.toString st)))))
+
+(defn reset-account! [session params]
+ (let [nick (params :nick)
+ ts (maybe-parse-long (params :ts) 0)
+ token (params :token)
+ hash (params :hash)]
+ (if (and (valid-reset-link? nick token ts) hash)
+ (let [info (fetch-nick nick)]
+ (update-nick-hash nick hash)
+ [(session-assoc-from-db info)
+ (redirect-to "http://dump.fm/")])
+ [200 "BAD_REQUEST"])))
+
+;; Upload
+
+(def max-avatar-dimensions [800 800])
+(def max-avatar-size (kbytes 500))
+
+(defn is-file-too-big? [f limit]
+ (if (> (.length f) limit)
+ (str "FILE_TOO_BIG " limit)))
+
+(defn invalid-image-dimensions? [f [max-width max-height]]
+ (try
+ (let [i (ImageIO/read f)
+ height (.getHeight i)
+ width (.getWidth i)]
+ (if (or (> width max-width)
+ (> height max-height))
+ (str "INVALID_RESOLUTION " max-width " " max-height)))
+ (catch Exception _ "INVALID_IMAGE")))
+
+(defn format-filename [s nick]
+ (let [spaceless (.replace s \space \-)
+ nick-clean (re-gsub #"[^A-Za-z0-9]" "" nick)
+ subbed (re-gsub #"[^\w.-]" "" spaceless)]
+ (str-join "-" [(System/currentTimeMillis) "dumpfm" nick-clean subbed])))
+
+(defn image-url-from-file [dir date file]
+ (str-join "/" [*server-url* dir date (.getName file)]))
+
+(defn validate-upload-file [f room]
+ (or (is-file-too-big? f (:max_file_size room))
+ (invalid-image-dimensions? f [(:max_image_width room)
+ (:max_image_height room)])))
+
+(defn validate-avatar-file [f]
+ (or (is-file-too-big? f max-avatar-size)
+ (invalid-image-dimensions? f max-avatar-dimensions)))
+
+
+; Upload notes:
+; The webcam code doesn't feature an error handler,
+; so all upload responses not equal to "OK" are considered
+; errors.
+; The upload code doesn't use jQuery.ajax, and doesn't JSON-eval
+; responses. Therefore, return strings should not be JSON-encoded.
+
+(defn do-upload [session image room]
+ (if-let [err (validate-upload-file (image :tempfile) room)]
+ (resp-error err)
+ (let [filename (format-filename (:filename image) (session :nick))
+ date (today)
+ dest (open-file [*image-directory* date] filename)
+ url (image-url-from-file "images" date dest)
+ msg-id (msg-db (session :user_id) (room :room_id) url)
+ msg (struct message-struct (session :nick) url (new Date) msg-id)]
+ (do
+ (dosync
+ (add-message msg room))
+ (copy (:tempfile image) dest)
+ [200 "OK"]))))
+
+(defn upload [session params request]
+ (let [room-key (params :room)
+ nick (session :nick)
+ user-id (session :user_id)
+ image (params :image)
+ mute (get (poll *active-mutes*) user-id)
+ has-access (validate-room-access room-key session)]
+ (cond (not nick) [200 "NOT_LOGGED_IN"]
+ (not image) [200 "INVALID_REQUEST"]
+ mute [200 (format-mute mute)]
+ (not has-access) [200 "UNKNOWN_ROOM"]
+ :else (do-upload session image (lookup-room room-key)))))
+
+(defn upload-photo [session params]
+ (let [room-key (params :room)
+ nick "~photobot"
+ user-id (rooms/fetch-or-create-bot-id! nick)
+ image (params :image)]
+ (do-upload {:is_admin true :nick nick :user_id user-id} image (lookup-room room-key))))
+
+;; N.B. -- Upload responses aren't JSON-evaluated
+(defn do-upload-avatar [session image]
+ (let [filename (format-filename (:filename image) (session :nick))
+ date (today)
+ dest (open-file [*avatar-directory* date] filename)
+ url (image-url-from-file "avatars" date dest)]
+ (do
+ (copy (:tempfile image) dest)
+ (update-user-db (session :user_id) "avatar" url)
+ [(session-assoc :avatar url)
+ [200 url]])))
+
+(defn upload-avatar [session params]
+ (let [image (params :image)]
+ (cond (not image) [200 "INVALID_REQUEST"]
+ (not (session :nick)) [200 "NOT_LOGGED_IN"]
+ :else (if-let [err (validate-avatar-file (:tempfile image))]
+ [200 err]
+ (do-upload-avatar session image)))))
+
+(defn serve-meme [session meme]
+ (if-let [st (fetch-template meme session)]
+ (let [now (System/currentTimeMillis)]
+ (.setAttribute st "timestamp" now)
+ (.toString st))
+ (unknown-page)))
+
+(defn hall-of-fame [session]
+ (let [st (fetch-template "fame" session)
+ msgs (add-user-favs-to-msgs (poll hall-results)
+ (session :user_id))]
+ (.setAttribute st "dumps" (map process-message-for-output msgs))
+ (.toString st)))
+
+;; MGMT logic
+
+(def mgmt-pw "idontgetit")
+
+(defn mgmt [session pw]
+ (if (= (and pw (lower-case pw)) mgmt-pw)
+ (validated-chat session "mgmt" "chat")
+ (validated-chat session "mgmt")))
+
+;; Compojure Routes
+
+(defn serve-static [dir path]
+ (if (= path "")
+ (redirect-to "http://dump.fm")
+ (serve-file dir path)))
+
+(defroutes static
+ (GET "/static/*" (serve-static "static" (params :*)))
+ (GET "/images/*" (serve-static *image-directory* (params :*)))
+ (GET "/avatars/*" (serve-static *avatar-directory* (params :*)))
+;; irl
+ (GET "/irl" (redirect-to "/irl/"))
+ (GET "/irl/" (serve-static "static/319" "index.html"))
+ (GET "/irl/*" (serve-static "static/319" (params :*)))
+ (GET "/irl2" (redirect-to "/irl2/"))
+ (GET "/irl2/" (serve-static "static/319" "res.html"))
+ (GET "/irl2/*" (serve-static "static/319" (params :*)))
+ (GET "/irlhell" (redirect-to "/irhell/"))
+ (GET "/irhell" (redirect-to "/irhell/"))
+ (GET "/irhell/" (serve-static "static/319" "irhell.html"))
+ (GET "/irhell/*" (serve-static "static/319" (params :*))))
+
+
+
+(defroutes pichat
+ (GET "http://:sub.dump.fm/" (validated-chat session (params :sub)))
+ (GET "http://:sub.dump.fm/chat" (validated-chat session (params :sub)))
+ (GET "http://:sub.dump.fm/chat" (validated-chat session (params :sub) (params :t)))
+ (GET "/:room/chat" (validated-chat session (params :room)))
+ (GET "/chat" (validated-chat session *default-room*))
+ (GET "/chat/:t" (validated-chat session *default-room* (params :t)))
+
+ (GET "http://:sub.dump.fm/log" (validated-log session (params :sub) "0" params))
+ (GET "http://:sub.dump.fm/log/:offset" (validated-log session (params :sub) (params :offset) params))
+ (GET "/log" (validated-log session *default-room* "0" params))
+ (GET "/log/:offset" (validated-log session *default-room* (params :offset) params))
+ (GET "/r/:room/log" (validated-log session (params :room) "0" params))
+ (GET "/r/:room/log/:offset" (validated-log session (params :room) (params :offset) params))
+
+ (GET "/favicon.ico" (serve-static "static" "favicon.ico"))
+ (GET "/u/:nick" (redirect-to (str "/" (params :nick))))
+ (GET "/u/:nick/" (redirect-to (str "/" (params :nick))))
+ (GET "/u/:nick/tag/:tag" (tagged-dumps-by-nick session params (request-url request)))
+ (GET "/u/:nick/tag/:tag/:offset" (tagged-dumps-by-nick session params (request-url request)))
+ (GET "/u/:nick/favorites" (redirect-to (format "/%s/favorites" (params :nick))))
+ (GET "/u/:nick/favorites/:offset" (redirect-to (format "/%s/favorites" (params :nick))))
+ (GET "/json/:nick/favorites" (json-favorites session params))
+
+ ; have to put this route after favs
+ (GET "/u/:nick/:offset" (redirect-to (str "/" (params :nick))))
+
+ (GET "/p/:nick/:postid" (single-message session (params :nick) (params :postid)))
+
+ ;; TODO: delete GET routes very shortly
+ (GET "/login" (login session params cookies request))
+ (POST "/login" (login session params cookies request))
+ (GET "/logout" (logout session))
+ (POST "/logout" (logout session))
+ (GET "/register" (serve-static "static" "register.html"))
+ (GET "/registerdis" (serve-static "static" "registerdis.html"))
+ (GET "/browser" (browser session))
+ (GET "/refresh" (validated-refresh session params))
+ (GET "/tag/:tag" (tagged-dumps session params (request-url request)))
+ (GET "/tag/:tag/:offset" (tagged-dumps session params (request-url request)))
+ (POST "/cmd/tag/add" (validated-add-tag session params))
+ (POST "/cmd/tag/rm" (validated-remove-tag session params))
+
+ ;; Altars
+ (GET "/altars" (altar-log session params))
+ (GET "/altars/" (altar-log session params))
+ (GET "/altars/:id" (if (maybe-parse-int (params :id) false)
+ (altar-log session params)
+ (redirect-to (str "/" (params :id) "/altars")))) ;; redirect /altars/timb to /timb/altars
+
+ ;; testing
+ (GET "/test/hiscores" (hiscore-test session params "week"))
+ (GET "/test/hiscores/alltime" (hiscore-test session params "all"))
+ (GET "/test/hiscores/day" (hiscore-test session params "day"))
+ (GET "/test/hiscores/week" (hiscore-test session params "week"))
+ (GET "/test/hiscores/month" (hiscore-test session params "month"))
+
+ (GET "/mgmt" (mgmt session nil))
+ (GET "/mgmt/:pw" (mgmt session (:pw params)))
+
+ ;; Events
+; (GET "/event" (event-page session))
+; (GET "/event/proxy" (image-proxy session params request))
+; (POST "/event/submit" (submit! session params request))
+
+ ;; Fullscreen
+ (GET "/fullscreen" (serve-meme session "fullscreen"))
+
+ ;; TODO: add form tokens for all destructive actions
+ (POST "/msg" (validated-msg session params request))
+ (POST "/submit-registration" (register session params request))
+ (POST "/update-profile" (update-profile session params))
+ (GET "/directory" (directory session 0))
+ (GET "/directory/:offset"
+ (directory session (maybe-parse-int (params :offset) 0)))
+ (GET "/reset-request" (reset-request-page session))
+ (POST "/reset-request" (reset-request! session params))
+ (GET "/reset" (reset-page session params))
+ (POST "/reset" (reset-account! session params))
+
+ ;; Admin stuff (should be own route?)
+ (GET "/debug" (debug-page session flash))
+ (POST "/debug" (debug-commmand! session params))
+ (GET "/mutes" (show-mutes session))
+ (GET "/roomlist" (show-rooms session))
+ (POST "/mute" (mute! session params))
+ (POST "/cancel-mute" (handle-cancel-mute! session params))
+ (GET "/profile-test/:t" (profile session "ryder" (params :t)))
+ (GET "/reports" (list-reports-dir session))
+ (GET "/reports/:file" (show-report session (params :file)))
+
+ (GET "/cmd/search/:searchterm" (json-search (undecoded-url-piece (request-url request) 2) params))
+ (GET "/search" (serve-template "search_files" session))
+
+ ;; Memes
+ (GET "/m/:m" (serve-meme session (params :m)))
+ (GET "/hall" (hall-of-fame session))
+
+ ;; Store
+ (GET "/stickers" (serve-static "static" "sticker.html"))
+
+ ;; Footer pages
+ (GET "/about_us" (serve-template "about_us" session))
+ (GET "/goodies" (serve-template "goodies" session))
+ (GET "/help" (serve-template "help" session))
+ (GET "/privacy" (serve-template "privacy" session))
+ (GET "/terms" (serve-template "terms" session))
+ (GET "/error/ie" (serve-template "error_ie" session))
+
+ ;; Put username routes below all others in priority
+ (GET "/:nick" (profile session (params :nick)))
+ (GET "/:nick/" (profile session (params :nick)))
+ (GET "/:nick/altars" (altar-log session params))
+ (GET "/:nick/altars/" (altar-log session params))
+ (GET "/:nick/altars/:id" (altar-log session params))
+ (GET "/:nick/tag/:tag" (tagged-dumps-by-nick session params (request-url request)))
+ (GET "/:nick/tag/:tag/:offset" (tagged-dumps-by-nick session params (request-url request)))
+ (GET "/:nick/favorites" (favorites-handler session (params :nick) nil nil))
+ (GET "/:nick/favorites/" (favorites-handler session (params :nick) nil nil))
+ (GET "/:nick/favorites/:date" (favorites-handler session (params :nick) (params :date) nil))
+ (GET "/:nick/favorites/:date/" (favorites-handler session (params :nick) (params :date) nil))
+ (GET "/:nick/favorites/:date/:msg" (favorites-handler session (params :nick) (params :date) (params :msg)))
+ (GET "/:nick/favs" (favorites-handler session (params :nick) nil nil))
+ (GET "/:nick/favs/:date" (favorites-handler session (params :nick) (params :date) nil))
+ (GET "/:nick/favs/:date/:msg" (favorites-handler session (params :nick) (params :date) (params :msg)))
+ (GET "/:nick/popular" (popular session (params :nick)))
+ (GET "/:nick/log" (user-log-handler session (params :nick) nil nil))
+ (GET "/:nick/log/" (user-log-handler session (params :nick) nil nil))
+ (GET "/:nick/:date" (user-log-handler session (params :nick) (params :date) nil))
+ (GET "/:nick/:date/" (user-log-handler session (params :nick) (params :date) nil))
+ (GET "/:nick/:date/:msg" (user-log-handler session (params :nick) (params :date) (params :msg)))
+
+ (GET "/" (landing session))
+ (ANY "*" (unknown-page)))
+
+(defroutes multipart
+ (POST "/upload/message" (upload session params request))
+ (POST "/upload/photo" (upload-photo session params))
+ (POST "/upload/avatar" (upload-avatar session params)))
+
+;; Add jpeg to list
+(def mimetypes
+ {"css" "text/css"
+ "gif" "image/gif"
+ "gz" "application/gzip"
+ "htm" "text/html"
+ "html" "text/html"
+ "jpg" "image/jpeg"
+ "jpeg" "image/jpeg"
+ "js" "text/javascript"
+ "pdf" "application/pdf"
+ "png" "image/png"
+ "svg" "image/svg+xml"
+ "swf" "application/x-shockwave-flash"
+ "txt" "text/plain"
+ "xml" "text/xml"
+ "zip" "application/zip"})
+
+(decorate static
+ (with-mimetypes {:mimetypes mimetypes}))
+
+(def *session-cookie-params* {:type :memory
+ :expires (* 60 60)
+ :domain *cookie-domain*})
+
+(decorate pichat
+ (with-mimetypes {:mimetypes mimetypes})
+ (with-cookie-login (comp not logged-in?) make-login-token read-login-token)
+ (with-session *session-cookie-params*))
+
+(decorate multipart
+ (with-mimetypes {:mimetypes mimetypes})
+ (with-cookie-login (comp not logged-in?) make-login-token read-login-token)
+ (with-session *session-cookie-params*)
+ (with-multipart))
+
+
+;;; Startup Code
+
+(defn start-server [port]
+ (run-server {:port port
+ :nio true}
+ "/static/*" (servlet static)
+ "/images/*" (servlet static)
+ "/avatars/*" (servlet static)
+ "/irl" (servlet static)
+ "/irl2" (servlet static)
+ "/irl/*" (servlet static)
+ "/irl2/*" (servlet static)
+ "/irhell" (servlet static)
+ "/irhell/*" (servlet static)
+ "/upload/*" (servlet multipart)
+ "/*" (servlet pichat)))
+
+(defn parse-command-args
+ "Parses command-line arguments. First arg is script name,
+ second arg is port number (defaults to 8080)."
+ ([script] {:port 8080})
+ ([script port] {:port (Integer/parseInt port)}))
+
+(def options
+ (apply parse-command-args *command-line-args*))
+
+(load-rooms!)
+(start! reserved-nicks)
+(def server (start-server (options :port)))
+(start! *active-mutes*)
+
+; Delay the following to reduce start-load
+(Thread/sleep 15000)
+(start! *user-scores*)
+
+(start-user-flusher!)
+(start-session-pruner!)
+(start! hall-results)
+
+;(if (not= *server-url* "http://dump.fm")
+; (start! random-poster))
diff --git a/src/utils.clj b/src/utils.clj
index 8ed801e..9d7fd3a 100755
--- a/src/utils.clj
+++ b/src/utils.clj
@@ -431,10 +431,13 @@
(defn is-super-vip? [session]
(contains? super-vips (:nick session)))
-(defmacro if-vip [e]
+(defmacro if-vip
"Evaluates expr if user is super-vip otherwise returns 404. Can only be used
where session is defined."
- `(if (is-vip? ~'session) ~e (unknown-page)))
+ ([e]
+ `(if (is-vip? ~'session) ~e (unknown-page)))
+ ([e alt]
+ `(if (is-vip? ~'session) ~e ~alt)))
(defmacro if-super-vip [e]
"Evaluates expr if user is super-vip otherwise returns 404. Can only be used
@@ -475,4 +478,4 @@
(for [[idx elt] (indexed coll) :when (pred elt)] idx))
(defn index-of [pred coll]
- (first (index-filter pred coll))) \ No newline at end of file
+ (first (index-filter pred coll)))
generated by cgit v1.2.3-70-g09d2 (git 2.51.0) at 2025-12-10 18:08:31 +0000