diff options
Diffstat (limited to 'src/site.clj')
| -rw-r--r-- | src/site.clj | 184 |
1 files changed, 104 insertions, 80 deletions
diff --git a/src/site.clj b/src/site.clj index d45aa09..ceea48b 100644 --- a/src/site.clj +++ b/src/site.clj @@ -2,10 +2,8 @@ (:import java.lang.System java.text.SimpleDateFormat java.util.Date - java.util.TimeZone java.io.File javax.imageio.ImageIO - org.apache.commons.codec.digest.DigestUtils javax.servlet.http.Cookie) (:use clojure.xml clojure.contrib.command-line @@ -41,11 +39,12 @@ (defn flush-inactive-users! [x] (doseq [[rid room] @rooms] (dosync - (let [users (room :users) - now (System/currentTimeMillis) - alive? (fn [[n u]] (> (u :last-seen) (- now *user-timeout*)))] + (let [users (room :users) + now (System/currentTimeMillis) + cutoff (- now *user-timeout*) + alive? (fn [[n u]] (> (u :last-seen) cutoff))] (ref-set users - (into {} (filter alive? @users)))))) + (into {} (filter alive? (ensure users))))))) (Thread/sleep *flusher-sleep*) (when *run-flusher* (send *agent* #'flush-inactive-users!)) @@ -69,30 +68,6 @@ (.mkdir (new File *image-directory*)) (.mkdir (new File *avatar-directory*)) -;; Utils - -(defn id [x] - x) - -(defn open-file [dir-comps filename] - (let [d (str-join (System/getProperty "file.separator") - (cons *root-directory* dir-comps)) - f (str-join (System/getProperty "file.separator") - [d filename])] - (.mkdir (new File d)) - (new File f))) - -(defn sha1-hash [& more] - (DigestUtils/shaHex (apply str more))) - -(defn gmt-string - ([] (gmt-string (new Date))) - ([dt] - (let [df (new SimpleDateFormat "EEE, dd MMM yyyy kk:mm:ss z")] - (.setTimeZone df (TimeZone/getTimeZone "GMT")) - (.format df dt)))) - - ;; Room handling (defn lookup-room [key] @@ -138,17 +113,6 @@ (defn strip-empty-vals [m] (into {} (filter (fn [[k v]] (non-empty-string? v)) m))) -(declare stringify-and-escape) -(defn escape-html-deep [o] - (if (map? o) - (stringify-and-escape o) - (if (seq? o) - (map escape-html-deep o) - (escape-html o)))) - -(defn stringify-and-escape [m] - (zipmap (map str* (keys m)) (map escape-html-deep (vals m)))) - (defn process-message-for-json [d] (assoc d :created_on (.getTime (d :created_on)))) @@ -156,7 +120,7 @@ (escape-html-deep (strip-empty-vals (if (contains? d :created_on) - (assoc d :created_on (.format formatter (d :created_on))) + (assoc d :created_on (format-timestamp (d :created_on))) d)))) (defn new-messages [room since-ts] @@ -172,14 +136,13 @@ (strip-empty-vals d))) (defn prepare-user-list [room] - (map process-user (sort-by #(% :nick) - (vals @(room :users))))) + ; Sorting is done on client + (map process-user (vals @(room :users)))) (defn updates [room since] - (let [m {"users" (prepare-user-list room) + (let [m {"users" (prepare-user-list room) "messages" (map process-message-for-json (new-messages room since))} - topic @(room :topic)] (if topic (assoc m "topic" topic) @@ -225,14 +188,14 @@ (do-select [query nick *dumps-per-page* offset])))) -(defn fetch-public-message-by-id [id] +(defn fetch-public-message-by-id [m-id] (let [query "SELECT m.content, m.created_on, m.user_id, u.nick, u.avatar FROM messages m, users u, rooms r WHERE m.user_id = u.user_id AND r.room_id = m.room_id AND r.admin_only = false AND m.message_id = ?"] - (first (do-select [query (maybe-parse-int id -1)])))) + (first (do-select [query (maybe-parse-int m-id -1)])))) (defn build-room-map-from-db [room-db] {:admin_only (room-db :admin_only) @@ -287,19 +250,40 @@ ;; login-token functions (defn logged-in? - "Test whether user is logged in by presence of nick key in session." - [request] - (contains? (request :session) :nick)) + "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 nick "%" expiry "%" token-hash))) + (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] - (let [x (.split token "\\%")] - (if (= (alength x) 3) - (try [(aget x 0) (Long/parseLong (aget x 1)) (aget x 2)] - (catch NumberFormatException _ nil))))) + ; 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)] @@ -311,11 +295,11 @@ (defn make-login-token [{nick :nick hash :hash}] - (let [expiration (ms-in-future *login-token-expiry*)] - (set-cookie *login-token-key* - (encode-login-token nick hash expiration) - :expires - (gmt-string (new Date expiration))))) + (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 ".dump.fm"))) ;; Landing @@ -340,18 +324,36 @@ (defn logout [session] [(session-dissoc :nick :user_id :is_admin :avatar) - (clear-login-token *login-token-key*) + (set-cookie *login-token-key* "dummy" + :expires "Thu, 01-Jan-1970 00:00:01 GMT" + :domain ".dump.fm") (redirect-to "/")]) ;; 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 (no-args-adaptor 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"] + (and (not (contains? (poll *reserved-nicks*) nick)) + (= (count (do-select [query (lower-case nick)])) 0)))) + (defn register [session params] (let [nick (params :nick) email (params :email) hash (params :hash) invalid-nick-reason (is-invalid-nick? nick)] (cond invalid-nick-reason (resp-error invalid-nick-reason) - (check-nick nick) (resp-error "NICK_TAKEN") + (nick-reserved? nick) (resp-error "NICK_TAKEN") :else (do (do-insert :users [:nick :hash :email] @@ -556,6 +558,18 @@ ;; 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 @@ -580,12 +594,11 @@ (.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] (if (validate-room-access room-key session) (chat session (lookup-room room-key) template) @@ -603,7 +616,7 @@ (commute users assoc nick (merge user-info {:last-seen now :avatar (session :avatar)})) (commute (room :users) assoc nick (user-struct-from-session session)))) - (resp-success (assoc (updates room since) :timestamp now))))) + (resp-success (assoc (updates room since) :timestamp now :v *chat-version-number*))))) (defn validated-refresh [session params] (let [room-key (params :room) @@ -619,10 +632,11 @@ (defn strip-params [s] (.replaceFirst s "\\?.*$" "")) +; TODO: is-image? is broken for messages w/ multiple image links. + (defn is-image? [content] - (if (and (re-find single-url-regex content) - (re-find pic-regex (strip-params content))) - true false)) + (boolean (and (re-find single-url-regex content) + (re-find pic-regex (strip-params content))))) (defn msg-db [user-id room-id content] (let [is-image (is-image? content) @@ -867,6 +881,14 @@ (or (is-file-too-big? f vip) (is-image-invalid? f))) + +; 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) @@ -880,7 +902,7 @@ (dosync (add-message msg room)) (copy (:tempfile image) dest) - "OK")))) + [200 "OK"])))) (defn upload [session params] (let [room-key (params :room) @@ -889,13 +911,10 @@ image (params :image) mute ((poll *active-mutes*) user-id) has-access (validate-room-access room-key session)] - ; --TODO-- - ; Because ajaxupload.js doesn't feature an error-handler, - ; all responses not equal to "OK" signal errors. - (cond (not nick) (resp-success "NOT_LOGGED_IN") - (not image) (resp-success "INVALID_REQUEST") - mute (resp-success (format-mute mute)) - (not has-access) (resp-success "UNKNOWN_ROOM") + (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 @@ -987,8 +1006,9 @@ ;; Admin stuff (should be own route?) (GET "/debug" (debug-page session flash)) (POST "/debug" (debug-commmand! session params)) - (GET "/mute-status" (mute-status session)) + (GET "/mutes" (show-mutes session)) (POST "/mute" (mute! session params)) + (POST "/cancel-mute" (handle-cancel-mute! session params)) ;; Footer pages (GET "/about_us" (serve-template "about_us" session)) @@ -1023,15 +1043,19 @@ (decorate static (with-mimetypes {:mimetypes mimetypes})) +(def *session-cookie-params* {:type :memory + :expires (* 60 60) + :domain ".dump.fm"}) + (decorate pichat (with-mimetypes {:mimetypes mimetypes}) (with-cookie-login (comp not logged-in?) make-login-token read-login-token) - (with-session {:type :memory, :expires (* 60 60)})) + (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 {:type :memory, :expires (* 60 60)}) + (with-session *session-cookie-params*) (with-multipart)) ;; Load messages from database |