diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/site.clj | 163 | ||||
| -rw-r--r-- | src/tags.clj | 241 | ||||
| -rwxr-xr-x | src/utils.clj | 19 |
3 files changed, 347 insertions, 76 deletions
diff --git a/src/site.clj b/src/site.clj index 713dc9d..bf745c9 100644 --- a/src/site.clj +++ b/src/site.clj @@ -15,6 +15,7 @@ clojure.contrib.json.write clojure.contrib.sql clojure.contrib.str-utils + clojure.contrib.def compojure email utils @@ -202,6 +203,7 @@ (assoc m "topic" topic) m))) + (defn count-messages-by-room [room-id image-only] (let [query (str "SELECT COUNT(*) FROM messages m, users u @@ -261,6 +263,46 @@ :topic (ref nil) }) +;; User-id/nick cache +;; I keep needing to grab user-id from a nick or nick from a user-id so I thought I'd cache them + +(def user-id-nick-cache (ref {})) +(def *user-id-nick-cache-size* 500) + +;; this is really ugly, need to make this nicer or get rid of it +(defnk user-id-from-nick-or-nick-from-user-id [:nick false :user-id false] + (let [cache-key (or nick (str "~" user-id)) + found (@user-id-nick-cache cache-key)] + (if found + found + (let [query (if nick + (str "SELECT user_id FROM users WHERE lower(nick) = ?") + (str "SELECT nick FROM users WHERE user_id = ?")) + res (first (do-select [query (or nick user-id)]))] + (if (nil? res) + nil + (let [found (if nick + (res :user_id) + (res :nick)) + cache-key2 (if nick + (str "~" found) + (lower-case found))] + (dosync + (if (> (count @user-id-nick-cache) *user-id-nick-cache-size*) (ref-set user-id-nick-cache {})) + (alter user-id-nick-cache assoc cache-key found cache-key2 (or nick user-id)) + ) + found)))))) + +(defn user-id-from-nick [nick] (user-id-from-nick-or-nick-from-user-id :nick (lower-case nick))) +(defn nick-from-user-id [user-id] (user-id-from-nick-or-nick-from-user-id :user-id user-id)) + +;; Favorites cache + +(def favorites-cache (ref [])) +(def *favorites-cache-size* 50) + + + ;; Login code (defn is-vip? [session] @@ -385,7 +427,7 @@ has-avatar (non-empty-string? (user-info :avatar)) offset (maybe-parse-int offset 0) dump-offset (* offset *dumps-per-page*) - raw-dumps (logger tags/fetch-dumps-by-nick profile-nick true (+ 1 *dumps-per-page*) dump-offset) + raw-dumps (logger tags/fetch-dumps-by-nick :nick profile-nick :amount (+ 1 *dumps-per-page*) :offset dump-offset) dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session)) dumps (map tags/remove-tags-for-output dumps) dumps (logger doall (map process-message-for-output dumps))] @@ -580,7 +622,7 @@ nick (session :nick) st (fetch-template template session) ; TODO: remove db query - message-list (reverse (tags/fetch-dumps-by-room (room :room_id) false)) + message-list (reverse (tags/fetch-dumps-by-room :room-id (room :room_id) :image-only false)) message-list (map tags/add-favorited-flag message-list (repeat session)) message-list (to-array (map process-message-for-output message-list))] (if nick @@ -698,7 +740,10 @@ 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 :room_id) image-only (+ 1 *dumps-per-page*) dump-offset) + 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) dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session)) ;; json-tags (for [dump dumps :when (not (empty? (dump :tags)))] ;; (json-str {"id" (dump :message_id) "tags" (dump :tags) })) @@ -720,6 +765,103 @@ (log session (@rooms room-key) offset params) (resp-error "UNKNOWN_ROOM"))) +;; Tags + +(defn undecoded-url-piece [url position] + "Get nth thing out of a url path. + For example, (undecoded-url-piece 'http://example.com/a/b/c?foo' 2) will return 'c'" + (let [path-without-domain (nth (re-find #"//[^/]+/(.+)" url) 1)] + (nth (re-split #"/|\?" path-without-domain) position))) + +(defn add-tag [user-id message-id tag] + (try + (do-insert "tags" ["user_id" "message_id" "tag"] [user-id (maybe-parse-int message-id) (normalize-tag-for-db tag)]) + true + ; catch error when inserting duplicate tags + (catch Exception e false))) + + +; to do: don't let people set tags on messages they can't access +(defn validated-add-tag [session params] + (if (session :nick) + (if (add-tag (session :user_id) (params :message_id) (params :tag)) + (resp-success "OK") + (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 validated-remove-tag [session params] + (if (session :nick) + (remove-tag (session :user_id) (params :message_id) (params :tag)) + (resp-error "NO_USER"))) + +(defnk tagged-dumps-template [session params tags url page-title :message-user-id false + :tag-user-id false + :logger (make-time-logger)] + (let [st (fetch-template "tagged_dumps" session) + offset (maybe-parse-int (params :offset) 0) + dump-offset (* offset *dumps-per-page*) + raw-dumps (logger tags/fetch-dumps-by-tag :tags tags + :image-only false + :amount (+ 1 *dumps-per-page*) + :offset dump-offset + :message-user-id message-user-id + :tag-user-id tag-user-id) + dumps (map tags/add-favorited-flag (take *dumps-per-page* raw-dumps) (repeat session)) + dumps (map tags/remove-tags-for-output dumps) + dumps (logger doall (map process-message-for-output dumps))] + (if (> (count raw-dumps) *dumps-per-page*) + (.setAttribute st "next" (inc offset))) + (if (not= offset 0) + (.setAttribute st "prev" (max (dec offset) 0))) + (.setAttribute st "dumps" dumps) + (.setAttribute st "page_title" page-title) + (.setAttribute st "page_url" url) + (.setAttribute st "debug_log_items" (logger)) + (.toString st))) + +;; gotta parse tag intersections myself because +'s get decoded into spaces +;; there's probably a less hacky way to do this +(defn tagged-dumps-by-nick [session params url] + (let [nick (params :nick) + tags (map url-decode (re-split #"\+" (undecoded-url-piece url 3))) + user-id (user-id-from-nick nick) + url (str "u/" nick "/tag/" (str-join "+" (map url-encode tags))) + page-title (str "dumps " nick " tagged as '" (escape-html (str-join "' and '" tags)) "'")] + (tagged-dumps-template session params tags url page-title :tag-user-id user-id))) + +(defn tagged-dumps [session params url] + (let [tags (map url-decode (re-split #"\+" (undecoded-url-piece url 1))) + url (str "tag/" (str-join "+" (map url-encode tags))) + page-title (str "dumps tagged as '" (escape-html (str-join "' and '" tags)) "'")] + (tagged-dumps-template session params tags url page-title))) + +(defn favorites [session params] + (let [nick (params :nick) + user-id (user-id-from-nick nick) + url (str "u/" nick "/favorites") + page-title (str nick "'s favorites")] + (tagged-dumps-template session params "favorite" url page-title :tag-user-id user-id))) + +(defn json-favorites [session params] + (let [nick (params :nick) + user-id (user-id-from-nick nick) + raw-favs (tags/fetch-dumps-by-tag :tags "favorite" + :image-only false + :amount 50 + :offset 0 + :tag-user-id user-id + :with-tags false) + favs (reduce (fn [m fav] (assoc m (str (fav :message_id)) (fav :content))) {} raw-favs)] + (str "RawFavs=" (json-str favs)))) + + + + ;; Account resets (defn reset-page [session] @@ -884,13 +1026,14 @@ (GET "/favicon.ico" (serve-static "static" "favicon.ico")) (GET "/u/:nick" (profile session (params :nick) "0")) (GET "/u/:nick/" (profile session (params :nick) "0")) - (GET "/u/:nick/tag/:tag" ("nuthin yet")) - (GET "/u/:nick/tag/:tag/:offset" ("nuthin yet")) - (GET "/u/:nick/favorites" ("nuthin yet")) - (GET "/u/:nick/favorites/:offset" ("nuthing yet")) + (GET "/u/:nick/tag/:tag" (tagged-dumps-by-nick session params (request-url request))) + (GET "/u/:nick/tag/:tag/:offset" (tagged-dumps-by-nick session params (request-url request))) + (GET "/u/:nick/favorites" (favorites session params)) + (GET "/u/:nick/favorites/:offset" (favorites session params)) + (GET "/json/:nick/favorites" (json-favorites session params)) (GET "/u/:nick/:offset" (profile session (params :nick) - (params :offset))) + (params :offset))) ; have to put this route after favs (GET "/p/:nick/:postid" (single-message session (params :nick) (params :postid))) (GET "/login" (login session params cookies)) (GET "/logout" (logout session)) @@ -900,8 +1043,8 @@ (GET "/chat/:t" (no-cache (validated-chat session "dumpfm" (-> request :route-params :t)))) (GET "/browser" (browser session)) (GET "/refresh" (validated-refresh session params)) - (GET "/tag/:tag" ("nuthin yet")) - (GET "/tag/:tag/:offset" ("nuthin yet")) + (GET "/tag/:tag" (tagged-dumps session params (request-url request))) + (GET "/tag/:tag/:offset" (tagged-dumps session params (request-url request))) (POST "/cmd/tag/add" (validated-add-tag session params)) (POST "/cmd/tag/rm" (validated-remove-tag session params)) (GET "/log" (validated-log session "dumpfm" "0" params)) diff --git a/src/tags.clj b/src/tags.clj index ba32635..77933d6 100644 --- a/src/tags.clj +++ b/src/tags.clj @@ -1,7 +1,9 @@ (ns tags (:import java.lang.System) (:use clojure.contrib.sql + clojure.contrib.def clojure.contrib.json.write + clojure.contrib.str-utils compojure utils)) @@ -10,38 +12,10 @@ ; (.replace tag " " "-")) ; todo: remove unicode escape sequences and line breaks and stuff? - ; maybe show all dashes as spaces on output? (defn normalize-tag-for-out [tag] (str tag)) -(defn add-tag [user-id message-id tag] - (let [query "INSERT INTO tags2(user_id, message_id, tag) VALUES(?, ?, ?)"] - (try - (do-select [query user-id (maybe-parse-int message-id) (normalize-tag-for-db tag)]) - ; catch error when inserting duplicate tags - (catch org.postgresql.util.PSQLException e - resp-error "TAG_EXISTS_ALREADY_OR_SOMETHING_ELSE_IS_FUCKED") - ))) - -; to do: don't let people set tags on messages they can't access -(defn validated-add-tag [session params] - (if (session :nick) - (add-tag (session :user_id) (params :message_id) (params :tag)) - (resp-error "NO_USER"))) - -(defn remove-tag [user-id message-id tag] - (let [query "DELETE FROM tags2 WHERE user_id = ? AND message_id = ? AND lower(tag) = ?"] - (do-select [query user-id (maybe-parse-int message-id) (normalize-tag-for-db (.toLowerCase tag))]))) - -(defn validated-remove-tag [session params] - (if (session :nick) - (remove-tag (session :user_id) (params :message_id) (params :tag)) - (resp-error "NO_USER"))) - - -(defn fetch-messages-by-tag []) - -; lol "Can't remove struct key" +; lol "Can't remove struct key" (jdbc thing returns structified data) (defn remove-tags-for-output [row] (dissoc (into {} row) :tags)) @@ -51,15 +25,15 @@ ; turn "a 1 b 2" to ({:nick a :tag 1}, {:nick b :tag 2}) ; this seems to be a waste of cpu and memory, but i'm trying to make these easily accessible from templates ; also: i can't figure out how to access array indexes directly in StringTemplate templates -(defn parse-tags-from-row [row] - (assoc row :tags - (for [t (partition 2 (.split (row :tags) " "))] - {"nick" (first t) "tag" (last t)}))) +;; (defn parse-tags-from-row [row] +;; (assoc row :tags +;; (for [t (partition 2 (.split (row :tags) " "))] +;; {"nick" (first t) "tag" (last t)}))) (defn parse-tags-from-string [string] (partition 2 (.split string " "))) -(defn build-tag-map-by-tag [tags nick-tag] +(defn build-tag-map [tags nick-tag] (let [nick (first nick-tag) tag (last nick-tag)] (if (tags tag) (assoc tags tag (conj (tags tag) nick)) @@ -67,9 +41,11 @@ ; making something like {"tag1": ["nick a", "nick b"], "tag2": ["nick c", "nick d"]} ; why is building data structures in clojure so hard for me -(defn parse-tags-from-row-as-map-by-tag [row] - (assoc row :tags - (reduce build-tag-map-by-tag {} (parse-tags-from-string (row :tags))))) +(defn parse-tags-from-row-as-tag-map [row] + (if (row :tags) + (assoc row :tags + (reduce build-tag-map {} (parse-tags-from-string (row :tags)))) + row)) (defn does-tag-exist? ([tags tag] @@ -86,36 +62,173 @@ (defn explain-query [query] (str "EXPLAIN ANALYZE " query)) -; todo: offset is slow. probably need to include message_id in 'next page' url (tumblr & reddit do that) -(defn fetch-messages-with-tags-by-room-query [image-only] - (str "SELECT m.content, m.message_id, m.created_on, u.nick, u.avatar, +;; 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) +;; but probably people don't page back too far anyway +;; (not used yet) +(defn fetch-dumps-by-room-query-faster [image-only] (str +" SELECT + m.content, m.message_id, m.created_on, + u.nick, u.avatar, + 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 (SELECT message_id + FROM messages + WHERE room_id = ? " + (if image-only "AND is_image = true " "") + " ORDER BY created_on DESC + LIMIT ? OFFSET ?) as sq, users u, messages m + WHERE sq.message_id = m.message_id + AND u.user_id = m.user_id")) + +(defn fetch-dumps-by-room-query [image-only] (str +" SELECT + m.content, m.message_id, m.created_on, + u.nick, u.avatar, array_to_string(ARRAY(SELECT nick || ' ' || tag - FROM tags2, users - WHERE message_id = m.message_id AND tags2.user_id = users.user_id), ' ') as tags + FROM tags, users + WHERE message_id = m.message_id AND tags.user_id = users.user_id), ' ') as tags FROM users u, messages m - WHERE room_id = ? AND m.user_id = u.user_id " - (if image-only "AND m.is_image = true " "") - "ORDER BY created_on DESC + WHERE room_id = ? + AND m.user_id = u.user_id " + (if image-only "AND m.is_image = true " "") +" ORDER BY created_on DESC LIMIT ? OFFSET ?")) -; offset is slow... problem with this one though it doesn't take into account deleted messages -(defn fetch-messages-with-tags-by-room-fast-paging-query [image-only] - (str "SELECT m.content, m.message_id, m.created_on, u.nick, u.avatar, +;; unoptimized +;; the room join here is very bad on large offsets... +(defn fetch-dumps-by-nick-query [image-only] (str +" SELECT + m.content, m.message_id, m.created_on, + u.nick, u.avatar, r.key, array_to_string(ARRAY(SELECT nick || ' ' || tag - FROM tags2, users - WHERE message_id = m.message_id AND tags2.user_id = users.user_id), ' ') as tags - FROM users u, messages m - WHERE room_id = ? AND m.user_id = u.user_id - AND m.message_id BETWEEN ? AND ? " - (if image-only "AND m.is_image = true " "") - "ORDER BY created_on DESC - LIMIT ?")) + 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 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 ?")) + +;; SPEED HACK +;; explicit use of room ids, but fast +;; (not used yet) +(defnk fetch-dumps-by-user-id-query [:image-only true :with-tags true] (str +" SELECT + m.content, m.message_id, m.created_on, + u.nick, u.avatar, r.key" + (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 " "") +" FROM (SELECT message_id + FROM messages as m + WHERE m.user_id = ? + AND m.room_id IN (1) " + (if image-only "AND m.is_image = true " "") + " ORDER BY m.message_id DESC + LIMIT ? OFFSET ? + ) as sq, messages m, users u, rooms r + WHERE m.message_id = sq.message_id + AND m.user_id = u.user_id + AND r.room_id = m.room_id")) + +;; todo: only return distinct dumps? sorted by tag.created_on? +(defnk fetch-dumps-by-tag-query [:image-only true :message-user-id false :tag-user-id false :with-tags true] (str +" SELECT + m.content, m.message_id, m.created_on, + u.nick, u.avatar, r.key " + (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 " "") +" FROM (SELECT + m.message_id + FROM messages as m, tags as t + WHERE lower(t.tag) = ? " + (if message-user-id "AND m.user_id = ? " "") + (if tag-user-id "AND t.user_id = ? " "") + (if image-only "AND m.is_image = true " "") + " AND m.message_id = t.message_id + ORDER BY m.message_id DESC + LIMIT ? OFFSET ? + ) as sq, messages m, users u, rooms r + WHERE m.message_id = sq.message_id + AND m.user_id = u.user_id + AND r.room_id = m.room_id")) + +;; tag intersections +(defnk fetch-dumps-by-tags-query [:image-only true :num-tags 1 :message-user-id false :tag-user-id false :with-tags true] (str +" SELECT + m.content, m.message_id, m.created_on, + u.nick, u.avatar, r.key " + (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 " "") +" FROM (SELECT + m.message_id" + " FROM messages as m + INNER JOIN tags USING (message_id) + WHERE lower(tags.tag) IN (" (str-join ", " (take num-tags (repeat "?"))) ") " + (if message-user-id "AND m.user_id = ? " "") + (if tag-user-id "AND tags.user_id = ? " "") + (if image-only "AND m.is_image = true " "") + " GROUP BY m.message_id HAVING COUNT(*) = " (str num-tags) " + ORDER BY m.message_id DESC + LIMIT ? OFFSET ? + ) as sq, messages m, users u, rooms r + WHERE m.message_id = sq.message_id + AND m.user_id = u.user_id + AND r.room_id = m.room_id")) + + +(defnk fetch-dumps-by-room [:room-id 1 :image-only true :amount *dumps-per-page* :offset 0] + (let [query (fetch-dumps-by-room-query image-only)] + (let [rows (do-select [query room-id amount offset])] + (map parse-tags-from-row-as-tag-map rows)))) + +(defnk fetch-dumps-by-nick [:nick "anon" :image-only true :amount *dumps-per-page* :offset 0] + (let [query (fetch-dumps-by-nick-query image-only)] + (let [rows (do-select [query nick amount offset])] + (map parse-tags-from-row-as-tag-map rows)))) + +(defnk fetch-dumps-by-user-id [user-id :image-only true :amount *dumps-per-page* :offset 0] + (let [query (fetch-dumps-by-user-id-query image-only)] + (let [rows (do-select [query user-id amount offset])] + (map parse-tags-from-row-as-tag-map rows)))) + +(defnk fetch-dumps-by-tag [:tags "favorite" + :message-user-id false + :tag-user-id false + :image-only true + :amount *dumps-per-page* + :offset 0 + :with-tags true] + (let [tags (if (string? tags) [tags] tags) + query (if (= 1 (count tags)) + (fetch-dumps-by-tag-query :image-only image-only + :message-user-id message-user-id + :tag-user-id tag-user-id + :with-tags with-tags) + (fetch-dumps-by-tags-query :image-only image-only + :message-user-id message-user-id + :tag-user-id tag-user-id + :num-tags (count tags) + :with-tags with-tags)) + query-vars [amount offset] + query-vars (if message-user-id (concat [message-user-id] query-vars ) query-vars) + query-vars (if tag-user-id (concat [tag-user-id] query-vars ) query-vars) + rows (do-select (vec (concat [query] tags query-vars)))] + (map parse-tags-from-row-as-tag-map rows))) -(defn fetch-messages-with-tags-by-room - ([] (fetch-messages-with-tags-by-room 1 true *dumps-per-page* 0)) - ([room-id] (fetch-messages-with-tags-by-room room-id true *dumps-per-page* 0)) - ([room-id image-only] (fetch-messages-with-tags-by-room room-id image-only *dumps-per-page* 0)) - ([room-id image-only amount offset] - (let [query (fetch-messages-with-tags-by-room-query image-only)] - (let [rows (do-select [query room-id amount offset])] - (map parse-tags-from-row-as-map-by-tag rows))))) + + + + + + +
\ No newline at end of file diff --git a/src/utils.clj b/src/utils.clj index 92fdad6..3f2f4e4 100755 --- a/src/utils.clj +++ b/src/utils.clj @@ -1,6 +1,7 @@ (ns utils (:import java.text.SimpleDateFormat - java.util.Date) + java.util.Date + java.net.URLDecoder) (:use clojure.contrib.json.write clojure.contrib.sql)) @@ -13,6 +14,8 @@ :user "postgres" :password "root"})) +;; moved this to here which doesn't seem right... maybe a 'settings.clj' or something? +(def *dumps-per-page* 20) ;; Misc @@ -70,6 +73,10 @@ (with-connection *db* (delete-rows table query))) +(defn do-insert [table cols values] + (with-connection *db* + (insert-values table cols values))) + ;; Parsing (defn maybe-parse-int @@ -79,4 +86,12 @@ (catch NumberFormatException _ default)))) (defn maybe-parse-long [s f] - (if s (Long/parseLong s) f))
\ No newline at end of file + (if s (Long/parseLong s) f)) + +(defn url-decode [text] + (URLDecoder/decode text "UTF-8")) + +(defn #^String lower-case + "Converts string to all lower-case." + [#^String s] + (.toLowerCase s))
\ No newline at end of file |