Browse Source

http-client: Add 'http-fetch/cached'.

* guix/utils.scm (cache-directory): New procedure.
* guix/http-client.scm (%http-cache-ttl): New variable.
  (http-fetch/cached): New procedure.
gn-latest-20200428
Ludovic Courtès 6 years ago
parent
commit
739ab68bac
  1. 56
      guix/http-client.scm
  2. 7
      guix/utils.scm

56
guix/http-client.scm

@ -23,6 +23,8 @@
#:use-module ((web client) #:hide (open-socket-for-uri))
#:use-module (web response)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
@ -30,6 +32,8 @@
#:use-module (rnrs bytevectors)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module ((guix build utils)
#:select (mkdir-p dump-port))
#:use-module ((guix build download)
#:select (open-socket-for-uri resolve-uri-reference))
#:re-export (open-socket-for-uri)
@ -39,7 +43,10 @@
http-get-error-code
http-get-error-reason
http-fetch))
http-fetch
%http-cache-ttl
http-fetch/cached))
;;; Commentary:
;;;
@ -229,4 +236,51 @@ Raise an '&http-get-error' condition if downloading fails."
(&message
(message "download failed"))))))))))
;;;
;;; Caching.
;;;
(define (%http-cache-ttl)
;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
(make-parameter
(* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
string->number*)
36))))
(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?)
"Like 'http-fetch', return an input port, but cache its contents in
~/.cache/guix. The cache remains valid for TTL seconds."
(let* ((directory (string-append (cache-directory) "/http/"
(uri-host uri)))
(file (string-append directory "/"
(basename (uri-path uri)))))
(define (update-cache)
;; Update the cache and return an input port.
(let ((port (http-fetch uri #:text? text?)))
(mkdir-p directory)
(call-with-output-file file
(cut dump-port port <>))
(close-port port)
(open-input-file file)))
(define (old? port)
;; Return true if PORT has passed TTL.
(let* ((s (stat port))
(now (current-time time-utc)))
(< (+ (stat:mtime s) ttl) (time-second now))))
(catch 'system-error
(lambda ()
(let ((port (open-input-file file)))
(if (old? port)
(begin
(close-port port)
(update-cache))
port)))
(lambda args
(if (= ENOENT (system-error-errno args))
(update-cache)
(apply throw args))))))
;;; http-client.scm ends here

7
guix/utils.scm

@ -81,6 +81,7 @@
fold-tree
fold-tree-leaves
split
cache-directory
filtered-port
compressed-port
@ -703,6 +704,12 @@ elements after E."
((head . tail)
(loop tail (cons head acc))))))
(define (cache-directory)
"Return the cache directory for Guix, by default ~/.cache/guix."
(or (getenv "XDG_CONFIG_HOME")
(and=> (getenv "HOME")
(cut string-append <> "/.cache/guix"))))
;;;
;;; Source location.

Loading…
Cancel
Save