diff options
| -rw-r--r-- | guix/http-client.scm | 56 | ||||
| -rw-r--r-- | guix/utils.scm | 7 |
2 files changed, 62 insertions, 1 deletions
diff --git a/guix/http-client.scm b/guix/http-client.scm index 9861ec80cb..8d1cc9b8f3 100644 --- a/guix/http-client.scm +++ b/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 diff --git a/guix/utils.scm b/guix/utils.scm index 0802a1b67a..190b787185 100644 --- a/guix/utils.scm +++ b/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. |