Refactored user updates and caching, added cache-dot-clj caching library

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)))