From b6d00d6f0748d6678f58b784ad5611a46c9655e0 Mon Sep 17 00:00:00 2001 From: Scott Ostler Date: Sun, 5 Sep 2010 05:45:57 -0400 Subject: Don't allow registration from active muted ips --- src/site.clj | 2803 +++++++++++++++++++++++++++++----------------------------- 1 file changed, 1425 insertions(+), 1378 deletions(-) (limited to 'src/site.clj') diff --git a/src/site.clj b/src/site.clj index 422c0b3..aee56d3 100644 --- a/src/site.clj +++ b/src/site.clj @@ -1,1378 +1,1425 @@ -(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)) - -; 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 - -;; http://snippets.dzone.com/posts/show/6995 -(def url-regex #"(?i)^((http\:\/\/|https\:\/\/|ftp\:\/\/)|(www\.))+(\w+:{0,1}\w*@)?(\S+)(:[0-9]+)?(\/|\/([\w#!:.?+=&%@!\-\/]))?$") -(def pic-regex #"(?i)\.(jpg|jpeg|png|gif|bmp|svg)(\?|&|$)") - -(defn is-image? [word] - (and (re-find url-regex word) - (re-find pic-regex word))) - -(defn classify-msg [msg] - (let [words (.split msg " ") - imgs (map is-image? words)] - (cond (every? boolean imgs) :image - (some boolean imgs) :mixed - :else :text))) - -(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 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))) - 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 *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) "") - invalid-nick-reason (is-invalid-nick? nick)] - (cond invalid-nick-reason (resp-error invalid-nick-reason) - (nick-reserved? nick) (resp-error "NICK_TAKEN") - :else (do - (do-insert :users - [:nick :hash :email] - [nick hash email]) - (let [db-user (fetch-nick nick) - user_id (db-user :user_id) - ip (get-ip request) - query (format "UPDATE users SET created_ip = '%s'::cidr WHERE user_id = %s" (str ip) (str user_id))] - (send-registration-email nick email) - (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] - ["♟" "♞" "♝" "♜" "♛" "♚" "☠"])) - -(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 take-images [content] - (filter is-image? (.split content " "))) - -(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-image-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-image-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-image-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) - limit (if (:admin_only room) *vip-dumps-per-page* *dumps-per-page*) - raw-msgs (reverse (tags/fetch-image-dumps :room (:key room) - :image-only false - :user-tag-id (:user_id session) - :hide-vip false - :limit limit)) - 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 -;; this is temporary so that i can test generating html messages -(defn validated-content [content session] - (if (.startsWith content "") - (if (is-vip? session) - (str content) - (str "" content "")) - (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] - (if (validate-room-access (params :room) session) - (msg session params) - (resp-error "UNKNOWN_ROOM"))) - -;; 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")))) - -;; 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 ghetto-search-query [num-tokens] - (str "select - content from messages - where room_id = 1 - and content ilike " (str-join " and content ilike " (take num-tokens (repeat "?"))) " - and content like '%http://%' - order by message_id desc - limit 250;")) - -(def *ghetto-search-regex* #"^[A-Za-z0-9\-_.+]*$") - -(defn json-ghetto-search [undecoded-url-searchterms] - (if (re-matches *ghetto-search-regex* undecoded-url-searchterms) - (let [tokens (map url-decode (re-split #"\+" undecoded-url-searchterms)) - tokens (map #(str "%" %1 "%") tokens) - query (ghetto-search-query (count tokens)) - rows (do-select (vec (concat [query] tokens)))] - (str "Search.searchResult(" (json-str rows) ")")) - (str "Search.searchError('sorry, no fancy characters')"))) - -;; 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-upload-dimensions [2000 2000]) -(def max-avatar-dimensions [800 800]) -(def max-vip-file-size (mbytes 5)) ; don't be nuts guys -(def max-file-size (mbytes 1)) -(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 vip] - (let [file-limit (if vip - max-vip-file-size - max-file-size)] - (or (is-file-too-big? f file-limit) - (invalid-image-dimensions? f max-upload-dimensions)))) - -(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) (is-vip? session))] - (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] - (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))) - -;; 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 :*)))) - -(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)) - - (GET "/fullscreen" (serve-meme session "fullscreen")) - - ;; TODO: add form tokens for all destructive actions - (POST "/msg" (validated-msg session params)) - (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)) - (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/ghettosearch/:searchterm" (json-ghetto-search (undecoded-url-piece (request-url request) 2))) - (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/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)) - (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) - "/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 -;(if (= *server-url* "http://dump.fm") -; (do (start! feed-downloader) -; (start! feed-inserter))) +(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 + events + fame + utils + cookie-login + session-sweeper + feed + rooms + tags + scheduled-agent + user)) + +; 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 + +;; http://snippets.dzone.com/posts/show/6995 +(def url-regex #"(?i)^((http\:\/\/|https\:\/\/|ftp\:\/\/)|(www\.))+(\w+:{0,1}\w*@)?(\S+)(:[0-9]+)?(\/|\/([\w#!:.?+=&%@!\-\/]))?$") +(def pic-regex #"(?i)\.(jpg|jpeg|png|gif|bmp|svg)(\?|&|$)") + +(defn is-image? [word] + (and (re-find url-regex word) + (re-find pic-regex word))) + +(defn classify-msg [msg] + (let [words (.split msg " ") + imgs (map is-image? words)] + (cond (every? boolean imgs) :image + (some boolean imgs) :mixed + :else :text))) + +(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 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))) + 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))] + (send-registration-email nick email) + (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] + ["♟" "♞" "♝" "♜" "♛" "♚" "☠"])) + +(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 take-images [content] + (filter is-image? (.split content " "))) + +(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-image-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-image-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-image-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) + limit (if (:admin_only room) *vip-dumps-per-page* *dumps-per-page*) + raw-msgs (reverse (tags/fetch-image-dumps :room (:key room) + :image-only false + :user-tag-id (:user_id session) + :hide-vip false + :limit limit)) + 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 +;; this is temporary so that i can test generating html messages +(defn validated-content [content session] + (if (.startsWith content "") + (if (is-vip? session) + (str content) + (str "" content "")) + (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] + (if (validate-room-access (params :room) session) + (msg session params) + (resp-error "UNKNOWN_ROOM"))) + +;; 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")))) + +;; 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 ghetto-search-query [num-tokens] + (str "select + content from messages + where room_id = 1 + and content ilike " (str-join " and content ilike " (take num-tokens (repeat "?"))) " + and content like '%http://%' + order by message_id desc + limit 250;")) + +(def *ghetto-search-regex* #"^[A-Za-z0-9\-_.+]*$") + +(defn json-ghetto-search [undecoded-url-searchterms] + (if (re-matches *ghetto-search-regex* undecoded-url-searchterms) + (let [tokens (map url-decode (re-split #"\+" undecoded-url-searchterms)) + tokens (map #(str "%" %1 "%") tokens) + query (ghetto-search-query (count tokens)) + rows (do-select (vec (concat [query] tokens)))] + (str "Search.searchResult(" (json-str rows) ")")) + (str "Search.searchError('sorry, no fancy characters')"))) + +;; 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-upload-dimensions [2000 2000]) +(def max-avatar-dimensions [800 800]) +(def max-vip-file-size (mbytes 5)) ; don't be nuts guys +(def max-file-size (mbytes 1)) +(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 vip] + (let [file-limit (if vip + max-vip-file-size + max-file-size)] + (or (is-file-too-big? f file-limit) + (invalid-image-dimensions? f max-upload-dimensions)))) + +(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) (is-vip? session))] + (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] + (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))) + +;; 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 :*)))) + +(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)) + + ;; Events + (GET "/event" (current-event session)) + + ;; Fullscreen + (GET "/fullscreen" (serve-meme session "fullscreen")) + + ;; TODO: add form tokens for all destructive actions + (POST "/msg" (validated-msg session params)) + (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)) + (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/ghettosearch/:searchterm" (json-ghetto-search (undecoded-url-piece (request-url request) 2))) + (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/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)) + (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) + "/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)) + -- cgit v1.2.3-70-g09d2