diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/config.clj | 23 | ||||
| -rw-r--r-- | src/datalayer.clj | 211 | ||||
| -rw-r--r-- | src/fame.clj | 4 | ||||
| -rwxr-xr-x | src/feed.clj | 2 | ||||
| -rw-r--r-- | src/jedis.clj | 15 | ||||
| -rw-r--r-- | src/message.clj | 39 | ||||
| -rw-r--r-- | src/redisload.clj | 100 | ||||
| -rw-r--r-- | src/rooms.clj | 17 | ||||
| -rw-r--r-- | src/site.clj | 378 | ||||
| -rw-r--r-- | src/tags.clj | 63 | ||||
| -rw-r--r-- | src/user.clj | 60 | ||||
| -rwxr-xr-x | src/utils.clj | 67 |
12 files changed, 656 insertions, 323 deletions
diff --git a/src/config.clj b/src/config.clj index 3230c72..c4e2fe3 100644 --- a/src/config.clj +++ b/src/config.clj @@ -11,10 +11,25 @@ "http://localhost:8080")) (def *cookie-domain* - (if (= *server-user* "timb") - "" - ".dump.fm")) + (if (= *server-user* "dumpfmprod") + ".dump.fm" + "")) + +(def redis-server + (if (= *server-user* "dumpfmprod") + {:host "192.168.156.111" :port 6379 :db 0 } + {:host "127.0.0.1" :port 6379 :db 0 })) (def *root-directory* (System/getProperty "user.dir")) (def *image-directory* "images") -(def *avatar-directory* "avatars")
\ No newline at end of file +(def *avatar-directory* "avatars") + + +;; Settings + +(def num-popular-dumps 40) +(def *dumps-per-page* 20) +(def *vip-dumps-per-page* 200) +(def message-count-limit 200) +(def num-hall-dumps 50) +(def max-content-size 2468)
\ No newline at end of file diff --git a/src/datalayer.clj b/src/datalayer.clj new file mode 100644 index 0000000..6b2a466 --- /dev/null +++ b/src/datalayer.clj @@ -0,0 +1,211 @@ +(ns datalayer + (:require redis + tags) + (:use clojure.contrib.sql + clojure.contrib.json.write + clojure.contrib.json.read + config + jedis + message + user + utils)) + + + +;;;; Message lookup + +(defn recent-posts-query [user-id] + (format " +SELECT u.user_id, u.nick, u.avatar, + m.content, m.message_id%s +FROM users u +LEFT JOIN messages m on m.message_id = + (SELECT message_id FROM messages + WHERE user_id = u.user_id + AND is_image + AND room_id IN (SELECT room_id from rooms where admin_only = false) + ORDER BY created_on desc LIMIT 1) +WHERE u.user_id = ANY(?)" + (if user-id + (format + ", + EXISTS (SELECT 1 FROM tags + WHERE tag = 'favorite' AND user_id = %s AND message_id = m.message_id) AS favorited" + user-id) + ", false AS favorited"))) + +(defn recent-posts-nick-query [user-id] + (format " +SELECT u.user_id, u.nick, u.avatar, + m.content, m.message_id%s +FROM users u +LEFT JOIN messages m on m.message_id = + (SELECT message_id FROM messages + WHERE user_id = u.user_id + AND is_image + AND room_id IN (SELECT room_id from rooms where admin_only = false) + ORDER BY created_on desc LIMIT 1) +WHERE u.nick = ANY(?)" + (if user-id + (format + ", + EXISTS (SELECT 1 FROM tags + WHERE tag = 'favorite' AND user_id = %s AND message_id = m.message_id) AS favorited" + user-id) + ", false AS favorited"))) + +(defn lookup-recent-posts [user-tag-id user-ids] + (do-select [(recent-posts-query user-tag-id) + (sql-array "int" user-ids)])) + +(defn lookup-recent-posts-tagless [user-ids] + (do-select [(recent-posts-query nil) + (sql-array "int" user-ids)])) + +(defn lookup-recent-posts-by-nicks [user-tag-id nicks] + (do-select [(recent-posts-nick-query user-tag-id) + (sql-array "varchar" nicks)])) + +(defn lookup-recent-posts-tagless-by-nicks [nicks] + (do-select [(recent-posts-nick-query nil) + (sql-array "text" nicks)])) + +(defn fetch-message-by-id [m-id] + (let [query "SELECT m.message_id, m.content, m.created_on, m.user_id, + m.is_image, 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)])))) + +;;;; Popular Posts + +(def popular-dumps-qry " +select u.nick, u.avatar, r.key, m.message_id, m.content, m.created_on, count(*) as count, + array_agg(u2.nick) as user_nicks +from users u, messages m, rooms r, tags t, users u2 +where lower(u.nick) = lower(?) +and u.user_id = m.user_id and m.message_id = t.message_id +and m.room_id = r.room_id and m.is_image = true and r.admin_only = false +and t.tag = 'favorite' +and t.user_id = u2.user_id +group by u.nick, u.avatar, r.key, m.message_id, m.content, m.created_on +order by count desc limit ? offset ?") + +(defn fetch-popular-dumps [nick viewer-nick] + (for [d (do-select [popular-dumps-qry nick 40 0])] + (let [favers (.getArray (:user_nicks d))] + (assoc d + :favers favers + :favorited (some #(= % viewer-nick) favers))))) + +(defn fetch-popular-dumps-redis [nick viewer-nick] + (let [rkey (str "popular:" nick) + msg-ids (redis/with-server redis-server + (redis/zrevrange rkey 0 (dec num-popular-dumps))) + msg-ids (map maybe-parse-int msg-ids)] + (if-not (empty? msg-ids) + (tags/fetch-dumps-by-ids msg-ids viewer-nick)))) + + +;;;; Redis Favscores + +(defn fetch-redis-directory [page num] + (vec + (for [t (with-jedis + #(.zrevrangeWithScores % + "favscores" + (* page num) + (dec (* (inc page) num))))] + {:nick (.getElement t) + :score (int (.getScore t))}))) + +(defn fetch-redis-favscore [nick] + (if (= (lower-case nick) "scottbot") + -1 + (maybe-parse-int + (redis/with-server redis-server + (redis/zscore "favscores" (lower-case nick))) + 0))) + +(defn incrby-redis-favscore! [nick msg-id inc is-image] + (let [msg-id (str msg-id) + inc (double inc)] + (with-jedis + #(do + (.zincrby % "favscores" inc (lower-case nick)) + (when is-image + (.zincrby % (str "popular:" nick) inc msg-id) + (.zincrby % "hall" inc msg-id)))))) + + +;;;; Redis Hall of Fame + +(defn fetch-redis-hall [viewer-nick] + (let [ids (map maybe-parse-int + (redis/with-server redis-server + (redis/zrevrange "hall" 0 (dec num-hall-dumps))))] + (if-not (empty? ids) + (tags/fetch-dumps-by-ids ids viewer-nick)))) + +;;;; Message insertion + +(def msg-insert-query + "INSERT INTO messages (user_id, room_id, content, is_image, is_text) + VALUES (?, ?, ?, ?, ?) RETURNING message_id, created_on") + +(defn insert-message-into-postgres! [author-id room-id content is-image is-text recips] + (with-connection *db* + (transaction + (let [{msg-id :message_id ts :created_on} + (first + (do-select [msg-insert-query + author-id room-id content is-image is-text]))] + (doseq [r recips] + (insert-values + :direct_messages + [:message_id :author_id :recip_id] + [msg-id author-id (:user_id r)])) + [msg-id ts])))) + +(defn insert-recips-into-redis! [recips author-id ts content] + (let [dm-json (json-str {"author_id" author-id + "recips" (map :nick recips) + "content" content})] + (redis/with-server redis-server + (redis/atomically + (doseq [r recips] + (redis/zadd (str "directmessage:" (:user_id r)) + (.getTime ts) + dm-json)))))) + +(defn insert-message! [author-id author-nick room-id content] + (let [msg-type (classify-msg content) + is-image (boolean (#{:image :mixed} msg-type)) + is-text (boolean (#{:mixed :text} msg-type)) + recips (get-recips content) + [msg-id ts] (insert-message-into-postgres! author-id + room-id + content + is-image + is-text + recips)] + (if-not (empty? recips) + (insert-recips-into-redis! recips author-id ts content)) + {:author author-nick + :msg-id msg-id + :room room-id + :db-ts ts + :content content + :recips (map (comp lower-case :nick) recips)})) + +(defn fetch-private-messages [user-id] + (for [dm (redis/with-server redis-server + (redis/zrevrange (str "directmessage:" user-id) 0 40))] + (let [dm (read-json dm) + info (fetch-user-id (get dm "author_id"))] + {"nick" (:nick info) + "content" (get dm "content") + "recips" (get dm "recips" []) + "avatar" (:avatar info)}))) diff --git a/src/fame.clj b/src/fame.clj index 0732992..1baf6e0 100644 --- a/src/fame.clj +++ b/src/fame.clj @@ -2,8 +2,8 @@ (:use scheduled-agent utils)) -; should probably cache this to disk somewhere -(def hall-of-fame-update-frequency (* 5 60 60)) +; sostler: don't refresh until redis cache can be added +(def hall-of-fame-update-frequency (* 5 60 60 999999)) (def hall-of-fame-query " select m.created_on, m.message_id, m.content, u.nick, u.avatar, r.key, count(*) diff --git a/src/feed.clj b/src/feed.clj index c8454d0..898f085 100755 --- a/src/feed.clj +++ b/src/feed.clj @@ -16,6 +16,8 @@ scheduled-agent utils)) +;; DEPRECATED + (def *feeds-path* "docs/feeds.csv") (defn queue-image! [room-key img] diff --git a/src/jedis.clj b/src/jedis.clj new file mode 100644 index 0000000..bc53eda --- /dev/null +++ b/src/jedis.clj @@ -0,0 +1,15 @@ +(ns jedis + (:import org.apache.commons.pool.impl.GenericObjectPool$Config + redis.clients.jedis.JedisPool) + (:use config)) + +(def pool (JedisPool. (:host redis-server) (:port redis-server))) +(.init pool) + + +(defn with-jedis [fn] + (let [r (.getResource pool)] + (try + (fn r) + (finally (.returnResource pool r))))) + diff --git a/src/message.clj b/src/message.clj new file mode 100644 index 0000000..a8e0e9b --- /dev/null +++ b/src/message.clj @@ -0,0 +1,39 @@ +(ns message + (:use user)) + +;; Message parsing + +;; 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-image? [word] + (and (re-find url-regex word) + (re-find pic-regex word))) + +(defn take-images [content] + (filter is-image? (.split content " "))) + +(defn classify-msg [msg] + (let [words (.split msg " ") + imgs (map is-image? words)] + (cond (every? boolean imgs) :image + (some boolean imgs) :mixed + :else :text))) + +(def recip-regex #"(?:^|\s)@\w+") + +(defn get-recips [content] + (filter + boolean + (for [at-nick (re-seq recip-regex content)] + (fetch-nick (.substring (.trim at-nick) 1))))) + +(defn get-recips-from-msgs [msgs] + (let [recips (set (apply concat + (for [m msgs] + (re-seq recip-regex (:content m)))))] + (filter + boolean + (for [r recips] + (fetch-nick (.substring (.trim r) 1)))))) diff --git a/src/redisload.clj b/src/redisload.clj new file mode 100644 index 0000000..31a25f0 --- /dev/null +++ b/src/redisload.clj @@ -0,0 +1,100 @@ +(ns redisload + (:use clojure.contrib.sql + clojure.contrib.str-utils + config + datalayer + utils) + (:require redis)) + +(defn redis-days [n] + (* 24 60 60)) + +(def tag-query " +SELECT + u.nick as author, + u.user_id as author_id, + m.message_id as message_id, + m.content as message_content, + m.is_image as is_image, + m.created_on as message_ts, + r.key as room, + r.admin_only as admin_only, + t.created_on as tagged_on, + u2.nick as tagger, + u2.user_id as tagger_id +FROM users u, messages m, rooms r, tags t, users u2 +WHERE + u.user_id = m.user_id AND + m.message_id = t.message_id AND + r.room_id = m.room_id AND + u2.user_id = t.user_id AND + r.admin_only = false +") + +(def tag-counter (ref 0)) + +(defn stream-tags [fs] + (with-connection *db* + (with-query-results rs [tag-query] + (doseq [r rs] + (if (:admin_only r) + (println r)) + (dosync + (ref-set tag-counter (inc @tag-counter))) + (doseq [f fs] + (f r)))))) + +(def hall-map (ref {})) +(def popular-map (ref {})) +(def score-map (ref {})) + +(defn update-popular [r] + (dosync + (let [author (:author r) + msg-id (:message_id r) + user-map (get @popular-map author {}) + msg-cnt (get user-map msg-id 0) + hall-cnt (get @hall-map msg-id 0) + usr-cnt (get @score-map author 0)] + (alter score-map assoc author (inc usr-cnt)) + (alter hall-map assoc msg-id (inc hall-cnt)) + (if (:is_image r) + (alter popular-map assoc author + (assoc user-map msg-id (inc msg-cnt))))))) + +(defn transmit-popular [] + (doseq [[nick msgs] @popular-map] + (let [sorted-msgs (sort #(>= (second %1) (second %2)) msgs) + userkey (str "popular:" nick)] + (redis/atomically + (redis/del key) + (doseq [[msg-id score] (take (* num-popular-dumps 2) + sorted-msgs)] + (redis/zadd userkey score msg-id))))) + (println "cached popular data for" (count @popular-map) "users")) + +(defn transmit-favscores [] + (redis/atomically + (redis/del "favscores") + (doseq [[nick score] @score-map] + (redis/zadd "favscores" score (lower-case nick)))) + (println "cached favscores for " (count @score-map) "users")) + +(defn transmit-hall [] + (let [scores (take (* 2 num-hall-dumps) + (sort #(>= (second %1) (second %2)) @hall-map))] + (redis/atomically + (redis/del "hall") + (doseq [[msg-id score] scores] + (redis/zadd "hall" score msg-id))))) + + +(println "streaming tags") +(stream-tags [update-popular]) +(println (format "processed %s tags" @tag-counter)) + +(redis/with-server redis-server + (transmit-favscores) + (transmit-popular) + (transmit-hall)) + diff --git a/src/rooms.clj b/src/rooms.clj index e919557..3367ea9 100644 --- a/src/rooms.clj +++ b/src/rooms.clj @@ -2,10 +2,11 @@ (:import java.util.Date) (:use clojure.contrib.str-utils clojure.contrib.def + config utils user)) -(defstruct message-struct :nick :content :created_on :msg_id) +(defstruct message-struct :nick :content :created_on :msg_id :recips) (def *run-flusher* true) (def *flusher-sleep* (seconds 4)) @@ -98,21 +99,12 @@ ; Note: To ensure that the msg's timestamp is consistent ; with other msg creations, build-msg must be used ; within a dosync. -(defn build-msg [nick content msg-id] - (struct message-struct nick content (new Date) msg-id)) - -(def message-count-limit 200) +(defn build-msg [nick content msg-id recips] + (struct message-struct nick content (new Date) msg-id recips)) (defn add-message [msg room] (insert-and-truncate! (room :messages) msg message-count-limit)) -(defn insert-message-into-db! [user-id room-id content is-image] - (:message_id - (first - (do-select ["INSERT INTO messages (user_id, room_id, content, is_image) - VALUES (?, ?, ?, ?) RETURNING message_id" - user-id room-id content is-image])))) - (defn create-and-add-room! [key] (do-select ["INSERT INTO rooms (key, name, description) VALUES (?, ?, ?) RETURNING room_id" @@ -123,7 +115,6 @@ (build-room-map-from-db room-db)) room-db))) -; TODO: cache (defn get-or-create-room! [key] (:room_id (or (first (do-select ["SELECT room_id FROM rooms WHERE lower(key) = ?" diff --git a/src/site.clj b/src/site.clj index a1f5c08..fc7d541 100644 --- a/src/site.clj +++ b/src/site.clj @@ -18,12 +18,13 @@ config admin compojure + datalayer email fame + message utils cookie-login session-sweeper - feed rooms tags scheduled-agent @@ -110,50 +111,21 @@ (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 (tags/fetch-dump-by-id m-id)] - (if (and msg (not (:admin_only msg))) +(defn fetch-public-message-by-id [m-id viewer-nick] + (if-let [msg (tags/fetch-dump-by-id m-id viewer-nick)] + (if-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 {})) +;; sostler todo: will replace this w/ user/user-id-cache soon +(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)] + found (@*user-id-cache* nick)] (if found found (let [query (str "SELECT user_id FROM users WHERE lower(nick) = ?") @@ -162,8 +134,8 @@ 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)) + (if (> (count @*user-id-cache*) *user-id-cache-size*) (ref-set *user-id-cache* {})) + (alter *user-id-cache* assoc nick found)) found)))))) ;; Login code @@ -246,9 +218,10 @@ (defn log-login [user_id ip] ;; i'm using do-cmds here because update-values can't deal with stuff like 'last_login = now()' - (let [query (format "UPDATE users SET last_ip = '%s'::cidr, last_login = now() WHERE user_id = %s" (str ip) (str user_id))] - (do-cmds query)) -) + (try + (let [query (format "UPDATE users SET last_ip = '%s'::cidr, last_login = now() WHERE user_id = %s" (str ip) (str user_id))] + (do-cmds query)) + (catch Exception e nil))) (defn login [session params cookies request] (let [nick (or (params :nick) "") @@ -264,16 +237,15 @@ (log-login (db-user :user_id) ip) [(session-assoc-from-db db-user) login-cookie - (resp-success "OK")] - ) - (resp-error "BAD_LOGIN")))) + (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/")]) + (redirect-to "/")]) ;; Registration @@ -355,7 +327,8 @@ ORDER BY cnt DESC {:list res :map (zipmap (map :nick res) (map :cnt res))})) -(def *scores-refresh-period-sec* (* 29 60)) +;; sostler: stop score refresh until redis cache can be added +(def *scores-refresh-period-sec* (* 29 60 9999999)) (def *user-scores* (scheduled-agent build-score-list @@ -401,22 +374,8 @@ ORDER BY cnt DESC (map (comp take-images :content) dumps)))))) - -(defn count-dumps-posted [nick] - (:count - (first - (do-select ["select count(*) from messages m, users u - where m.user_id = u.user_id and lower(u.nick) = ? - and m.is_image = true" (.toLowerCase nick)])))) -(defn count-dumps-user-faved [nick] - (:count - (first - (do-select ["select count(distinct(m.message_id)) from users u, tags t, messages m - where lower(u.nick) = ? and u.user_id = t.user_id - and t.tag = 'favorite' - and t.message_id = m.message_id and m.is_image = true" - (.toLowerCase nick)])))) +(def use-redis-favscore true) (defn profile ([session profile-nick] (profile session profile-nick "profile")) @@ -424,14 +383,18 @@ ORDER BY cnt DESC (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) + nick (:nick session) logger (make-time-logger) is-home (and nick (= nick profile-nick)) - score (lookup-score profile-nick) + score (if use-redis-favscore + (fetch-redis-favscore profile-nick) + (lookup-score profile-nick)) dumps (logger tags/fetch-dumps :user-tag-id (:user_id session) :nick profile-nick :limit 10) + dms (fetch-private-messages (:user_id user-info)) + recips (set (apply concat (map #(get % "recips") dms))) imgs (pull-random-dump-images dumps 5)] (do (.setAttribute st "is_home" is-home) @@ -441,6 +404,9 @@ ORDER BY cnt DESC (if (non-empty-string? v) (escape-html v))))) (.setAttribute st "score" (comma-format score)) (.setAttribute st "score_ent" (score-to-entity score)) + (when-not (empty? dms) + (.setAttribute st "dms" dms) + (.setAttribute st "recips" (json-str (map lower-case recips)))) (if (not (empty? imgs)) (.setAttribute st "imgs" imgs)) (.setAttribute st "debug_log_items" (logger)) @@ -449,7 +415,8 @@ ORDER BY cnt DESC (defn update-user-db [user-id attr val] (with-connection *db* - (update-values "users" ["user_id = ?" user-id] {attr val}))) + (update-values "users" ["user_id = ?" user-id] {attr val})) + (update-cache! user-id attr val)) (defn update-avatar [session url] (update-user-db (session :user_id) "avatar" url) @@ -490,7 +457,9 @@ ORDER BY cnt DESC (defn build-mini-profile [user-info] (let [st (fetch-template-fragment "mini_profile") nick (user-info :nick) - score (lookup-score nick)] + score (if use-redis-favscore + (fetch-redis-favscore nick) + (lookup-score nick))] (doseq [a [:nick :avatar :contact :bio]] (let [v (user-info a)] (.setAttribute st (name a) @@ -549,42 +518,16 @@ ORDER BY cnt DESC ;; Who faved me -(def popular-dumps-qry " -select u.nick, u.avatar, r.key, m.message_id, m.content, m.created_on, count(*) as count, - array_agg(u2.nick) as user_nicks, - array_agg(u2.avatar) as user_avs, - array_agg(t.created_on) as favtime, - (select exists (select 1 from tags - where tag = 'favorite' and user_id = ? and message_id = m.message_id)) as favorited -from users u, messages m, rooms r, tags t, users u2 -where lower(u.nick) = lower(?) -and u.user_id = m.user_id and m.message_id = t.message_id -and m.room_id = r.room_id and m.is_image = true and r.admin_only = false -and t.tag = 'favorite' and t.user_id != u.user_id -and t.user_id = u2.user_id -group by u.nick, u.avatar, r.key, m.message_id, m.content, m.created_on -order by count desc limit ? offset ?") - -(def num-popular-dumps 40) - -(defn get-popular-dumps [nick user-id] - (for [d (do-select [popular-dumps-qry user-id nick 40 0])] - (let [fav-nicks (.getArray (:user_nicks d))] - (assoc d - :favers (sort-by :t (comp #(* -1 %) compare) - (map (fn [n a t] (if (non-empty-string? a) - {:nick n :avatar a :t t} - {:nick n :t t})) - fav-nicks - (.getArray (:user_avs d)) - (.getArray (:favtime d)))) - :user_nicks nil :user_avs nil :favtime nil)))) +(def use-popular-redis true) (defn popular [session profile-nick] (if-let [user-info (fetch-nick profile-nick)] (let [st (fetch-template "popular" session) profile-nick (:nick user-info) - raw-dumps (get-popular-dumps profile-nick (or (:user_id session) -1)) + raw-dumps (if use-popular-redis + (fetch-popular-dumps-redis profile-nick (:nick session)) + (fetch-popular-dumps profile-nick (:nick session))) + raw-dumps (filter #(> (:count %) 0) raw-dumps) dumps (map process-message-for-output raw-dumps)] (.setAttribute st "nick" profile-nick) (.setAttribute st "mini_profile" (build-mini-profile user-info)) @@ -597,38 +540,9 @@ order by count desc limit ? offset ?") (def *per-directory-page* 25) (defn process-directory-entry [entry] - (let [score (lookup-score (:nick entry))] - (assoc (stringify-and-escape entry) - "score_ent" (score-to-entity score) - "score" score))) - -(defn recent-posts-query [user-id] - (format " -SELECT u.user_id, u.nick, u.avatar, - m.content, m.message_id%s -FROM users u -LEFT JOIN messages m on m.message_id = - (SELECT message_id FROM messages - WHERE user_id = u.user_id - AND is_image - AND room_id IN (SELECT room_id from rooms where admin_only = false) - ORDER BY created_on desc LIMIT 1) -WHERE u.user_id = ANY(?)" - (if user-id - (format - ", - EXISTS (SELECT 1 FROM tags - WHERE tag = 'favorite' AND user_id = %s AND message_id = m.message_id) AS favorited" - user-id) - ", false AS favorited"))) - -(defn lookup-recent-posts [user-tag-id user-ids] - (do-select [(recent-posts-query user-tag-id) - (sql-array "int" user-ids)])) + (assoc (stringify-and-escape entry) + "score_ent" (score-to-entity (:score entry)))) -(defn lookup-recent-posts-tagless [user-tag-id user-ids] - (do-select [(recent-posts-query nil) - (sql-array "int" user-ids)])) (def directory-cache-ttl (minutes 10)) (def memoized-lookup-recent-posts-tagless @@ -637,15 +551,25 @@ WHERE u.user_id = ANY(?)" (defn add-recent-posts [user-id users] (if-not (empty? users) - (let [f (if user-id lookup-recent-posts lookup-recent-posts-tagless) - res (f user-id (map :user_id users))] + (let [res (if user-id + (lookup-recent-posts user-id (map :user_id users)) + (lookup-recent-posts-tagless (map :user_id users)))] (for [u users] (merge u (find-first #(= (:user_id u) (:user_id %)) res)))))) +(defn add-recent-posts-nick [user-id users] + (if-not (empty? users) + (let [nicks (map :nick users) + res (if user-id + (lookup-recent-posts-by-nicks user-id nicks) + (lookup-recent-posts-tagless-by-nicks nicks))] + (for [u users] + (merge u (find-first #(= (:nick u) (:nick %)) res)))))) + (defn get-directory-info [user-id offset] - (map process-directory-entry - (add-recent-posts user-id - (get-user-ranking offset *per-directory-page*)))) + (let [res (fetch-redis-directory offset *per-directory-page*)] + (map process-directory-entry + (add-recent-posts-nick user-id res)))) (defn directory [session offset] (let [st (fetch-template "directory" session) @@ -662,19 +586,15 @@ WHERE u.user_id = ANY(?)" ;; 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) - message (tags/add-favorited-flag message session) - message (tags/remove-tags-for-output message)] - (.setAttribute st "dump" (process-message-for-output message)) - (.toString st)) - (resp-error "NO_MESSAGE")) + (if-let [message (fetch-public-message-by-id id-from-url (:nick session))] + ; 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 (= nick-from-url (:nick message)) + (let [st (fetch-template "single_message" session)] + (.setAttribute st "dump" (process-message-for-output message)) + (.toString st)) (resp-error "NO_MESSAGE")) - (resp-error "NO_USER"))) + (resp-error "NO_MESSAGE"))) ;; Chat @@ -699,6 +619,7 @@ WHERE u.user_id = ANY(?)" :user-tag-id (:user_id session) :hide-vip false :limit (:history_size room))) + recips (map :nick (get-recips-from-msgs raw-msgs)) message-list (to-array (map process-message-for-output raw-msgs))] (if nick (dosync @@ -706,6 +627,7 @@ WHERE u.user_id = ANY(?)" (doto st (.setAttribute "users" (prepare-user-list room true)) (.setAttribute "messages" message-list) + (.setAttribute "recips" (json-str (map lower-case recips))) (.setAttribute "roomkey" (room :key)) (.setAttribute "isadminroom" (room :admin_only)) (.setAttribute "json_room_key" (json-str (room :key))) @@ -755,34 +677,29 @@ WHERE u.user_id = ANY(?)" (str "<unsafe>" content "</unsafe>")) (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)) + (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)) + content-too-long? (> (count content) + max-content-size)] + (cond (not room) (resp-error "BAD_ROOM") + (not nick) (resp-error "NOT_LOGGED_IN") + content-too-long? (resp-error "TOO_LONG") + mute (resp-error (format-mute mute)) :else - (let [content (validated-content content session) - msg-id (msg-db user-id (room :room_id) content)] + (let [content (validated-content content session) + msg-info (insert-message! user-id nick (:room_id room) content) + msg-id (:msg-id msg-info)] (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))))) + (add-message (build-msg nick content msg-id (:recips msg-info)) room)) + (resp-success {:msgid msg-id + :recips (:recips msg-info)}))))) (defn validated-msg [session params request] @@ -822,7 +739,8 @@ WHERE u.user_id = ANY(?)" 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) + 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) @@ -844,18 +762,17 @@ WHERE u.user_id = ANY(?)" (.toString st))) (defn validated-log [session room-key offset params] - (if-vip - (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"))) - (redirect-to "http://dump.fm"))) + (if (is-vip? session) + (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"))) + (redirect-to "/"))) ;; Hiscore test... redis test... (defn redis-ids-test [period] - (let [reddis-server {:host "127.0.0.1" :port 6379 :db 0} - ids (redis/with-server reddis-server + (let [ids (redis/with-server redis-server (redis/zrevrange (str "hiscore:" period) 0 -1)) ids (map maybe-parse-int ids)] ids)) @@ -908,28 +825,31 @@ WHERE u.user_id = ANY(?)" (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)))) + [(:user_id user) (:message_id msg) tag]) + (when (and (= tag "favorite") + (not (= (msg :nick) (:nick user)))) + (if-not (or (:admin_only msg) (= (:user_id user) (:user_id msg))) + (incrby-redis-favscore! (:nick msg) (:message_id msg) 1 (:is_image msg))) (insert-fav-notification! (msg :nick) (user :nick) (user :avatar) (msg :content))) true ; catch error when inserting duplicate tags - (catch Exception e false))) + (catch Exception e + (do (println 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) + 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)))] + (not (:admin_only msg)))] (cond (not msg) (resp-error "NO_MSG") (not access) (resp-error "NO_MSG") (not tag) (resp-error "NO_TAG") @@ -938,10 +858,18 @@ WHERE u.user_id = ANY(?)" (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 remove-tag [user-id msg-id tag] + (let [query "user_id = ? AND message_id = ? AND lower(tag) = ?" + msg-id (maybe-parse-int msg-id) + tag (normalize-tag-for-db tag) + msg (fetch-message-by-id msg-id)] + (let [rows-deleted (first (do-delete "tags" [query user-id msg-id tag]))] + (if-not (zero? rows-deleted) + (do + (if-not (or (:admin_only msg) (= user-id (:user_id msg))) + (incrby-redis-favscore! (:nick msg) msg-id -1 (:is_image msg))) + (resp-success "OK")) + (resp-error "NO_TAG"))))) (defn validated-remove-tag [session params] (if (session :nick) @@ -1010,12 +938,14 @@ WHERE u.user_id = ANY(?)" :nick (:nick user-info) :user-tag-id (:user_id session) :msg-id msg-id + :hide-vip (not (:is_admin session)) :date (if msg-id nil date) :limit (inc *dumps-per-page*)) back-dumps (if (or date msg-id) (tags/fetch-tagged-dumps :nick (:nick user-info) :msg-id msg-id + :hide-vip (not (:is_admin session)) :date (if msg-id nil date) :limit (inc *dumps-per-page*) :direction :forward)) @@ -1070,15 +1000,14 @@ WHERE u.user_id = ANY(?)" ;; cons: has to use a <script> tag. seems to freeze browser until results returned ;; (defn json-search [undecoded-url-searchterms params] - (let [tokens (map url-decode (re-split #"\+" undecoded-url-searchterms)) - tokens (map search-replace-weird-chars tokens) - tokens (map #(str "%" %1 "%") tokens) - query (search-query (count tokens)) - rows (do-select (vec (concat [query] tokens)))] - (if (:callback params) - (str (:callback params) "(" (json-str rows) ")") - (json-str rows)))) - + (let [tokens (map url-decode (re-split #"\+" undecoded-url-searchterms)) + tokens (map search-replace-weird-chars tokens) + tokens (map #(str "%" %1 "%") tokens) + query (search-query (count tokens)) + rows (do-select (vec (concat [query] tokens)))] + (if (:callback params) + (str (:callback params) "(" (json-str rows) ")") + (json-str rows)))) ;; Local testing @@ -1187,21 +1116,20 @@ WHERE u.user_id = ANY(?)" ; 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) room)] (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"])))) + (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-info (insert-message! (:user_id session) (:nick session) + (:room_id room) url)] + (copy (:tempfile image) dest) + (dosync + (let [msg (build-msg (:nick session) url (:msg-id msg-info) (:recips msg-info))] + (add-message msg room))) + [200 "OK"]))) (defn upload [session params request] (let [room-key (params :room) @@ -1251,9 +1179,8 @@ WHERE u.user_id = ANY(?)" (unknown-page))) (defn hall-of-fame [session] - (let [st (fetch-template "fame" session) - msgs (add-user-favs-to-msgs (poll hall-results) - (session :user_id))] + (let [st (fetch-template "fame" session) + msgs (fetch-redis-hall (:nick session))] (.setAttribute st "dumps" (map process-message-for-output msgs)) (.toString st))) @@ -1401,16 +1328,16 @@ WHERE u.user_id = ANY(?)" (GET "/error/ie" (serve-template "error_ie" session)) ;; Put username routes below all others in priority - (GET "/:nick" (profile session (params :nick))) - (GET "/:nick/" (profile session (params :nick))) - (GET "/:nick/altars" (altar-log session params)) - (GET "/:nick/altars/" (altar-log session params)) - (GET "/:nick/altars/:id" (altar-log session params)) - (GET "/:nick/tag/:tag" (tagged-dumps-by-nick session params (request-url request))) + (GET "/:nick" (profile session (params :nick))) + (GET "/:nick/" (profile session (params :nick))) + (GET "/:nick/altars" (altar-log session params)) + (GET "/:nick/altars/" (altar-log session params)) + (GET "/:nick/altars/:id" (altar-log session params)) + (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-handler session (params :nick) nil nil)) - (GET "/:nick/favorites/" (favorites-handler session (params :nick) nil nil)) - (GET "/:nick/favorites/:date" (favorites-handler session (params :nick) (params :date) nil)) + (GET "/:nick/favorites" (favorites-handler session (params :nick) nil nil)) + (GET "/:nick/favorites/" (favorites-handler session (params :nick) nil nil)) + (GET "/:nick/favorites/:date" (favorites-handler session (params :nick) (params :date) nil)) (GET "/:nick/favorites/:date/" (favorites-handler session (params :nick) (params :date) nil)) (GET "/:nick/favorites/:date/:msg" (favorites-handler session (params :nick) (params :date) (params :msg))) (GET "/:nick/favs" (favorites-handler session (params :nick) nil nil)) @@ -1496,19 +1423,14 @@ WHERE u.user_id = ANY(?)" (load-rooms!) (start! reserved-nicks) -(def server (start-server (options :port))) -(start! *active-mutes*) -; Delay the following to reduce start-load -(Thread/sleep 15000) -(start! *user-scores*) +(def server (start-server (options :port))) +(start! *active-mutes*) (start-user-flusher!) (start-session-pruner!) -(start! hall-results) ;(if (not= *server-url* "http://dump.fm") ; (start! random-poster)) - - + diff --git a/src/tags.clj b/src/tags.clj index 835591a..53236c5 100644 --- a/src/tags.clj +++ b/src/tags.clj @@ -6,6 +6,7 @@ clojure.contrib.fcase clojure.contrib.json.write clojure.contrib.str-utils + config compojure utils)) @@ -14,7 +15,8 @@ (.toLowerCase tag))) ; save all spaces in tags as dashes? -(defn normalize-tag-for-db [tag] (str tag)) +(defn normalize-tag-for-db [tag] + (lower-case tag)) ; (.replace tag " " "-")) ; todo: remove unicode escape sequences and line breaks and stuff? @@ -90,22 +92,6 @@ WHERE EXISTS (defn explain-query [query] (str "EXPLAIN ANALYZE " query)) -(defn fetch-dump-by-message-id-query [] (str -" SELECT - m.content, m.message_id, m.created_on, m.user_id, - u.nick, u.avatar, - r.key, r.admin_only, - array_to_string(ARRAY(SELECT nick || ' ' || tag - FROM tags, users - WHERE message_id = m.message_id AND tags.user_id = users.user_id), ' ') as tags - 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 = ?")) - ;; OFFSET is very slow when it is large ;; so, a subquery could be used when offset is large ;; one other thing we could do is include message_id in 'next page' url (tumblr & reddit do that for example) @@ -163,9 +149,9 @@ WHERE EXISTS (except! "Unknown direction: " d))) (defnk fetch-dumps [:nick nil :room nil - :date nil :msg-id nil :direction :backward - :image-only true - :user-tag-id nil :hide-vip true :limit 21] + :date nil :msg-id nil :direction :backward + :image-only true + :user-tag-id nil :hide-vip true :limit 21] (cond (and nick room) (except! "Cannot provide both nick and room for fetch-image-dumps") (not (or nick room)) (except! "Must provide nick or room for fetch-image-dumps") @@ -253,11 +239,12 @@ WHERE EXISTS (defnk fetch-dumps-by-message-id-query [:with-tags true :num-messages 1] (str " SELECT m.content, m.message_id, m.created_on, - u.nick, u.avatar, r.key" + u.nick, u.avatar, r.key, r.admin_only" (if with-tags ", array_to_string(ARRAY(SELECT nick || ' ' || tag FROM tags, users - WHERE message_id = m.message_id AND tags.user_id = users.user_id), ' ') as tags " "") + WHERE message_id = m.message_id AND tags.user_id = users.user_id + ORDER BY tags.created_on), ' ') as tags " "") " FROM messages m, users u, rooms r WHERE m.message_id IN (" (str-join ", " (take num-messages (repeat "?"))) ") " @@ -342,16 +329,30 @@ WHERE EXISTS ORDER BY message_id DESC " ;; needed in case subquery was selected ASC )) +(defn fetch-dumps-by-ids + ([ids] (fetch-dumps-by-ids ids nil)) + ([ids viewer-nick] + (let [ids (map maybe-parse-int ids) + query (fetch-dumps-by-message-id-query :num-messages (count ids)) + raw-rows (do-select (vec (concat [query] ids))) + tagged-rows (map parse-tags-from-row-as-tag-map raw-rows) + index-func (fn [row] + (index-of #(= (:message_id row) %) ids))] + (for [m (sort-by index-func tagged-rows)] + (let [favers (get (:tags m) "favorite") + favorited (and viewer-nick + (boolean (some #(= % viewer-nick) favers))) + filtered-favers (filter #(not= % (:nick m)) favers)] + (assoc m + :favers filtered-favers + :favorited favorited + :count (count filtered-favers))))))) -(defn fetch-dump-by-id [m-id] - (let [query (fetch-dump-by-message-id-query)] - (let [rows (do-select [query (maybe-parse-int m-id -1)])] - (first (map parse-tags-from-row-as-tag-map rows))))) - -(defn fetch-dumps-by-ids [ids] - (let [query (fetch-dumps-by-message-id-query :num-messages (count ids)) - rows (do-select (vec (concat [query] ids)))] - (map parse-tags-from-row-as-tag-map rows))) +(defn fetch-dump-by-id + ([m-id] + (first (fetch-dumps-by-ids [m-id]))) + ([m-id viewer-nick] + (first (fetch-dumps-by-ids [m-id] viewer-nick)))) (defnk fetch-altars [:message-id 0 :user-id false :amount *dumps-per-page* :offset 0] (let [message-id (maybe-parse-int message-id 0) diff --git a/src/user.clj b/src/user.clj index 1d59944..7641bd8 100644 --- a/src/user.clj +++ b/src/user.clj @@ -16,12 +16,62 @@ (> (count n) 16) "NICK_TOO_LONG" (not (re-matches *nick-regex* n)) "NICK_INVALID_CHARS")) +;;; User info cache + +(def user-cache-size 500) +(def user-nick-cache (ref {})) +(def user-id-cache (ref {})) + +(defn update-cache! [uid attr val] + (dosync + (if-let [info (get @user-id-cache uid)] + (let [nick (lower-case (:nick info)) + new-info (assoc info attr val)] + (alter user-id-cache assoc uid new-info) + (alter user-nick-cache assoc nick new-info))))) + + (defn fetch-nick [nick] - (let [q1 "SELECT * FROM users WHERE nick = ? LIMIT 1" - ; ORDER BY ensures consistent retrieval of ambiguious names - q2 "SELECT * FROM users WHERE lower(nick) = ? ORDER BY nick LIMIT 1"] - (or (first-or-nil (do-select [q1 nick])) - (first-or-nil (do-select [q2 (lower-case nick)]))))) + (let [lcnick (lower-case nick)] + (if (contains? user-nick-cache lcnick) + (get user-nick-cache lcnick) + (let [info (first + (do-select ["SELECT * FROM users WHERE lower(nick) = ? LIMIT 1" + lcnick])) + user-id (:user_id info)] + (dosync + (alter user-nick-cache assoc lcnick info) + (if (and info user-id) + (alter user-id-cache assoc user-id info))) + info)))) + +(defn fetch-nicks [nicks] + (let [lcnicks (map lower-case nicks) + cache @user-nick-cache + to-fetch (filter #(not (contains? cache %)) lcnicks) + fetched-info (do-select ["SELECT * FROM users WHERE lower(nick) = ANY(?)" + (sql-array "text" to-fetch)]) + info-map (zipmap (map (comp lower-case :nick) fetched-info) + fetched-info)] + (doseq [nick to-fetch] + (let [info (get info-map nick)] + (dosync + (alter user-nick-cache assoc nick info) + (if info + (alter user-id-cache assoc (:user_id info) info))))) + (filter + boolean + (for [nick lcnicks] + (get @user-nick-cache nick))))) + +(defn fetch-user-id [uid] + (if (contains? @user-id-cache uid) + (get @user-id-cache uid) + (if-let [info (first + (do-select ["SELECT * FROM users WHERE user_id = ? LIMIT 1" uid]))] + (dosync + (alter user-nick-cache assoc (lower-case (:nick info)) info) + (alter user-id-cache assoc uid info))))) (defn authorize-nick-hash [nick hash] (let [db-user (fetch-nick nick)] diff --git a/src/utils.clj b/src/utils.clj index 1a9e09e..8aaffba 100755 --- a/src/utils.clj +++ b/src/utils.clj @@ -18,6 +18,7 @@ clojure.contrib.sql clojure.contrib.def clojure.contrib.duck-streams + clojure.contrib.seq-utils clojure.contrib.str-utils compojure config)) @@ -34,29 +35,6 @@ (.setPassword db-pass) (.setMaxConnections 10))})) -;; moved this to here which doesn't seem right... maybe a 'settings.clj' or something? -(def *dumps-per-page* 20) -(def *vip-dumps-per-page* 200) - -;; Message parsing - -;; 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-image? [word] - (and (re-find url-regex word) - (re-find pic-regex word))) - -(defn take-images [content] - (filter is-image? (.split content " "))) - -(defn classify-msg [msg] - (let [words (.split msg " ") - imgs (map is-image? words)] - (cond (every? boolean imgs) :image - (some boolean imgs) :mixed - :else :text))) ;; Misc @@ -82,11 +60,12 @@ (declare stringify-and-escape) (defn escape-html-deep [o] - (if (map? o) - (stringify-and-escape o) - (cond (seq? o) (map escape-html-deep o) - (or (true? o) (false? o)) o - :else (escape-html o)))) + (cond (map? o) (stringify-and-escape o) + (vector? o) (map escape-html-deep o) + (seq? o) (map escape-html-deep o) + (true? o) o + (false? o) o + :else (escape-html o))) (defn stringify-and-escape [m] (zipmap (map str* (keys m)) (map escape-html-deep (vals m)))) @@ -343,18 +322,21 @@ ;; Parsing -(= (type 0) java.lang.Integer) - (defn maybe-parse-int ([s] (maybe-parse-int s 0)) - ([s default] - (if (= (type s) java.lang.Integer) - s - (try (Integer/parseInt s) - (catch NumberFormatException _ default))))) + ([s a] + (if (number? s) + (int s) + (try (Integer/parseInt s) + (catch NumberFormatException _ a))))) -(defn maybe-parse-long [s f] - (if s (Long/parseLong s) f)) +(defn maybe-parse-long + ([s] (maybe-parse-long s 0)) + ([s a] + (if (number? s) + (long s) + (try (Long/parseLong s) + (catch NumberFormatException _ a))))) (defn parse-yyyy-mm-dd-date [s] (try (.parse yyyy-mm-dd-formatter s) @@ -413,9 +395,6 @@ (defn serve-template [template session] (.toString (fetch-template template session))) -(defn first-or-nil [l] - (if (empty? l) nil (first l))) - ;; VIP (defn is-vip? [session] @@ -466,3 +445,11 @@ (swap! cached-results assoc arguments { :result result :time (System/currentTimeMillis)}) result))))) + +;; Taken from Programming Clojure by Stuart Halloway + +(defn index-filter [pred coll] + (for [[idx elt] (indexed coll) :when (pred elt)] idx)) + +(defn index-of [pred coll] + (first (index-filter pred coll))) |