-
Notifications
You must be signed in to change notification settings - Fork 2
/
mount.clj
131 lines (117 loc) · 5.56 KB
/
mount.clj
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
(ns memento.mount
"Mount points, they serve as glue between a cache that can house entries from
multiple functions and the individual functions."
{:author "Rok Lenarčič"}
(:require [memento.base :as base]
[memento.config :as config])
(:import (clojure.lang AFn ISeq)
(memento.base ICache Segment)
(memento.mount CachedFn IMountPoint)))
(def ^:dynamic *caches* "Contains map of mount point to cache instance" {})
(def tags "Map tag to mount-point" (atom {}))
(def configuration-props [config/key-fn config/ret-fn config/seed config/tags
config/evt-fn config/id config/key-fn*])
(defn assoc-cache-tags
"Add Mount Point ref to tag index"
[index cache-tags ref]
(reduce #(update %1 %2 (fnil conj #{}) ref) index cache-tags))
(defn dissoc-cache-tags
"Remove Mount Point ref from tag index"
[index ref]
(reduce-kv #(assoc %1 %2 (disj %3 ref)) {} index))
(deftype ReloadGuard [cache-mount]
Object
(finalize [this]
(swap! tags dissoc-cache-tags cache-mount)
(alter-var-root #'*caches* dissoc cache-mount)
nil))
(defrecord UntaggedMountPoint [^ICache cache ^Segment segment evt-handler]
IMountPoint
(asMap [this] (.asMap cache segment))
(cached [this args] (.cached cache segment args))
(ifCached [this args] (.ifCached cache segment args))
(getTags [this] [])
(handleEvent [this evt] (evt-handler this evt))
(invalidate [this args] (.invalidate cache segment args))
(invalidateAll [this] (.invalidate cache segment))
(mountedCache [this] cache)
(addEntries [this args-to-vals] (.addEntries cache segment args-to-vals))
(segment [this] segment))
(defrecord TaggedMountPoint [tags ^Segment segment evt-handler]
IMountPoint
(asMap [this] (.asMap ^ICache (*caches* this base/no-cache) segment))
(cached [this args] (.cached ^ICache (*caches* this base/no-cache) segment args))
(ifCached [this args] (.ifCached ^ICache (*caches* this base/no-cache) segment args))
(getTags [this] tags)
(handleEvent [this evt] (evt-handler this evt))
(invalidate [this args] (.invalidate ^ICache (*caches* this base/no-cache) segment args))
(invalidateAll [this] (.invalidate ^ICache (*caches* this base/no-cache) segment))
(mountedCache [this] (*caches* this base/no-cache))
(addEntries [this args-to-vals]
(.addEntries ^ICache (*caches* this base/no-cache) segment args-to-vals))
(segment [this] segment))
(defn mounted-cache [^IMountPoint mp] (.mountedCache mp))
(defn reify-mount-conf
"Transform user given mount-conf to a canonical form of a map."
[mount-conf]
(if (map? mount-conf)
mount-conf
{config/tags ((if (sequential? mount-conf) vec vector) mount-conf)}))
(defn create-mount
"Create mount record by specified map conf"
[f cache mount-conf]
(let [key-fn (or (config/key-fn mount-conf)
(when-let [base (config/key-fn* mount-conf)]
(fn [args] (AFn/applyToHelper base (if (instance? ISeq args) args (seq args)))))
identity)
evt-fn (config/evt-fn mount-conf (fn [_ _] nil))
f* (if-let [ret-fn (config/ret-fn mount-conf)]
(fn [& args] (ret-fn args (AFn/applyToHelper f args)))
f)
segment (Segment. f* key-fn (mount-conf config/id f))]
(if-let [t (config/tags mount-conf)]
(let [wrapped-t (if (sequential? t) t (vector t))
mp (->TaggedMountPoint wrapped-t segment evt-fn)]
(alter-var-root #'*caches* assoc mp cache)
(swap! tags assoc-cache-tags wrapped-t mp)
mp)
(->UntaggedMountPoint cache segment evt-fn))))
(defn bind
"Bind a cache to a fn or var. Internal function."
[fn-or-var mount-conf cache]
(if (var? fn-or-var)
(let [mount-conf (-> mount-conf
reify-mount-conf
(update config/id #(or % (str fn-or-var))))]
(alter-var-root fn-or-var bind mount-conf cache))
(let [mount-conf (reify-mount-conf mount-conf)
stacking (if (instance? CachedFn fn-or-var) (config/bind-mode mount-conf :new) :none)
^IMountPoint cache-mount (case stacking
:new (create-mount (.getOriginalFn ^CachedFn fn-or-var) cache mount-conf)
:keep (.getMp ^CachedFn fn-or-var)
(:none :stack) (create-mount fn-or-var cache mount-conf))
reload-guard (when (and config/reload-guards? (config/tags mount-conf) (not= :keep stacking))
(ReloadGuard. cache-mount))
f (case stacking
:keep fn-or-var
(:new :stack) (CachedFn. reload-guard cache-mount (meta fn-or-var) (.getOriginalFn ^CachedFn fn-or-var))
:none (CachedFn. reload-guard cache-mount (meta fn-or-var) fn-or-var))]
(.addEntries (.getMp ^CachedFn f) (config/seed mount-conf {}))
f)))
(defn mount-point
"Return active mount point from the object's meta."
[obj]
(when (instance? IMountPoint obj) obj))
(defn update-existing
"Convenience function. Updates ks's that are present with the provided update fn."
[m ks update-fn]
(reduce #(if-let [kv (find %1 %2)] (assoc %1 %2 (update-fn (val kv))) %1) m ks))
(defn alter-caches-mapping
"Internal function. Modifies entire tagged cache map with the provided function.
Applies the function as (fn [*caches* refs & other-update-fn-args])"
[tag update-fn & update-fn-args]
(let [refs (get @tags tag [])
update-fn #(apply update-fn % refs update-fn-args)]
(if (.getThreadBinding #'*caches*)
(var-set #'*caches* (update-fn *caches*))
(alter-var-root #'*caches* update-fn))))