diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/admin.clj | 209 | ||||
| -rwxr-xr-x | src/cookie_login.clj | 4 | ||||
| -rw-r--r-- | src/email.clj | 26 | ||||
| -rw-r--r-- | src/scheduled_agent.clj | 24 | ||||
| -rw-r--r-- | src/site.clj | 112 | ||||
| -rwxr-xr-x | src/utils.clj | 78 |
6 files changed, 314 insertions, 139 deletions
diff --git a/src/admin.clj b/src/admin.clj index e5d0c8f..ef33aa2 100644 --- a/src/admin.clj +++ b/src/admin.clj @@ -6,63 +6,62 @@ scheduled-agent utils)) -;; Debug Page - -(defn exception-to-string [e] - (let [sw (java.io.StringWriter.) - pw (java.io.PrintWriter. sw)] - (.printStackTrace e pw) - (.toString sw))) - -(defn lookup-templates [dir selected] - (for [f (.listFiles (File. dir)) - :when (and (.isFile f) (.endsWith (.getName f) ".st"))] - (let [n (s/butlast (.getName f) 3)] - {"template" n - "selected" (= selected n)}))) - -(defn debug-page [session flash] - (if-vip - (let [st (fetch-template "debug" session)] - (.setAttribute st "flash" (:msg flash)) - (.setAttribute st "mailtemps" (lookup-templates "template/mail" "welcome")) - (.toString st)))) - -(defn debug-commmand! [session params] - (if-vip - (let [action (:action params) - msg (try - (cond (= action "regemail") - (do (send-registration-email (params :nick) (params :to) (params :template)) - (str "Sent registration mail to " (params :to))) - :else (str "Unknown action: " action)) - (catch Exception e - (str "<h2 color=\"red\">Caught Exception in " action " --" - (.getMessage e) - "</h2><br><pre>" - (exception-to-string e) - "</pre>")))] - [(flash-assoc :msg msg) - (redirect-to "/debug")]))) - ;; Muting (def *mute-refresh-period-sec* 60) -(def fetch-mutes-query " -SELECT m.*, (m.set_on + m.duration) AS expiry, u.nick AS admin_nick -FROM mutes m, users u +(def fetch-active-mutes-query " +SELECT m.*, + (m.set_on + m.duration) AS expiry, + a.nick AS admin_nick, + o.nick AS nick +FROM mutes m, users a, users o WHERE (m.set_on + m.duration) > now() -AND u.user_id = m.admin_id -AND NOT m.is_canceled +AND a.user_id = m.admin_id +AND o.user_id = m.user_id +AND NOT m.cancelled +") + +(def fetch-inactive-mutes-query " +SELECT m.*, + (m.set_on + m.duration) AS expiry, + a.nick AS admin_nick, + o.nick AS nick, + c.nick AS cancel_nick +FROM mutes m +LEFT OUTER JOIN users o ON (m.user_id = o.user_id) +LEFT OUTER JOIN users a ON (m.admin_id = a.user_id) +LEFT OUTER JOIN users c ON (m.cancel_admin_id = c.user_id) +WHERE m.cancelled OR (m.set_on + m.duration < now()) ") -(defn update-mutes [] - (let [res (do-select [fetch-mutes-query])] +(def fetch-mute-query " +SELECT m.*, + (m.set_on + m.duration) AS expiry, + (m.set_on + m.duration) < now() as expired, + a.nick AS admin_nick +FROM mutes m, users a +WHERE mute_id = ? +AND a.user_id = m.admin_id +LIMIT 1 +") + + +(defn fetch-active-mutes [] + (do-select [fetch-active-mutes-query])) + +(defn fetch-active-mute-map [] + (let [res (fetch-active-mutes)] (zipmap (map :user_id res) res))) -(def *active-mutes* - (scheduled-agent (no-args-adaptor update-mutes) +(defn fetch-inactive-mutes [] + (do-select [fetch-inactive-mutes-query])) + +(defn fetch-mute [mute-id] + (first (do-select [fetch-mute-query mute-id]))) + +(def *active-mutes* + (scheduled-agent (no-args-adaptor fetch-active-mute-map) *mute-refresh-period-sec* nil)) @@ -74,8 +73,14 @@ AND NOT m.is_canceled (let [t (maybe-parse-int time 0) u (lower-case unit)] (and (> t 0) - (#{"minute" "hour" "day"} u) - (str time " " u)))) + (contains? #{"minutes" "hours" "days"} u) + (str time " " (pluralize (s/butlast u 1) t))))) + +(defn insert-mute! [user-id admin-id reason duration] + (do-prepared! "INSERT INTO mutes (user_id, admin_id, duration, reason) + VALUES (?, ?, CAST (? AS INTERVAL), ?)" + [user-id admin-id duration reason]) + (update! *active-mutes*)) (defn mute! [session params] (if-vip @@ -83,22 +88,106 @@ AND NOT m.is_canceled user-id (:user_id (fetch-nick nick)) time (params :time) unit (params :unit) - duration (parse-pos-interval time (s/butlast unit 1)) + duration (parse-pos-interval time unit) reason (params :reason) admin-id (session :user_id) admin-nick (session :nick)] - (cond (not user-id) [400 "INVALID_NICK"] - (not duration) [400 "INVALID_DURATION"] - ;; TODO: Ugly interval hack, w/ no escaping. Totally unsafe. - :else (let [q (format "INSERT INTO mutes (user_id, admin_id, duration, reason) - VALUES (%s, %s, '%s', '%s')" - user-id admin-id duration reason)] - (do-cmds q) - (send-mute-email nick admin-nick reason time unit) - "OK"))))) + (cond (not user-id) [400 "INVALID_NICK"] + (not duration) [400 "INVALID_DURATION"] + :else (do (insert-mute! user-id admin-id reason duration) + (send-mute-email nick admin-nick reason duration) + "OK"))))) +(def mute-cancel-query " +UPDATE mutes +SET cancelled=true, cancel_admin_id=? +WHERE mute_id = ? +AND cancelled = false +") + +(defn- assert-update [res ok err] + (if (zero? (first res)) err ok)) + +(defn cancel-mute! [mute-id admin-id] + (let [mute (fetch-mute mute-id) + active (nor (:expired mute) (:cancelled mute)) + qry "mute_id = ? AND cancelled = false + AND (set_on + duration) > now()"] + (cond (not mute) (resp-error "INVALID_MUTE_ID") + (not active) (resp-error "EXPIRED_MUTE") + :else (assert-update + (do-update :mutes [qry mute-id] + {:cancelled true + :cancel_admin_id admin-id}) + (resp-success "OK") + (resp-error "UPDATE_ERROR"))))) + +(defn handle-cancel-mute! [session params] + (if-vip + (let [mute-id (maybe-parse-int (params :mute_id) 0) + admin-id (session :user_id)] + (cancel-mute! mute-id admin-id)))) (defn format-mute [mute] (format (str "I'm sorry, you've been muted for %s. " "You'll be able to post again on %s EST.") (mute :reason) (mute :expiry))) + +(def mute-formatter {:duration format-interval + :set_on format-date-first-timestamp + :expiry format-date-first-timestamp + :cancelled #(if % "Cancelled" "Expired")}) + +(defn show-mutes [session] + (if-vip + (let [st (fetch-template "mutes" session) + active (fetch-active-mutes) + inactive (fetch-inactive-mutes) + formatter (partial apply-formats mute-formatter) + f #(map (comp stringify-and-escape formatter) %)] + (.setAttribute st "active" (f active)) + (.setAttribute st "inactive" (f inactive)) + (.toString st)))) + + +;; Debug Page + +(defn exception-to-string [e] + (let [sw (java.io.StringWriter.) + pw (java.io.PrintWriter. sw)] + (.printStackTrace e pw) + (.toString sw))) + +(defn lookup-templates [dir selected] + (for [f (.listFiles (File. dir)) + :when (and (.isFile f) (.endsWith (.getName f) ".st"))] + (let [n (s/butlast (.getName f) 3)] + {"template" n + "selected" (= selected n)}))) + +(defn debug-page [session flash] + (if-vip + (let [mutes (poll *active-mutes*) + st (fetch-template "debug" session)] + (.setAttribute st "flash" (:msg flash)) + (.setAttribute st "mailtemps" (lookup-templates "template/mail" "welcome")) + (.toString st)))) + +(defn debug-commmand! [session params] + (if-vip + (let [action (:action params) + msg (try + (cond (= action "regemail") + (do (send-registration-email (params :nick) + (params :to) + (params :template)) + (str "Sent registration mail to " (params :to))) + :else (str "Unknown action: " action)) + (catch Exception e + (str "<h2 color=\"red\">Caught Exception in " action " --" + (.getMessage e) + "</h2><br><pre>" + (exception-to-string e) + "</pre>")))] + [(flash-assoc :msg msg) + (redirect-to "/debug")]))) diff --git a/src/cookie_login.clj b/src/cookie_login.clj index 8c948a6..7eee2ae 100755 --- a/src/cookie_login.clj +++ b/src/cookie_login.clj @@ -8,8 +8,8 @@ "Creates an expiration cookie for a given cookie name." [token-key] (set-cookie token-key "dummy" - :expires "Thu, 01-Jan-1970 00:00:01 GMT")) - + :expires "Thu, 01-Jan-1970 00:00:01 GMT" + :domain ".dump.fm")) (defn handle-request-with-login-token "Validates login token, handles request, and updates cookies and session diff --git a/src/email.clj b/src/email.clj index 74d6625..1124f48 100644 --- a/src/email.clj +++ b/src/email.clj @@ -61,15 +61,20 @@ :host "smtpout.secureserver.net" :port 25 :ssl false - :to to + :to [(join to ",")] :subject subject :text text :mime (classify-mimetype text))) -(def admins ["opuscule@gmail.com" - "sbostler@gmail.com" - "stfn6000@gmail.com" - "theryderproject@gmail.com"]) +(def *admin-lists* {"dumpfmprod" ["opuscule@gmail.com" + "sbostler@gmail.com" + "stfn6000@gmail.com" + "theryderproject@gmail.com"] + "sostler" ["sbostler@gmail.com"]}) + +(defn get-admins [] + (or (*admin-lists* (System/getProperty "user.name")) + (*admin-lists* "dumpfmprod"))) (defn send-registration-email ([nick email] (send-registration-email nick email "welcome")) @@ -81,10 +86,9 @@ (let [[s b] (parse-mail-template "reset" {"nick" nick "key" key})] (dump-mail [email] s b))) -(defn send-mute-email [user-nick admin-nick reason time unit] - (let [subject (format "%s was muted by %s for %s %s" - user-nick admin-nick time unit) +(defn send-mute-email [user-nick admin-nick reason duration] + (let [subject (format "%s was muted by %s for %s" + user-nick admin-nick duration) body (format "Reason: %s" - reason) - recips (join admins ",")] - (dump-mail [recips] subject body))) + reason)] + (dump-mail (get-admins) subject body))) diff --git a/src/scheduled_agent.clj b/src/scheduled_agent.clj index 702b314..b42bb57 100644 --- a/src/scheduled_agent.clj +++ b/src/scheduled_agent.clj @@ -9,23 +9,29 @@ (defn scheduled-agent [func period init] (let [pool (Executors/newScheduledThreadPool 1) - r (ref init) + data (ref init) pfunc (runnable-proxy (fn [] (try (dosync - (ref-set r (func (ensure r)))) + (ref-set data (func (ensure data)))) (catch Exception e (print-stack-trace e 5))))) future (.scheduleWithFixedDelay pool pfunc 0 period TimeUnit/SECONDS)] - {:pool pool - :data r + {:pool pool + :data data :future future - :func pfunc + :func func :period period - :init init})) - -(defn cancel [{f :future}] - (.cancel f false)) + :init init})) (defn poll [{d :data}] + "Return current contents of agent." @d) + +(defn cancel! [{f :future}] + "Cancel automatic updating of agent data. Cannot be restarted." + (.cancel f false)) + +(defn update! [{func :func data :data}] + "Synchronously update contents of agent." + (dosync (ref-set data (func (ensure data)))))
\ No newline at end of file diff --git a/src/site.clj b/src/site.clj index d45aa09..d58406c 100644 --- a/src/site.clj +++ b/src/site.clj @@ -71,9 +71,6 @@ ;; Utils -(defn id [x] - x) - (defn open-file [dir-comps filename] (let [d (str-join (System/getProperty "file.separator") (cons *root-directory* dir-comps)) @@ -138,17 +135,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 +142,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] @@ -225,14 +211,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 +273,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 +318,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,7 +347,9 @@ (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 @@ -584,8 +593,6 @@ (.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) @@ -619,10 +626,11 @@ (defn strip-params [s] (.replaceFirst s "\\?.*$" "")) +; TODO: is-image? has *long* been broken wrt 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 +875,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 +896,7 @@ (dosync (add-message msg room)) (copy (:tempfile image) dest) - "OK")))) + [200 "OK"])))) (defn upload [session params] (let [room-key (params :room) @@ -889,13 +905,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 +1000,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 +1037,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 diff --git a/src/utils.clj b/src/utils.clj index d6a95e5..d2575c6 100755 --- a/src/utils.clj +++ b/src/utils.clj @@ -4,7 +4,8 @@ java.net.URLDecoder org.antlr.stringtemplate.StringTemplateGroup) (:use clojure.contrib.json.write - clojure.contrib.sql)) + clojure.contrib.sql + compojure)) (let [db-host "localhost" db-port 5432 @@ -20,6 +21,20 @@ ;; Misc +(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 nor [& args] + (not-any? identity args)) + (defn no-args-adaptor [f] (fn [& more] (f))) @@ -32,13 +47,6 @@ (defn join [lst int] (apply str (interpose int lst))) -(def YYYYMMDD-format (new SimpleDateFormat "yyyyMMdd")) - -(defn today [] - (.format YYYYMMDD-format (new Date))) - -(def formatter (new SimpleDateFormat "h:mm a EEE M/d")) - (defn non-empty-string? [s] (cond (string? s) (> (count s) 0) :else s)) @@ -49,13 +57,55 @@ (defn kbytes [b] (* b 1024)) (defn mbytes [b] (* b 1024 1024)) -;; JSON responses +;; Formatters (def yyyy-mm-dd-formatter (new SimpleDateFormat "yyyy-MM-dd")) +(defn format-yyyy-mm-dd [d] + (.format yyyy-mm-dd-formatter d)) + +(def yymmdd-formatter (new SimpleDateFormat "yyyyMMdd")) + +(defn format-yyyymmdd [d] + (.format yymmdd-formatter d)) + +(defn today [] + (format-yyyymmdd (new Date))) + +(def timestamp-formatter (new SimpleDateFormat "h:mm a EEE M/d")) +(def date-first-timestamp-formatter (new SimpleDateFormat "M/d h:mm a")) + +(defn format-timestamp [d] + (.format timestamp-formatter d)) + +(defn format-date-first-timestamp [d] + (.format date-first-timestamp-formatter d)) + +(defn pluralize [word val] + (if (= val 1) word (str word "s"))) + +(defn format-interval [i] + (let [vals [(.getYears i) + (.getMonths i) + (.getDays i) + (.getHours i) + (.getMinutes i)] + labels ["year" "month" "day" "hour" "minute"] + arr (into [] (for [[l v] (map vector labels vals) :when (> v 0)] + (str v " " (pluralize l v))))] + (join arr ", "))) + +(defn apply-formats [formats d] + (into {} (for [[k v] d] + (if-let [f (formats k)] + [k (f v)] + [k v])))) + +;; JSON responses + (defmethod print-json Date [d] - (print-json (.format yyyy-mm-dd-formatter d))) + (print-json (format-yyyy-mm-dd d))) (defn resp-error [message] {:status 400 :headers {} :body message}) @@ -69,6 +119,14 @@ (with-connection *db* (do-commands query))) +(defn do-prepared! [& args] + (with-connection *db* + (apply do-prepared args))) + +(defn do-update [& args] + (with-connection *db* + (apply update-values args))) + (defn do-select [query] (with-connection *db* (with-query-results rs query |