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 | 184 | ||||
| -rwxr-xr-x | src/utils.clj | 104 |
6 files changed, 375 insertions, 176 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..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 diff --git a/src/utils.clj b/src/utils.clj index d6a95e5..f42746c 100755 --- a/src/utils.clj +++ b/src/utils.clj @@ -1,10 +1,15 @@ (ns utils (:import java.text.SimpleDateFormat java.util.Date + java.util.TimeZone + java.io.File java.net.URLDecoder + org.apache.commons.codec.digest.DigestUtils org.antlr.stringtemplate.StringTemplateGroup) (:use clojure.contrib.json.write - clojure.contrib.sql)) + clojure.contrib.sql + clojure.contrib.str-utils + compojure)) (let [db-host "localhost" db-port 5432 @@ -20,6 +25,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 +51,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 +61,73 @@ (defn kbytes [b] (* b 1024)) (defn mbytes [b] (* b 1024 1024)) -;; JSON responses +(defn open-file [dir-comps filename] + (let [d (str-join (System/getProperty "file.separator") + 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)))) + +;; 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 +141,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 @@ -144,10 +224,6 @@ (< (count n) 3) "NICK_TOO_SHORT" (not (re-matches nick-regex n)) "NICK_INVALID_CHARS")) -(defn check-nick [nick] - (let [query "SELECT * FROM users WHERE LOWER(nick) = ? LIMIT 1"] - (> (count (do-select [query (lower-case nick)])) 0))) - (defn fetch-nick [nick] (let [q1 "SELECT * FROM users WHERE nick = ? LIMIT 1" ; ORDER BY ensures consistent retrieval of ambiguious names |