Merge pull request #24 from kimmyg/master

Selective cache flushing

Author: jeapostrophe

web-server-doc/web-server/scribblings/cache-table.scrbl

@@ -22,9 +22,13 @@ functions.
  called to construct the value and add it to @racket[ct].
 }
 
-@defproc[(cache-table-clear! [ct cache-table?])
+@defproc[(cache-table-clear! [ct cache-table?]
+                             [entry-ids (or/c false/c (listof symbol?)) #f])
          void?]{
- Clears all entries in @racket[ct].
+ If @racket[entry-ids] is @racket[#f], clears all entries in @racket[ct].
+ Otherwise, clears only the entries with keys in @racket[entry-ids].
+
+ @history[#:changed "6.9.0.1" "Added optional argument."]
 }
 
 @defproc[(cache-table? [v any/c])

web-server-doc/web-server/scribblings/dispatch-servlets.scrbl

@@ -18,12 +18,17 @@
 @defproc[(make-cached-url->servlet
           [url->path url->path/c]
           [path->serlvet path->servlet/c])
-         (values (-> void)
+         (values (->* () ((or/c false/c (listof url?))) void?)
                  url->servlet/c)]{
- The first return value flushes the cache.  The second is a procedure
- that uses @racket[url->path] to resolve the URL to a path, then uses
+ The first return value flushes the cache. If its optional argument is
+ @racket[#f] (the default), all servlet caches are flushed. Otherwise,
+ only those servlet caches to which @racket[url->path] maps the given
+ URLs are flushed. The second return value is a procedure that uses
+ @racket[url->path] to resolve the URL to a path, then uses
  @racket[path->servlet] to resolve that path to a servlet, caching the
  results in an internal table.
+
+ @history[#:changed "6.9.0.1" "Added optional argument to first return value."]
 }
 
 @defproc[(make [url->servlet url->servlet/c]

web-server-lib/web-server/dispatchers/dispatch-servlets.rkt

@@ -23,16 +23,21 @@
  [make-cached-url->servlet
   (-> url->path/c
       path->servlet/c
-      (values (-> void)
+      (values (() ((or/c false/c (listof url?))) . ->* . void?)
               url->servlet/c))])
 
 (define (make-cached-url->servlet         
          url->path 
          path->servlet)
   (define config:scripts (make-cache-table))
-  (values (lambda ()
+  (values (lambda ([uris #f])
             ;; This is broken - only out of date or specifically mentioned scripts should be flushed.  This destroys persistent state!
-            (cache-table-clear! config:scripts))
+            (cache-table-clear!
+             config:scripts
+             (and uris
+                  (for/list ([uri (in-list uris)])
+                    (let-values ([(servlet-path _) (url->path uri)])
+                      (string->symbol (path->string servlet-path)))))))
           (lambda (uri)
             (define-values (servlet-path _)
               (with-handlers

web-server-lib/web-server/private/cache-table.rkt

@@ -8,11 +8,15 @@
   (make-cache-table (make-hasheq)
                     (make-semaphore 1)))
 
-(define (cache-table-clear! ct)
+(define (cache-table-clear! ct [entry-ids #f])
   (call-with-semaphore
    (cache-table-semaphore ct)
    (lambda ()
-     (set-cache-table-hash! ct (make-hasheq)))))
+     (if entry-ids
+       (let ([cache-hash (cache-table-hash ct)])
+         (for ([entry-id (in-list entry-ids)])
+           (hash-remove! cache-hash entry-id))) 
+       (set-cache-table-hash! ct (make-hasheq))))))
 
 (define (cache-table-lookup! ct entry-id entry-thunk)
   (define ht (cache-table-hash ct))
@@ -31,5 +35,5 @@
  [rename new-cache-table make-cache-table
          (-> cache-table?)]
  [cache-table-lookup! (cache-table? symbol? (-> any/c) . -> . any/c)]
- [cache-table-clear! (cache-table? . -> . void?)]
+ [cache-table-clear! ((cache-table?) ((or/c false/c (listof symbol?))) . ->* . void?)]
  [cache-table? (any/c . -> . boolean?)])

web-server-test/tests/web-server/private/cache-table-test.rkt

@@ -28,10 +28,33 @@
     (check-true (let ([ct (make-cache-table)])
                   (cache-table-lookup! ct 'foo (lambda () #t))
                   (cache-table-lookup! ct 'foo (lambda () #f)))))
-   
+
    (test-case
     "cache-table-clear! is effective"
     (check-false (let ([ct (make-cache-table)])
                    (cache-table-lookup! ct 'foo (lambda () #t))
                    (cache-table-clear! ct)
-                   (cache-table-lookup! ct 'foo (lambda () #f)))))))
+                   (cache-table-lookup! ct 'foo (lambda () #f)))))
+
+   (test-case
+    "cache-table-clear! is selective (1)"
+    (check-true (let ([ct (make-cache-table)])
+                  (cache-table-lookup! ct 'foo (lambda () #t))
+                  (cache-table-lookup! ct 'bar (lambda () #t))
+                  (cache-table-clear! ct (list 'bar))
+                  (cache-table-lookup! ct 'foo (lambda () #f)))))
+
+   (test-case
+    "cache-table-clear! is selective (2)"
+    (check-false (let ([ct (make-cache-table)])
+                   (cache-table-lookup! ct 'foo (lambda () #t))
+                   (cache-table-lookup! ct 'bar (lambda () #t))
+                   (cache-table-clear! ct (list 'bar))
+                   (cache-table-lookup! ct 'bar (lambda () #f)))))
+
+   (test-case
+    "cache-table-clear! is robust"
+    (check-true (let ([ct (make-cache-table)])
+                  (cache-table-lookup! ct 'foo (lambda () #t))
+                  (cache-table-clear! ct (list 'bar 'baz))
+                  (cache-table-lookup! ct 'foo (lambda () #f)))))))