guix/http-client.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
   5 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix http-client)
  23   #:use-module (web uri)
  24   #:use-module ((web client) #:hide (open-socket-for-uri))
  25   #:use-module (web response)
  26   #:use-module (srfi srfi-11)
  27   #:use-module (srfi srfi-19)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (srfi srfi-34)
  30   #:use-module (srfi srfi-35)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 binary-ports)
  33   #:use-module (rnrs bytevectors)
  34   #:use-module (guix ui)
  35   #:use-module (guix utils)
  36   #:use-module (guix base64)
  37   #:autoload   (gcrypt hash) (sha256)
  38   #:use-module ((guix build utils)
  39                 #:select (mkdir-p dump-port))
  40   #:use-module ((guix build download)
  41                 #:select (open-socket-for-uri
  42                           (open-connection-for-uri
  43                            . guix:open-connection-for-uri)
  44                           resolve-uri-reference))
  45   #:re-export (open-socket-for-uri)
  46   #:export (&http-get-error
  47             http-get-error?
  48             http-get-error-uri
  49             http-get-error-code
  50             http-get-error-reason
  51
  52             http-fetch
  53
  54             %http-cache-ttl
  55             http-fetch/cached))
  56
  57 ;;; Commentary:
  58 ;;;
  59 ;;; HTTP client portable among Guile versions, and with proper error condition
  60 ;;; reporting.
  61 ;;;
  62 ;;; Code:
  63
  64 ;; HTTP GET error.
  65 (define-condition-type &http-get-error &error
  66   http-get-error?
  67   (uri    http-get-error-uri)                     ; URI
  68   (code   http-get-error-code)                    ; integer
  69   (reason http-get-error-reason))                 ; string
  70
  71
  72 (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
  73                      (verify-certificate? #t)
  74                      (headers '((user-agent . "GNU Guile"))))
  75   "Return an input port containing the data at URI, and the expected number of
  76 bytes available or #f.  If TEXT? is true, the data at URI is considered to be
  77 textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
  78 unbuffered port, suitable for use in `filtered-port'.  HEADERS is an alist of
  79 extra HTTP headers.
  80
  81 When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
  82
  83 Raise an '&http-get-error' condition if downloading fails."
  84   (let loop ((uri (if (string? uri)
  85                       (string->uri uri)
  86                       uri)))
  87     (let ((port (or port (guix:open-connection-for-uri uri
  88                                                        #:verify-certificate?
  89                                                        verify-certificate?)))
  90           (headers (match (uri-userinfo uri)
  91                      ((? string? str)
  92                       (cons (cons 'Authorization
  93                                   (string-append "Basic "
  94                                                  (base64-encode
  95                                                   (string->utf8 str))))
  96                             headers))
  97                      (_ headers))))
  98       (unless (or buffered? (not (file-port? port)))
  99         (setvbuf port 'none))
 100       (let*-values (((resp data)
 101                      (http-get uri #:streaming? #t #:port port
 102                                ;; XXX: When #:keep-alive? is true, if DATA is
 103                                ;; a chunked-encoding port, closing DATA won't
 104                                ;; close PORT, leading to a file descriptor
 105                                ;; leak.
 106                                #:keep-alive? #f
 107                                #:headers headers))
 108                     ((code)
 109                      (response-code resp)))
 110         (case code
 111           ((200)
 112            (values data (response-content-length resp)))
 113           ((301                                   ; moved permanently
 114             302                                   ; found (redirection)
 115             303                                   ; see other
 116             307                                   ; temporary redirection
 117             308)                                  ; permanent redirection
 118            (let ((uri (resolve-uri-reference (response-location resp) uri)))
 119              (close-port port)
 120              (format (current-error-port) (G_ "following redirection to `~a'...~%")
 121                      (uri->string uri))
 122              (loop uri)))
 123           (else
 124            (raise (condition (&http-get-error
 125                               (uri uri)
 126                               (code code)
 127                               (reason (response-reason-phrase resp)))
 128                              (&message
 129                               (message
 130                                (format
 131                                 #f
 132                                 (G_ "~a: HTTP download failed: ~a (~s)")
 133                                 (uri->string uri) code
 134                                 (response-reason-phrase resp))))))))))))
 135
 136 \f
 137 ;;;
 138 ;;; Caching.
 139 ;;;
 140
 141 (define %http-cache-ttl
 142   ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
 143   (make-parameter
 144    (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
 145                       string->number*)
 146                36))))
 147
 148 (define (cache-file-for-uri uri)
 149   "Return the name of the file in the cache corresponding to URI."
 150   (let ((digest (sha256 (string->utf8 (uri->string uri)))))
 151     ;; Use the "URL" alphabet because it does not contain "/".
 152     (string-append (cache-directory) "/http/"
 153                    (base64-encode digest 0 (bytevector-length digest)
 154                                   #f #f base64url-alphabet))))
 155
 156 (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
 157                             (write-cache dump-port)
 158                             (cache-miss (const #t)))
 159   "Like 'http-fetch', return an input port, but cache its contents in
 160 ~/.cache/guix.  The cache remains valid for TTL seconds.
 161
 162 Call WRITE-CACHE with the HTTP input port and the cache output port to write
 163 the data to cache.  Call CACHE-MISS with URI just before fetching data from
 164 URI."
 165   (let ((file (cache-file-for-uri uri)))
 166     (define (update-cache cache-port)
 167       (define cache-time
 168         (and cache-port
 169              (stat:mtime (stat cache-port))))
 170
 171       (define headers
 172         `((user-agent . "GNU Guile")
 173           ,@(if cache-time
 174                 `((if-modified-since
 175                    . ,(time-utc->date (make-time time-utc 0 cache-time))))
 176                 '())))
 177
 178       ;; Update the cache and return an input port.
 179       (guard (c ((http-get-error? c)
 180                  (if (= 304 (http-get-error-code c)) ;"Not Modified"
 181                      (begin
 182                        (utime file)               ;update FILE's mtime
 183                        cache-port)
 184                      (raise c))))
 185         (let ((port (http-fetch uri #:text? text?
 186                                 #:headers headers)))
 187           (cache-miss uri)
 188           (mkdir-p (dirname file))
 189           (when cache-port
 190             (close-port cache-port))
 191           (with-atomic-file-output file
 192             (cut write-cache port <>))
 193           (close-port port)
 194           (open-input-file file))))
 195
 196     (define (old? port)
 197       ;; Return true if PORT has passed TTL.
 198       (let* ((s   (stat port))
 199              (now (current-time time-utc)))
 200         (< (+ (stat:mtime s) ttl) (time-second now))))
 201
 202     (catch 'system-error
 203       (lambda ()
 204         (let ((port (open-input-file file)))
 205           (if (old? port)
 206               (update-cache port)
 207               port)))
 208       (lambda args
 209         (if (= ENOENT (system-error-errno args))
 210             (update-cache #f)
 211             (apply throw args))))))
 212
 213 ;;; http-client.scm ends here