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.
 
 
 
 
 
 

1124 lines
44 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
  4. ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
  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 scripts substitute)
  21. #:use-module (guix ui)
  22. #:use-module ((guix store) #:hide (close-connection))
  23. #:use-module (guix utils)
  24. #:use-module (guix combinators)
  25. #:use-module (guix config)
  26. #:use-module (guix records)
  27. #:use-module ((guix serialization) #:select (restore-file))
  28. #:use-module (gcrypt hash)
  29. #:use-module (guix base32)
  30. #:use-module (guix base64)
  31. #:use-module (guix cache)
  32. #:use-module (gcrypt pk-crypto)
  33. #:use-module (guix pki)
  34. #:use-module ((guix build utils) #:select (mkdir-p dump-port))
  35. #:use-module ((guix build download)
  36. #:select (uri-abbreviation nar-uri-abbreviation
  37. (open-connection-for-uri
  38. . guix:open-connection-for-uri)
  39. close-connection
  40. store-path-abbreviation byte-count->string))
  41. #:use-module (guix progress)
  42. #:use-module ((guix build syscalls)
  43. #:select (set-thread-name))
  44. #:use-module (ice-9 rdelim)
  45. #:use-module (ice-9 regex)
  46. #:use-module (ice-9 match)
  47. #:use-module (ice-9 format)
  48. #:use-module (ice-9 ftw)
  49. #:use-module (ice-9 binary-ports)
  50. #:use-module (ice-9 vlist)
  51. #:use-module (rnrs bytevectors)
  52. #:use-module (srfi srfi-1)
  53. #:use-module (srfi srfi-9)
  54. #:use-module (srfi srfi-11)
  55. #:use-module (srfi srfi-19)
  56. #:use-module (srfi srfi-26)
  57. #:use-module (srfi srfi-34)
  58. #:use-module (srfi srfi-35)
  59. #:use-module (web uri)
  60. #:use-module (web http)
  61. #:use-module (web request)
  62. #:use-module (web response)
  63. #:use-module (guix http-client)
  64. #:export (narinfo-signature->canonical-sexp
  65. narinfo?
  66. narinfo-path
  67. narinfo-uri
  68. narinfo-uri-base
  69. narinfo-compression
  70. narinfo-file-hash
  71. narinfo-file-size
  72. narinfo-hash
  73. narinfo-size
  74. narinfo-references
  75. narinfo-deriver
  76. narinfo-system
  77. narinfo-signature
  78. narinfo-hash->sha256
  79. lookup-narinfos
  80. lookup-narinfos/diverse
  81. read-narinfo
  82. write-narinfo
  83. substitute-urls
  84. guix-substitute))
  85. ;;; Comment:
  86. ;;;
  87. ;;; This is the "binary substituter". It is invoked by the daemon do check
  88. ;;; for the existence of available "substitutes" (pre-built binaries), and to
  89. ;;; actually use them as a substitute to building things locally.
  90. ;;;
  91. ;;; If possible, substitute a binary for the requested store path, using a Nix
  92. ;;; "binary cache". This program implements the Nix "substituter" protocol.
  93. ;;;
  94. ;;; Code:
  95. (cond-expand
  96. (guile-2.2
  97. ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
  98. ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
  99. (define time-monotonic time-tai))
  100. (else #t))
  101. (define %narinfo-cache-directory
  102. ;; A local cache of narinfos, to avoid going to the network. Most of the
  103. ;; time, 'guix substitute' is called by guix-daemon as root and stores its
  104. ;; cached data in /var/guix/…. However, when invoked from 'guix challenge'
  105. ;; as a user, it stores its cache in ~/.cache.
  106. (if (zero? (getuid))
  107. (or (and=> (getenv "XDG_CACHE_HOME")
  108. (cut string-append <> "/guix/substitute"))
  109. (string-append %state-directory "/substitute/cache"))
  110. (string-append (cache-directory #:ensure? #f) "/substitute")))
  111. (define %allow-unauthenticated-substitutes?
  112. ;; Whether to allow unchecked substitutes. This is useful for testing
  113. ;; purposes, and should be avoided otherwise.
  114. (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
  115. (cut string-ci=? <> "yes"))
  116. (begin
  117. (warning (G_ "authentication and authorization of substitutes \
  118. disabled!~%"))
  119. #t)))
  120. (define %narinfo-ttl
  121. ;; Number of seconds during which cached narinfo lookups are considered
  122. ;; valid for substitute servers that do not advertise a TTL via the
  123. ;; 'Cache-Control' response header.
  124. (* 36 3600))
  125. (define %narinfo-negative-ttl
  126. ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
  127. (* 3 3600))
  128. (define %narinfo-transient-error-ttl
  129. ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
  130. (* 10 60))
  131. (define %narinfo-expired-cache-entry-removal-delay
  132. ;; How often we want to remove files corresponding to expired cache entries.
  133. (* 7 24 3600))
  134. (define fields->alist
  135. ;; The narinfo format is really just like recutils.
  136. recutils->alist)
  137. (define %fetch-timeout
  138. ;; Number of seconds after which networking is considered "slow".
  139. 5)
  140. (define %random-state
  141. (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
  142. (define-syntax-rule (with-timeout duration handler body ...)
  143. "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
  144. again."
  145. (begin
  146. (sigaction SIGALRM
  147. (lambda (signum)
  148. (sigaction SIGALRM SIG_DFL)
  149. handler))
  150. (alarm duration)
  151. (call-with-values
  152. (lambda ()
  153. (let try ()
  154. (catch 'system-error
  155. (lambda ()
  156. body ...)
  157. (lambda args
  158. ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
  159. ;; because of the bug at
  160. ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
  161. ;; When that happens, try again. Note: SA_RESTART cannot be
  162. ;; used because of <http://bugs.gnu.org/14640>.
  163. (if (= EINTR (system-error-errno args))
  164. (begin
  165. ;; Wait a little to avoid bursts.
  166. (usleep (random 3000000 %random-state))
  167. (try))
  168. (apply throw args))))))
  169. (lambda result
  170. (alarm 0)
  171. (sigaction SIGALRM SIG_DFL)
  172. (apply values result)))))
  173. (define* (fetch uri #:key (buffered? #t) (timeout? #t))
  174. "Return a binary input port to URI and the number of bytes it's expected to
  175. provide."
  176. (case (uri-scheme uri)
  177. ((file)
  178. (let ((port (open-file (uri-path uri)
  179. (if buffered? "rb" "r0b"))))
  180. (values port (stat:size (stat port)))))
  181. ((http https)
  182. (guard (c ((http-get-error? c)
  183. (leave (G_ "download from '~a' failed: ~a, ~s~%")
  184. (uri->string (http-get-error-uri c))
  185. (http-get-error-code c)
  186. (http-get-error-reason c))))
  187. ;; Test this with:
  188. ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
  189. ;; and then cancel with:
  190. ;; sudo tc qdisc del dev eth0 root
  191. (let ((port #f))
  192. (with-timeout (if timeout?
  193. %fetch-timeout
  194. 0)
  195. (begin
  196. (warning (G_ "while fetching ~a: server is somewhat slow~%")
  197. (uri->string uri))
  198. (warning (G_ "try `--no-substitutes' if the problem persists~%")))
  199. (begin
  200. (when (or (not port) (port-closed? port))
  201. (set! port (guix:open-connection-for-uri
  202. uri #:verify-certificate? #f))
  203. (unless (or buffered? (not (file-port? port)))
  204. (setvbuf port _IONBF)))
  205. (http-fetch uri #:text? #f #:port port
  206. #:verify-certificate? #f))))))
  207. (else
  208. (leave (G_ "unsupported substitute URI scheme: ~a~%")
  209. (uri->string uri)))))
  210. (define-record-type <cache-info>
  211. (%make-cache-info url store-directory wants-mass-query?)
  212. cache-info?
  213. (url cache-info-url)
  214. (store-directory cache-info-store-directory)
  215. (wants-mass-query? cache-info-wants-mass-query?))
  216. (define (download-cache-info url)
  217. "Download the information for the cache at URL. On success, return a
  218. <cache-info> object and a port on which to send further HTTP requests. On
  219. failure, return #f and #f."
  220. (define uri
  221. (string->uri (string-append url "/nix-cache-info")))
  222. (define (read-cache-info port)
  223. (alist->record (fields->alist port)
  224. (cut %make-cache-info url <...>)
  225. '("StoreDir" "WantMassQuery")))
  226. (catch #t
  227. (lambda ()
  228. (case (uri-scheme uri)
  229. ((file)
  230. (values (call-with-input-file (uri-path uri)
  231. read-cache-info)
  232. #f))
  233. ((http https)
  234. (let ((port (guix:open-connection-for-uri
  235. uri
  236. #:verify-certificate? #f
  237. #:timeout %fetch-timeout)))
  238. (guard (c ((http-get-error? c)
  239. (warning (G_ "while fetching '~a': ~a (~s)~%")
  240. (uri->string (http-get-error-uri c))
  241. (http-get-error-code c)
  242. (http-get-error-reason c))
  243. (close-connection port)
  244. (warning (G_ "ignoring substitute server at '~s'~%") url)
  245. (values #f #f)))
  246. (values (read-cache-info (http-fetch uri
  247. #:verify-certificate? #f
  248. #:port port
  249. #:keep-alive? #t))
  250. port))))))
  251. (lambda (key . args)
  252. (case key
  253. ((getaddrinfo-error system-error)
  254. ;; Silently ignore the error: probably due to lack of network access.
  255. (values #f #f))
  256. (else
  257. (apply throw key args))))))
  258. (define-record-type <narinfo>
  259. (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
  260. references deriver system signature contents)
  261. narinfo?
  262. (path narinfo-path)
  263. (uri narinfo-uri)
  264. (uri-base narinfo-uri-base) ; URI of the cache it originates from
  265. (compression narinfo-compression)
  266. (file-hash narinfo-file-hash)
  267. (file-size narinfo-file-size)
  268. (nar-hash narinfo-hash)
  269. (nar-size narinfo-size)
  270. (references narinfo-references)
  271. (deriver narinfo-deriver)
  272. (system narinfo-system)
  273. (signature narinfo-signature) ; canonical sexp
  274. ;; The original contents of a narinfo file. This field is needed because we
  275. ;; want to preserve the exact textual representation for verification purposes.
  276. ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
  277. ;; for more information.
  278. (contents narinfo-contents))
  279. (define (narinfo-hash->sha256 hash)
  280. "If the string HASH denotes a sha256 hash, return it as a bytevector.
  281. Otherwise return #f."
  282. (and (string-prefix? "sha256:" hash)
  283. (nix-base32-string->bytevector (string-drop hash 7))))
  284. (define (narinfo-signature->canonical-sexp str)
  285. "Return the value of a narinfo's 'Signature' field as a canonical sexp."
  286. (match (string-split str #\;)
  287. ((version host-name sig)
  288. (let ((maybe-number (string->number version)))
  289. (cond ((not (number? maybe-number))
  290. (leave (G_ "signature version must be a number: ~s~%")
  291. version))
  292. ;; Currently, there are no other versions.
  293. ((not (= 1 maybe-number))
  294. (leave (G_ "unsupported signature version: ~a~%")
  295. maybe-number))
  296. (else
  297. (let ((signature (utf8->string (base64-decode sig))))
  298. (catch 'gcry-error
  299. (lambda ()
  300. (string->canonical-sexp signature))
  301. (lambda (key proc err)
  302. (leave (G_ "signature is not a valid \
  303. s-expression: ~s~%")
  304. signature))))))))
  305. (x
  306. (leave (G_ "invalid format of the signature field: ~a~%") x))))
  307. (define (narinfo-maker str cache-url)
  308. "Return a narinfo constructor for narinfos originating from CACHE-URL. STR
  309. must contain the original contents of a narinfo file."
  310. (lambda (path url compression file-hash file-size nar-hash nar-size
  311. references deriver system signature)
  312. "Return a new <narinfo> object."
  313. (%make-narinfo path
  314. ;; Handle the case where URL is a relative URL.
  315. (or (string->uri url)
  316. (string->uri (string-append cache-url "/" url)))
  317. cache-url
  318. compression file-hash
  319. (and=> file-size string->number)
  320. nar-hash
  321. (and=> nar-size string->number)
  322. (string-tokenize references)
  323. (match deriver
  324. ((or #f "") #f)
  325. (_ deriver))
  326. system
  327. (false-if-exception
  328. (and=> signature narinfo-signature->canonical-sexp))
  329. str)))
  330. (define* (assert-valid-signature narinfo signature hash
  331. #:optional (acl (current-acl)))
  332. "Bail out if SIGNATURE, a canonical sexp representing the signature of
  333. NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
  334. (let ((uri (uri->string (narinfo-uri narinfo))))
  335. (signature-case (signature hash acl)
  336. (valid-signature #t)
  337. (invalid-signature
  338. (leave (G_ "invalid signature for '~a'~%") uri))
  339. (hash-mismatch
  340. (leave (G_ "hash mismatch for '~a'~%") uri))
  341. (unauthorized-key
  342. (leave (G_ "'~a' is signed with an unauthorized key~%") uri))
  343. (corrupt-signature
  344. (leave (G_ "signature on '~a' is corrupt~%") uri)))))
  345. (define* (read-narinfo port #:optional url
  346. #:key size)
  347. "Read a narinfo from PORT. If URL is true, it must be a string used to
  348. build full URIs from relative URIs found while reading PORT. When SIZE is
  349. true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
  350. No authentication and authorization checks are performed here!"
  351. (let ((str (utf8->string (if size
  352. (get-bytevector-n port size)
  353. (get-bytevector-all port)))))
  354. (alist->record (call-with-input-string str fields->alist)
  355. (narinfo-maker str url)
  356. '("StorePath" "URL" "Compression"
  357. "FileHash" "FileSize" "NarHash" "NarSize"
  358. "References" "Deriver" "System"
  359. "Signature"))))
  360. (define (narinfo-sha256 narinfo)
  361. "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
  362. 'Signature' field."
  363. (let ((contents (narinfo-contents narinfo)))
  364. (match (string-contains contents "Signature:")
  365. (#f #f)
  366. (index
  367. (let ((above-signature (string-take contents index)))
  368. (sha256 (string->utf8 above-signature)))))))
  369. (define* (valid-narinfo? narinfo #:optional (acl (current-acl))
  370. #:key verbose?)
  371. "Return #t if NARINFO's signature is not valid."
  372. (or %allow-unauthenticated-substitutes?
  373. (let ((hash (narinfo-sha256 narinfo))
  374. (signature (narinfo-signature narinfo))
  375. (uri (uri->string (narinfo-uri narinfo))))
  376. (and hash signature
  377. (signature-case (signature hash acl)
  378. (valid-signature #t)
  379. (invalid-signature
  380. (when verbose?
  381. (format (current-error-port)
  382. "invalid signature for substitute at '~a'~%"
  383. uri))
  384. #f)
  385. (hash-mismatch
  386. (when verbose?
  387. (format (current-error-port)
  388. "hash mismatch for substitute at '~a'~%"
  389. uri))
  390. #f)
  391. (unauthorized-key
  392. (when verbose?
  393. (format (current-error-port)
  394. "substitute at '~a' is signed by an \
  395. unauthorized party~%"
  396. uri))
  397. #f)
  398. (corrupt-signature
  399. (when verbose?
  400. (format (current-error-port)
  401. "corrupt signature for substitute at '~a'~%"
  402. uri))
  403. #f))))))
  404. (define (write-narinfo narinfo port)
  405. "Write NARINFO to PORT."
  406. (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
  407. (define (narinfo->string narinfo)
  408. "Return the external representation of NARINFO."
  409. (call-with-output-string (cut write-narinfo narinfo <>)))
  410. (define (string->narinfo str cache-uri)
  411. "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of
  412. the cache STR originates form."
  413. (call-with-input-string str (cut read-narinfo <> cache-uri)))
  414. (define (narinfo-cache-file cache-url path)
  415. "Return the name of the local file that contains an entry for PATH. The
  416. entry is stored in a sub-directory specific to CACHE-URL."
  417. ;; The daemon does not sanitize its input, so PATH could be something like
  418. ;; "/gnu/store/foo". Gracefully handle that.
  419. (match (store-path-hash-part path)
  420. (#f
  421. (leave (G_ "'~a' does not name a store item~%") path))
  422. ((? string? hash-part)
  423. (string-append %narinfo-cache-directory "/"
  424. (bytevector->base32-string (sha256 (string->utf8 cache-url)))
  425. "/" hash-part))))
  426. (define (cached-narinfo cache-url path)
  427. "Check locally if we have valid info about PATH coming from CACHE-URL.
  428. Return two values: a Boolean indicating whether we have valid cached info, and
  429. that info, which may be either #f (when PATH is unavailable) or the narinfo
  430. for PATH."
  431. (define now
  432. (current-time time-monotonic))
  433. (define cache-file
  434. (narinfo-cache-file cache-url path))
  435. (catch 'system-error
  436. (lambda ()
  437. (call-with-input-file cache-file
  438. (lambda (p)
  439. (match (read p)
  440. (('narinfo ('version 2)
  441. ('cache-uri cache-uri)
  442. ('date date) ('ttl ttl) ('value #f))
  443. ;; A cached negative lookup.
  444. (if (obsolete? date now ttl)
  445. (values #f #f)
  446. (values #t #f)))
  447. (('narinfo ('version 2)
  448. ('cache-uri cache-uri)
  449. ('date date) ('ttl ttl) ('value value))
  450. ;; A cached positive lookup
  451. (if (obsolete? date now ttl)
  452. (values #f #f)
  453. (values #t (string->narinfo value cache-uri))))
  454. (('narinfo ('version v) _ ...)
  455. (values #f #f))))))
  456. (lambda _
  457. (values #f #f))))
  458. (define (cache-narinfo! cache-url path narinfo ttl)
  459. "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the
  460. given TTL (a number of seconds or #f). NARINFO may be #f, in which case it
  461. indicates that PATH is unavailable at CACHE-URL."
  462. (define now
  463. (current-time time-monotonic))
  464. (define (cache-entry cache-uri narinfo)
  465. `(narinfo (version 2)
  466. (cache-uri ,cache-uri)
  467. (date ,(time-second now))
  468. (ttl ,(or ttl
  469. (if narinfo %narinfo-ttl %narinfo-negative-ttl)))
  470. (value ,(and=> narinfo narinfo->string))))
  471. (let ((file (narinfo-cache-file cache-url path)))
  472. (mkdir-p (dirname file))
  473. (with-atomic-file-output file
  474. (lambda (out)
  475. (write (cache-entry cache-url narinfo) out))))
  476. narinfo)
  477. (define (narinfo-request cache-url path)
  478. "Return an HTTP request for the narinfo of PATH at CACHE-URL."
  479. (let ((url (string-append cache-url "/" (store-path-hash-part path)
  480. ".narinfo"))
  481. (headers '((User-Agent . "GNU Guile"))))
  482. (build-request (string->uri url) #:method 'GET #:headers headers)))
  483. (define (at-most max-length lst)
  484. "If LST is shorter than MAX-LENGTH, return it; otherwise return its
  485. MAX-LENGTH first elements."
  486. (let loop ((len 0)
  487. (lst lst)
  488. (result '()))
  489. (match lst
  490. (()
  491. (reverse result))
  492. ((head . tail)
  493. (if (>= len max-length)
  494. (reverse result)
  495. (loop (+ 1 len) tail (cons head result)))))))
  496. (define* (http-multiple-get base-uri proc seed requests
  497. #:key port (verify-certificate? #t))
  498. "Send all of REQUESTS to the server at BASE-URI. Call PROC for each
  499. response, passing it the request object, the response, a port from which to
  500. read the response body, and the previous result, starting with SEED, à la
  501. 'fold'. Return the final result. When PORT is specified, use it as the
  502. initial connection on which HTTP requests are sent."
  503. (let connect ((port port)
  504. (requests requests)
  505. (result seed))
  506. ;; (format (current-error-port) "connecting (~a requests left)..."
  507. ;; (length requests))
  508. (let ((p (or port (guix:open-connection-for-uri
  509. base-uri
  510. #:verify-certificate?
  511. verify-certificate?))))
  512. ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
  513. (when (file-port? p)
  514. (setvbuf p _IOFBF (expt 2 16)))
  515. ;; Send REQUESTS, up to a certain number, in a row.
  516. ;; XXX: Do our own caching to work around inefficiencies when
  517. ;; communicating over TLS: <http://bugs.gnu.org/22966>.
  518. (let-values (((buffer get) (open-bytevector-output-port)))
  519. ;; Inherit the HTTP proxying property from P.
  520. (set-http-proxy-port?! buffer (http-proxy-port? p))
  521. (for-each (cut write-request <> buffer)
  522. (at-most 1000 requests))
  523. (put-bytevector p (get))
  524. (force-output p))
  525. ;; Now start processing responses.
  526. (let loop ((requests requests)
  527. (result result))
  528. (match requests
  529. (()
  530. (reverse result))
  531. ((head tail ...)
  532. (let* ((resp (read-response p))
  533. (body (response-body-port resp))
  534. (result (proc head resp body result)))
  535. ;; The server can choose to stop responding at any time, in which
  536. ;; case we have to try again. Check whether that is the case.
  537. ;; Note that even upon "Connection: close", we can read from BODY.
  538. (match (assq 'connection (response-headers resp))
  539. (('connection 'close)
  540. (close-connection p)
  541. (connect #f tail result)) ;try again
  542. (_
  543. (loop tail result)))))))))) ;keep going
  544. (define (read-to-eof port)
  545. "Read from PORT until EOF is reached. The data are discarded."
  546. (dump-port port (%make-void-port "w")))
  547. (define (narinfo-from-file file url)
  548. "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f
  549. if file doesn't exist, and the narinfo otherwise."
  550. (catch 'system-error
  551. (lambda ()
  552. (call-with-input-file file
  553. (cut read-narinfo <> url)))
  554. (lambda args
  555. (if (= ENOENT (system-error-errno args))
  556. #f
  557. (apply throw args)))))
  558. (define (fetch-narinfos url paths)
  559. "Retrieve all the narinfos for PATHS from the cache at URL and return them."
  560. (define update-progress!
  561. (let ((done 0)
  562. (total (length paths)))
  563. (lambda ()
  564. (display "\r\x1b[K" (current-error-port)) ;erase current line
  565. (force-output (current-error-port))
  566. (format (current-error-port)
  567. (G_ "updating substitutes from '~a'... ~5,1f%")
  568. url (* 100. (/ done total)))
  569. (set! done (+ 1 done)))))
  570. (define hash-part->path
  571. (let ((mapping (fold (lambda (path result)
  572. (vhash-cons (store-path-hash-part path) path
  573. result))
  574. vlist-null
  575. paths)))
  576. (lambda (hash)
  577. (match (vhash-assoc hash mapping)
  578. (#f #f)
  579. ((_ . path) path)))))
  580. (define (handle-narinfo-response request response port result)
  581. (let* ((code (response-code response))
  582. (len (response-content-length response))
  583. (cache (response-cache-control response))
  584. (ttl (and cache (assoc-ref cache 'max-age))))
  585. ;; Make sure to read no more than LEN bytes since subsequent bytes may
  586. ;; belong to the next response.
  587. (if (= code 200) ; hit
  588. (let ((narinfo (read-narinfo port url #:size len)))
  589. (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
  590. (update-progress!)
  591. (cons narinfo result))
  592. (let* ((path (uri-path (request-uri request)))
  593. (hash-part (basename
  594. (string-drop-right path 8)))) ;drop ".narinfo"
  595. (if len
  596. (get-bytevector-n port len)
  597. (read-to-eof port))
  598. (cache-narinfo! url (hash-part->path hash-part) #f
  599. (if (= 404 code)
  600. ttl
  601. %narinfo-transient-error-ttl))
  602. (update-progress!)
  603. result))))
  604. (define (do-fetch uri port)
  605. (case (and=> uri uri-scheme)
  606. ((http https)
  607. (let ((requests (map (cut narinfo-request url <>) paths)))
  608. (update-progress!)
  609. ;; Note: Do not check HTTPS server certificates to avoid depending on
  610. ;; the X.509 PKI. We can do it because we authenticate narinfos,
  611. ;; which provides a much stronger guarantee.
  612. (let ((result (http-multiple-get uri
  613. handle-narinfo-response '()
  614. requests
  615. #:verify-certificate? #f
  616. #:port port)))
  617. (close-connection port)
  618. (newline (current-error-port))
  619. result)))
  620. ((file #f)
  621. (let* ((base (string-append (uri-path uri) "/"))
  622. (files (map (compose (cut string-append base <> ".narinfo")
  623. store-path-hash-part)
  624. paths)))
  625. (filter-map (cut narinfo-from-file <> url) files)))
  626. (else
  627. (leave (G_ "~s: unsupported server URI scheme~%")
  628. (if uri (uri-scheme uri) url)))))
  629. (let-values (((cache-info port)
  630. (download-cache-info url)))
  631. (and cache-info
  632. (if (string=? (cache-info-store-directory cache-info)
  633. (%store-prefix))
  634. (do-fetch (string->uri url) port) ;reuse PORT
  635. (begin
  636. (warning (G_ "'~a' uses different store '~a'; ignoring it~%")
  637. url (cache-info-store-directory cache-info))
  638. (close-connection port)
  639. #f)))))
  640. (define (lookup-narinfos cache paths)
  641. "Return the narinfos for PATHS, invoking the server at CACHE when no
  642. information is available locally."
  643. (let-values (((cached missing)
  644. (fold2 (lambda (path cached missing)
  645. (let-values (((valid? value)
  646. (cached-narinfo cache path)))
  647. (if valid?
  648. (if value
  649. (values (cons value cached) missing)
  650. (values cached missing))
  651. (values cached (cons path missing)))))
  652. '()
  653. '()
  654. paths)))
  655. (if (null? missing)
  656. cached
  657. (let ((missing (fetch-narinfos cache missing)))
  658. (append cached (or missing '()))))))
  659. (define (equivalent-narinfo? narinfo1 narinfo2)
  660. "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe
  661. the same store item. This ignores unnecessary metadata such as the Nar URL."
  662. (and (string=? (narinfo-hash narinfo1)
  663. (narinfo-hash narinfo2))
  664. ;; The following is not needed if all we want is to download a valid
  665. ;; nar, but it's necessary if we want valid narinfo.
  666. (string=? (narinfo-path narinfo1)
  667. (narinfo-path narinfo2))
  668. (equal? (narinfo-references narinfo1)
  669. (narinfo-references narinfo2))
  670. (= (narinfo-size narinfo1)
  671. (narinfo-size narinfo2))))
  672. (define (lookup-narinfos/diverse caches paths authorized?)
  673. "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
  674. That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
  675. cache, and so on.
  676. Return a list of narinfos for PATHS or a subset thereof. The returned
  677. narinfos are either AUTHORIZED?, or they claim a hash that matches an
  678. AUTHORIZED? narinfo."
  679. (define (select-hit result)
  680. (lambda (path)
  681. (match (vhash-fold* cons '() path result)
  682. ((one)
  683. one)
  684. ((several ..1)
  685. (let ((authorized (find authorized? (reverse several))))
  686. (and authorized
  687. (find (cut equivalent-narinfo? <> authorized)
  688. several)))))))
  689. (let loop ((caches caches)
  690. (paths paths)
  691. (result vlist-null) ;path->narinfo vhash
  692. (hits '())) ;paths
  693. (match paths
  694. (() ;we're done
  695. ;; Now iterate on all the HITS, and return exactly one match for each
  696. ;; hit: the first narinfo that is authorized, or that has the same hash
  697. ;; as an authorized narinfo, in the order of CACHES.
  698. (filter-map (select-hit result) hits))
  699. (_
  700. (match caches
  701. ((cache rest ...)
  702. (let* ((narinfos (lookup-narinfos cache paths))
  703. (definite (map narinfo-path (filter authorized? narinfos)))
  704. (missing (lset-difference string=? paths definite))) ;XXX: perf
  705. (loop rest missing
  706. (fold vhash-cons result
  707. (map narinfo-path narinfos) narinfos)
  708. (append definite hits))))
  709. (() ;that's it
  710. (filter-map (select-hit result) hits)))))))
  711. (define (lookup-narinfo caches path authorized?)
  712. "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
  713. was found."
  714. (match (lookup-narinfos/diverse caches (list path) authorized?)
  715. ((answer) answer)
  716. (_ #f)))
  717. (define (cached-narinfo-expiration-time file)
  718. "Return the expiration time for FILE, which is a cached narinfo."
  719. (catch 'system-error
  720. (lambda ()
  721. (call-with-input-file file
  722. (lambda (port)
  723. (match (read port)
  724. (('narinfo ('version 2) ('cache-uri uri)
  725. ('date date) ('ttl ttl) ('value #f))
  726. (+ date ttl))
  727. (('narinfo ('version 2) ('cache-uri uri)
  728. ('date date) ('ttl ttl) ('value value))
  729. (+ date ttl))
  730. (x
  731. 0)))))
  732. (lambda args
  733. ;; FILE may have been deleted.
  734. 0)))
  735. (define (narinfo-cache-directories directory)
  736. "Return the list of narinfo cache directories (one per cache URL.)"
  737. (map (cut string-append directory "/" <>)
  738. (scandir %narinfo-cache-directory
  739. (lambda (item)
  740. (and (not (member item '("." "..")))
  741. (file-is-directory?
  742. (string-append %narinfo-cache-directory
  743. "/" item)))))))
  744. (define* (cached-narinfo-files #:optional
  745. (directory %narinfo-cache-directory))
  746. "Return the list of cached narinfo files under DIRECTORY."
  747. (append-map (lambda (directory)
  748. (map (cut string-append directory "/" <>)
  749. (scandir directory
  750. (lambda (file)
  751. (= (string-length file) 32)))))
  752. (narinfo-cache-directories directory)))
  753. (define (progress-report-port reporter port)
  754. "Return a port that continuously reports the bytes read from PORT using
  755. REPORTER, which should be a <progress-reporter> object."
  756. (match reporter
  757. (($ <progress-reporter> start report stop)
  758. (let* ((total 0)
  759. (read! (lambda (bv start count)
  760. (let ((n (match (get-bytevector-n! port bv start count)
  761. ((? eof-object?) 0)
  762. (x x))))
  763. (set! total (+ total n))
  764. (report total)
  765. n))))
  766. (start)
  767. (make-custom-binary-input-port "progress-port-proc"
  768. read! #f #f
  769. (lambda ()
  770. (close-connection port)
  771. (stop)))))))
  772. (define-syntax with-networking
  773. (syntax-rules ()
  774. "Catch DNS lookup errors and TLS errors and gracefully exit."
  775. ;; Note: no attempt is made to catch other networking errors, because DNS
  776. ;; lookup errors are typically the first one, and because other errors are
  777. ;; a subset of `system-error', which is harder to filter.
  778. ((_ exp ...)
  779. (catch #t
  780. (lambda () exp ...)
  781. (match-lambda*
  782. (('getaddrinfo-error error)
  783. (leave (G_ "host name lookup error: ~a~%")
  784. (gai-strerror error)))
  785. (('gnutls-error error proc . rest)
  786. (let ((error->string (module-ref (resolve-interface '(gnutls))
  787. 'error->string)))
  788. (leave (G_ "TLS error in procedure '~a': ~a~%")
  789. proc (error->string error))))
  790. (args
  791. (apply throw args)))))))
  792. ;;;
  793. ;;; Help.
  794. ;;;
  795. (define (show-help)
  796. (display (G_ "Usage: guix substitute [OPTION]...
  797. Internal tool to substitute a pre-built binary to a local build.\n"))
  798. (display (G_ "
  799. --query report on the availability of substitutes for the
  800. store file names passed on the standard input"))
  801. (display (G_ "
  802. --substitute STORE-FILE DESTINATION
  803. download STORE-FILE and store it as a Nar in file
  804. DESTINATION"))
  805. (newline)
  806. (display (G_ "
  807. -h, --help display this help and exit"))
  808. (display (G_ "
  809. -V, --version display version information and exit"))
  810. (newline)
  811. (show-bug-report-information))
  812. ;;;
  813. ;;; Daemon/substituter protocol.
  814. ;;;
  815. (define (display-narinfo-data narinfo)
  816. "Write to the current output port the contents of NARINFO in the format
  817. expected by the daemon."
  818. (format #t "~a\n~a\n~a\n"
  819. (narinfo-path narinfo)
  820. (or (and=> (narinfo-deriver narinfo)
  821. (cute string-append (%store-prefix) "/" <>))
  822. "")
  823. (length (narinfo-references narinfo)))
  824. (for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
  825. (narinfo-references narinfo))
  826. (format #t "~a\n~a\n"
  827. (or (narinfo-file-size narinfo) 0)
  828. (or (narinfo-size narinfo) 0)))
  829. (define* (process-query command
  830. #:key cache-urls acl)
  831. "Reply to COMMAND, a query as written by the daemon to this process's
  832. standard input. Use ACL as the access-control list against which to check
  833. authorized substitutes."
  834. (define (valid? obj)
  835. (valid-narinfo? obj acl))
  836. (match (string-tokenize command)
  837. (("have" paths ..1)
  838. ;; Return the subset of PATHS available in CACHE-URLS.
  839. (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
  840. (for-each (lambda (narinfo)
  841. (format #t "~a~%" (narinfo-path narinfo)))
  842. substitutable)
  843. (newline)))
  844. (("info" paths ..1)
  845. ;; Reply info about PATHS if it's in CACHE-URLS.
  846. (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
  847. (for-each display-narinfo-data substitutable)
  848. (newline)))
  849. (wtf
  850. (error "unknown `--query' command" wtf))))
  851. (define* (process-substitution store-item destination
  852. #:key cache-urls acl)
  853. "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
  854. DESTINATION as a nar file. Verify the substitute against ACL."
  855. (let* ((narinfo (lookup-narinfo cache-urls store-item
  856. (cut valid-narinfo? <> acl)))
  857. (uri (and=> narinfo narinfo-uri)))
  858. (unless uri
  859. (leave (G_ "no valid substitute for '~a'~%")
  860. store-item))
  861. ;; Tell the daemon what the expected hash of the Nar itself is.
  862. (format #t "~a~%" (narinfo-hash narinfo))
  863. (format (current-error-port)
  864. (G_ "Downloading ~a...~%") (uri->string uri))
  865. (let*-values (((raw download-size)
  866. ;; Note that Hydra currently generates Nars on the fly
  867. ;; and doesn't specify a Content-Length, so
  868. ;; DOWNLOAD-SIZE is #f in practice.
  869. (fetch uri #:buffered? #f #:timeout? #f))
  870. ((progress)
  871. (let* ((comp (narinfo-compression narinfo))
  872. (dl-size (or download-size
  873. (and (equal? comp "none")
  874. (narinfo-size narinfo))))
  875. (reporter (progress-reporter/file
  876. (uri->string uri) dl-size
  877. (current-error-port)
  878. #:abbreviation nar-uri-abbreviation)))
  879. (progress-report-port reporter raw)))
  880. ((input pids)
  881. ;; NOTE: This 'progress' port of current process will be
  882. ;; closed here, while the child process doing the
  883. ;; reporting will close it upon exit.
  884. (decompressed-port (and=> (narinfo-compression narinfo)
  885. string->symbol)
  886. progress)))
  887. ;; Unpack the Nar at INPUT into DESTINATION.
  888. (restore-file input destination)
  889. (close-port input)
  890. ;; Wait for the reporter to finish.
  891. (every (compose zero? cdr waitpid) pids)
  892. ;; Skip a line after what 'progress-reporter/file' printed, and another
  893. ;; one to visually separate substitutions.
  894. (display "\n\n" (current-error-port)))))
  895. ;;;
  896. ;;; Entry point.
  897. ;;;
  898. (define (check-acl-initialized)
  899. "Warn if the ACL is uninitialized."
  900. (define (singleton? acl)
  901. ;; True if ACL contains just the user's public key.
  902. (and (file-exists? %public-key-file)
  903. (let ((key (call-with-input-file %public-key-file
  904. (compose string->canonical-sexp
  905. read-string))))
  906. (match acl
  907. ((thing)
  908. (equal? (canonical-sexp->string thing)
  909. (canonical-sexp->string key)))
  910. (_
  911. #f)))))
  912. (let ((acl (acl->public-keys (current-acl))))
  913. (when (or (null? acl) (singleton? acl))
  914. (warning (G_ "ACL for archive imports seems to be uninitialized, \
  915. substitutes may be unavailable\n")))))
  916. (define (daemon-options)
  917. "Return a list of name/value pairs denoting build daemon options."
  918. (define %not-newline
  919. (char-set-complement (char-set #\newline)))
  920. (match (getenv "_NIX_OPTIONS")
  921. (#f ;should not happen when called by the daemon
  922. '())
  923. (newline-separated
  924. ;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n".
  925. (filter-map (lambda (option=value)
  926. (match (string-index option=value #\=)
  927. (#f ;invalid option setting
  928. #f)
  929. (equal-sign
  930. (cons (string-take option=value equal-sign)
  931. (string-drop option=value (+ 1 equal-sign))))))
  932. (string-tokenize newline-separated %not-newline)))))
  933. (define (find-daemon-option option)
  934. "Return the value of build daemon option OPTION, or #f if it could not be
  935. found."
  936. (assoc-ref (daemon-options) option))
  937. (define %default-substitute-urls
  938. (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client
  939. (find-daemon-option "substitute-urls")) ;admin
  940. string-tokenize)
  941. ((urls ...)
  942. urls)
  943. (#f
  944. ;; This can only happen when this script is not invoked by the
  945. ;; daemon.
  946. '("http://hydra.gnu.org"))))
  947. (define substitute-urls
  948. ;; List of substitute URLs.
  949. (make-parameter %default-substitute-urls))
  950. (define (client-terminal-columns)
  951. "Return the number of columns in the client's terminal, if it is known, or a
  952. default value."
  953. (or (and=> (or (find-daemon-option "untrusted-terminal-columns")
  954. (find-daemon-option "terminal-columns"))
  955. (lambda (str)
  956. (let ((number (string->number str)))
  957. (and number (max 20 (- number 1))))))
  958. 80))
  959. (define (validate-uri uri)
  960. (unless (string->uri uri)
  961. (leave (G_ "~a: invalid URI~%") uri)))
  962. (define (guix-substitute . args)
  963. "Implement the build daemon's substituter protocol."
  964. (mkdir-p %narinfo-cache-directory)
  965. (maybe-remove-expired-cache-entries %narinfo-cache-directory
  966. cached-narinfo-files
  967. #:entry-expiration
  968. cached-narinfo-expiration-time
  969. #:cleanup-period
  970. %narinfo-expired-cache-entry-removal-delay)
  971. (check-acl-initialized)
  972. ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
  973. ;; when we know we cannot substitute, but we must emit a newline on stdout
  974. ;; when everything is alright.
  975. (when (null? (substitute-urls))
  976. (exit 0))
  977. ;; Say hello (see above.)
  978. (newline)
  979. (force-output (current-output-port))
  980. ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error message.
  981. (for-each validate-uri (substitute-urls))
  982. ;; Attempt to install the client's locale, mostly so that messages are
  983. ;; suitably translated.
  984. (match (or (find-daemon-option "untrusted-locale")
  985. (find-daemon-option "locale"))
  986. (#f #f)
  987. (locale (false-if-exception (setlocale LC_ALL locale))))
  988. (set-thread-name "guix substitute")
  989. (with-networking
  990. (with-error-handling ; for signature errors
  991. (match args
  992. (("--query")
  993. (let ((acl (current-acl)))
  994. (let loop ((command (read-line)))
  995. (or (eof-object? command)
  996. (begin
  997. (process-query command
  998. #:cache-urls (substitute-urls)
  999. #:acl acl)
  1000. (loop (read-line)))))))
  1001. (("--substitute" store-path destination)
  1002. ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
  1003. ;; Specify the number of columns of the terminal so the progress
  1004. ;; report displays nicely.
  1005. (parameterize ((current-terminal-columns (client-terminal-columns)))
  1006. (process-substitution store-path destination
  1007. #:cache-urls (substitute-urls)
  1008. #:acl (current-acl))))
  1009. ((or ("-V") ("--version"))
  1010. (show-version-and-exit "guix substitute"))
  1011. (("--help")
  1012. (show-help))
  1013. (opts
  1014. (leave (G_ "~a: unrecognized options~%") opts))))))
  1015. ;;; Local Variables:
  1016. ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
  1017. ;;; End:
  1018. ;;; substitute.scm ends here