├── private ├── atomic-test-file.rktd └── with-cache.rkt ├── test ├── data1.rktd ├── subdir │ └── data2.rktd └── main.rkt ├── .gitignore ├── info.rkt ├── LICENSE.txt ├── .travis.yml ├── main.rkt ├── README.md └── scribblings └── with-cache.scrbl /private/atomic-test-file.rktd: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/data1.rktd: -------------------------------------------------------------------------------- 1 | racket/fasl:oqnnsu$$$52 -------------------------------------------------------------------------------- /test/subdir/data2.rktd: -------------------------------------------------------------------------------- 1 | racket/fasl:0.6qnnsu$$$44 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | compiled 2 | coverage 3 | 4 | *\.swp 5 | *~ 6 | \.\#* 7 | 8 | \.LOCK* 9 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "with-cache") 3 | (define deps '("base" "typed-racket-lib")) 4 | (define build-deps '("basedir" "scribble-lib" "racket-doc" "rackunit-lib" "pict-lib")) 5 | (define pkg-desc "Simple, filesystem-based caching") 6 | (define version "0.6") 7 | (define pkg-authors '(ben)) 8 | (define scribblings '(("scribblings/with-cache.scrbl" () (tool-library)))) 9 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | with-cache 2 | Copyright (c) 2016-2021 Ben Greenman 3 | 4 | This package is distributed under the GNU Lesser General Public 5 | License (LGPL). This means that you can link this package into proprietary 6 | applications, provided you follow the rules stated in the LGPL. You 7 | can also modify this package; if you distribute a modified version, 8 | you must distribute it under the terms of the LGPL, which in 9 | particular means that you must release the source code for the 10 | modified software. See http://www.gnu.org/copyleft/lesser.html 11 | for more information. 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | langauge: c 2 | sudo: false 3 | env: 4 | global: 5 | - RACKET_DIR=~/racket 6 | matrix: 7 | - RACKET_VERSION=HEAD 8 | 9 | before_install: 10 | - git clone https://github.com/greghendershott/travis-racket.git ../travis-racket 11 | - cat ../travis-racket/install-racket.sh | bash 12 | - export PATH="${RACKET_DIR}/bin:${PATH}" 13 | 14 | install: raco pkg install --deps search-auto $TRAVIS_BUILD_DIR 15 | 16 | script: 17 | - raco test $TRAVIS_BUILD_DIR 18 | - raco setup --check-pkg-deps with-cache 19 | 20 | after_success: 21 | - raco pkg install --deps search-auto cover 22 | - raco pkg install --deps search-auto cover-coveralls 23 | - raco cover -f coveralls -d $TRAVIS_BUILD_DIR/coverage -b -n test . 24 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | with-cache/private/with-cache) 6 | 7 | (define keys/c 8 | (or/c #f (listof (or/c parameter? (-> any/c))))) 9 | 10 | (define equivalence/c 11 | (flat-named-contract "equivalence/c" 12 | (and/c procedure? (procedure-arity-includes/c 2)))) 13 | 14 | (provide 15 | equivalence/c 16 | 17 | get-with-cache-version 18 | 19 | parent-directory-exists? 20 | 21 | (contract-out 22 | [with-cache-logger 23 | logger?] 24 | 25 | [*use-cache?* 26 | (parameter/c boolean?)] 27 | 28 | [*with-cache-fasl?* 29 | (parameter/c boolean?)] 30 | 31 | [*current-cache-directory* 32 | (parameter/c (and/c path-string? directory-exists?))] 33 | 34 | [*current-cache-keys* 35 | (parameter/c keys/c)] 36 | 37 | [*keys-equal?* 38 | (parameter/c equivalence/c)] 39 | 40 | [cachefile 41 | (-> path-string? parent-directory-exists?)] 42 | 43 | [with-cache 44 | (->* [parent-directory-exists? (-> any)] 45 | [#:use-cache? boolean? 46 | #:fasl? boolean? 47 | #:keys keys/c 48 | #:keys-equal? equivalence/c 49 | #:read (-> any/c any) 50 | #:write (-> any/c any)] 51 | any)])) 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | with-cache 2 | === 3 | [![Build Status](https://travis-ci.org/bennn/with-cache.svg)](https://travis-ci.org/bennn/with-cache) 4 | [![Coverage Status](https://coveralls.io/repos/bennn/with-cache/badge.svg?branch=master&service=github)](https://coveralls.io/github/bennn/with-cache?branch=master) 5 | [![Scribble](https://img.shields.io/badge/Docs-Scribble-blue.svg)](http://docs.racket-lang.org/with-cache/index.html) 6 | 7 | Simple, filesystem-based caching. 8 | 9 | 0. Pick a directory to store caches in. 10 | By default, it's the `./compiled/with-cache` directory. 11 | 1. Wrap "expensive" computations in a thunk, call the thunk via `with-cache`. 12 | 2. Results of the expensive computation are automatically stored and retrieved. 13 | 14 | Example: 15 | ``` 16 | (with-cache "fact42.rktd" 17 | (λ () (factorial 42))) 18 | (with-cache "pict.rktd" 19 | (λ () (standard-fish 100 50)) 20 | #:read deserialize 21 | #:write serialize) 22 | ``` 23 | 24 | 25 | Install 26 | --- 27 | 28 | From the Racket [package server](pkgs.racket-lang.org): 29 | 30 | ``` 31 | $ raco pkg install with-cache 32 | ``` 33 | 34 | From Github: 35 | 36 | ``` 37 | $ git clone https://github.com/bennn/with-cache 38 | $ raco pkg install ./with-cache 39 | ``` 40 | 41 | Don't forget the `./`! 42 | 43 | 44 | More 45 | --- 46 | 47 | The real documentation is here: 48 | http://docs.racket-lang.org/with-cache/index.html 49 | 50 | and has instructions for: 51 | - invalidating cachefiles 52 | - changing the default cache directory 53 | - cachefile naming conventions 54 | 55 | -------------------------------------------------------------------------------- /test/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (module+ test 3 | (require 4 | rackunit 5 | racket/file 6 | racket/runtime-path 7 | with-cache 8 | (for-syntax racket/base)) 9 | 10 | (define-runtime-path data1 "./data1.rktd") 11 | (define-runtime-path with-cache-subdir "./subdir") 12 | (define-runtime-path data2 "./subdir/data2.rktd") 13 | (define-runtime-path compiled "./compiled") 14 | 15 | (unless (directory-exists? with-cache-subdir) (error 'with-cache "missing data directory ~a" with-cache-subdir)) 16 | (unless (directory-exists? compiled) (make-directory compiled)) 17 | 18 | (define (reset-file! f) 19 | (when (file-exists? f) 20 | (delete-file f))) 21 | 22 | ;; Return 3 values: 23 | ;; - (Boxof Natural), counts the number of calls to the 2nd return value 24 | ;; - (-> Symbol), a thunk that simulates writing to a cache 25 | ;; - Symbol, the return value of the thunk 26 | (define (make-counter) 27 | (define num-calls (box 0)) 28 | (define result (gensym '$$$)) 29 | (define (f) 30 | (set-box! num-calls (+ (unbox num-calls) 1)) 31 | result) 32 | (values num-calls f result)) 33 | 34 | ;; --------------------------------------------------------------------------- 35 | 36 | (test-case "with-cache:cwd" 37 | ;; TODO always prints to an error port, because list of *current-cache-keys* 38 | ;; is changing for each invocation 39 | (reset-file! data1) 40 | 41 | (define-values (num-calls f result) (make-counter)) 42 | 43 | (define v0 (with-cache data1 f)) 44 | (check-equal? (symbol->string v0) (symbol->string (with-cache data1 f))) 45 | (check-equal? (symbol->string v0) (symbol->string result)) 46 | (check-equal? (unbox num-calls) 1) 47 | 48 | (define v1 49 | (parameterize ([*current-cache-keys* '()]) 50 | (with-cache data1 f))) 51 | (check-equal? v0 v1) 52 | (check-equal? (unbox num-calls) 2) 53 | 54 | (define v2 55 | (parameterize ([*use-cache?* #f]) 56 | (with-cache data1 f))) 57 | (check-equal? v0 v2) 58 | (check-equal? (unbox num-calls) 3) 59 | ) 60 | 61 | (test-case "with-cache:*use-cache?*=#f/parameter" 62 | (reset-file! data1) 63 | 64 | (define-values (num-calls f result) (make-counter)) 65 | 66 | (parameterize ([*use-cache?* #f]) 67 | (check-equal? (with-cache data1 f) result) 68 | (check-false (file-exists? data1)) 69 | (check-equal? (with-cache data1 f) result) 70 | (check-equal? (unbox num-calls) 2))) 71 | 72 | (test-case "with-cache:*use-cache?*=#f/keyword" 73 | (reset-file! data1) 74 | 75 | (define-values (num-calls f result) (make-counter)) 76 | 77 | (check-equal? (with-cache data1 f #:use-cache? #f) result) 78 | (check-false (file-exists? data1)) 79 | (check-equal? (with-cache data1 f #:use-cache? #f) result) 80 | (check-equal? (unbox num-calls) 2)) 81 | 82 | (test-case "with-cache:fasl=#t/parameter" 83 | (reset-file! data1) 84 | 85 | (define the-value 4) 86 | 87 | (check-false (file-exists? data1)) 88 | (parameterize ([*with-cache-fasl?* #t]) 89 | (with-cache data1 (λ () the-value))) 90 | (check-true (file-exists? data1)) 91 | 92 | (define new-value 93 | (parameterize ([read-accept-compiled #true]) 94 | (with-input-from-file data1 read))) 95 | (check-false (equal? new-value the-value))) 96 | 97 | (test-case "with-cache:fasl=#t/keyword" 98 | (reset-file! data1) 99 | (define the-value 4) 100 | 101 | (check-false (file-exists? data1)) 102 | (with-cache data1 (λ () the-value) #:fasl? #t) 103 | (check-true (file-exists? data1)) 104 | 105 | (define new-value 106 | (parameterize ([read-accept-compiled #true]) 107 | (with-input-from-file data1 read))) 108 | (check-false (equal? new-value the-value))) 109 | 110 | (test-case "with-cache:fasl=#f" 111 | (reset-file! data1) 112 | 113 | (define n 48) 114 | 115 | (check-false (file-exists? data1)) 116 | (parameterize ([*with-cache-fasl?* #f]) 117 | (with-cache data1 (λ () n))) 118 | (check-true (file-exists? data1)) 119 | 120 | (with-handlers ([exn:fail:read? (λ (exn) (raise-user-error 'with-cache:test "Error reading, got exception '~a'" (exn-message exn)))]) 121 | (check-true (and 122 | (parameterize ([read-accept-compiled #true]) 123 | (with-input-from-file data1 read)) 124 | #t)))) 125 | 126 | (test-case "with-cache:read/write" 127 | (reset-file! data1) 128 | 129 | (define read-result 'read-result) 130 | (define write-result 'write-result) 131 | (define thunk-result 'thunk-result) 132 | 133 | (define v0 134 | (with-cache data1 135 | (λ () thunk-result) 136 | #:read (λ (v) (if (eq? v write-result) read-result #f)) 137 | #:write (λ (v) (if (eq? v thunk-result) write-result #f)))) 138 | 139 | (define v1 140 | (with-cache data1 141 | (λ () thunk-result) 142 | #:read (λ (v) (if (eq? v write-result) read-result #f)) 143 | #:write (λ (v) (if (eq? v thunk-result) write-result #f)))) 144 | 145 | (check-equal? v0 thunk-result) 146 | (check-equal? v1 read-result)) 147 | 148 | (test-case "with-cache:subdir" 149 | (reset-file! data2) 150 | 151 | (define-values (num-calls f result) (make-counter)) 152 | 153 | (define v0 154 | (parameterize ([*current-cache-directory* with-cache-subdir]) 155 | (with-cache (cachefile "data2.rktd") f))) 156 | 157 | (define v1 158 | (let ([cf (cachefile "data2.rktd")]) 159 | (reset-file! cf) 160 | (with-cache cf f))) 161 | 162 | (check-equal? v0 result) 163 | (check-equal? v0 v1) 164 | 165 | (check-equal? (unbox num-calls) 2) 166 | ) 167 | 168 | (test-case "with-cache:truncate-long-values" 169 | (struct non-serializable-structure-with-long-name ()) 170 | 171 | (define exn-msg 172 | (parameterize ([error-print-width 10]) 173 | (with-handlers ([exn:fail:user? (λ (exn) (exn-message exn))]) 174 | (with-cache "test.rktd" 175 | (λ () (non-serializable-structure-with-long-name)))))) 176 | 177 | (check-regexp-match #rx"'#string v0) (symbol->string v1)) 197 | 198 | (define v1/no-key 199 | (with-cache data1 count++)) 200 | 201 | (check-equal? (unbox count) 2) 202 | 203 | (define v2 204 | (parameterize ([*current-cache-keys* k2]) 205 | (with-cache data1 count++))) 206 | 207 | (define v3 208 | (parameterize ([*current-cache-keys* k1]) 209 | (with-cache data1 count++))) 210 | 211 | (check-equal? (unbox count) 4) 212 | (check-equal? (symbol->string v2) (symbol->string v3)) 213 | ) 214 | 215 | (test-case "current-cache-keys/keyword" 216 | (reset-file! data1) 217 | 218 | (define-values (count count++ secret-key) (make-counter)) 219 | 220 | (define k1 (list (lambda () 1))) 221 | (define k2 (list (lambda () 2))) 222 | 223 | (define v0 224 | (with-cache data1 count++ #:keys k1)) 225 | 226 | (define v1 227 | (with-cache data1 count++ #:keys k1)) 228 | 229 | (check-equal? (unbox count) 1) 230 | (check-equal? (symbol->string v0) (symbol->string v1)) 231 | 232 | (define v1/no-key 233 | (with-cache data1 count++ #:read (lambda (x) x) #:keys '())) 234 | 235 | (check-equal? (unbox count) 2) 236 | 237 | (define v2 238 | (with-cache data1 count++ #:keys k2)) 239 | 240 | (define v3 241 | (with-cache data1 count++ #:keys k1)) 242 | 243 | (check-equal? (unbox count) 4) 244 | (check-equal? (symbol->string v2) (symbol->string v3)) 245 | ) 246 | 247 | (test-case "current-cache-keys/custom-eq" 248 | (reset-file! data1) 249 | 250 | (define-values (count count++ secret-key) (make-counter)) 251 | 252 | (define k1 (list (lambda () 1))) 253 | (define k2 (list (lambda () 2))) 254 | 255 | (define v0 256 | (with-cache data1 count++ #:keys k1)) 257 | 258 | (define v1 259 | (with-cache data1 count++ #:keys k1 #:keys-equal? (λ (x y) #f))) 260 | 261 | (check-equal? (unbox count) 2) 262 | (check-equal? (symbol->string v0) (symbol->string v1)) 263 | 264 | (define v1+ 265 | (with-cache data1 count++ #:keys k1 #:keys-equal? (λ (x y) (andmap = x y)))) 266 | 267 | (check-equal? (unbox count) 2) 268 | (check-equal? (symbol->string v1) (symbol->string v1+)) 269 | ) 270 | 271 | ) 272 | -------------------------------------------------------------------------------- /scribblings/with-cache.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[scribble/eval 3 | scriblib/footnote 4 | pict 5 | (only-in racket/math pi) 6 | with-cache 7 | (for-label 8 | racket/base racket/contract racket/fasl racket/path 9 | racket/file racket/serialize version/utils with-cache)] 10 | 11 | @title[#:tag "top"]{with-cache} 12 | @author[@hyperlink["https://github.com/bennn"]{Ben Greenman}] 13 | 14 | @defmodule[with-cache] 15 | 16 | Simple, filesystem-based caching. 17 | Wrap your large computations in a thunk and let @racket[with-cache] deal with 18 | saving and retrieving the result. 19 | 20 | @racketblock[ 21 | (define fish 22 | (with-cache (cachefile "stdfish.rktd") 23 | (λ () (standard-fish 100 50)))) 24 | ] 25 | @margin-note{By default, any cache built by an older version of @racketmodname[with-cache] is invalid. Set @racket[*current-cache-keys*] to override this default.} 26 | 27 | Here's a diagram of what's happening in @racket[with-cache]: 28 | 29 | @(let* ([val-pict (colorize (text "$" (list 'bold) 50) "ForestGreen")] 30 | [ser-pict (cc-superimpose (rectangle 50 50 #:border-color "black" #:border-width 1) 31 | (text "1101" "Courier" 20))] 32 | [lock (filled-rectangle 50 30 #:color "gold" #:border-color "chocolate" #:border-width 2)] 33 | [key-pict (cc-superimpose lock ser-pict)] 34 | [fil-pict (file-icon 40 50 "bisque")] 35 | [arrow-line (hline 130 4)] 36 | [head-size 24] 37 | [arrows (λ (top bot) (vc-append 44 (vc-append (text top '() 14) 38 | (hc-append arrow-line (arrowhead head-size 0))) 39 | (vc-append (hc-append (arrowhead head-size pi) arrow-line) 40 | (text bot '() 15))))] 41 | [all (hc-append val-pict (arrows "#:write" "#:read") 42 | ser-pict (arrows "add-keys" "keys-equal?") 43 | key-pict (arrows "write-data" "read-data") 44 | fil-pict)] 45 | ) 46 | @centered[all]) 47 | 48 | @itemlist[ 49 | @item{ 50 | The @emph{dollar sign} on the left represents a value that is expensive to compute. 51 | } 52 | @item{ 53 | The @emph{box} in the left-middle is a serialized version of the expensive value. 54 | } 55 | @item{ 56 | The @emph{yellow box} in the right-middle is the serialized data paired with a (yellow) label. 57 | } 58 | @item{ 59 | The @emph{file symbol} on the right represents a location on the filesystem. 60 | } 61 | ] 62 | 63 | The @racket[with-cache] function implements this pipeline and provides hooks for controlling the interesting parts. 64 | @itemlist[ 65 | @item{ 66 | @racket[#:write] and @racket[#:read] are optional arguments to @racket[with-cache]. 67 | They default to @racket[serialize] and @racket[deserialize]. 68 | } 69 | @item{ 70 | @racket[add-keys] is a hidden function that adds the value of @racket[*current-cache-keys*] to a cached value. 71 | } 72 | @item{ 73 | @racket[keys-equal?] compares the keys in a cache file to the now-current value of @racket[*current-cache-keys*]. 74 | } 75 | @item{ 76 | @racket[write-data] and @racket[read-data] are @racket[s-exp->fasl] and @racket[fasl->s-exp] when the parameter @racket[*with-cache-fasl?*] is @racket[#t]. 77 | Otherwise, these functions are @racket[write] and @racket[read]. 78 | } 79 | ] 80 | 81 | 82 | @defproc[(with-cache [cache-path path-string?] 83 | [thunk (-> any)] 84 | [#:read read-proc (-> any/c any) deserialize] 85 | [#:write write-proc (-> any/c any) serialize] 86 | [#:use-cache? use-cache? boolean? (*use-cache?*)] 87 | [#:fasl? fasl? boolean? (*with-cache-fasl?*)] 88 | [#:keys keys (or/c #f (listof (or/c parameter? (-> any/c)))) (*current-cache-keys*)] 89 | [#:keys-equal? keys-equal? equivalence/c (*keys-equal?*)]) 90 | any]{ 91 | If @racket[cache-path] exists: 92 | @nested[#:style 'inset]{@itemlist[#:style 'ordered 93 | @item{ 94 | reads the contents of @racket[cache-path] (using @racket[s-exp->fasl] if @racket[*with-cache-fasl?*] is @racket[#t] and @racket[read] otherwise); 95 | } 96 | @item{ 97 | checks whether the result contains keys equal to @racket[*current-cache-keys*], 98 | where "equal" is determined by @racket[keys-equal?]; 99 | } 100 | @item{ 101 | if so, removes the keys and deserializes a value. 102 | } 103 | ]} 104 | If @racket[cache-path] does not exist or contains invalid data: 105 | @nested[#:style 'inset]{@itemlist[#:style 'ordered 106 | @item{ 107 | executes @racket[thunk], obtains result @racket[r]; 108 | } 109 | @item{ 110 | retrieves the values of @racket[*current-cache-keys*]; 111 | } 112 | @item{ 113 | saves the keys and @racket[r] to @racket[cache-path]; 114 | } 115 | @item{ 116 | returns @racket[r] 117 | } 118 | ]} 119 | 120 | Uses @racket[call-with-file-lock/timeout] to protect concurrent reads and writes to the same @racket[cache-path]. 121 | If a thread fails to lock @racket[cache-path], @racket[with-cache] throws an exception (@racket[exn:fail:filesystem]) giving the location of the problematic lock file. 122 | All lock files are generated by @racket[make-lock-file-name] and stored in @racket[(find-system-path 'temp-dir)]. 123 | 124 | Diagnostic information is logged under the @racket[with-cache] topic. 125 | To see logging information, use either: 126 | 127 | @nested[#:style 'inset @exec{racket -W with-cache }] 128 | 129 | or, if you are not invoking @exec{racket} directly: 130 | 131 | @nested[#:style 'inset @exec|{PLTSTDERR="error info@with-cache" }|] 132 | 133 | } 134 | 135 | 136 | @section{Parameters} 137 | 138 | @defparam[*use-cache?* use-cache? boolean? #:value #t]{ 139 | Parameter for disabling @racket[with-cache]. 140 | When @racket[#f], @racket[with-cache] will not read or write any cachefiles. 141 | } 142 | 143 | @defparam[*with-cache-fasl?* fasl? boolean? #:value #t]{ 144 | When @racket[#t], write files in @tt{fasl} format. 145 | Otherwise, write files with @racket[write]. 146 | 147 | Note that byte strings written using @racket[s-exp->fasl] cannot be read by code running a different version of Racket. 148 | } 149 | 150 | @defparam[*current-cache-directory* cache-dir (and/c path-string? directory-exists?) #:value (build-path (current-directory) "compiled" "with-cache")]{ 151 | The value of this parameter is the prefix of paths returned by @racket[cachefile]. 152 | Another good default is @racket[(find-system-path 'temp-dir)]. 153 | See also the @other-doc['(lib "basedir/basedir.scrbl")]. 154 | } 155 | 156 | @defparam[*current-cache-keys* params (or/c #f (listof (or/c parameter? (-> any/c)))) #:value (list get-with-cache-version)]{ 157 | List of parameters (or thunks) used to check when a cache is invalid. 158 | 159 | Before writing a cache file, @racket[with-cache] gets the value of @racket[*current-cache-keys*] 160 | (by taking the value of the parameters and forcing the thunks) 161 | and writes the result to the file. 162 | When reading a cache file, @racket[with-cache] gets the current value of @racket[*current-cache-keys*] 163 | and compares this value to the value written in the cache file. 164 | If the current keys are NOT equal to the old keys (equal in the sense of @racket[*keys-equal?*]), 165 | then the cache is invalid. 166 | 167 | For example, @racket[(*current-cache-keys* (list current-seconds))] causes 168 | @racket[with-cache] to ignore cachefiles written more than 1 second ago. 169 | 170 | @(begin #reader scribble/comment-reader 171 | (racketblock 172 | (define (fresh-fish) 173 | (parameterize ([*current-cache-keys* (list current-seconds)]) 174 | (with-cache (cachefile "stdfish.rktd") 175 | (λ () (standard-fish 100 50))))) 176 | 177 | (fresh-fish) ;; Writes to "compiled/with-cache/stdfish.rktd" 178 | (fresh-fish) ;; Reads from "compiled/with-cache/stdfish.rktd" 179 | (sleep 1) 180 | (fresh-fish) ;; Writes to "compiled/with-cache/stdfish.rktd" 181 | )) 182 | 183 | By default, the only key is a thunk that retrieves the installed version of 184 | the @racket[with-cache] package. 185 | 186 | } 187 | 188 | @defparam[*keys-equal?* =? equivalence/c #:value equal?]{ 189 | Used to check whether a cache file is invalid. 190 | 191 | A cache is invalid if @racket[(=? _old-keys _current-keys)] returns @racket[#false], 192 | where @racket[_current-keys] is the current value of @racket[*current-cache-keys*]. 193 | 194 | By convention, the function bound to @racket[=?] should be an equivalence, 195 | meaning it obeys the following 3 laws: 196 | @itemlist[ 197 | @item{ 198 | @racket[(=? _k _k)] returns a true value for all @racket[_k]; 199 | } 200 | @item{ 201 | @racket[(=? _k1 _k2)] returns the same value as @racket[(=? _k2 _k1)]; and 202 | } 203 | @item{ 204 | @racket[(and (=? _k1 _k2) (=? _k2 _k3))] implies @racket[(=? _k1 _k3)] is true. 205 | } 206 | ] 207 | 208 | The contract @racket[equivalence/c] does not enforce these laws, 209 | but it might in the future. 210 | } 211 | 212 | 213 | @section{Utilities} 214 | 215 | @defproc[(cachefile [filename path-string?]) parent-directory-exists?]{ 216 | Prefix @racket[filename] with the value of @racket[*current-cache-directory*]. 217 | By contract, this function returns only paths whose parent directory exists. 218 | } 219 | 220 | @defproc[(parent-directory-exists? [x any/c]) boolean?]{ 221 | Flat contract that checks whether @racket[(path-only x)] exists. 222 | } 223 | 224 | @defproc[(equivalence/c [x any/c]) boolean?]{ 225 | Flat contract for functions that implement equivalence relations. 226 | } 227 | 228 | @defproc[(get-with-cache-version) valid-version?]{ 229 | Return the current version of @racket[with-cache]. 230 | } 231 | 232 | @defthing[with-cache-logger logger?]{ 233 | A @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{logger} that reports events from the @racketmodname[with-cache] library. 234 | Logs @racket['info] events when reading or writing caches and @racket['error] events after detecting corrupted cache files. 235 | } 236 | 237 | -------------------------------------------------------------------------------- /private/with-cache.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; lightweight, filesystem-based caching 4 | 5 | (provide 6 | *use-cache?* 7 | ;; (Parameterof Boolean) 8 | ;; When #f, do not read or save caches, ever. 9 | 10 | *with-cache-fasl?* 11 | ;; (Parameterof Boolean) 12 | ;; When #t, store cachefiles in fasl format. 13 | ;; When #f, directly read/write the values. 14 | 15 | *current-cache-directory* 16 | ;; (Parameterof Path-String) 17 | ;; Default directory to save caches in. 18 | ;; Used as a prefix to `cache-file` 19 | 20 | *current-cache-keys* 21 | ;; (Parameterof (U #f (Listof (Parameterof Any)))) 22 | ;; List of keys to query when reading/writing the cache 23 | 24 | *keys-equal?* 25 | ;; (Parameterof equivalence/c) 26 | ;; Use to override the way `with-cache` checks that keys are equal. 27 | 28 | cachefile 29 | ;; (cachefile ps) 30 | ;; Prefix the path string `ps` with the current value of `*CACHE-DIRECTORY*` 31 | 32 | with-cache 33 | ;; (with-cache path thunk #:read r #:write w #:use-cache? c #:fasl? f #:keys k*) 34 | ;; Checks `path` for a value `r` can interpret; if so returns the interpreted value. 35 | ;; Else runs `thunk` and writes the result to `path` using `w`. 36 | ;; Optional arguments (#:use-cache? #:fasl? #:keys) override the default values 37 | ;; for the (*use-cache?* *with-cache-fasl?* *current-cache-keys*) parameters 38 | 39 | parent-directory-exists? 40 | ;; (parent-directory-exists? ps) 41 | ;; Returns #t if `(path-only ps)` exists on the filesystem or is #f 42 | 43 | with-cache-logger 44 | ;; Logger 45 | ;; Your trusted source for information about the inner workings of `with-cache` 46 | 47 | get-with-cache-version 48 | ;; (-> valid-version?) 49 | ;; Return version of this package. 50 | ) 51 | 52 | (require 53 | (only-in racket/file file->value call-with-file-lock/timeout make-lock-file-name make-directory*) 54 | (only-in racket/path path-only) 55 | (only-in racket/date date-display-format current-date date->string) 56 | (only-in racket/serialize serialize deserialize) 57 | (only-in racket/port open-output-nowhere) 58 | (only-in setup/getinfo get-info) 59 | racket/fasl 60 | ) 61 | 62 | ;; ============================================================================= 63 | 64 | (define (get-with-cache-version) 65 | ((get-info '("with-cache")) 'version)) 66 | 67 | (define no-keys (string->symbol (string-append "no-keys:" (get-with-cache-version)))) 68 | 69 | (define *use-cache?* (make-parameter #t)) 70 | (define *with-cache-fasl?* (make-parameter #t)) 71 | (define *current-cache-directory* (make-parameter (build-path (current-directory) "compiled" "with-cache"))) 72 | (define *current-cache-keys* (make-parameter (list get-with-cache-version))) 73 | (define *keys-equal?* (make-parameter equal?)) 74 | 75 | (define-logger with-cache) 76 | 77 | (define (no-keys? x) 78 | (eq? x no-keys)) 79 | 80 | ;; ----------------------------------------------------------------------------- 81 | 82 | (define (cachefile ps) 83 | (define ccd (*current-cache-directory*)) 84 | (unless (directory-exists? ccd) 85 | (make-directory* ccd)) 86 | (build-path ccd ps)) 87 | 88 | (define (with-cache cache-file 89 | thunk 90 | #:use-cache? [use? (*use-cache?*)] 91 | #:fasl? [fasl? (*with-cache-fasl?*)] 92 | #:keys [keys (*current-cache-keys*)] 93 | #:keys-equal? [keys-equal? (*keys-equal?*)] 94 | #:read [read-proc deserialize] 95 | #:write [write-proc serialize]) 96 | (let* (;; resolve read&write functions 97 | [read-proc (read/keys read-proc keys keys-equal?)] 98 | [write-proc (write/keys write-proc keys)]) 99 | (or ;; -- read from cachefile 100 | (and use? 101 | (file-exists? cache-file) 102 | (with-handlers ([exn:fail? (cache-read-error cache-file)]) 103 | (log-with-cache-info "reading cache file '~a'..." cache-file) 104 | (cond 105 | [(read-proc (call-with-atomic-input-file cache-file (if fasl? fasl->s-exp read))) 106 | => (λ (read-val) 107 | (log-with-cache-info "successfully read cache file '~a'" cache-file) 108 | read-val)] 109 | [else #f]))) 110 | ;; -- write new cache file 111 | (let ([r (thunk)]) 112 | (when use? 113 | (define val-to-write 114 | (with-handlers ([exn:fail? (λ (exn) (raise-user-error 'with-cache "Internal error: failed to make writable value from result '~e'" r))]) 115 | (write-proc r))) 116 | (log-with-cache-info "writing cache file '~a'" cache-file) 117 | (with-handlers ([exn:fail? (cache-write-error cache-file)]) 118 | (call-with-atomic-output-file cache-file 119 | (λ (out) 120 | (if fasl? 121 | (s-exp->fasl val-to-write out) 122 | (begin 123 | (parameterize ([date-display-format 'iso-8601]) 124 | (fprintf out ";; This file was generated by the `with-cache` library on ~a~n" (date->string (current-date)))) 125 | (writeln val-to-write out))) 126 | (log-with-cache-info "successfully wrote to cache file '~a'" cache-file))))) 127 | r)))) 128 | 129 | ;; ----------------------------------------------------------------------------- 130 | 131 | (define (exn->string exn) 132 | (format "got exception:~n~a" (exn-message exn))) 133 | 134 | (define (cache-read-error cache-file) ; (-> Path-String (-> Exception #f)) 135 | (define msg-prefix (format "Failed to read cache file '~a'" cache-file)) 136 | (CI-case 137 | (λ (exn) 138 | (log-with-cache-info (string-append msg-prefix ", " (exn->string exn))) 139 | #f) 140 | (λ (exn) 141 | (log-with-cache-error (string-append msg-prefix ", " (exn->string exn))) 142 | #f))) 143 | 144 | (define (cache-write-error cache-file) ; (-> Path-String (-> Exception #f)) 145 | (define msg-prefix (format "Failed to write cache file '~a'" cache-file)) 146 | (define err-prefix (format "Internal error: failed to delete malformed cache file '~a'" cache-file)) 147 | (CI-case 148 | (λ (exn) 149 | (log-with-cache-info (string-append msg-prefix ", " (exn->string exn))) 150 | (define (err-handler e) 151 | (raise-user-error 'with-cache (string-append err-prefix ", " (exn->string e)))) 152 | (with-handlers ([exn:fail:filesystem? err-handler]) 153 | (when (file-exists? cache-file) 154 | (delete-file cache-file))) 155 | #f) 156 | (λ (exn) 157 | (log-with-cache-error (string-append msg-prefix ", " (exn->string exn))) 158 | (define (err-handler e) 159 | (raise-user-error 'with-cache (string-append err-prefix ", " (exn->string e)))) 160 | (with-handlers ([exn:fail:filesystem? err-handler]) 161 | (when (file-exists? cache-file) 162 | (delete-file cache-file))) 163 | #f))) 164 | 165 | (define (call-with-atomic-input-file filename success-proc) 166 | (call/atomic filename (λ () (call-with-input-file filename success-proc)))) 167 | 168 | (define (call-with-atomic-output-file filename success-proc) 169 | (call/atomic filename (λ () (call-with-output-file filename success-proc #:exists 'replace)))) 170 | 171 | (define (call/atomic filename success-thunk) 172 | (define lockfile (make-lock-file-name 173 | (build-path (find-system-path 'temp-dir) 174 | (format "with-cache~a" (equal-hash-code filename))))) 175 | (call-with-file-lock/timeout filename 176 | 'exclusive 177 | success-thunk 178 | (λ () 179 | (raise (exn:fail:filesystem 180 | (format "with-cache: Failed to lock file '~a', delete the lock '~a' and try again." filename lockfile) 181 | (current-continuation-marks)))) 182 | #:lock-file lockfile)) 183 | 184 | (define (parent-directory-exists? ps) 185 | (and (path-string? ps) 186 | (let ([dir (path-only ps)]) 187 | (or (not dir) (directory-exists? dir))))) 188 | 189 | (define (read/keys read-proc keys keys-equal?) 190 | (if (and keys (not (null? keys))) 191 | (λ (v) 192 | (and (pair? v) 193 | (list? (car v)) 194 | (keys-equal? (car v) (keys->vals keys)) 195 | (read-proc (cdr v)))) 196 | (λ (v) 197 | (and (pair? v) 198 | (no-keys? (car v)) 199 | (read-proc (cdr v)))))) 200 | 201 | (define (write/keys write-proc keys) 202 | (if (and keys (not (null? keys))) 203 | (λ (v) 204 | (cons (keys->vals keys) (write-proc v))) 205 | (λ (v) 206 | (cons no-keys (write-proc v))))) 207 | 208 | (define (keys->vals key-thunks) 209 | (for/list ([t (in-list key-thunks)]) 210 | (t))) 211 | 212 | (define-syntax-rule (CI-case a b) 213 | (if (equal? "true" (getenv "CI")) a b)) 214 | 215 | ;; ============================================================================= 216 | 217 | (module+ test 218 | (require rackunit racket/string racket/logging racket/port racket/runtime-path version/utils) 219 | 220 | (define ccm (current-continuation-marks)) 221 | 222 | (define msg1 "with-cache:test:sample-message") 223 | (define exn1 (make-exn msg1 ccm)) 224 | 225 | (define msg/filesystem "with-cache:test:filesystem") 226 | (define exn/filesystem (make-exn:fail:filesystem msg/filesystem ccm)) 227 | 228 | (define cachefile1 "foo/bar/tmp.dat") 229 | (define cachefile/no-parent "with-cache-test.dat") 230 | 231 | (define (intercept-with-cache-log thunk [level 'info]) 232 | (define inbox (make-hasheq '((debug . ()) (info . ()) (warning . ()) (error . ()) (fatal . ())))) 233 | (with-intercepted-logging 234 | (λ (l) 235 | (define lvl (vector-ref l 0)) 236 | (define msg (vector-ref l 1)) 237 | (when (eq? 'with-cache (vector-ref l 3)) 238 | (hash-set! inbox lvl (cons msg (hash-ref inbox lvl)))) 239 | (void)) 240 | thunk 241 | #:logger with-cache-logger 242 | level) 243 | inbox) 244 | 245 | (define-runtime-path test-file "./atomic-test-file.rktd") 246 | 247 | (define ERROR-LEVEL 248 | (CI-case 249 | 'info 250 | 'error)) 251 | 252 | (test-case "exn->string" 253 | (define (check-exn->string msg exn) 254 | (let ([str (exn->string exn)]) 255 | (check-true (string? str)) 256 | (check-true (string-prefix? str "got exception")) 257 | (check-true (string-contains? str msg)))) 258 | 259 | (check-exn->string msg1 exn1) 260 | (check-exn->string msg/filesystem exn/filesystem)) 261 | 262 | (test-case "cache-read-error" 263 | 264 | (define (check-cache-read-error cachefile exn) 265 | (define logs 266 | (intercept-with-cache-log 267 | (lambda () 268 | (check-false ((cache-read-error cachefile) exn))) 269 | ERROR-LEVEL)) 270 | (define errs (hash-ref logs ERROR-LEVEL)) 271 | (check-equal? (length errs) 1) 272 | (define msg (car errs)) 273 | (check-true (string-contains? msg "Failed to read")) 274 | (check-true (string-contains? msg cachefile)) 275 | (check-true (string-contains? msg (exn-message exn)))) 276 | 277 | (check-cache-read-error cachefile1 exn1) 278 | (check-cache-read-error cachefile1 exn/filesystem)) 279 | 280 | (test-case "cache-write-error" 281 | 282 | (define (check-cache-write-error cachefile exn) 283 | (define logs 284 | (intercept-with-cache-log 285 | (lambda () 286 | (check-false ((cache-write-error cachefile) exn))) 287 | ERROR-LEVEL)) 288 | (define errs (hash-ref logs ERROR-LEVEL)) 289 | (check-equal? (length errs) 1) 290 | (define msg (car errs)) 291 | (check-true (string-contains? msg "Failed to write")) 292 | (check-true (string-contains? msg cachefile)) 293 | (check-true (string-contains? msg (exn-message exn)))) 294 | 295 | (check-cache-write-error cachefile1 exn1) 296 | (check-cache-write-error cachefile1 exn/filesystem)) 297 | 298 | (test-case "call/atomic" 299 | (define msg 300 | (with-handlers ([exn:fail:filesystem? exn-message]) 301 | (call-with-atomic-output-file test-file 302 | (λ (out-port) 303 | (call-with-atomic-input-file test-file 304 | (λ (in-port) (check-true #f))))))) 305 | 306 | (check-regexp-match #rx"Failed to lock file" msg) 307 | (check-regexp-match #rx"delete the lock" msg) 308 | ) 309 | 310 | (test-case "read+write/keys:no-keys" 311 | (define x (gensym 'x)) 312 | (define y (gensym 'y)) 313 | 314 | (check-equal? 315 | ((write/keys (λ (_) x) (list)) y) 316 | (cons no-keys x)) 317 | 318 | (check-equal? 319 | ((read/keys (λ (_) x) (list) equal?) (cons no-keys y)) 320 | x) 321 | 322 | (check-equal? 323 | ((read/keys (λ (_) x) (list) equal?) y) 324 | #f)) 325 | 326 | (test-case "read+write/keys:some-keys" 327 | (define x (gensym 'x)) 328 | (define y (gensym 'y)) 329 | 330 | (define good-keys (list (λ () y))) 331 | (define bad-keys (list (λ () x))) 332 | 333 | (define id (λ (z) z)) 334 | 335 | (define v0 ((write/keys id good-keys) x)) 336 | (check-not-equal? v0 x) 337 | (check-equal? ((read/keys id good-keys equal?) v0) x) 338 | 339 | (check-false ((read/keys id bad-keys equal?) v0))) 340 | 341 | (test-case "keys->vals" 342 | (define v0 #t) 343 | (define v1 (gensym)) 344 | 345 | (parameterize ([*use-cache?* v0]) 346 | (check-equal? 347 | (keys->vals (list *use-cache?* *use-cache?*)) 348 | (list v0 v0))) 349 | 350 | (check-equal? 351 | (keys->vals (list (λ () v0) (λ () v1))) 352 | (list v0 v1))) 353 | 354 | (test-case "get-with-cache-version" 355 | (check-true (valid-version? (get-with-cache-version)))) 356 | 357 | ) 358 | --------------------------------------------------------------------------------