diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/cache_dot_clj/cache.clj | 241 | ||||
| -rw-r--r-- | src/site.clj | 44 | ||||
| -rw-r--r-- | src/user.clj | 93 |
3 files changed, 282 insertions, 96 deletions
diff --git a/src/cache_dot_clj/cache.clj b/src/cache_dot_clj/cache.clj new file mode 100644 index 0000000..7dcfbfe --- /dev/null +++ b/src/cache_dot_clj/cache.clj @@ -0,0 +1,241 @@ +;; Release 0.0.3 +;; https://github.com/alienscience/cache-dot-clj/tree/master/src + +(ns cache-dot-clj.cache "Resettable memoize") + +(declare naive-strategy) + +(defn- external-memoize + "Conventional memoize for use with external caching packages" + [f f-name strategy] + (let [{:keys [init lookup miss! invalidate!]} strategy + cache (init f-name)] + {:memoized + (fn [& args] + (let [[in-cache? res] (lookup cache args)] + (if in-cache? + res + (miss! cache args (apply f args))))) + :invalidate + (fn [args] + (invalidate! cache args)) + })) + +;; TODO Move some of doc up a level +(defn- internal-memoize + "Returns a map containing: + + {:memoized fn ;; Memoized version of given function + :invalidate fn ;; Invalidate arguments in the cache + } + + The memoized version of the function keeps a cache of the mapping from + arguments to results and, when calls with the same arguments are repeated + often, has higher performance at the expense of higher memory use. + + The invalidation function takes a set of function arguments and causes + the appropriate cache entry to re-evaluate the memoized function. + Invalidation can be used to support the memoization of functions + that can be effected by external events. + + Takes a cache strategy. The strategy is provided as a map + containing the following keys. All keys are mandatory! + + - :init – the initial value for the cache and strategy state + - :cache – access function to access the cache + - :lookup – determines whether a value is in the cache or not + - :hit – a function called with the cache state and the argument + list in case of a cache hit + - :miss – a function called with the cache state, the argument list + and the computation result in case of a cache miss + - :invalidate - a function called with the cache state, the argument + list and the computation result that is used to + invalidate the cache entry for the computation. + " + [f _ strategy] + (let [{:keys [init cache lookup hit miss invalidate]} strategy + cache-state (atom init) + hit-or-miss (fn [state args] + (if (lookup state args) + (hit state args) + (miss state args (delay (apply f args))))) + mark-dirty (fn [state args] + (if (lookup state args) + (invalidate state args (delay (apply f args))) + state))] + {:memoized + (fn [& args] + (let [cs (swap! cache-state hit-or-miss args)] + (-> cs cache (get args) deref))) + :invalidate + (fn [args] + (swap! cache-state mark-dirty args) + nil)})) + +(defmacro defn-cached + "Defines a cached function, like defn-memo from clojure.contrib.def + e.g + (defn-cached fib + (lru-cache-strategy 10) + [n] + (if (<= n 1) + n + (+ (fib (dec n)) (fib (- n 2)))))" + [fn-name cache-strategy & defn-stuff] + `(let [f-name# (str *ns* "." '~fn-name)] + (defn ~fn-name ~@defn-stuff) + (alter-var-root (var ~fn-name) + cached* f-name# ~cache-strategy) + (var ~fn-name))) + +(def function-utils* (atom {})) + +(def memoizers* {:external-memoize external-memoize + :internal-memoize internal-memoize}) + +(defn cached* + "Sets up a cache for the given function with the given name" + [f f-name strategy] + (let [memoizer (-> strategy :plugs-into memoizers*) + internals (memoizer f f-name strategy) + cached-f (:memoized internals) + utils (dissoc internals :memoized)] + (if (and (= memoizer external-memoize) + (= f-name :anon)) + (throw (Exception. (str (strategy :description) + " does not support anonymous functions")))) + (if-not (empty? utils) + (swap! function-utils* assoc cached-f utils)) + cached-f)) + +(defmacro cached + "Returns a cached function that can be invalidated by calling + invalidate-cache e.g + (def fib (cached fib (lru-cache-stategy 5)))" + [f strategy] + (if-not (symbol? f) + `(cached* ~f :anon ~strategy) + `(let [f-name# (str *ns* "." '~f)] + (cached* ~f f-name# ~strategy)))) + +(defn invalidate-cache + "Invalidates the cache for the function call with the given arguments + causing it to be re-evaluated e.g + (invalidate-cache fib 30) ;; A call to (fib 30) will not use the cache + (invalidate-cache fib 29) ;; A call to (fib 29) will not use the cache + (fib 18) ;; A call to (fib 18) will use the cache" + [cached-f & args] + (if-let [inv-fn (:invalidate (@function-utils* cached-f))] + (inv-fn args))) + + +;;======== Stategies for for memoize ========================================== + +(def #^{:doc "A naive strategy for testing external-memoize"} + naive-external-strategy + {:init (fn [_] (atom {})) + :lookup (fn [m args] + (let [v (get @m args ::not-found)] + (if (= v ::not-found) + [false nil] + [true v]))) + :miss! (fn [m args res] + (swap! m assoc args res) + res) + :invalidate! (fn [m args] + (swap! m dissoc args) + nil) + :description "Naive external strategy" + :plugs-into :external-memoize}) + +(def #^{:doc "The naive save-all cache strategy for memoize."} + naive-strategy + {:init {} + :cache identity + :lookup contains? + :hit (fn [state _] state) + :miss assoc + :invalidate assoc + :plugs-into :internal-memoize}) + +(defn lru-cache-strategy + "Implements a LRU cache strategy, which drops the least recently used + argument lists from the cache. If the given limit of items in the cache + is reached, the longest unaccessed item is removed from the cache. In + case there is a tie, the removal order is unspecified." + [limit] + {:init {:lru (into {} (for [x (range (- limit) 0)] [x x])) + :tick 0 + :cache {}} + :cache :cache + :lookup (fn [state k] (contains? (:cache state) k)) + :hit (fn [state args] + (-> state + (assoc-in [:lru args] (:tick state)) + (update-in [:tick] inc))) + :miss (fn [state args result] + (let [k (apply min-key (:lru state) (keys (:lru state)))] + (-> state + (update-in [:lru] dissoc k) + (update-in [:cache] dissoc k) + (assoc-in [:lru args] (:tick state)) + (update-in [:tick] inc) + (assoc-in [:cache args] result)))) + :invalidate (fn [state args placeholder] + (if (contains? (:lru state) args) + (assoc-in state [:cache args] placeholder))) + :plugs-into :internal-memoize}) + + +(defn ttl-cache-strategy + "Implements a time-to-live cache strategy. Upon access to the cache + all expired items will be removed. The time to live is defined by + the given expiry time span. Items will only be removed on function + call. No background activity is done." + [ttl] + (let [dissoc-dead (fn [state now] + (let [ks (map key (filter #(> (- now (val %)) ttl) + (:ttl state))) + dissoc-ks #(apply dissoc % ks)] + (-> state + (update-in [:ttl] dissoc-ks) + (update-in [:cache] dissoc-ks))))] + {:init {:ttl {} :cache {}} + :cache :cache + :lookup (fn [state args] + (when-let [t (get (:ttl state) args)] + (< (- (System/currentTimeMillis) t) ttl))) + :hit (fn [state args] + (dissoc-dead state (System/currentTimeMillis))) + :miss (fn [state args result] + (let [now (System/currentTimeMillis)] + (-> state + (dissoc-dead now) + (assoc-in [:ttl args] now) + (assoc-in [:cache args] result)))) + :invalidate (fn [state args placeholder] + (if (contains? (:ttl state) args) + (assoc-in state [:cache args] placeholder))) + :plugs-into :internal-memoize})) + +(defn lu-cache-strategy + "Implements a least-used cache strategy. Upon access to the cache + it will be tracked which items are requested. If the cache size reaches + the given limit, items with the lowest usage count will be removed. In + case of ties the removal order is unspecified." + [limit] + {:init {:lu (into {} (for [x (range (- limit) 0)] [x x])) :cache {}} + :cache :cache + :lookup (fn [state k] (contains? (:cache state) k)) + :hit (fn [state args] (update-in state [:lu args] inc)) + :miss (fn [state args result] + (let [k (apply min-key (:lu state) (keys (:lu state)))] + (-> state + (update-in [:lu] dissoc k) + (update-in [:cache] dissoc k) + (assoc-in [:lu args] 0) + (assoc-in [:cache args] result)))) + :invalidate (fn [state args placeholder] + (if (contains? (:lu state) args) + (assoc-in state [:cache args] placeholder))) + :plugs-into :internal-memoize})
\ No newline at end of file diff --git a/src/site.clj b/src/site.clj index b7b8787..90db5dc 100644 --- a/src/site.clj +++ b/src/site.clj @@ -117,27 +117,6 @@ (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 -;; 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)] - (if found - found - (let [query (str "SELECT user_id FROM users WHERE lower(nick) = ?") - res (first (do-select [query nick]))] - (if (nil? res) - 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)) - found)))))) - ;; Login code (defn session-map-from-db @@ -353,26 +332,15 @@ WHERE user_id IN (.toString st))) (resp-error "NO_USER")))) -(defn update-user-db [user-id attr val] - (with-connection *db* - (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) - [(session-assoc :avatar url) - (resp-success url)]) - (defn update-profile [session params] - (let [user-id (session :user_id) - attr (params :attr) - val (params :val) - attr-set #{"avatar" "contact" "bio"}] + (let [user-id (session :user_id) + attr (params :attr) + val (params :val) + attr-set #{"contact" "bio"}] (cond (not user-id) (resp-error "MUST_LOGIN") (not (and user-id attr val)) (resp-error "BAD_REQUEST") (not (contains? attr-set attr)) (resp-error "BAD_REQUEST") - (= attr "avatar") (update-avatar session val) - :else (do (update-user-db user-id attr val) + :else (do (update-user-info! (:nick session) user-id attr val) (resp-success "OK"))))) ;; Generic Handler @@ -1133,7 +1101,7 @@ WHERE user_id IN url (image-url-from-file "avatars" date dest)] (do (copy (:tempfile image) dest) - (update-user-db (session :user_id) "avatar" url) + (update-user-info! (:nick session) (:user_id session) "avatar" url) [(session-assoc :avatar url) [200 url]]))) diff --git a/src/user.clj b/src/user.clj index 8380bce..c516fd2 100644 --- a/src/user.clj +++ b/src/user.clj @@ -1,5 +1,7 @@ (ns user - (:use compojure + (:use clojure.contrib.sql + compojure + cache-dot-clj.cache utils)) (defstruct user-struct :nick :user_id :avatar :last-seen) @@ -18,71 +20,38 @@ ;;; User info cache -(def user-cache-size 99999) -(def user-nick-cache (ref {})) -(def user-id-cache (ref {})) +(defn-cached fetch-nick-cached + (lru-cache-strategy 2000) + "Retrieves user info from database" + [nick] + (first (do-select ["SELECT * FROM users WHERE lower(nick) = ? LIMIT 1" + (lower-case nick)]))) -(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))))) - +(def fetch-nick (comp fetch-nick-cached lower-case)) -(defn fetch-nick [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-cached nick-from-user-id + (lru-cache-strategy 10000) + "Retrieves nick for user id" + [uid] + (:nick (first (do-select ["SELECT nick FROM users WHERE user_id = ? LIMIT 1" uid])))) -(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))))) +(def fetch-user-id + (comp fetch-nick nick-from-user-id)) -(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))))) +(def user-id-from-nick + (comp :user_id fetch-nick)) + +;; user login (defn authorize-nick-hash [nick hash] - (let [db-user (fetch-nick nick)] - (and db-user (= (db-user :hash) hash) db-user))) + (if-let [db-user (fetch-nick nick)] + (and (= (db-user :hash) hash) db-user))) (defn update-nick-hash [nick hash] - (if (not (assert-update - (do-update :users ["nick=?" nick] - {:hash hash}))) - ; TODO: logging - (println (format "Error updating hash for %s" nick)))) + (do-update :users ["nick=?" nick] + {:hash hash})) + +;; user pw reset (defn reset-token [nick hash ts] (sha1-hash nick hash ts)) @@ -96,3 +65,11 @@ (if-let [info (and nick (fetch-nick nick))] (and (= token (reset-token (info :nick) (info :hash) ts)) (>= ts (ms-ago (days 2)))))) + + +;; user db update & cache invalidation + +(defn update-user-info! [nick user-id attr val] + (with-connection *db* + (update-values "users" ["user_id = ?" user-id] {attr val})) + (invalidate-cache fetch-nick-cached (lower-case nick))) |