You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

211 lines
8.2 KiB

  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. (define-module (guix http-client)
  22. #:use-module (web uri)
  23. #:use-module ((web client) #:hide (open-socket-for-uri))
  24. #:use-module (web response)
  25. #:use-module (srfi srfi-11)
  26. #:use-module (srfi srfi-19)
  27. #:use-module (srfi srfi-26)
  28. #:use-module (srfi srfi-34)
  29. #:use-module (srfi srfi-35)
  30. #:use-module (ice-9 match)
  31. #:use-module (ice-9 binary-ports)
  32. #:use-module (rnrs bytevectors)
  33. #:use-module (guix ui)
  34. #:use-module (guix utils)
  35. #:use-module (guix base64)
  36. #:autoload (gcrypt hash) (sha256)
  37. #:use-module ((guix build utils)
  38. #:select (mkdir-p dump-port))
  39. #:use-module ((guix build download)
  40. #:select (open-socket-for-uri
  41. (open-connection-for-uri
  42. . guix:open-connection-for-uri)
  43. resolve-uri-reference))
  44. #:re-export (open-socket-for-uri)
  45. #:export (&http-get-error
  46. http-get-error?
  47. http-get-error-uri
  48. http-get-error-code
  49. http-get-error-reason
  50. http-fetch
  51. %http-cache-ttl
  52. http-fetch/cached))
  53. ;;; Commentary:
  54. ;;;
  55. ;;; HTTP client portable among Guile versions, and with proper error condition
  56. ;;; reporting.
  57. ;;;
  58. ;;; Code:
  59. ;; HTTP GET error.
  60. (define-condition-type &http-get-error &error
  61. http-get-error?
  62. (uri http-get-error-uri) ; URI
  63. (code http-get-error-code) ; integer
  64. (reason http-get-error-reason)) ; string
  65. (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
  66. keep-alive? (verify-certificate? #t)
  67. (headers '((user-agent . "GNU Guile"))))
  68. "Return an input port containing the data at URI, and the expected number of
  69. bytes available or #f. If TEXT? is true, the data at URI is considered to be
  70. textual. Follow any HTTP redirection. When BUFFERED? is #f, return an
  71. unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is
  72. true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be
  73. reused for future HTTP requests. HEADERS is an alist of extra HTTP headers.
  74. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
  75. Raise an '&http-get-error' condition if downloading fails."
  76. (let loop ((uri (if (string? uri)
  77. (string->uri uri)
  78. uri)))
  79. (let ((port (or port (guix:open-connection-for-uri uri
  80. #:verify-certificate?
  81. verify-certificate?)))
  82. (headers (match (uri-userinfo uri)
  83. ((? string? str)
  84. (cons (cons 'Authorization
  85. (string-append "Basic "
  86. (base64-encode
  87. (string->utf8 str))))
  88. headers))
  89. (_ headers))))
  90. (unless (or buffered? (not (file-port? port)))
  91. (setvbuf port _IONBF))
  92. (let*-values (((resp data)
  93. (http-get uri #:streaming? #t #:port port
  94. #:keep-alive? #t
  95. #:headers headers))
  96. ((code)
  97. (response-code resp)))
  98. (case code
  99. ((200)
  100. (values data (response-content-length resp)))
  101. ((301 ; moved permanently
  102. 302 ; found (redirection)
  103. 303 ; see other
  104. 307 ; temporary redirection
  105. 308) ; permanent redirection
  106. (let ((uri (resolve-uri-reference (response-location resp) uri)))
  107. (close-port port)
  108. (format (current-error-port) (G_ "following redirection to `~a'...~%")
  109. (uri->string uri))
  110. (loop uri)))
  111. (else
  112. (raise (condition (&http-get-error
  113. (uri uri)
  114. (code code)
  115. (reason (response-reason-phrase resp)))
  116. (&message
  117. (message
  118. (format
  119. #f
  120. (G_ "~a: HTTP download failed: ~a (~s)")
  121. (uri->string uri) code
  122. (response-reason-phrase resp))))))))))))
  123. ;;;
  124. ;;; Caching.
  125. ;;;
  126. (define %http-cache-ttl
  127. ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
  128. (make-parameter
  129. (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
  130. string->number*)
  131. 36))))
  132. (define (cache-file-for-uri uri)
  133. "Return the name of the file in the cache corresponding to URI."
  134. (let ((digest (sha256 (string->utf8 (uri->string uri)))))
  135. ;; Use the "URL" alphabet because it does not contain "/".
  136. (string-append (cache-directory) "/http/"
  137. (base64-encode digest 0 (bytevector-length digest)
  138. #f #f base64url-alphabet))))
  139. (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
  140. (write-cache dump-port)
  141. (cache-miss (const #t)))
  142. "Like 'http-fetch', return an input port, but cache its contents in
  143. ~/.cache/guix. The cache remains valid for TTL seconds.
  144. Call WRITE-CACHE with the HTTP input port and the cache output port to write
  145. the data to cache. Call CACHE-MISS with URI just before fetching data from
  146. URI."
  147. (let ((file (cache-file-for-uri uri)))
  148. (define (update-cache cache-port)
  149. (define cache-time
  150. (and cache-port
  151. (stat:mtime (stat cache-port))))
  152. (define headers
  153. `((user-agent . "GNU Guile")
  154. ,@(if cache-time
  155. `((if-modified-since
  156. . ,(time-utc->date (make-time time-utc 0 cache-time))))
  157. '())))
  158. ;; Update the cache and return an input port.
  159. (guard (c ((http-get-error? c)
  160. (if (= 304 (http-get-error-code c)) ;"Not Modified"
  161. (begin
  162. (utime file) ;update FILE's mtime
  163. cache-port)
  164. (raise c))))
  165. (let ((port (http-fetch uri #:text? text?
  166. #:headers headers)))
  167. (cache-miss uri)
  168. (mkdir-p (dirname file))
  169. (when cache-port
  170. (close-port cache-port))
  171. (with-atomic-file-output file
  172. (cut write-cache port <>))
  173. (close-port port)
  174. (open-input-file file))))
  175. (define (old? port)
  176. ;; Return true if PORT has passed TTL.
  177. (let* ((s (stat port))
  178. (now (current-time time-utc)))
  179. (< (+ (stat:mtime s) ttl) (time-second now))))
  180. (catch 'system-error
  181. (lambda ()
  182. (let ((port (open-input-file file)))
  183. (if (old? port)
  184. (update-cache port)
  185. port)))
  186. (lambda args
  187. (if (= ENOENT (system-error-errno args))
  188. (update-cache #f)
  189. (apply throw args))))))
  190. ;;; http-client.scm ends here