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                      keep-alive? (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'.  When KEEP-ALIVE? is
  79 true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be
  80 reused for future HTTP requests.  HEADERS is an alist of extra HTTP headers.
  81
  82 When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
  83
  84 Raise an '&http-get-error' condition if downloading fails."
  85   (let loop ((uri (if (string? uri)
  86                       (string->uri uri)
  87                       uri)))
  88     (let ((port (or port (guix:open-connection-for-uri uri
  89                                                        #:verify-certificate?
  90                                                        verify-certificate?)))
  91           (headers (match (uri-userinfo uri)
  92                      ((? string? str)
  93                       (cons (cons 'Authorization
  94                                   (string-append "Basic "
  95                                                  (base64-encode
  96                                                   (string->utf8 str))))
  97                             headers))
  98                      (_ headers))))
  99       (unless (or buffered? (not (file-port? port)))
 100         (setvbuf port 'none))
 101       (let*-values (((resp data)
 102                      (http-get uri #:streaming? #t #:port port
 103                                #:keep-alive? #t
 104                                #:headers headers))
 105                     ((code)
 106                      (response-code resp)))
 107         (case code
 108           ((200)
 109            (values data (response-content-length resp)))
 110           ((301                                   ; moved permanently
 111             302                                   ; found (redirection)
 112             303                                   ; see other
 113             307                                   ; temporary redirection
 114             308)                                  ; permanent redirection
 115            (let ((uri (resolve-uri-reference (response-location resp) uri)))
 116              (close-port port)
 117              (format (current-error-port) (G_ "following redirection to `~a'...~%")
 118                      (uri->string uri))
 119              (loop uri)))
 120           (else
 121            (raise (condition (&http-get-error
 122                               (uri uri)
 123                               (code code)
 124                               (reason (response-reason-phrase resp)))
 125                              (&message
 126                               (message
 127                                (format
 128                                 #f
 129                                 (G_ "~a: HTTP download failed: ~a (~s)")
 130                                 (uri->string uri) code
 131                                 (response-reason-phrase resp))))))))))))
 132
 133 \f
 134 ;;;
 135 ;;; Caching.
 136 ;;;
 137
 138 (define %http-cache-ttl
 139   ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
 140   (make-parameter
 141    (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
 142                       string->number*)
 143                36))))
 144
 145 (define (cache-file-for-uri uri)
 146   "Return the name of the file in the cache corresponding to URI."
 147   (let ((digest (sha256 (string->utf8 (uri->string uri)))))
 148     ;; Use the "URL" alphabet because it does not contain "/".
 149     (string-append (cache-directory) "/http/"
 150                    (base64-encode digest 0 (bytevector-length digest)
 151                                   #f #f base64url-alphabet))))
 152
 153 (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
 154                             (write-cache dump-port)
 155                             (cache-miss (const #t)))
 156   "Like 'http-fetch', return an input port, but cache its contents in
 157 ~/.cache/guix.  The cache remains valid for TTL seconds.
 158
 159 Call WRITE-CACHE with the HTTP input port and the cache output port to write
 160 the data to cache.  Call CACHE-MISS with URI just before fetching data from
 161 URI."
 162   (let ((file (cache-file-for-uri uri)))
 163     (define (update-cache cache-port)
 164       (define cache-time
 165         (and cache-port
 166              (stat:mtime (stat cache-port))))
 167
 168       (define headers
 169         `((user-agent . "GNU Guile")
 170           ,@(if cache-time
 171                 `((if-modified-since
 172                    . ,(time-utc->date (make-time time-utc 0 cache-time))))
 173                 '())))
 174
 175       ;; Update the cache and return an input port.
 176       (guard (c ((http-get-error? c)
 177                  (if (= 304 (http-get-error-code c)) ;"Not Modified"
 178                      (begin
 179                        (utime file)               ;update FILE's mtime
 180                        cache-port)
 181                      (raise c))))
 182         (let ((port (http-fetch uri #:text? text?
 183                                 #:headers headers)))
 184           (cache-miss uri)
 185           (mkdir-p (dirname file))
 186           (when cache-port
 187             (close-port cache-port))
 188           (with-atomic-file-output file
 189             (cut write-cache port <>))
 190           (close-port port)
 191           (open-input-file file))))
 192
 193     (define (old? port)
 194       ;; Return true if PORT has passed TTL.
 195       (let* ((s   (stat port))
 196              (now (current-time time-utc)))
 197         (< (+ (stat:mtime s) ttl) (time-second now))))
 198
 199     (catch 'system-error
 200       (lambda ()
 201         (let ((port (open-input-file file)))
 202           (if (old? port)
 203               (update-cache port)
 204               port)))
 205       (lambda args
 206         (if (= ENOENT (system-error-errno args))
 207             (update-cache #f)
 208             (apply throw args))))))
 209
 210 ;;; http-client.scm ends here