aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-10-17 13:02:53 +0200
committerLudovic Courtès <ludo@gnu.org>2015-10-17 14:42:01 +0200
commit739ab68bac4c5b15fee34d5938e3d7eee4735627 (patch)
tree8b4d5d40072c1b35386d9db3487017c9371ed0a6
parent34a7bfb049572fdf02e593ce94dde68736bd1268 (diff)
downloadpatches-739ab68bac4c5b15fee34d5938e3d7eee4735627.tar
patches-739ab68bac4c5b15fee34d5938e3d7eee4735627.tar.gz
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.
-rw-r--r--guix/http-client.scm56
-rw-r--r--guix/utils.scm7
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.