Mirror of GNU Guix
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.

827 lines
34 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
  4. ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (guix build download)
  21. #:use-module (web uri)
  22. #:use-module (web http)
  23. #:use-module ((web client) #:hide (open-socket-for-uri))
  24. #:use-module (web response)
  25. #:use-module (guix base64)
  26. #:use-module (guix ftp-client)
  27. #:use-module (guix build utils)
  28. #:use-module (guix progress)
  29. #:use-module (rnrs io ports)
  30. #:use-module ((ice-9 binary-ports) #:select (unget-bytevector))
  31. #:use-module (rnrs bytevectors)
  32. #:use-module (srfi srfi-1)
  33. #:use-module (srfi srfi-11)
  34. #:use-module (srfi srfi-19)
  35. #:use-module (srfi srfi-26)
  36. #:autoload (ice-9 ftw) (scandir)
  37. #:use-module (ice-9 match)
  38. #:use-module (ice-9 format)
  39. #:export (open-socket-for-uri
  40. open-connection-for-uri
  41. http-fetch
  42. %x509-certificate-directory
  43. close-connection
  44. resolve-uri-reference
  45. maybe-expand-mirrors
  46. url-fetch
  47. byte-count->string
  48. uri-abbreviation
  49. nar-uri-abbreviation
  50. store-path-abbreviation))
  51. ;;; Commentary:
  52. ;;;
  53. ;;; Fetch data such as tarballs over HTTP or FTP (builder-side code).
  54. ;;;
  55. ;;; Code:
  56. (define %http-receive-buffer-size
  57. ;; Size of the HTTP receive buffer.
  58. 65536)
  59. (define* (ellipsis #:optional (port (current-output-port)))
  60. "Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written
  61. in PORT's encoding, and return either that or ASCII dots."
  62. (if (equal? (port-encoding port) "UTF-8")
  63. "…"
  64. "..."))
  65. (define* (store-path-abbreviation store-path #:optional (prefix-length 6))
  66. "If STORE-PATH is the file name of a store entry, return an abbreviation of
  67. STORE-PATH for display, showing PREFIX-LENGTH characters of the hash.
  68. Otherwise return STORE-PATH."
  69. (if (string-prefix? (%store-directory) store-path)
  70. (let ((base (basename store-path)))
  71. (string-append (string-take base prefix-length)
  72. (ellipsis)
  73. (string-drop base 32)))
  74. store-path))
  75. (define* (uri-abbreviation uri #:optional (max-length 42))
  76. "If URI's string representation is larger than MAX-LENGTH, return an
  77. abbreviation of URI showing the scheme, host, and basename of the file."
  78. (define uri-as-string
  79. (uri->string uri))
  80. (define (elide-path)
  81. (let* ((path (uri-path uri))
  82. (base (basename path))
  83. (prefix (string-append (symbol->string (uri-scheme uri)) "://"
  84. ;; `file' URIs have no host part.
  85. (or (uri-host uri) "")
  86. (string-append "/" (ellipsis) "/"))))
  87. (if (> (+ (string-length prefix) (string-length base)) max-length)
  88. (string-append prefix (ellipsis)
  89. (string-drop base (quotient (string-length base) 2)))
  90. (string-append prefix base))))
  91. (if (> (string-length uri-as-string) max-length)
  92. (let ((short (elide-path)))
  93. (if (< (string-length short) (string-length uri-as-string))
  94. short
  95. uri-as-string))
  96. uri-as-string))
  97. (define (nar-uri-abbreviation uri)
  98. "Abbreviate URI, which is assumed to be the URI of a nar as served by Hydra
  99. and 'guix publish', something like
  100. \"http://example.org/nar/1ldrllwbna0aw5z8kpci4fsvbd2w8cw4-texlive-bin-2015\"."
  101. (let* ((uri (if (string? uri) (string->uri uri) uri))
  102. (path (basename (uri-path uri))))
  103. (if (and (> (string-length path) 33)
  104. (char=? (string-ref path 32) #\-))
  105. (string-drop path 33)
  106. path)))
  107. (define* (ftp-fetch uri file #:key timeout print-build-trace?)
  108. "Fetch data from URI and write it to FILE. Return FILE on success. Bail
  109. out if the connection could not be established in less than TIMEOUT seconds."
  110. (let* ((conn (match (and=> (uri-userinfo uri)
  111. (cut string-split <> #\:))
  112. (((? string? user))
  113. (ftp-open (uri-host uri) #:timeout timeout
  114. #:username user))
  115. (((? string? user) (? string? pass))
  116. (ftp-open (uri-host uri) #:timeout timeout
  117. #:username user
  118. #:password pass))
  119. (_ (ftp-open (uri-host uri) #:timeout timeout))))
  120. (size (false-if-exception (ftp-size conn (uri-path uri))))
  121. (in (ftp-retr conn (basename (uri-path uri))
  122. (dirname (uri-path uri))
  123. #:timeout timeout)))
  124. (call-with-output-file file
  125. (lambda (out)
  126. (dump-port* in out
  127. #:buffer-size %http-receive-buffer-size
  128. #:reporter
  129. (if print-build-trace?
  130. (progress-reporter/trace
  131. file (uri->string uri) size)
  132. (progress-reporter/file
  133. (uri-abbreviation uri) size)))))
  134. (ftp-close conn)
  135. (unless print-build-trace?
  136. (newline))
  137. file))
  138. ;; Autoload GnuTLS so that this module can be used even when GnuTLS is
  139. ;; not available. At compile time, this yields "possibly unbound
  140. ;; variable" warnings, but these are OK: we know that the variables will
  141. ;; be bound if we need them, because (guix download) adds GnuTLS as an
  142. ;; input in that case.
  143. (define (load-gnutls)
  144. ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
  145. ;; See <http://bugs.gnu.org/12202>.
  146. (module-use! (resolve-module '(guix build download))
  147. (resolve-interface '(gnutls)))
  148. (set! load-gnutls (const #t)))
  149. (define %x509-certificate-directory
  150. ;; The directory where X.509 authority PEM certificates are stored.
  151. (make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
  152. (getenv "SSL_CERT_DIR") ;like OpenSSL
  153. "/etc/ssl/certs")))
  154. (define (set-certificate-credentials-x509-trust-file!* cred file format)
  155. "Like 'set-certificate-credentials-x509-trust-file!', but without the file
  156. name decoding bug described at
  157. <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>."
  158. (let ((data (call-with-input-file file get-bytevector-all)))
  159. (set-certificate-credentials-x509-trust-data! cred data format)))
  160. (define (make-credendials-with-ca-trust-files directory)
  161. "Return certificate credentials with X.509 authority certificates read from
  162. DIRECTORY. Those authority certificates are checked when
  163. 'peer-certificate-status' is later called."
  164. (let ((cred (make-certificate-credentials))
  165. (files (match (scandir directory (cut string-suffix? ".pem" <>))
  166. ((or #f ())
  167. ;; Some distros provide nothing but bundles (*.crt) under
  168. ;; /etc/ssl/certs, so look for them.
  169. (or (scandir directory (cut string-suffix? ".crt" <>))
  170. '()))
  171. (pem pem))))
  172. (for-each (lambda (file)
  173. (let ((file (string-append directory "/" file)))
  174. ;; Protect against dangling symlinks.
  175. (when (file-exists? file)
  176. (set-certificate-credentials-x509-trust-file!*
  177. cred file
  178. x509-certificate-format/pem))))
  179. files)
  180. cred))
  181. (define (peer-certificate session)
  182. "Return the certificate of the remote peer in SESSION."
  183. (match (session-peer-certificate-chain session)
  184. ((first _ ...)
  185. (import-x509-certificate first x509-certificate-format/der))))
  186. (define (assert-valid-server-certificate session server)
  187. "Return #t if the certificate of the remote peer for SESSION is a valid
  188. certificate for SERVER, where SERVER is the expected host name of peer."
  189. (define cert
  190. (peer-certificate session))
  191. ;; First check whether the server's certificate matches SERVER.
  192. (unless (x509-certificate-matches-hostname? cert server)
  193. (throw 'tls-certificate-error 'host-mismatch cert server))
  194. ;; Second check its validity and reachability from the set of authority
  195. ;; certificates loaded via 'set-certificate-credentials-x509-trust-file!'.
  196. (match (peer-certificate-status session)
  197. (() ;certificate is valid
  198. #t)
  199. ((statuses ...)
  200. (throw 'tls-certificate-error 'invalid-certificate cert server
  201. statuses))))
  202. (define (print-tls-certificate-error port key args default-printer)
  203. "Print the TLS certificate error represented by ARGS in an intelligible
  204. way."
  205. (match args
  206. (('host-mismatch cert server)
  207. (format port
  208. "X.509 server certificate for '~a' does not match: ~a~%"
  209. server (x509-certificate-dn cert)))
  210. (('invalid-certificate cert server statuses)
  211. (format port
  212. "X.509 certificate of '~a' could not be verified:~%~{ ~a~%~}"
  213. server
  214. (map certificate-status->string statuses)))))
  215. (set-exception-printer! 'tls-certificate-error
  216. print-tls-certificate-error)
  217. (define* (tls-wrap port server #:key (verify-certificate? #t))
  218. "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS
  219. host name without trailing dot."
  220. (define (log level str)
  221. (format (current-error-port)
  222. "gnutls: [~a|~a] ~a" (getpid) level str))
  223. (load-gnutls)
  224. (let ((session (make-session connection-end/client))
  225. (ca-certs (%x509-certificate-directory)))
  226. ;; Some servers such as 'cloud.github.com' require the client to support
  227. ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is
  228. ;; not available in older GnuTLS releases. See
  229. ;; <http://bugs.gnu.org/18526> for details.
  230. (if (module-defined? (resolve-interface '(gnutls))
  231. 'set-session-server-name!)
  232. (set-session-server-name! session server-name-type/dns server)
  233. (format (current-error-port)
  234. "warning: TLS 'SERVER NAME' extension not supported~%"))
  235. (set-session-transport-fd! session (fileno port))
  236. (set-session-default-priority! session)
  237. ;; The "%COMPAT" bit allows us to work around firewall issues (info
  238. ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
  239. ;; Explicitly disable SSLv3, which is insecure:
  240. ;; <https://tools.ietf.org/html/rfc7568>.
  241. (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")
  242. (set-session-credentials! session
  243. (if (and verify-certificate? ca-certs)
  244. (make-credendials-with-ca-trust-files
  245. ca-certs)
  246. (make-certificate-credentials)))
  247. ;; Uncomment the following lines in case of debugging emergency.
  248. ;;(set-log-level! 10)
  249. ;;(set-log-procedure! log)
  250. (catch 'gnutls-error
  251. (lambda ()
  252. (handshake session))
  253. (lambda (key err proc . rest)
  254. (cond ((eq? err error/warning-alert-received)
  255. ;; Like Wget, do no stop upon non-fatal alerts such as
  256. ;; 'alert-description/unrecognized-name'.
  257. (format (current-error-port)
  258. "warning: TLS warning alert received: ~a~%"
  259. (alert-description->string (alert-get session)))
  260. (handshake session))
  261. (else
  262. ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't
  263. ;; provide a binding for this.
  264. (apply throw key err proc rest)))))
  265. ;; Verify the server's certificate if needed.
  266. (when verify-certificate?
  267. (catch 'tls-certificate-error
  268. (lambda ()
  269. (assert-valid-server-certificate session server))
  270. (lambda args
  271. (close-port port)
  272. (apply throw args))))
  273. (let ((record (session-record-port session)))
  274. (define (read! bv start count)
  275. (define read-bv (get-bytevector-some record))
  276. (if (eof-object? read-bv)
  277. 0 ; read! returns 0 on eof-object
  278. (let ((read-bv-len (bytevector-length read-bv)))
  279. (bytevector-copy! read-bv 0 bv start (min read-bv-len count))
  280. (when (< count read-bv-len)
  281. (unget-bytevector record bv count (- read-bv-len count)))
  282. read-bv-len)))
  283. (define (write! bv start count)
  284. (put-bytevector record bv start count)
  285. (force-output record)
  286. count)
  287. (define (get-position)
  288. (port-position record))
  289. (define (set-position! new-position)
  290. (set-port-position! record new-position))
  291. (define (close)
  292. (unless (port-closed? port)
  293. (close-port port))
  294. (unless (port-closed? record)
  295. (close-port record)))
  296. (setvbuf record 'block)
  297. ;; Return a port that wraps RECORD to ensure that closing it also
  298. ;; closes PORT, the actual socket port, and its file descriptor.
  299. ;; XXX: This wrapper would be unnecessary if GnuTLS could
  300. ;; automatically close SESSION's file descriptor when RECORD is
  301. ;; closed, but that doesn't seem to be possible currently (as of
  302. ;; 3.6.9).
  303. (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
  304. get-position set-position!
  305. close))))
  306. (define (ensure-uri uri-or-string) ;XXX: copied from (web http)
  307. (cond
  308. ((string? uri-or-string) (string->uri uri-or-string))
  309. ((uri? uri-or-string) uri-or-string)
  310. (else (error "Invalid URI" uri-or-string))))
  311. (define* (open-socket-for-uri uri-or-string #:key timeout)
  312. "Return an open input/output port for a connection to URI. When TIMEOUT is
  313. not #f, it must be a (possibly inexact) number denoting the maximum duration
  314. in seconds to wait for the connection to complete; passed TIMEOUT, an
  315. ETIMEDOUT error is raised."
  316. ;; Includes a fix for <http://bugs.gnu.org/15368> which affects Guile's
  317. ;; 'open-socket-for-uri' up to 2.0.11 included, uses 'connect*' instead
  318. ;; of 'connect', and uses AI_ADDRCONFIG.
  319. (define http-proxy (current-http-proxy))
  320. (define uri (ensure-uri (or http-proxy uri-or-string)))
  321. (define addresses
  322. (let ((port (uri-port uri)))
  323. (delete-duplicates
  324. (getaddrinfo (uri-host uri)
  325. (cond (port => number->string)
  326. (else (symbol->string (uri-scheme uri))))
  327. (if (number? port)
  328. (logior AI_ADDRCONFIG AI_NUMERICSERV)
  329. AI_ADDRCONFIG))
  330. (lambda (ai1 ai2)
  331. (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))
  332. (let loop ((addresses addresses))
  333. (let* ((ai (car addresses))
  334. (s (with-fluids ((%default-port-encoding #f))
  335. ;; Restrict ourselves to TCP.
  336. (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
  337. (catch 'system-error
  338. (lambda ()
  339. (connect* s (addrinfo:addr ai) timeout)
  340. ;; Buffer input and output on this port.
  341. (setvbuf s 'block)
  342. ;; If we're using a proxy, make a note of that.
  343. (when http-proxy (set-http-proxy-port?! s #t))
  344. s)
  345. (lambda args
  346. ;; Connection failed, so try one of the other addresses.
  347. (close s)
  348. (if (null? (cdr addresses))
  349. (apply throw args)
  350. (loop (cdr addresses))))))))
  351. (define (setup-http-tunnel port uri)
  352. "Establish over PORT an HTTP tunnel to the destination server of URI."
  353. (define target
  354. (string-append (uri-host uri) ":"
  355. (number->string
  356. (or (uri-port uri)
  357. (match (uri-scheme uri)
  358. ('http 80)
  359. ('https 443))))))
  360. (format port "CONNECT ~a HTTP/1.1\r\n" target)
  361. (format port "Host: ~a\r\n\r\n" target)
  362. (force-output port)
  363. (read-response port))
  364. (define* (open-connection-for-uri uri
  365. #:key
  366. timeout
  367. (verify-certificate? #t))
  368. "Like 'open-socket-for-uri', but also handle HTTPS connections. The
  369. resulting port must be closed with 'close-connection'. When
  370. VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
  371. ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually
  372. ;; undefined. See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047.
  373. (define https?
  374. (eq? 'https (uri-scheme uri)))
  375. (define https-proxy (let ((proxy (getenv "https_proxy")))
  376. (and (not (equal? proxy ""))
  377. proxy)))
  378. (let-syntax ((with-https-proxy
  379. (syntax-rules ()
  380. ((_ exp)
  381. ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
  382. (let ((thunk (lambda () exp)))
  383. (if (and https?
  384. (module-variable
  385. (resolve-interface '(web client))
  386. 'current-http-proxy))
  387. (parameterize ((current-http-proxy https-proxy))
  388. (thunk))
  389. (thunk)))))))
  390. (with-https-proxy
  391. (let ((s (open-socket-for-uri uri #:timeout timeout)))
  392. ;; Buffer input and output on this port.
  393. (setvbuf s 'block %http-receive-buffer-size)
  394. (when (and https? https-proxy)
  395. (setup-http-tunnel s uri))
  396. (if https?
  397. (tls-wrap s (uri-host uri)
  398. #:verify-certificate? verify-certificate?)
  399. s)))))
  400. (define (close-connection port) ;deprecated
  401. (unless (port-closed? port)
  402. (close-port port)))
  403. ;; XXX: This is an awful hack to make sure the (set-port-encoding! p
  404. ;; "ISO-8859-1") call in `read-response' passes, even during bootstrap
  405. ;; where iconv is not available.
  406. (module-define! (resolve-module '(web response))
  407. 'set-port-encoding!
  408. (lambda (p e) #f))
  409. ;; XXX: Work around <http://bugs.gnu.org/23421>, fixed in Guile commit
  410. ;; 16050431f29d56f80c4a8253506fc851b8441840. Guile's date validation
  411. ;; procedure rejects dates in which the hour is not padded with a zero but
  412. ;; with whitespace.
  413. (begin
  414. (define-syntax string-match?
  415. (lambda (x)
  416. (syntax-case x ()
  417. ((_ str pat) (string? (syntax->datum #'pat))
  418. (let ((p (syntax->datum #'pat)))
  419. #`(let ((s str))
  420. (and
  421. (= (string-length s) #,(string-length p))
  422. #,@(let lp ((i 0) (tests '()))
  423. (if (< i (string-length p))
  424. (let ((c (string-ref p i)))
  425. (lp (1+ i)
  426. (case c
  427. ((#\.) ; Whatever.
  428. tests)
  429. ((#\d) ; Digit.
  430. (cons #`(char-numeric? (string-ref s #,i))
  431. tests))
  432. ((#\a) ; Alphabetic.
  433. (cons #`(char-alphabetic? (string-ref s #,i))
  434. tests))
  435. (else ; Literal.
  436. (cons #`(eqv? (string-ref s #,i) #,c)
  437. tests)))))
  438. tests)))))))))
  439. (define (parse-rfc-822-date str space zone-offset)
  440. (let ((parse-non-negative-integer (@@ (web http) parse-non-negative-integer))
  441. (parse-month (@@ (web http) parse-month))
  442. (bad-header (@@ (web http) bad-header)))
  443. ;; We could verify the day of the week but we don't.
  444. (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd")
  445. (let ((date (parse-non-negative-integer str 5 7))
  446. (month (parse-month str 8 11))
  447. (year (parse-non-negative-integer str 12 16))
  448. (hour (parse-non-negative-integer str 17 19))
  449. (minute (parse-non-negative-integer str 20 22))
  450. (second (parse-non-negative-integer str 23 25)))
  451. (make-date 0 second minute hour date month year zone-offset)))
  452. ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd")
  453. (let ((date (parse-non-negative-integer str 5 6))
  454. (month (parse-month str 7 10))
  455. (year (parse-non-negative-integer str 11 15))
  456. (hour (parse-non-negative-integer str 16 18))
  457. (minute (parse-non-negative-integer str 19 21))
  458. (second (parse-non-negative-integer str 22 24)))
  459. (make-date 0 second minute hour date month year zone-offset)))
  460. ;; The next two clauses match dates that have a space instead of
  461. ;; a leading zero for hours, like " 8:49:37".
  462. ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd")
  463. (let ((date (parse-non-negative-integer str 5 7))
  464. (month (parse-month str 8 11))
  465. (year (parse-non-negative-integer str 12 16))
  466. (hour (parse-non-negative-integer str 18 19))
  467. (minute (parse-non-negative-integer str 20 22))
  468. (second (parse-non-negative-integer str 23 25)))
  469. (make-date 0 second minute hour date month year zone-offset)))
  470. ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd")
  471. (let ((date (parse-non-negative-integer str 5 6))
  472. (month (parse-month str 7 10))
  473. (year (parse-non-negative-integer str 11 15))
  474. (hour (parse-non-negative-integer str 17 18))
  475. (minute (parse-non-negative-integer str 19 21))
  476. (second (parse-non-negative-integer str 22 24)))
  477. (make-date 0 second minute hour date month year zone-offset)))
  478. (else
  479. (bad-header 'date str) ; prevent tail call
  480. #f))))
  481. (module-set! (resolve-module '(web http))
  482. 'parse-rfc-822-date parse-rfc-822-date))
  483. ;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in
  484. ;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and
  485. ;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143. See bug report at
  486. ;; <https://lists.gnu.org/archive/html/guix-devel/2017-11/msg00070.html>.
  487. (cond-expand
  488. (guile-2.2
  489. (when (<= (string->number (micro-version)) 2)
  490. (let ()
  491. (define put-symbol (@@ (web http) put-symbol))
  492. (define put-non-negative-integer
  493. (@@ (web http) put-non-negative-integer))
  494. (define write-http-version
  495. (@@ (web http) write-http-version))
  496. (define (write-request-line method uri version port)
  497. "Write the first line of an HTTP request to PORT."
  498. (put-symbol port method)
  499. (put-char port #\space)
  500. (when (http-proxy-port? port)
  501. (let ((scheme (uri-scheme uri))
  502. (host (uri-host uri))
  503. (host-port (uri-port uri)))
  504. (when (and scheme host)
  505. (put-symbol port scheme)
  506. (put-string port "://")
  507. (cond
  508. ((string-index host #\:) ;<---- The fix is here!
  509. (put-char port #\[) ;<---- And here!
  510. (put-string port host)
  511. (put-char port #\]))
  512. (else
  513. (put-string port host)))
  514. (unless ((@@ (web uri) default-port?) scheme host-port)
  515. (put-char port #\:)
  516. (put-non-negative-integer port host-port)))))
  517. (let ((path (uri-path uri))
  518. (query (uri-query uri)))
  519. (if (string-null? path)
  520. (put-string port "/")
  521. (put-string port path))
  522. (when query
  523. (put-string port "?")
  524. (put-string port query)))
  525. (put-char port #\space)
  526. (write-http-version version port)
  527. (put-string port "\r\n"))
  528. (module-set! (resolve-module '(web http)) 'write-request-line
  529. write-request-line))))
  530. (else #t))
  531. (define (resolve-uri-reference ref base)
  532. "Resolve the URI reference REF, interpreted relative to the BASE URI, into a
  533. target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
  534. Return the resulting target URI."
  535. (define (merge-paths base-path rel-path)
  536. (let* ((base-components (string-split base-path #\/))
  537. (base-directory-components (match base-components
  538. ((components ... last) components)
  539. (() '())))
  540. (base-directory (string-join base-directory-components "/")))
  541. (string-append base-directory "/" rel-path)))
  542. (define (remove-dot-segments path)
  543. (let loop ((in
  544. ;; Drop leading "." and ".." components from a relative path.
  545. ;; (absolute paths will start with a "" component)
  546. (drop-while (match-lambda
  547. ((or "." "..") #t)
  548. (_ #f))
  549. (string-split path #\/)))
  550. (out '()))
  551. (match in
  552. (("." . rest)
  553. (loop rest out))
  554. ((".." . rest)
  555. (match out
  556. ((or () (""))
  557. (error "remove-dot-segments: too many '..' components" path))
  558. (_
  559. (loop rest (cdr out)))))
  560. ((component . rest)
  561. (loop rest (cons component out)))
  562. (()
  563. (string-join (reverse out) "/")))))
  564. (cond ((or (uri-scheme ref)
  565. (uri-host ref))
  566. (build-uri (or (uri-scheme ref)
  567. (uri-scheme base))
  568. #:userinfo (uri-userinfo ref)
  569. #:host (uri-host ref)
  570. #:port (uri-port ref)
  571. #:path (remove-dot-segments (uri-path ref))
  572. #:query (uri-query ref)
  573. #:fragment (uri-fragment ref)))
  574. ((string-null? (uri-path ref))
  575. (build-uri (uri-scheme base)
  576. #:userinfo (uri-userinfo base)
  577. #:host (uri-host base)
  578. #:port (uri-port base)
  579. #:path (remove-dot-segments (uri-path base))
  580. #:query (or (uri-query ref)
  581. (uri-query base))
  582. #:fragment (uri-fragment ref)))
  583. (else
  584. (build-uri (uri-scheme base)
  585. #:userinfo (uri-userinfo base)
  586. #:host (uri-host base)
  587. #:port (uri-port base)
  588. #:path (remove-dot-segments
  589. (if (string-prefix? "/" (uri-path ref))
  590. (uri-path ref)
  591. (merge-paths (uri-path base)
  592. (uri-path ref))))
  593. #:query (uri-query ref)
  594. #:fragment (uri-fragment ref)))))
  595. (define* (http-fetch uri #:key timeout (verify-certificate? #t))
  596. "Return an input port containing the data at URI, and the expected number of
  597. bytes available or #f. When TIMEOUT is true, bail out if the connection could
  598. not be established in less than TIMEOUT seconds. When VERIFY-CERTIFICATE? is
  599. true, verify HTTPS certificates; otherwise simply ignore them."
  600. (define headers
  601. `(;; Some web sites, such as http://dist.schmorp.de, would block you if
  602. ;; there's no 'User-Agent' header, presumably on the assumption that
  603. ;; you're a spammer. So work around that.
  604. (User-Agent . "GNU Guile")
  605. ;; Some servers, such as https://alioth.debian.org, return "406 Not
  606. ;; Acceptable" when not explicitly told that everything is accepted.
  607. (Accept . "*/*")
  608. ;; Basic authentication, if needed.
  609. ,@(match (uri-userinfo uri)
  610. ((? string? str)
  611. `((Authorization . ,(string-append "Basic "
  612. (base64-encode
  613. (string->utf8 str))))))
  614. (_ '()))))
  615. (let*-values (((connection)
  616. (open-connection-for-uri uri
  617. #:timeout timeout
  618. #:verify-certificate?
  619. verify-certificate?))
  620. ((resp port)
  621. (http-get uri #:port connection #:decode-body? #f
  622. #:streaming? #t
  623. #:headers headers))
  624. ((code)
  625. (response-code resp)))
  626. (case code
  627. ((200) ; OK
  628. (values port (response-content-length resp)))
  629. ((301 ; moved permanently
  630. 302 ; found (redirection)
  631. 303 ; see other
  632. 307 ; temporary redirection
  633. 308) ; permanent redirection
  634. (let ((uri (resolve-uri-reference (response-location resp) uri)))
  635. (format #t "following redirection to `~a'...~%"
  636. (uri->string uri))
  637. (close connection)
  638. (http-fetch uri
  639. #:timeout timeout
  640. #:verify-certificate? verify-certificate?)))
  641. (else
  642. (error "download failed" (uri->string uri)
  643. code (response-reason-phrase resp))))))
  644. (define-syntax-rule (false-if-exception* body ...)
  645. "Like `false-if-exception', but print the exception on the error port."
  646. (catch #t
  647. (lambda ()
  648. body ...)
  649. (lambda (key . args)
  650. #f)
  651. (lambda (key . args)
  652. (print-exception (current-error-port) #f key args))))
  653. (define (uri-vicinity dir file)
  654. "Concatenate DIR, slash, and FILE, keeping only one slash in between.
  655. This is required by some HTTP servers."
  656. (string-append (string-trim-right dir #\/) "/"
  657. (string-trim file #\/)))
  658. (define (maybe-expand-mirrors uri mirrors)
  659. "If URI uses the 'mirror' scheme, expand it according to the MIRRORS alist.
  660. Return a list of URIs."
  661. (case (uri-scheme uri)
  662. ((mirror)
  663. (let ((kind (string->symbol (uri-host uri)))
  664. (path (uri-path uri)))
  665. (match (assoc-ref mirrors kind)
  666. ((mirrors ..1)
  667. (map (compose string->uri (cut uri-vicinity <> path))
  668. mirrors))
  669. (_
  670. (error "unsupported URL mirror kind" kind uri)))))
  671. (else
  672. (list uri))))
  673. (define* (url-fetch url file
  674. #:key
  675. (timeout 10) (verify-certificate? #t)
  676. (mirrors '()) (content-addressed-mirrors '())
  677. (hashes '())
  678. print-build-trace?)
  679. "Fetch FILE from URL; URL may be either a single string, or a list of
  680. string denoting alternate URLs for FILE. Return #f on failure, and FILE
  681. on success.
  682. When MIRRORS is defined, it must be an alist of mirrors; it is used to resolve
  683. 'mirror://' URIs.
  684. HASHES must be a list of algorithm/hash pairs, where each algorithm is a
  685. symbol such as 'sha256 and each hash is a bytevector.
  686. CONTENT-ADDRESSED-MIRRORS must be a list of procedures that, given a hash
  687. algorithm and a hash, return a URL where the specified data can be retrieved
  688. or #f.
  689. When VERIFY-CERTIFICATE? is true, validate HTTPS server certificates;
  690. otherwise simply ignore them."
  691. (define uri
  692. (append-map (cut maybe-expand-mirrors <> mirrors)
  693. (match url
  694. ((_ ...) (map string->uri url))
  695. (_ (list (string->uri url))))))
  696. (define (fetch uri file)
  697. (format #t "~%Starting download of ~a~%From ~a...~%"
  698. file (uri->string uri))
  699. (case (uri-scheme uri)
  700. ((http https)
  701. (false-if-exception*
  702. (let-values (((port size)
  703. (http-fetch uri
  704. #:verify-certificate? verify-certificate?
  705. #:timeout timeout)))
  706. (call-with-output-file file
  707. (lambda (output)
  708. (dump-port* port output
  709. #:buffer-size %http-receive-buffer-size
  710. #:reporter (if print-build-trace?
  711. (progress-reporter/trace
  712. file (uri->string uri) size)
  713. (progress-reporter/file
  714. (uri-abbreviation uri) size)))
  715. (newline)))
  716. file)))
  717. ((ftp)
  718. (false-if-exception* (ftp-fetch uri file
  719. #:timeout timeout
  720. #:print-build-trace?
  721. print-build-trace?)))
  722. (else
  723. (format #t "skipping URI with unsupported scheme: ~s~%"
  724. uri)
  725. #f)))
  726. (define content-addressed-uris
  727. (append-map (lambda (make-url)
  728. (filter-map (match-lambda
  729. ((hash-algo . hash)
  730. (let ((file (strip-store-file-name file)))
  731. (string->uri (make-url file hash-algo hash)))))
  732. hashes))
  733. content-addressed-mirrors))
  734. ;; Make this unbuffered so 'progress-report/file' works as expected. 'line
  735. ;; means '\n', not '\r', so it's not appropriate here.
  736. (setvbuf (current-output-port) 'none)
  737. (setvbuf (current-error-port) 'line)
  738. (let try ((uri (append uri content-addressed-uris)))
  739. (match uri
  740. ((uri tail ...)
  741. (or (fetch uri file)
  742. (try tail)))
  743. (()
  744. (format (current-error-port) "failed to download ~s from ~s~%"
  745. file url)
  746. #f))))
  747. ;;; download.scm ends here