(ns pichat (:import java.lang.System java.text.SimpleDateFormat java.util.Date java.io.File javax.imageio.ImageIO javax.servlet.http.Cookie) (:use clojure.xml clojure.contrib.command-line clojure.contrib.duck-streams clojure.contrib.json.write clojure.contrib.sql clojure.contrib.str-utils clojure.contrib.def config admin compojure email 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 (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] ; Sorting is done on client (map process-user (vals @(room :users)))) (defn updates [nick room ts] {"users" (prepare-user-list room) "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 (fetch-message-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] (if (session :nick) (redirect-to "/chat") (serve-file "static" "index.html"))) (defn login [session params cookies] (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*))] (if db-user [(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] (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)] (send-registration-email nick email) [(session-assoc-from-db db-user) (resp-success "OK")]))))) ;; Fav scores (def *score-query* " SELECT 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.nick ORDER BY cnt DESC ") (def *user-info-query* " SELECT u.nick, u.user_id, u.avatar, LAST.content, LAST.message_id FROM users u LEFT JOIN messages LAST ON u.user_id = LAST.user_id AND LAST.created_on = (SELECT MAX(created_on) FROM messages WHERE user_id = u.user_id AND room_id != 2 AND is_image) ") (defn build-user-info-map [] (let [res (do-select [*user-info-query*])] (zipmap (map :nick res) res))) (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* (* 30 60)) (def *user-info-refresh-period-sec* 300) (def *user-scores* (scheduled-agent build-score-list *scores-refresh-period-sec* [])) (def *user-info* (scheduled-agent build-user-info-map *user-info-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 lookup-user-info [nick] (if-let [i (get (poll *user-info*) nick)] (if-let [score (lookup-score nick)] (assoc i :score (lookup-score nick) :score_ent (score-to-entity score)) i) {})) (defn get-user-ranking [offset num] (let [ranking (:list (poll *user-scores*)) count (count ranking)] (subvec ranking (min count (* offset num)) (min count (* (inc offset) num))))) ;; Profile (defn profile ([session profile-nick offset] (profile session profile-nick offset "profile")) ([session profile-nick offset 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)) has-avatar (non-empty-string? (user-info :avatar)) offset (maybe-parse-int offset 0) score (lookup-score profile-nick) dump-offset (* offset *dumps-per-page*) raw-dumps (logger tags/fetch-dumps-by-nick :nick profile-nick :amount (+ 1 *dumps-per-page*) :offset dump-offset) 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))] (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))))) (if (> (count dumps) 0) (.setAttribute st "dumps" dumps)) (if (> (count raw-dumps) *dumps-per-page*) (.setAttribute st "next" (inc offset))) (.setAttribute st "score" score) (.setAttribute st "score_ent" (score-to-entity score)) (if (not= offset 0) (.setAttribute st "prev" (max (dec offset) 0))) (.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"))))) ;; Directory (def *per-directory-page* 25) (defn process-directory-entry [entry] (let [info (lookup-user-info (:nick entry))] (assoc (stringify-and-escape info) "score_ent" (:score_ent info)))) (defn get-directory-info [offset] (map process-directory-entry (get-user-ranking offset *per-directory-page*))) (defn directory [session offset] (let [st (fetch-template "directory" session) users (get-directory-info 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)] (.setAttribute st "message" (process-message-for-output message)) (.toString st)) (resp-error "NO_MESSAGE")) (resp-error "NO_MESSAGE")) (resp-error "NO_USER"))) ;; Chat ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Chat format version history ; ; v0: Keys: users, messages, timestamp ; Date: Mists of dump antiquity ; ; v1: Keys: users, messages, timestamp, v ; Date: 2010/04/25 ; Note: Incorporates explicit version (def *chat-version-number* 1) (defn validate-room-access [room-key session] (let [room (lookup-room room-key)] (and room (or (not (room :admin_only)) (is-vip? session))))) (defn chat [session room template] (let [now (System/currentTimeMillis) nick (session :nick) st (fetch-template template session) limit (if (:admin_only room) *vip-dumps-per-page* *dumps-per-page*) message-list (reverse (tags/fetch-dumps-by-room :room-id (room :room_id) :image-only false :amount limit)) message-list (map tags/add-favorited-flag message-list (repeat session)) message-list (to-array (map process-message-for-output message-list))] (if nick (dosync (login-user (user-struct-from-session session) room))) (let [user-list (prepare-user-list room)] (.setAttribute st "users" user-list)) (.setAttribute st "messages" message-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 "version" *chat-version-number*) (.setAttribute st "roomname" (room :name)) (.setAttribute st "timestamp" now) (.toString st))) (defn validated-chat [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 :v *chat-version-number*))))) (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")))) ;; 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-url? [word] (and (re-find url-regex word) (re-find pic-regex word))) (defn classify-msg [msg] (let [words (.split msg " ") urls (map is-url? words)] (cond (every? boolean urls) :image (some boolean urls) :mixed :else :text))) ;; 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)] (.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) (.setAttribute st "version" *chat-version-number*) (.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) ;; (.setAttribute st "json_tags" json-tags) (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 :message-user-id false :tag-user-id false :logger (make-time-logger)] (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) 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))] (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) (.setAttribute st "page_title" page-title) (.setAttribute st "page_url" url) (.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) tags (map url-decode (re-split #"\+" (undecoded-url-piece url 3))) user-id (user-id-from-nick nick) 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 :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 [session params] (let [nick (params :nick) user-id (user-id-from-nick nick) url (str nick "/favorites") page-title (str nick "'s favorites")] (tagged-dumps-template session params "favorite" url page-title :tag-user-id user-id))) (defn json-favorites [session params] (let [nick (params :nick) user-id (user-id-from-nick nick) raw-favs (tags/fetch-dumps-by-tag :tags "favorite" :image-only false :amount 50 :offset 0 :tag-user-id user-id :with-tags false) favs (reduce (fn [m fav] (assoc m (str (fav :message_id)) (fav :content))) {} raw-favs)] (str "RawFavs=" (json-str favs)))) ;; 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 [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)] (.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-image-dimensions* [2000 2000]) (def *max-avatar-dimensions* [2000 2000]) (def *vip-max-file-size* (mbytes 5)) ; don't be nuts guys (def *max-file-size* (kbytes 750)) (def *ignore-size-limit-for-vip* true) (def *avatar-dimensions* [50 50]) (defn file-size-limit [vip] (if (and *ignore-size-limit-for-vip* vip) *vip-max-file-size* *max-file-size*)) (defn is-file-too-big? [f vip] (let [limit (file-size-limit vip)] (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] (or (is-file-too-big? f vip) (invalid-image-dimensions? f *max-image-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))))) ;; 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 (do-upload-avatar session image)))) ;; 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) "chat")) (GET "http://:sub.dump.fm/chat" (validated-chat session (params :sub) "chat")) (GET "/:room/chat" (validated-chat session (params :room) "chat")) (GET "/chat" (validated-chat session *default-room* "chat")) (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 "/:room/log" (validated-log session (params :room) "0" params)) (GET "/:room/log/:offset" (validated-log session (params :room) (params :offset) params)) (GET "/favicon.ico" (serve-static "static" "favicon.ico")) (GET "/u/:nick" (profile session (params :nick) "0")) (GET "/u/:nick/" (profile session (params :nick) "0")) (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" (favorites session params)) (GET "/u/:nick/favorites/:offset" (favorites session params)) (GET "/json/:nick/favorites" (json-favorites session params)) ; have to put this route after favs (GET "/u/:nick/:offset" (profile session (params :nick) (params :offset))) (GET "/p/:nick/:postid" (single-message session (params :nick) (params :postid))) (GET "/login" (login session params cookies)) (GET "/logout" (logout session)) (GET "/register" (serve-static "static" "register.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)) ;; TODO: add form tokens for all destructive actions (POST "/msg" (validated-msg session params)) (POST "/submit-registration" (register session params)) (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" "0" (params :t))) ;; 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) "0")) (GET "/:nick/" (profile session (params :nick) "0")) (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 session params)) (GET "/:nick/favorites/:offset" (favorites session params)) (GET "/:nick/:offset" (profile session (params :nick) (params :offset))) (GET "/" (landing session)) (ANY "*" (unknown-page))) (defroutes multipart (POST "/upload/message" (upload 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} "/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) (start-server (options :port)) (start! *user-scores*) (start! *user-info*) (Thread/sleep 3000) ; Delay these to reduce start-load (start-user-flusher!) (start-session-pruner!) (start! feed-downloader) (start! feed-inserter)