diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/admin.clj | 204 | ||||
| -rw-r--r-- | src/email.clj | 6 | ||||
| -rw-r--r-- | src/scheduled_agent.clj | 24 | ||||
| -rw-r--r-- | src/site.clj | 34 | ||||
| -rwxr-xr-x | src/utils.clj | 78 |
5 files changed, 244 insertions, 102 deletions
diff --git a/src/admin.clj b/src/admin.clj index e5d0c8f..c1a6c07 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()) +") + +(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 update-mutes [] - (let [res (do-select [fetch-mutes-query])] + +(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))) +(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 update-mutes) + (scheduled-agent (no-args-adaptor fetch-active-mute-map) *mute-refresh-period-sec* nil)) @@ -74,8 +73,13 @@ 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 +87,104 @@ 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/email.clj b/src/email.clj index 74d6625..75121cf 100644 --- a/src/email.clj +++ b/src/email.clj @@ -81,9 +81,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 ",")] 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..8342a09 100644 --- a/src/site.clj +++ b/src/site.clj @@ -138,17 +138,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 +145,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] @@ -867,6 +856,11 @@ (or (is-file-too-big? f vip) (is-image-invalid? f))) +; TODO: +; The webcam code doesn't feature an error handler, +; so all upload responses not equal to "OK" are considered +; errors. + (defn do-upload [session image room] (if-let [err (validate-upload-file (image :tempfile) (is-vip? session))] (resp-error err) @@ -880,7 +874,7 @@ (dosync (add-message msg room)) (copy (:tempfile image) dest) - "OK")))) + (resp-success "OK"))))) (defn upload [session params] (let [room-key (params :room) @@ -889,13 +883,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 +978,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)) 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 |