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.
 
 
 
 
 
 

740 lines
29 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (guix scripts substitute-binary)
  20. #:use-module (guix ui)
  21. #:use-module (guix store)
  22. #:use-module (guix utils)
  23. #:use-module (guix config)
  24. #:use-module (guix records)
  25. #:use-module (guix nar)
  26. #:use-module (guix hash)
  27. #:use-module (guix base64)
  28. #:use-module (guix pk-crypto)
  29. #:use-module (guix pki)
  30. #:use-module ((guix build utils) #:select (mkdir-p))
  31. #:use-module ((guix build download)
  32. #:select (progress-proc uri-abbreviation))
  33. #:use-module (ice-9 rdelim)
  34. #:use-module (ice-9 regex)
  35. #:use-module (ice-9 match)
  36. #:use-module (ice-9 threads)
  37. #:use-module (ice-9 format)
  38. #:use-module (ice-9 ftw)
  39. #:use-module (ice-9 binary-ports)
  40. #:use-module (rnrs io ports)
  41. #:use-module (rnrs bytevectors)
  42. #:use-module (srfi srfi-1)
  43. #:use-module (srfi srfi-9)
  44. #:use-module (srfi srfi-11)
  45. #:use-module (srfi srfi-19)
  46. #:use-module (srfi srfi-26)
  47. #:use-module (srfi srfi-34)
  48. #:use-module (srfi srfi-35)
  49. #:use-module (web uri)
  50. #:use-module (guix http-client)
  51. #:export (narinfo-signature->canonical-sexp
  52. read-narinfo
  53. write-narinfo
  54. guix-substitute-binary))
  55. ;;; Comment:
  56. ;;;
  57. ;;; This is the "binary substituter". It is invoked by the daemon do check
  58. ;;; for the existence of available "substitutes" (pre-built binaries), and to
  59. ;;; actually use them as a substitute to building things locally.
  60. ;;;
  61. ;;; If possible, substitute a binary for the requested store path, using a Nix
  62. ;;; "binary cache". This program implements the Nix "substituter" protocol.
  63. ;;;
  64. ;;; Code:
  65. (define %narinfo-cache-directory
  66. ;; A local cache of narinfos, to avoid going to the network.
  67. (or (and=> (getenv "XDG_CACHE_HOME")
  68. (cut string-append <> "/guix/substitute-binary"))
  69. (string-append %state-directory "/substitute-binary/cache")))
  70. (define %allow-unauthenticated-substitutes?
  71. ;; Whether to allow unchecked substitutes. This is useful for testing
  72. ;; purposes, and should be avoided otherwise.
  73. (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
  74. (cut string-ci=? <> "yes"))
  75. (begin
  76. (warning (_ "authentication and authorization of substitutes \
  77. disabled!~%"))
  78. #t)))
  79. (define %narinfo-ttl
  80. ;; Number of seconds during which cached narinfo lookups are considered
  81. ;; valid.
  82. (* 24 3600))
  83. (define %narinfo-negative-ttl
  84. ;; Likewise, but for negative lookups---i.e., cached lookup failures.
  85. (* 3 3600))
  86. (define %narinfo-expired-cache-entry-removal-delay
  87. ;; How often we want to remove files corresponding to expired cache entries.
  88. (* 7 24 3600))
  89. ;; In Guile 2.0.9, `regexp-exec' is thread-unsafe, so work around it.
  90. ;; See <http://bugs.gnu.org/14404>.
  91. (set! regexp-exec
  92. (let ((real regexp-exec)
  93. (lock (make-mutex)))
  94. (lambda (rx str . rest)
  95. (with-mutex lock
  96. (apply real rx str rest)))))
  97. (define fields->alist
  98. ;; The narinfo format is really just like recutils.
  99. recutils->alist)
  100. (define %fetch-timeout
  101. ;; Number of seconds after which networking is considered "slow".
  102. 5)
  103. (define %random-state
  104. (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
  105. (define-syntax-rule (with-timeout duration handler body ...)
  106. "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
  107. again."
  108. (begin
  109. (sigaction SIGALRM
  110. (lambda (signum)
  111. (sigaction SIGALRM SIG_DFL)
  112. handler))
  113. (alarm duration)
  114. (call-with-values
  115. (lambda ()
  116. (let try ()
  117. (catch 'system-error
  118. (lambda ()
  119. body ...)
  120. (lambda args
  121. ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
  122. ;; because of the bug at
  123. ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
  124. ;; When that happens, try again. Note: SA_RESTART cannot be
  125. ;; used because of <http://bugs.gnu.org/14640>.
  126. (if (= EINTR (system-error-errno args))
  127. (begin
  128. ;; Wait a little to avoid bursts.
  129. (usleep (random 3000000 %random-state))
  130. (try))
  131. (apply throw args))))))
  132. (lambda result
  133. (alarm 0)
  134. (sigaction SIGALRM SIG_DFL)
  135. (apply values result)))))
  136. (define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f))
  137. "Return a binary input port to URI and the number of bytes it's expected to
  138. provide. If QUIET-404? is true, HTTP 404 error conditions are passed through
  139. to the caller without emitting an error message."
  140. (case (uri-scheme uri)
  141. ((file)
  142. (let ((port (open-file (uri-path uri)
  143. (if buffered? "rb" "r0b"))))
  144. (values port (stat:size (stat port)))))
  145. ((http)
  146. (guard (c ((http-get-error? c)
  147. (let ((code (http-get-error-code c)))
  148. (if (and (= code 404) quiet-404?)
  149. (raise c)
  150. (leave (_ "download from '~a' failed: ~a, ~s~%")
  151. (uri->string (http-get-error-uri c))
  152. code (http-get-error-reason c))))))
  153. ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So
  154. ;; honor TIMEOUT? to disable the timeout when fetching a nar.
  155. ;;
  156. ;; Test this with:
  157. ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
  158. ;; and then cancel with:
  159. ;; sudo tc qdisc del dev eth0 root
  160. (let ((port #f))
  161. (with-timeout (if (or timeout? (guile-version>? "2.0.5"))
  162. %fetch-timeout
  163. 0)
  164. (begin
  165. (warning (_ "while fetching ~a: server is unresponsive~%")
  166. (uri->string uri))
  167. (warning (_ "try `--no-substitutes' if the problem persists~%"))
  168. ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
  169. ;; and thus PORT had to be closed and re-opened. This is not the
  170. ;; case afterward.
  171. (unless (or (guile-version>? "2.0.9")
  172. (version>? (version) "2.0.9.39"))
  173. (when port
  174. (close-port port))))
  175. (begin
  176. (when (or (not port) (port-closed? port))
  177. (set! port (open-socket-for-uri uri #:buffered? buffered?)))
  178. (http-fetch uri #:text? #f #:port port))))))))
  179. (define-record-type <cache>
  180. (%make-cache url store-directory wants-mass-query?)
  181. cache?
  182. (url cache-url)
  183. (store-directory cache-store-directory)
  184. (wants-mass-query? cache-wants-mass-query?))
  185. (define (open-cache url)
  186. "Open the binary cache at URL. Return a <cache> object on success, or #f on
  187. failure."
  188. (define (download-cache-info url)
  189. ;; Download the `nix-cache-info' from URL, and return its contents as an
  190. ;; list of key/value pairs.
  191. (and=> (false-if-exception (fetch (string->uri url)))
  192. fields->alist))
  193. (and=> (download-cache-info (string-append url "/nix-cache-info"))
  194. (lambda (properties)
  195. (alist->record properties
  196. (cut %make-cache url <...>)
  197. '("StoreDir" "WantMassQuery")))))
  198. (define-record-type <narinfo>
  199. (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
  200. references deriver system signature contents)
  201. narinfo?
  202. (path narinfo-path)
  203. (uri narinfo-uri)
  204. (uri-base narinfo-uri-base) ; URI of the cache it originates from
  205. (compression narinfo-compression)
  206. (file-hash narinfo-file-hash)
  207. (file-size narinfo-file-size)
  208. (nar-hash narinfo-hash)
  209. (nar-size narinfo-size)
  210. (references narinfo-references)
  211. (deriver narinfo-deriver)
  212. (system narinfo-system)
  213. (signature narinfo-signature) ; canonical sexp
  214. ;; The original contents of a narinfo file. This field is needed because we
  215. ;; want to preserve the exact textual representation for verification purposes.
  216. ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
  217. ;; for more information.
  218. (contents narinfo-contents))
  219. (define (narinfo-signature->canonical-sexp str)
  220. "Return the value of a narinfo's 'Signature' field as a canonical sexp."
  221. (match (string-split str #\;)
  222. ((version _ sig)
  223. (let ((maybe-number (string->number version)))
  224. (cond ((not (number? maybe-number))
  225. (leave (_ "signature version must be a number: ~a~%")
  226. version))
  227. ;; Currently, there are no other versions.
  228. ((not (= 1 maybe-number))
  229. (leave (_ "unsupported signature version: ~a~%")
  230. maybe-number))
  231. (else
  232. (let ((signature (utf8->string (base64-decode sig))))
  233. (catch 'gcry-error
  234. (lambda ()
  235. (string->canonical-sexp signature))
  236. (lambda (key proc err)
  237. (leave (_ "signature is not a valid \
  238. s-expression: ~s~%")
  239. signature))))))))
  240. (x
  241. (leave (_ "invalid format of the signature field: ~a~%") x))))
  242. (define (narinfo-maker str cache-url)
  243. "Return a narinfo constructor for narinfos originating from CACHE-URL. STR
  244. must contain the original contents of a narinfo file."
  245. (lambda (path url compression file-hash file-size nar-hash nar-size
  246. references deriver system signature)
  247. "Return a new <narinfo> object."
  248. (%make-narinfo path
  249. ;; Handle the case where URL is a relative URL.
  250. (or (string->uri url)
  251. (string->uri (string-append cache-url "/" url)))
  252. cache-url
  253. compression file-hash
  254. (and=> file-size string->number)
  255. nar-hash
  256. (and=> nar-size string->number)
  257. (string-tokenize references)
  258. (match deriver
  259. ((or #f "") #f)
  260. (_ deriver))
  261. system
  262. (false-if-exception
  263. (and=> signature narinfo-signature->canonical-sexp))
  264. str)))
  265. (define* (assert-valid-signature narinfo signature hash
  266. #:optional (acl (current-acl)))
  267. "Bail out if SIGNATURE, a canonical sexp representing the signature of
  268. NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
  269. (let ((uri (uri->string (narinfo-uri narinfo))))
  270. (signature-case (signature hash acl)
  271. (valid-signature #t)
  272. (invalid-signature
  273. (leave (_ "invalid signature for '~a'~%") uri))
  274. (hash-mismatch
  275. (leave (_ "hash mismatch for '~a'~%") uri))
  276. (unauthorized-key
  277. (leave (_ "'~a' is signed with an unauthorized key~%") uri))
  278. (corrupt-signature
  279. (leave (_ "signature on '~a' is corrupt~%") uri)))))
  280. (define* (read-narinfo port #:optional url)
  281. "Read a narinfo from PORT. If URL is true, it must be a string used to
  282. build full URIs from relative URIs found while reading PORT.
  283. No authentication and authorization checks are performed here!"
  284. (let ((str (utf8->string (get-bytevector-all port))))
  285. (alist->record (call-with-input-string str fields->alist)
  286. (narinfo-maker str url)
  287. '("StorePath" "URL" "Compression"
  288. "FileHash" "FileSize" "NarHash" "NarSize"
  289. "References" "Deriver" "System"
  290. "Signature"))))
  291. (define %signature-line-rx
  292. ;; Regexp matching a signature line in a narinfo.
  293. (make-regexp "(.+)^[[:blank:]]*Signature:[[:blank:]].+$"))
  294. (define (narinfo-sha256 narinfo)
  295. "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
  296. 'Signature' field."
  297. (let ((contents (narinfo-contents narinfo)))
  298. (match (regexp-exec %signature-line-rx contents)
  299. (#f #f)
  300. ((= (cut match:substring <> 1) above-signature)
  301. (sha256 (string->utf8 above-signature))))))
  302. (define* (assert-valid-narinfo narinfo
  303. #:optional (acl (current-acl))
  304. #:key (verbose? #t))
  305. "Raise an exception if NARINFO lacks a signature, has an invalid signature,
  306. or is signed by an unauthorized key."
  307. (let ((hash (narinfo-sha256 narinfo)))
  308. (if (not hash)
  309. (if %allow-unauthenticated-substitutes?
  310. narinfo
  311. (leave (_ "substitute at '~a' lacks a signature~%")
  312. (uri->string (narinfo-uri narinfo))))
  313. (let ((signature (narinfo-signature narinfo)))
  314. (unless %allow-unauthenticated-substitutes?
  315. (assert-valid-signature narinfo signature hash acl)
  316. (when verbose?
  317. (format (current-error-port)
  318. "found valid signature for '~a', from '~a'~%"
  319. (narinfo-path narinfo)
  320. (uri->string (narinfo-uri narinfo)))))
  321. narinfo))))
  322. (define* (valid-narinfo? narinfo #:optional (acl (current-acl)))
  323. "Return #t if NARINFO's signature is not valid."
  324. (or %allow-unauthenticated-substitutes?
  325. (let ((hash (narinfo-sha256 narinfo))
  326. (signature (narinfo-signature narinfo)))
  327. (and hash signature
  328. (signature-case (signature hash acl)
  329. (valid-signature #t)
  330. (else #f))))))
  331. (define (write-narinfo narinfo port)
  332. "Write NARINFO to PORT."
  333. (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
  334. (define (narinfo->string narinfo)
  335. "Return the external representation of NARINFO."
  336. (call-with-output-string (cut write-narinfo narinfo <>)))
  337. (define (string->narinfo str cache-uri)
  338. "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of
  339. the cache STR originates form."
  340. (call-with-input-string str (cut read-narinfo <> cache-uri)))
  341. (define (fetch-narinfo cache path)
  342. "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
  343. (define (download url)
  344. ;; Download the .narinfo from URL, and return its contents as a list of
  345. ;; key/value pairs. Don't emit an error message upon 404.
  346. (false-if-exception (fetch (string->uri url)
  347. #:quiet-404? #t)))
  348. (and (string=? (cache-store-directory cache) (%store-prefix))
  349. (and=> (download (string-append (cache-url cache) "/"
  350. (store-path-hash-part path)
  351. ".narinfo"))
  352. (cute read-narinfo <> (cache-url cache)))))
  353. (define (obsolete? date now ttl)
  354. "Return #t if DATE is obsolete compared to NOW + TTL seconds."
  355. (time>? (subtract-duration now (make-time time-duration 0 ttl))
  356. (make-time time-monotonic 0 date)))
  357. (define %lookup-threads
  358. ;; Number of threads spawned to perform lookup operations. This means we
  359. ;; can have this many simultaneous HTTP GET requests to the server, which
  360. ;; limits the impact of connection latency.
  361. 20)
  362. (define (lookup-narinfo cache path)
  363. "Check locally if we have valid info about PATH, otherwise go to CACHE and
  364. check what it has."
  365. (define now
  366. (current-time time-monotonic))
  367. (define cache-file
  368. (string-append %narinfo-cache-directory "/"
  369. (store-path-hash-part path)))
  370. (define (cache-entry cache-uri narinfo)
  371. `(narinfo (version 1)
  372. (cache-uri ,cache-uri)
  373. (date ,(time-second now))
  374. (value ,(and=> narinfo narinfo->string))))
  375. (let*-values (((valid? cached)
  376. (catch 'system-error
  377. (lambda ()
  378. (call-with-input-file cache-file
  379. (lambda (p)
  380. (match (read p)
  381. (('narinfo ('version 1)
  382. ('cache-uri cache-uri)
  383. ('date date) ('value #f))
  384. ;; A cached negative lookup.
  385. (if (obsolete? date now %narinfo-negative-ttl)
  386. (values #f #f)
  387. (values #t #f)))
  388. (('narinfo ('version 1)
  389. ('cache-uri cache-uri)
  390. ('date date) ('value value))
  391. ;; A cached positive lookup
  392. (if (obsolete? date now %narinfo-ttl)
  393. (values #f #f)
  394. (values #t (string->narinfo value
  395. cache-uri))))
  396. (('narinfo ('version v) _ ...)
  397. (values #f #f))))))
  398. (lambda _
  399. (values #f #f)))))
  400. (if valid?
  401. cached ; including negative caches
  402. (let* ((cache (force cache))
  403. (narinfo (and cache (fetch-narinfo cache path))))
  404. ;; Cache NARINFO only when CACHE was actually accessible. This
  405. ;; avoids caching negative hits when in fact we just lacked network
  406. ;; access.
  407. (when cache
  408. (with-atomic-file-output cache-file
  409. (lambda (out)
  410. (write (cache-entry (cache-url cache) narinfo) out))))
  411. narinfo))))
  412. (define (remove-expired-cached-narinfos)
  413. "Remove expired narinfo entries from the cache. The sole purpose of this
  414. function is to make sure `%narinfo-cache-directory' doesn't grow
  415. indefinitely."
  416. (define now
  417. (current-time time-monotonic))
  418. (define (expired? file)
  419. (catch 'system-error
  420. (lambda ()
  421. (call-with-input-file file
  422. (lambda (port)
  423. (match (read port)
  424. (('narinfo ('version 1) ('cache-uri _) ('date date)
  425. ('value #f))
  426. (obsolete? date now %narinfo-negative-ttl))
  427. (('narinfo ('version 1) ('cache-uri _) ('date date)
  428. ('value _))
  429. (obsolete? date now %narinfo-ttl))
  430. (_ #t)))))
  431. (lambda args
  432. ;; FILE may have been deleted.
  433. #t)))
  434. (for-each (lambda (file)
  435. (let ((file (string-append %narinfo-cache-directory
  436. "/" file)))
  437. (when (expired? file)
  438. ;; Wrap in `false-if-exception' because FILE might have been
  439. ;; deleted in the meantime (TOCTTOU).
  440. (false-if-exception (delete-file file)))))
  441. (scandir %narinfo-cache-directory
  442. (lambda (file)
  443. (= (string-length file) 32)))))
  444. (define (maybe-remove-expired-cached-narinfo)
  445. "Remove expired narinfo entries from the cache if deemed necessary."
  446. (define now
  447. (current-time time-monotonic))
  448. (define expiry-file
  449. (string-append %narinfo-cache-directory "/last-expiry-cleanup"))
  450. (define last-expiry-date
  451. (or (false-if-exception
  452. (call-with-input-file expiry-file read))
  453. 0))
  454. (when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay)
  455. (remove-expired-cached-narinfos)
  456. (call-with-output-file expiry-file
  457. (cute write (time-second now) <>))))
  458. (define (progress-report-port report-progress port)
  459. "Return a port that calls REPORT-PROGRESS every time something is read from
  460. PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
  461. `progress-proc'."
  462. (define total 0)
  463. (define (read! bv start count)
  464. (let ((n (match (get-bytevector-n! port bv start count)
  465. ((? eof-object?) 0)
  466. (x x))))
  467. (set! total (+ total n))
  468. (report-progress total (const n))
  469. ;; XXX: We're not in control, so we always return anyway.
  470. n))
  471. ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done,
  472. ;; don't pretend to report any progress in that case.
  473. (if (guile-version>? "2.0.5")
  474. (make-custom-binary-input-port "progress-port-proc"
  475. read! #f #f
  476. (cut close-port port))
  477. (begin
  478. (format (current-error-port) (_ "Downloading, please wait...~%"))
  479. (format (current-error-port)
  480. (_ "(Please consider upgrading Guile to get proper progress report.)~%"))
  481. port)))
  482. (define %cache-url
  483. (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
  484. "http://hydra.gnu.org"))
  485. (define-syntax with-networking
  486. (syntax-rules ()
  487. "Catch DNS lookup errors and gracefully exit."
  488. ;; Note: no attempt is made to catch other networking errors, because DNS
  489. ;; lookup errors are typically the first one, and because other errors are
  490. ;; a subset of `system-error', which is harder to filter.
  491. ((_ exp ...)
  492. (catch 'getaddrinfo-error
  493. (lambda () exp ...)
  494. (lambda (key error)
  495. (leave (_ "host name lookup error: ~a~%")
  496. (gai-strerror error)))))))
  497. ;;;
  498. ;;; Help.
  499. ;;;
  500. (define (show-help)
  501. (display (_ "Usage: guix substitute-binary [OPTION]...
  502. Internal tool to substitute a pre-built binary to a local build.\n"))
  503. (display (_ "
  504. --query report on the availability of substitutes for the
  505. store file names passed on the standard input"))
  506. (display (_ "
  507. --substitute STORE-FILE DESTINATION
  508. download STORE-FILE and store it as a Nar in file
  509. DESTINATION"))
  510. (newline)
  511. (display (_ "
  512. -h, --help display this help and exit"))
  513. (display (_ "
  514. -V, --version display version information and exit"))
  515. (newline)
  516. (show-bug-report-information))
  517. ;;;
  518. ;;; Entry point.
  519. ;;;
  520. (define n-par-map*
  521. ;; We want the ability to run many threads in parallel, regardless of the
  522. ;; number of cores. However, Guile 2.0.5 has a bug whereby 'n-par-map' ends
  523. ;; up consuming a lot of memory, possibly leading to death. Thus, resort to
  524. ;; 'par-map' on 2.0.5.
  525. (if (guile-version>? "2.0.5")
  526. n-par-map
  527. (lambda (n proc lst)
  528. (par-map proc lst))))
  529. (define (check-acl-initialized)
  530. "Warn if the ACL is uninitialized."
  531. (define (singleton? acl)
  532. ;; True if ACL contains just the user's public key.
  533. (and (file-exists? %public-key-file)
  534. (let ((key (call-with-input-file %public-key-file
  535. (compose string->canonical-sexp
  536. get-string-all))))
  537. (match acl
  538. ((thing)
  539. (equal? (canonical-sexp->string thing)
  540. (canonical-sexp->string key)))
  541. (_
  542. #f)))))
  543. (let ((acl (acl->public-keys (current-acl))))
  544. (when (or (null? acl) (singleton? acl))
  545. (warning (_ "ACL for archive imports seems to be uninitialized, \
  546. substitutes may be unavailable\n")))))
  547. (define (guix-substitute-binary . args)
  548. "Implement the build daemon's substituter protocol."
  549. (mkdir-p %narinfo-cache-directory)
  550. (maybe-remove-expired-cached-narinfo)
  551. (check-acl-initialized)
  552. ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
  553. ;; when we know we cannot substitute, but we must emit a newline on stdout
  554. ;; when everything is alright.
  555. (let ((uri (string->uri %cache-url)))
  556. (case (uri-scheme uri)
  557. ((http)
  558. ;; Exit gracefully if there's no network access.
  559. (let ((host (uri-host uri)))
  560. (catch 'getaddrinfo-error
  561. (lambda ()
  562. (getaddrinfo host))
  563. (lambda (key error)
  564. (warning (_ "failed to look up host '~a' (~a), \
  565. substituter disabled~%")
  566. host (gai-strerror error))
  567. (exit 0)))))
  568. (else #t)))
  569. ;; Say hello (see above.)
  570. (newline)
  571. (force-output (current-output-port))
  572. (with-networking
  573. (with-error-handling ; for signature errors
  574. (match args
  575. (("--query")
  576. (let ((cache (delay (open-cache %cache-url)))
  577. (acl (current-acl)))
  578. (define (valid? obj)
  579. (and (narinfo? obj) (valid-narinfo? obj acl)))
  580. (let loop ((command (read-line)))
  581. (or (eof-object? command)
  582. (begin
  583. (match (string-tokenize command)
  584. (("have" paths ..1)
  585. ;; Return the subset of PATHS available in CACHE.
  586. (let ((substitutable
  587. (if cache
  588. (n-par-map* %lookup-threads
  589. (cut lookup-narinfo cache <>)
  590. paths)
  591. '())))
  592. (for-each (lambda (narinfo)
  593. (format #t "~a~%" (narinfo-path narinfo)))
  594. (filter valid? substitutable))
  595. (newline)))
  596. (("info" paths ..1)
  597. ;; Reply info about PATHS if it's in CACHE.
  598. (let ((substitutable
  599. (if cache
  600. (n-par-map* %lookup-threads
  601. (cut lookup-narinfo cache <>)
  602. paths)
  603. '())))
  604. (for-each (lambda (narinfo)
  605. (format #t "~a\n~a\n~a\n"
  606. (narinfo-path narinfo)
  607. (or (and=> (narinfo-deriver narinfo)
  608. (cute string-append
  609. (%store-prefix) "/"
  610. <>))
  611. "")
  612. (length (narinfo-references narinfo)))
  613. (for-each (cute format #t "~a/~a~%"
  614. (%store-prefix) <>)
  615. (narinfo-references narinfo))
  616. (format #t "~a\n~a\n"
  617. (or (narinfo-file-size narinfo) 0)
  618. (or (narinfo-size narinfo) 0)))
  619. (filter valid? substitutable))
  620. (newline)))
  621. (wtf
  622. (error "unknown `--query' command" wtf)))
  623. (loop (read-line)))))))
  624. (("--substitute" store-path destination)
  625. ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
  626. (let* ((cache (delay (open-cache %cache-url)))
  627. (narinfo (lookup-narinfo cache store-path))
  628. (uri (narinfo-uri narinfo)))
  629. ;; Make sure it is signed and everything.
  630. (assert-valid-narinfo narinfo)
  631. ;; Tell the daemon what the expected hash of the Nar itself is.
  632. (format #t "~a~%" (narinfo-hash narinfo))
  633. (format (current-error-port) "downloading `~a' from `~a'~:[~*~; (~,1f MiB installed)~]...~%"
  634. store-path (uri->string uri)
  635. ;; Use the Nar size as an estimate of the installed size.
  636. (narinfo-size narinfo)
  637. (and=> (narinfo-size narinfo)
  638. (cute / <> (expt 2. 20))))
  639. (let*-values (((raw download-size)
  640. ;; Note that Hydra currently generates Nars on the fly
  641. ;; and doesn't specify a Content-Length, so
  642. ;; DOWNLOAD-SIZE is #f in practice.
  643. (fetch uri #:buffered? #f #:timeout? #f))
  644. ((progress)
  645. (let* ((comp (narinfo-compression narinfo))
  646. (dl-size (or download-size
  647. (and (equal? comp "none")
  648. (narinfo-size narinfo))))
  649. (progress (progress-proc (uri-abbreviation uri)
  650. dl-size
  651. (current-error-port))))
  652. (progress-report-port progress raw)))
  653. ((input pids)
  654. (decompressed-port (and=> (narinfo-compression narinfo)
  655. string->symbol)
  656. progress)))
  657. ;; Unpack the Nar at INPUT into DESTINATION.
  658. (restore-file input destination)
  659. (every (compose zero? cdr waitpid) pids))))
  660. (("--version")
  661. (show-version-and-exit "guix substitute-binary"))
  662. (("--help")
  663. (show-help))
  664. (opts
  665. (leave (_ "~a: unrecognized options~%") opts))))))
  666. ;;; Local Variables:
  667. ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
  668. ;;; End:
  669. ;;; substitute-binary.scm ends here