blob: d487ee46ca62e13b27f0449d07071705243219e8 (
plain)
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
|
;; Tekuti
;; Copyright (C) 2010 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;;; Commentary:
;;
;; A simple response cache. The model is that all request-response
;; pairs that the cache sees are fresh and valid. The application can
;; invalidate the cache simply by creating a new empty cache.
;;
;;; Code:
(define-module (tekuti cache)
#:use-module (tekuti util)
#:use-module (web request)
#:use-module (web response)
#:use-module (srfi srfi-19)
#:export (make-empty-cache
cached-response-and-body
update-cache))
(define (cacheable-request? request)
(and (memq (request-method request) '(GET HEAD))
(not (request-authorization request))
;; We don't cache these conditional requests; just
;; if-modified-since and if-none-match.
(not (request-if-match request))
(not (request-if-range request))
(not (request-if-unmodified-since request))))
(define (cacheable-response? response)
(and (not (memq 'no-cache (response-pragma response)))
(not (member '(no-cache . #t) (response-cache-control response)))
(memq (response-code response) '(200 301 304 404 410))
(null? (response-vary response))))
(define (make-empty-cache)
'())
(define-syntax build-headers
(syntax-rules ()
((_ k v-exp rest ...)
(let ((v v-exp))
(let ((tail (build-headers rest ...)))
(if v
(acons 'k v tail)
tail))))
((_ tail)
tail)))
(define (make-entry request response body)
(let ((uri (request-uri request))
(method (request-method request)))
(case (response-code response)
((304)
(lambda (request)
(and (equal? (request-uri request) uri)
(eq? (request-method request) method)
(let ((last-modified (response-last-modified response))
(since (request-if-modified-since request)))
(if (and last-modified since)
(time<=? (date->time-utc last-modified)
(date->time-utc since))
#t))
(let ((etag (response-etag response))
(match (request-if-none-match request)))
(if (and etag match)
(and (list? match) (member etag match))
#t))
(cons response body))))
((200)
(lambda (request)
(and (equal? (request-uri request) uri)
(eq? (request-method request) method)
(or (let ((last-modified (response-last-modified response))
(since (request-if-modified-since request))
(etag (response-etag response))
(match (request-if-none-match request)))
(and (or since match)
(or (not since)
(and last-modified
(time<=? (date->time-utc last-modified)
(date->time-utc since))))
(or (not match)
(and etag (list? match) (member etag match)))
(cons (build-response
#:code 304
#:headers (build-headers
etag etag
last-modified last-modified
date (current-date)
'()))
#f)))
(cons response body)))))
(else
(lambda (request)
(and (equal? (request-uri request) uri)
(eq? (request-method request) method)
(cons response body)))))))
(define (cached-response-and-body cache request)
(and cache
(cacheable-request? request)
(or-map (lambda (entry) (entry request))
cache)))
(define (update-cache cache request response body)
(if (and (cacheable-request? request)
(cacheable-response? response))
(cons (make-entry request response body)
(take-max (or cache '()) 19))
(or cache '())))
|
