path: root/web-client-with-cache.org

#+title: Web Client with Cache
#+subtitle: for version {{{version}}}, {{{updated}}}
#+author: Vivien Kraus
#+email: vivien@planete-kraus.eu
#+options: ':t toc:t author:t email:t
#+language: en

#+macro: version @@texinfo:@value{VERSION}@@
#+macro: updated @@texinfo:@value{UPDATED}@@
#+texinfo_filename: web-client-with-cache.info
#+texinfo_header: @syncodeindex pg cp
#+texinfo_header: @syncodeindex pg fn
#+texinfo_header: @include version.texi
#+texinfo_dir_category: The Algorithmic Language Scheme
#+texinfo_dir_title: Web Client with Cache: (web-client-with-cache)
#+texinfo_dir_desc: Using the cache
#+texinfo_printed_title: Web Client with Cache

This manual is for the Guile Web Client with Cache (version
{{{version}}}, {{{updated}}}). The source code can be downloaded at
[[https://labo.planete-kraus.eu/web-client-with-cache.git]].

* Copying
  :PROPERTIES:
  :COPYING:  t
  :END:
This manual is for the Guile Web Client with Cache.

Copyright \copy 2021 Vivien Kraus.

#+begin_quote
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
any later version published by the Free Software Foundation; with no
Invariant Sections, with no Front-Cover Texts, and with no Back-Cover
Texts.  A copy of the license is included in the section entitled "GNU
Free Documentation License".

The program present in this document 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, see [[https://www.gnu.org/licenses/]].
#+end_quote

* Installation
The preferred method to install the web client is through Guix. Make
sure that your channels file (under =$HOME/.config/guix/channels.scm=)
looks like this:

#+begin_src scheme :eval no
  (cons (channel
         (name 'web-client-with-cache)
         (url "https://labo.planete-kraus.eu/web-client-with-cache.git"))
        %default-channels)
#+end_src

Then, run guix pull:

#+begin_src shell :eval no
  guix pull
#+end_src

You will then be able to install the package:

#+begin_src shell :eval no
  guix install guile-web-client-with-cache
#+end_src

If you don't have guix installed, you can still download the latest
distribution tarball and install it:

#+begin_src shell :eval no
  wget 'https://web-client-with-cache.planete-kraus.eu/source.tar.gz'
  tar xf source.tar.gz
  cd web-client-with-cache-*
  ./configure
  make
  make install
#+end_src
* Using the cache
#+cindex: using the cache

The API is defined in the =(web client with-cache)= module. It
consists of one function:

#+begin_src emacs-lisp :noweb yes :exports results :results drawer
  (format "
  ,#+begin_export texinfo
  @defun with-cache [#:http-get] [#:current-time] [#:box]
  <<with-cache-docstring>>
  @end defun
  ,#+end_export")
#+end_src

* Covoiturage
The goal here is to wrap an expensive long-running pure function so
that calling it multiple times with the same arguments until it has
not returned reuses the return value. The name is not pretty, if you
find a better one please tell me.

#+name: covoiturage-docstring
#+caption: Docstring of the covoiturage function
#+begin_src texinfo
  Wrap @var{f} so that simultaneous calls use the same return value. By
  simultaneous, we mean parallel calls with the same value for the first
  argument (compared with @code{equal?}) during the long-running
  evaluation of @var{f}.

  @var{f} takes at least one argument, the key. @var{f} may throw or
  return. It is executed in a Future (from @code{(ice-9 futures)}, so
  side effects should be synchronized somehow.
#+end_src

Internally, we use an atomic box. The atomic box contains an alist
from key values to promises to futures.  Futures are cool, but once
they are constructed they start running immediately.

However, if the lockless synchronization failed because of a
concurrent update (for instance, inserting a new query), we should not
start f at all before having updated the atomic box. Otherwise, for
http-get, an unwanted connection to the server will still be
attempted.

To work around that, we use a promise to a future, so the
future starts when the promise is forced -- thus, either by our
thread, after we have synchronized the box ourselves; or by another
thread, because it has already been added to the box.

Once the function has returned, we notify all the other waiting
threads and remove everything from the box. Function
[[fn-covoiturage-remove]] does the removal.

#+name: fn-covoiturage-remove
#+caption: Remove a completed entry from a box
#+begin_src scheme :eval no
  (define (remove box key)
    (let* ((old (atomic-box-ref box))
           (new (filter (lambda (record)
                          (not (equal? (car record) key)))
                        old))
           (discarded
            (atomic-box-compare-and-swap! box old new)))
      (unless (eq? discarded old)
        (remove box key))))
#+end_src

The application of function /f/ may either return (multiple values),
or throw. We want to forward both cases to all the callers, so we need
to intercept the throws. Function [[fn-covoiturage-wrap-f]] does that:
call f, and cons either ='ok= or ='error= and the return or throw
values.

#+name: fn-covoiturage-wrap-f
#+caption: Wrap a thunk so that we know whether it threw or returned
#+begin_src scheme :eval no
  (define (wrap-f f)
    (catch #t
      (lambda ()
        (call-with-values f
          (lambda args
            (cons 'ok args))))
      (lambda error
        (cons 'error error))))
#+end_src

Symmetrically, when we want to report the value, we need to apply
either =throw= or =values=. This is the job of [[fn-covoiturage-report]].

#+name: fn-covoiturage-report
#+caption: Report the computed values
#+begin_src scheme :eval no
  (define (report result)
    (case (car result)
      ((ok) (apply values (cdr result)))
      ((error) (apply throw (cdr result)))))
#+end_src

There are now two cases when we query a key: either there is an entry
in the cache, in which case we just remove that, or we need to create
a new future. Function [[fn-covoiturage-create]] will create the job (it
will not start until it has been added to the cache). We note that if
the return value should be cached for longer, the caching should
happen before /f/ has finished executing.

#+name: fn-covoiturage-create
#+caption: Create a new job (don't start it yet)
#+begin_src scheme :eval no
  (define (create box key f args)
    (delay
      (make-future
       (lambda ()
         (let ((ret (wrap-f (lambda () (apply f key args)))))
           (remove box key)
           ret)))))
#+end_src

The query function works atomically: it first reads the cache, use it
if it is present, and otherwise add an entry with a job and start the
job. If it can't do that atomically, it retries. That's function
[[fn-covoiturage-do-query]].

#+name: fn-covoiturage-do-query
#+caption: Do query the cache
#+begin_src scheme :eval no
  (define (do-query box f key args)
    (let ((old (atomic-box-ref box)))
      (if (assoc-ref old key)
          (report (touch (force (assoc-ref old key))))
          (let* ((job (create box key f args))
                 (new (acons key job old)))
            (let ((discarded
                   (atomic-box-compare-and-swap! box old new)))
              (if (eq? discarded old)
                  ;; The box is updated, so the future can be
                  ;; forced and f starts running
                  (report (touch (force job)))
                  ;; Concurrent update, retry.
                  (do-query box f key args)))))))
#+end_src

Finally, we wrap everything in a public function that will manage the
state (the atomic box). The final function is [[fn-covoiturage]].

#+name: fn-covoiturage
#+caption: The final function definition
#+begin_src scheme :eval no :noweb no-export
  (define-public (covoiturage f)
    "\
  <<covoiturage-docstring>>"
    (let ((box (make-atomic-box '())))
      <<fn-covoiturage-remove>>
      <<fn-covoiturage-wrap-f>>
      <<fn-covoiturage-report>>
      <<fn-covoiturage-create>>
      <<fn-covoiturage-do-query>>
      (lambda (key . args)
        (do-query box f key args))))
#+end_src

* Web caching
While we still use an atomic box for this cache, it is more complex
than covoiturage. We need to fix HTTP headers, parse the responses,
manipulate time.

** Filter =#:header= keyword argument

Let's start with the headers. We need a function to parse keyword
arguments, extract the non-ignored headers and the non-header keyword
arguments. The function [[fn-filter-keyword]] extracts the headers, and
[[fn-filter-headers]] removes the unwanted ones.

#+name: fn-filter-keyword
#+caption: Filter a keyword from a keyword list
#+begin_src scheme :eval no
  (define (filter-keyword kw args)
    (define (search args-kept value args)
      (if (null? args)
          (values value (reverse args-kept))
          (let ((next-keyword (car args))
                (next-value (cadr args))
                (rest (cddr args)))
            (if (eq? next-keyword kw)
                (search args-kept (or value next-value) rest)
                (search
                 ;; args-kept is in reverse order!
                 (cons* next-value next-keyword args-kept)
                 value
                 rest)))))
    (search '() #f args))
#+end_src

#+name: fn-filter-headers
#+caption: Remove headers for which we have the responsibility
#+begin_src scheme :eval no
  (define (filter-headers headers)
    (filter (lambda (header)
              (case (car header)
                ((if-none-match if-modified-since) #f)
                (else #t)))
            headers))
#+end_src

** Time management

Now, it's time for time management. We need different auxiliary
functions:
1. Add seconds to a date, which is polymorphic enough to allow SRFI-19
   dates and SRFI-19 times;
2. Compare two dates or times.

*** Adding seconds to a date
Function [[fn-date-add]] adds a number of seconds to a time or a date, and
returns a date.

#+name: fn-date-add
#+caption: Add seconds to a date
#+begin_src scheme :eval no
  (define (date-add date seconds)
    (let* ((duration (make-time time-duration 0 seconds))
           (time (if (time? date)
                     date
                     (date->time-utc date)))
           (result (add-duration time duration)))
      (time-utc->date result)))
#+end_src

*** Compare two dates/times
This is the job of functon [[fn-date-geqp]]. If the arguments are dates,
they are first compared to times.

#+name: fn-date-geqp
#+caption: Compare two dates
#+begin_src scheme :eval no
  (define (date>=? past future)
    (when (date? past)
      (set! past (date->time-utc past)))
    (when (date? future)
      (set! future (date->time-utc future)))
    (time>=? past future))
#+end_src

** Fix the responses
There are different things we need to do to responses:
1. Add a date to every response that does not have one;
2. Estimate an expiration date for a response, based on either the
   Expires header or its Date and Cache-Control information;
3. Merge the headers for two responses.

*** Ensure that a response has a date
If the server did not set a date, we set it from the client
clock. This is the job of [[fn-response-with-date]].

#+name: fn-response-with-date
#+caption: Ensure that the response has a date. Use the client clock if needed.
#+begin_src scheme :eval no
  (define (response-with-date response current-time)
    ;; current-time is only used if response does not have a date.
    (let ((date (response-date response (time-utc->date current-time)))
          (other-headers
           (filter (lambda (header)
                     (not (eq? (car header) 'date)))
                   (response-headers response))))
      (build-response
       #:version (response-version response)
       #:code (response-code response)
       #:reason-phrase (response-reason-phrase response)
       #:headers (acons 'date date other-headers)
       #:port (response-port response))))
#+end_src

*** Estimate the expiration date from the response
The expiration date can be:
- the max-age value of the cache control after the response date, if
  the cache control is present and has a max-age;
- the value of the Expires header;
- =#f= if the others failed.

If the max-age is unreasonably large, the response will overstay. So,
we will cap the max-age with the value of one day.

This is what [[fn-estimate-response-expires]] does.

#+name: fn-estimate-response-expires
#+caption: Estimate the expiration date of a response
#+begin_src scheme :eval no
  (define (estimate-response-expires response)
    (let ((cache-control (response-cache-control response '()))
          (expires (response-expires response))
          (date (response-date response)))
      (let ((max-age (assoc-ref cache-control 'max-age))
            (reasonable-max-age (* 1 24 60 60)))
        (cond (max-age
               (when (>= max-age reasonable-max-age)
                 (set! max-age reasonable-max-age))
               (date-add date max-age))
              (expires expires)
              (else #f)))))
#+end_src

*** Merge the headers of two responses
The difficult part is that this will happen every time a response is
refreshed from a 304 Not Modified response. So if we just merge the
alists, the header alist will grow arithmetically.  The trick is to
use a hash table to remove duplicate header names.  This explains
function [[fn-merge-headers]].

#+name: fn-merge-headers
#+caption: Merge the headers for two responses
#+begin_src scheme :eval no
  (define (merge-headers most-important less-important)
    (let ((h+ (response-headers most-important))
          (h- (response-headers less-important)))
      (let* ((alist (append h+ h-))
             (table (alist->hash-table alist)))
        (hash-table->alist table))))
#+end_src

** Detect useless responses
If we just cache all responses for ever, the cache will grow
indefinitely and eat up all the memory. However, some responses are
useless, and we should not keep them for too long. Useless responses
are responses that have expired some time ago. Since the Date header
is always refreshed when the response is refreshed with ETags, this
means that the ETag responses have not been used for a day.

Function [[fn-useful-p]] tests whether a response is useful.

#+name: fn-useful-p
#+caption: Check whether a response is useful
#+begin_src scheme :eval no
  (define (useful? current-time response response-body)
    (let ((end (date-add
                (or (estimate-response-expires response)
                    (response-date response))
                (* 1 24 60 60))))
      (not (date>=? current-time end))))
#+end_src
** Wrap =http-fetch= so as to store the response
Now we can start using the =covoiturage= function. The inner function
will call =http-get=, but between the moment we have the response and
response body and the moment we return them, we add them to a web
cache.

The function [[fn-with-cache-add-to-box]] atomically adds the response and
response-body to the cache, while ensuring there is a Date header. It
also filters the other entries so as to remove the useless responses.

#+name: fn-with-cache-add-to-box
#+caption: Add a response and its body to the cache
#+begin_src scheme :eval no
  (define (with-cache-add-to-box box key response body current-time)
    (set! response (response-with-date response current-time))
    (let* ((old (atomic-box-ref box))
           (new (acons key (cons response body)
                       (filter
                        (lambda (cell)
                          (and (not (equal? key (car cell)))
                               (useful? current-time (cadr cell) (cddr cell))))
                        old)))
           (discarded (atomic-box-compare-and-swap! box old new)))
      (if (eq? discarded old)
          (values response body)
          (with-cache-add-to-box box key response body current-time))))
#+end_src

The function [[fn-with-cache-smart-http-get]] takes more argument than
regular =http-get=. It takes a base response and base response body,
which are the previously cached versions of the response. Then, it
proceeds with =http-get=. If the result is a 304 Not Modified
response, then it updates the cached response with the headers from
the new response and returns the previous response. Also, it updates
the cache just before returning.

#+name: fn-with-cache-smart-http-get
#+caption: =http-get=, but compare with the previous cached responses
#+begin_src scheme :eval no
  (define (with-cache-smart-http-get base-response base-response-body
                                     box current-time http-get key . args)
    (receive (response response-body)
        (apply http-get key args)
      (set! response (response-with-date response current-time))
      (when (and base-response (eq? (response-code response) 304))
        (set! response
          (build-response
           #:version (response-version base-response)
           #:code (response-code base-response)
           #:reason-phrase (response-reason-phrase base-response)
           #:headers (merge-headers response base-response)
           #:port (response-port response)))
        (set! response-body base-response-body))
      (with-cache-add-to-box box key response response-body current-time)))
#+end_src

We can now wrap =with-cache-smart-http-get= within covoiturage, and
focus on the main function. The main function takes the box,
current-time and smart http-get function within covoiturage, looks up
the response in the cache, and returns it as is if it is still
valid. Otherwise, the smart http-get is called. This is the job of
function [[fn-with-cache-query]].

#+name: fn-with-cache-query
#+caption: The main function for the cache
#+begin_src scheme :eval no
  (define (with-cache-query box current-time smart-http-get http-get key . args)
    (let* ((old (atomic-box-ref box))
           (resp (assoc-ref old key)))
      (receive (request-headers other-request-args)
          (filter-keyword #:headers args)
        (unless request-headers
          (set! request-headers '()))
        (set! request-headers (filter-headers request-headers))
        (if resp
            (let ((response (car resp))
                  (response-body (cdr resp)))
              (let ((expires (estimate-response-expires response)))
                (if (and expires (date>=? expires current-time))
                    ;; The response is cached and not expired
                    (values response response-body)
                    ;; The response is cached but expired
                    (let ((etag (response-etag response))
                          (last-modified (response-last-modified response)))
                      (when (and etag (cdr etag))
                        (set! request-headers
                          (acons 'if-none-match (list (car etag)) request-headers)))
                      (when last-modified
                        (set! request-headers
                          (acons 'if-modified-since last-modified request-headers)))
                      (apply smart-http-get
                             response response-body box current-time http-get key
                             #:headers request-headers
                             other-request-args)))))
            ;; The response is not cached
            (apply smart-http-get
                   #f #f box current-time http-get key
                   #:headers request-headers
                   other-request-args)))))
#+end_src

** Putting everything together
The final function is [[fn-with-cache]]. It takes its docstring from
[[with-cache-docstring]].

#+name: with-cache-docstring
#+caption: Docstring of the http-get with cache
#+begin_src texinfo
  Call @var{http-get} with a cache. @var{http-get} is a procedure that
  takes an URI, and optionally some headers and other arguments, and
  either fails or returns two values: a response and a response body. By
  default, it is @code{http-get} from @code{(web client)}.

  The following headers are set by the caching function and are thus
  ignored from the additional arguments:

  @itemize
  @item @code{If-None-Match}
  @item @code{If-Modified-Since}
  @end itemize

  For cache validation without connecting to the server,
  @var{current-time} is needed. It should be thunk, returning a SRFI-19
  time or date. By default, we use the client system clock.

  The returned function takes the same arguments as @var{http-get} from
  @code{(web client)}, and also returns a response and a response body.

  The optional argument @code{#:box} can be used to use a specific
  atomic box instead of one created just for the occasion. If you
  specify this argument, the contained value should be an alist, mapping
  URIs to pairs of (response, response body).
#+end_src

#+name: fn-with-cache
#+caption: HTTP GET with cache
#+begin_src scheme :eval no :noweb no-export :tangle web/client/with-cache.scm :mkdirp t
  (define-module (web client with-cache)
    #:use-module (web client)
    #:use-module (web response)
    #:use-module (srfi srfi-1)
    #:use-module (srfi srfi-19)
    #:use-module (srfi srfi-69)
    #:use-module (ice-9 atomic)
    #:use-module (ice-9 receive)
    #:use-module (ice-9 optargs)
    #:use-module (ice-9 threads)
    #:use-module (ice-9 futures))

  <<fn-covoiturage>>

  (define*-public (with-cache
                   #:key
                   (http-get http-get)
                   (current-time current-time)
                   (box #f))
    "\
  <<with-cache-docstring>>"
    (let ((box (or box (make-atomic-box '()))))
      <<fn-filter-keyword>>
      <<fn-filter-headers>>
      <<fn-date-add>>
      <<fn-date-geqp>>
      <<fn-response-with-date>>
      <<fn-estimate-response-expires>>
      <<fn-merge-headers>>
      <<fn-useful-p>>
      <<fn-with-cache-add-to-box>>
      <<fn-with-cache-smart-http-get>>
      (define smart-http-get
        (covoiturage with-cache-smart-http-get))
      <<fn-with-cache-query>>
      (lambda (uri . args)
        (apply with-cache-query box (current-time) smart-http-get http-get uri args))))
#+end_src

* Test cases
We provide a few test cases to ensure that the caching works. First,
function [[fn-run-test-case]] is defined. It takes a list of request URIs
with time, a list of expected requests with their headers, and a list
of responses. It will process each request in order, check that the
back-end receive the expected requests, and respond the responses.

#+name: fn-run-test-case
#+caption: Run a test case
#+begin_src scheme :eval no
  (define (headers-equal? x y)
    (equal? (hash-table->alist (alist->hash-table x))
            (hash-table->alist (alist->hash-table y))))

  (define (response-equal? x y)
    (and (equal? (response-version x) (response-version y))
         (eq? (response-code x) (response-code y))
         (equal? (response-reason-phrase x)
                 (response-reason-phrase y))
         (headers-equal? (response-headers x) (response-headers y))))

  (define (run-test-case)
    (define current-time (make-time time-utc 0 0))
    (define backend-request-uri #f)
    (define backend-request-headers #f)
    (define backend-response #f)
    (define backend-response-body #f)
    (define cache (make-atomic-box '()))
    (let ((http-get
           (with-cache
            #:box
            cache
            #:current-time
            (lambda () current-time)
            #:http-get
            (lambda* (uri #:key (headers '()))
              (unless (and backend-request-uri
                           backend-request-headers
                           backend-response)
                (format (current-error-port)
                        "Test failed: the backend did not expect to have to respond to ~s ~s.\n"
                        uri headers)
                (format (current-error-port) "The cache is currently ~s.\n" (atomic-box-ref cache))
                (exit 1))
              (unless (and (equal? uri backend-request-uri)
                           (headers-equal? headers backend-request-headers))
                (format (current-error-port)
                        "Test failed: the backend expected to respond to ~s ~s, not ~s ~s.\n"
                        backend-request-uri backend-request-headers
                        uri headers)
                (format (current-error-port) "The cache is currently ~s.\n" (atomic-box-ref cache))
                (exit 2))
              (let ((ret-response backend-response)
                    (ret-body backend-response-body))
                (set! backend-request-uri #f)
                (set! backend-request-headers #f)
                (set! backend-response #f)
                (set! backend-response-body #f)
                (values ret-response ret-body))))))
      (lambda (time
               uri headers
               request-uri request-headers
               response response-body
               expected-response expected-response-body)
        (set! current-time
          (make-time time-utc 0 time))
        (set! backend-request-uri request-uri)
        (set! backend-request-headers request-headers)
        (set! backend-response response)
        (set! backend-response-body response-body)
        (receive (true-response true-response-body)
            (http-get uri #:headers headers)
          (when (or backend-request-uri backend-request-headers backend-response)
            (format (current-error-port)
                    "Test failed: there should have been a backend call to ~s ~s for which we would have responded ~s ~s.\n" backend-request-uri backend-request-headers
                    backend-response backend-response-body)
            (format (current-error-port) "The cache is currently ~s.\n" (atomic-box-ref cache))
            (exit 3))
          (unless (and (response-equal? true-response expected-response)
                       (equal? true-response-body expected-response-body))
            (format (current-error-port)
                    "Test failed: the response should be ~s / ~s, but it is ~s / ~s.\n"
                    expected-response expected-response-body true-response true-response-body)
            (format (current-error-port) "The cache is currently ~s.\n" (atomic-box-ref cache))
            (exit 4))))))
#+end_src

Let's see immediately an example, program [[test-1]].

#+name: test-1
#+caption: Check that responses with a max-age cache control are cached, until the expiration date
#+begin_src scheme :eval no
  (let ((script (run-test-case)))
    ;; At time 0, we request example.com, which is cached for 10
    ;; seconds. Since the cache is empty, it translates directly to a
    ;; call to the back-end with no headers.
    (let ((response-at-0
           (build-response
            #:code 200
            #:reason-phrase "OK"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 0)))
                        (cache-control . (public (max-age . 10)))
                        (content-type . (application/json)))))
          (response-body-at-0 "{}"))
      (script 0 "https://example.com" '()
              "https://example.com" '()
              response-at-0 response-body-at-0
              response-at-0 response-body-at-0)
      ;; At time 5, we request example.com again, and we don't expect
      ;; the back-end to generate a call.
      (script 5 "https://example.com" '()
              #f #f
              #f #f
              response-at-0 response-body-at-0)
      ;; At time 15, we request example.com again, and we expect the
      ;; cache to be invalid.
      (let ((response-at-15
             (build-response
              #:code 200
              #:reason-phrase "OK"
              #:headers `((date . ,(time-utc->date (make-time time-utc 0 15)))
                          (cache-control . (public (max-age . 10)))
                          (content-type . (application/json)))))
            (response-body-at-15 "{\"updated\": \"yes!\"}"))
        (script 15 "https://example.com" '()
                "https://example.com" '()
                response-at-15 response-body-at-15
                response-at-15 response-body-at-15))))
#+end_src

#+name: test-2
#+caption: Check that responses with a max-age cache control are cached, until the expiration date
#+begin_src scheme :eval no
  (let ((script (run-test-case)))
    ;; At time 0, we request example.com, which is set to expire at time
    ;; 10. Since the cache is empty, it translates directly to a call to
    ;; the back-end with no headers.
    (let ((response-at-0
           (build-response
            #:code 200
            #:reason-phrase "OK"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 0)))
                        (expires . ,(time-utc->date (make-time time-utc 0 10)))
                        (content-type . (application/json)))))
          (response-body-at-0 "{}"))
      (script 0 "https://example.com" '()
              "https://example.com" '()
              response-at-0 response-body-at-0
              response-at-0 response-body-at-0)
      ;; At time 5, we request example.com again, and we don't expect
      ;; the back-end to generate a call.
      (script 5 "https://example.com" '()
              #f #f
              #f #f
              response-at-0 response-body-at-0)
      ;; At time 15, we request example.com again, and we expect the
      ;; cache to be invalid.
      (let ((response-at-15
             (build-response
              #:code 200
              #:reason-phrase "OK"
              #:headers `((date . ,(time-utc->date (make-time time-utc 0 15)))
                          (expires . ,(time-utc->date (make-time time-utc 0 25)))
                          (content-type . (application/json)))))
            (response-body-at-15 "{\"updated\": \"yes!\"}"))
        (script 15 "https://example.com" '()
                "https://example.com" '()
                response-at-15 response-body-at-15
                response-at-15 response-body-at-15))))
#+end_src

#+name: test-3
#+caption: Check that responses with an ETag that are used once per day stay
#+begin_src scheme :eval no
  (let ((script (run-test-case)))
    ;; At time 0, we request example.com, which sets an ETag.
    (let ((response-at-0
           (build-response
            #:code 200
            #:reason-phrase "OK"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 0)))
                        (etag . ("Version_0.0.0" . #t))
                        (content-type . (application/json)))))
          (response-body-at-0 "{}"))
      (script 0 "https://example.com" '()
              "https://example.com" '()
              response-at-0 response-body-at-0
              response-at-0 response-body-at-0))
    ;; 20 hours later, we request that again.
    (let ((response-20-hours-later
           (build-response
            #:code 304
            #:reason-phrase "Not Modified"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 20 60 60))))))))
      (script (* 20 60 60) "https://example.com" '()
              "https://example.com" '((if-none-match "Version_0.0.0"))
              response-20-hours-later #f
              (build-response
               #:code 200
               #:reason-phrase "OK"
               #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 20 60 60))))
                           (etag . ("Version_0.0.0" . #t))
                           (content-type . (application/json))))
              "{}"))
    ;; 30 hours later, it should have been cleaned. We first trigger a
    ;; cleaning:
    (let ((cleaning-response
           (build-response
            #:code 200
            #:reason-phrase "OK")))
      (script (* 50 60 60) "https://example.com/cleanup" '()
              "https://example.com/cleanup" '()
              cleaning-response #f
              (build-response
               #:code 200
               #:reason-phrase "OK"
               ;; The date is automatically added:
               #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 50 60 60))))))
              #f))
    ;; Then we try the primary URL again:
    (script (* 50 60 60) "https://example.com" '()
            "https://example.com" '()
            (build-response
             #:code 200
             #:reason-phrase "OK"
             #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 50 60 60))))
                         (etag . ("Version_0.1.0" . #t))
                         (content-type . (application/json))))
            "{\"version\": \"0.1.0\"}"
            (build-response
             #:code 200
             #:reason-phrase "OK"
             #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 50 60 60))))
                         (etag . ("Version_0.1.0" . #t))
                         (content-type . (application/json))))
            "{\"version\": \"0.1.0\"}"))
#+end_src

#+name: test-4
#+caption: Check that responses with a max-age of one day and an ETag are still present 1.5 days later
#+begin_src scheme :eval no
  (let ((script (run-test-case)))
    ;; At time 0, we request example.com, which sets an ETag and has a max-age of 1 day.
    (let ((response-at-0
           (build-response
            #:code 200
            #:reason-phrase "OK"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 0)))
                        (etag . ("Version_0.0.0" . #t))
                        (cache-control . (public (max-age . ,(* 24 60 60))))
                        (content-type . (application/json)))))
          (response-body-at-0 "{}"))
      (script 0 "https://example.com" '()
              "https://example.com" '()
              response-at-0 response-body-at-0
              response-at-0 response-body-at-0))
    ;; 1.5 days later, we request that again. The response has not been
    ;; expired for a full day yet, so it should still be present.
    (let ((response-later
           (build-response
            #:code 304
            #:reason-phrase "Not Modified"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 30 60 60))))))))
      (script (* 30 60 60) "https://example.com" '()
              "https://example.com" '((if-none-match "Version_0.0.0"))
              response-later #f
              (build-response
               #:code 200
               #:reason-phrase "OK"
               #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 30 60 60))))
                           (etag . ("Version_0.0.0" . #t))
                           (cache-control . (public (max-age . ,(* 24 60 60))))
                           (content-type . (application/json))))
              "{}")))
#+end_src

#+name: test-5
#+caption: Check that responses with a max-age of a week disappear after one day
#+begin_src scheme :eval no
  (let ((script (run-test-case)))
    ;; At time 0, we request example.com, which sets a max-age of 10 days.
    (let ((response-at-0
           (build-response
            #:code 200
            #:reason-phrase "OK"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 0)))
                        (cache-control . (public (max-age . ,(* 10 24 60 60))))
                        (content-type . (application/json)))))
          (response-body-at-0 "{}"))
      (script 0 "https://example.com" '()
              "https://example.com" '()
              response-at-0 response-body-at-0
              response-at-0 response-body-at-0))
    ;; After 30 hours, clean
    (let ((cleaning-response
           (build-response
            #:code 200
            #:reason-phrase "OK"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 30 60 60))))))))
      (script (* 30 60 60) "https://example.com/cleanup" '()
              "https://example.com/cleanup" '()
              cleaning-response #f
              cleaning-response #f))
    ;; So now the response should not be cached anymore.
    (let ((response-next-day
           (build-response
            #:code 200
            #:reason-phrase "OK"
            #:headers `((date . ,(time-utc->date (make-time time-utc 0 (* 30 60 60))))
                        (content-type . (application/json)))))
          (response-body-next-day "{\"updated\": \"yes!\"}"))
      (script (* 30 60 60) "https://example.com" '()
              "https://example.com" '()
              response-next-day response-body-next-day
              response-next-day response-body-next-day)))
#+end_src

** All the tests                                                   :noexport:
#+name: tests
#+begin_src scheme :eval no :noweb yes :tangle tests/tests.scm :mkdirp t
  (define-module (tests-harness)
    #:use-module (web client with-cache)
    #:use-module (web response)
    #:use-module (ice-9 atomic)
    #:use-module (ice-9 receive)
    #:use-module (srfi srfi-19)
    #:use-module (srfi srfi-64)
    #:use-module (srfi srfi-69))

  (module-define! (resolve-module '(srfi srfi-64))
                  'test-log-to-file #f)

  <<fn-run-test-case>>

  (test-begin "test-1")

  <<test-1>>

  (test-end "test-1")
  (test-begin "test-2")

  <<test-2>>

  (test-end "test-2")
  (test-begin "test-3")

  <<test-3>>

  (test-end "test-3")
  (test-begin "test-4")

  <<test-4>>

  (test-end "test-4")
  (test-begin "test-5")

  <<test-5>>

  (test-end "test-5")
#+end_src
* GNU Free Documentation License
  :PROPERTIES:
  :APPENDIX: t
  :END:
#+texinfo: @include fdl.texi
* Index
  :PROPERTIES:
  :INDEX:    cp
  :END: