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.
 
 
 
 
 
 

901 lines
33 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix store)
  19. #:use-module (guix nar)
  20. #:use-module (guix utils)
  21. #:use-module (guix config)
  22. #:use-module (guix serialization)
  23. #:autoload (guix base32) (bytevector->base32-string)
  24. #:use-module (rnrs bytevectors)
  25. #:use-module (rnrs io ports)
  26. #:use-module (srfi srfi-1)
  27. #:use-module (srfi srfi-9)
  28. #:use-module (srfi srfi-9 gnu)
  29. #:use-module (srfi srfi-26)
  30. #:use-module (srfi srfi-34)
  31. #:use-module (srfi srfi-35)
  32. #:use-module (srfi srfi-39)
  33. #:use-module (ice-9 match)
  34. #:use-module (ice-9 regex)
  35. #:use-module (ice-9 vlist)
  36. #:use-module (ice-9 popen)
  37. #:export (%daemon-socket-file
  38. %gc-roots-directory
  39. nix-server?
  40. nix-server-major-version
  41. nix-server-minor-version
  42. nix-server-socket
  43. &nix-error nix-error?
  44. &nix-connection-error nix-connection-error?
  45. nix-connection-error-file
  46. nix-connection-error-code
  47. &nix-protocol-error nix-protocol-error?
  48. nix-protocol-error-message
  49. nix-protocol-error-status
  50. hash-algo
  51. open-connection
  52. close-connection
  53. with-store
  54. set-build-options
  55. valid-path?
  56. query-path-hash
  57. hash-part->path
  58. add-text-to-store
  59. add-to-store
  60. build-derivations
  61. add-temp-root
  62. add-indirect-root
  63. add-permanent-root
  64. remove-permanent-root
  65. substitutable?
  66. substitutable-path
  67. substitutable-deriver
  68. substitutable-references
  69. substitutable-download-size
  70. substitutable-nar-size
  71. has-substitutes?
  72. substitutable-paths
  73. substitutable-path-info
  74. references
  75. requisites
  76. referrers
  77. topologically-sorted
  78. valid-derivers
  79. query-derivation-outputs
  80. live-paths
  81. dead-paths
  82. collect-garbage
  83. delete-paths
  84. import-paths
  85. export-paths
  86. current-build-output-port
  87. register-path
  88. %store-prefix
  89. store-path?
  90. direct-store-path?
  91. derivation-path?
  92. store-path-package-name
  93. store-path-hash-part
  94. log-file))
  95. (define %protocol-version #x10c)
  96. (define %worker-magic-1 #x6e697863) ; "nixc"
  97. (define %worker-magic-2 #x6478696f) ; "dxio"
  98. (define (protocol-major magic)
  99. (logand magic #xff00))
  100. (define (protocol-minor magic)
  101. (logand magic #x00ff))
  102. (define-syntax define-enumerate-type
  103. (syntax-rules ()
  104. ((_ name->int (name id) ...)
  105. (define-syntax name->int
  106. (syntax-rules (name ...)
  107. ((_ name) id) ...)))))
  108. (define-enumerate-type operation-id
  109. ;; operation numbers from worker-protocol.hh
  110. (quit 0)
  111. (valid-path? 1)
  112. (has-substitutes? 3)
  113. (query-path-hash 4)
  114. (query-references 5)
  115. (query-referrers 6)
  116. (add-to-store 7)
  117. (add-text-to-store 8)
  118. (build-derivations 9)
  119. (ensure-path 10)
  120. (add-temp-root 11)
  121. (add-indirect-root 12)
  122. (sync-with-gc 13)
  123. (find-roots 14)
  124. (export-path 16)
  125. (query-deriver 18)
  126. (set-options 19)
  127. (collect-garbage 20)
  128. ;;(query-substitutable-path-info 21) ; obsolete as of #x10c
  129. (query-derivation-outputs 22)
  130. (query-all-valid-paths 23)
  131. (query-failed-paths 24)
  132. (clear-failed-paths 25)
  133. (query-path-info 26)
  134. (import-paths 27)
  135. (query-derivation-output-names 28)
  136. (query-path-from-hash-part 29)
  137. (query-substitutable-path-infos 30)
  138. (query-valid-paths 31)
  139. (query-substitutable-paths 32)
  140. (query-valid-derivers 33))
  141. (define-enumerate-type hash-algo
  142. ;; hash.hh
  143. (md5 1)
  144. (sha1 2)
  145. (sha256 3))
  146. (define-enumerate-type gc-action
  147. ;; store-api.hh
  148. (return-live 0)
  149. (return-dead 1)
  150. (delete-dead 2)
  151. (delete-specific 3))
  152. (define %default-socket-path
  153. (string-append %state-directory "/daemon-socket/socket"))
  154. (define %daemon-socket-file
  155. ;; File name of the socket the daemon listens too.
  156. (make-parameter (or (getenv "GUIX_DAEMON_SOCKET")
  157. %default-socket-path)))
  158. ;; Information about a substitutable store path.
  159. (define-record-type <substitutable>
  160. (substitutable path deriver refs dl-size nar-size)
  161. substitutable?
  162. (path substitutable-path)
  163. (deriver substitutable-deriver)
  164. (refs substitutable-references)
  165. (dl-size substitutable-download-size)
  166. (nar-size substitutable-nar-size))
  167. (define (read-substitutable-path-list p)
  168. (let loop ((len (read-int p))
  169. (result '()))
  170. (if (zero? len)
  171. (reverse result)
  172. (let ((path (read-store-path p))
  173. (deriver (read-store-path p))
  174. (refs (read-store-path-list p))
  175. (dl-size (read-long-long p))
  176. (nar-size (read-long-long p)))
  177. (loop (- len 1)
  178. (cons (substitutable path deriver refs dl-size nar-size)
  179. result))))))
  180. (define-syntax write-arg
  181. (syntax-rules (integer boolean file string string-list string-pairs
  182. store-path store-path-list base16)
  183. ((_ integer arg p)
  184. (write-int arg p))
  185. ((_ boolean arg p)
  186. (write-int (if arg 1 0) p))
  187. ((_ file arg p)
  188. (write-file arg p))
  189. ((_ string arg p)
  190. (write-string arg p))
  191. ((_ string-list arg p)
  192. (write-string-list arg p))
  193. ((_ string-pairs arg p)
  194. (write-string-pairs arg p))
  195. ((_ store-path arg p)
  196. (write-store-path arg p))
  197. ((_ store-path-list arg p)
  198. (write-store-path-list arg p))
  199. ((_ base16 arg p)
  200. (write-string (bytevector->base16-string arg) p))))
  201. (define-syntax read-arg
  202. (syntax-rules (integer boolean string store-path store-path-list
  203. substitutable-path-list base16)
  204. ((_ integer p)
  205. (read-int p))
  206. ((_ boolean p)
  207. (not (zero? (read-int p))))
  208. ((_ string p)
  209. (read-string p))
  210. ((_ store-path p)
  211. (read-store-path p))
  212. ((_ store-path-list p)
  213. (read-store-path-list p))
  214. ((_ substitutable-path-list p)
  215. (read-substitutable-path-list p))
  216. ((_ base16 p)
  217. (base16-string->bytevector (read-string p)))))
  218. ;; remote-store.cc
  219. (define-record-type <nix-server>
  220. (%make-nix-server socket major minor
  221. ats-cache atts-cache)
  222. nix-server?
  223. (socket nix-server-socket)
  224. (major nix-server-major-version)
  225. (minor nix-server-minor-version)
  226. ;; Caches. We keep them per-connection, because store paths build
  227. ;; during the session are temporary GC roots kept for the duration of
  228. ;; the session.
  229. (ats-cache nix-server-add-to-store-cache)
  230. (atts-cache nix-server-add-text-to-store-cache))
  231. (set-record-type-printer! <nix-server>
  232. (lambda (obj port)
  233. (format port "#<build-daemon ~a.~a ~a>"
  234. (nix-server-major-version obj)
  235. (nix-server-minor-version obj)
  236. (number->string (object-address obj)
  237. 16))))
  238. (define-condition-type &nix-error &error
  239. nix-error?)
  240. (define-condition-type &nix-connection-error &nix-error
  241. nix-connection-error?
  242. (file nix-connection-error-file)
  243. (errno nix-connection-error-code))
  244. (define-condition-type &nix-protocol-error &nix-error
  245. nix-protocol-error?
  246. (message nix-protocol-error-message)
  247. (status nix-protocol-error-status))
  248. (define* (open-connection #:optional (file (%daemon-socket-file))
  249. #:key (reserve-space? #t))
  250. "Connect to the daemon over the Unix-domain socket at FILE. When
  251. RESERVE-SPACE? is true, instruct it to reserve a little bit of extra
  252. space on the file system so that the garbage collector can still
  253. operate, should the disk become full. Return a server object."
  254. (let ((s (with-fluids ((%default-port-encoding #f))
  255. ;; This trick allows use of the `scm_c_read' optimization.
  256. (socket PF_UNIX SOCK_STREAM 0)))
  257. (a (make-socket-address PF_UNIX file)))
  258. (catch 'system-error
  259. (cut connect s a)
  260. (lambda args
  261. ;; Translate the error to something user-friendly.
  262. (let ((errno (system-error-errno args)))
  263. (raise (condition (&nix-connection-error
  264. (file file)
  265. (errno errno)))))))
  266. (write-int %worker-magic-1 s)
  267. (let ((r (read-int s)))
  268. (and (eqv? r %worker-magic-2)
  269. (let ((v (read-int s)))
  270. (and (eqv? (protocol-major %protocol-version)
  271. (protocol-major v))
  272. (begin
  273. (write-int %protocol-version s)
  274. (if (>= (protocol-minor v) 11)
  275. (write-int (if reserve-space? 1 0) s))
  276. (let ((s (%make-nix-server s
  277. (protocol-major v)
  278. (protocol-minor v)
  279. (make-hash-table 100)
  280. (make-hash-table 100))))
  281. (let loop ((done? (process-stderr s)))
  282. (or done? (process-stderr s)))
  283. s))))))))
  284. (define (close-connection server)
  285. "Close the connection to SERVER."
  286. (close (nix-server-socket server)))
  287. (define-syntax-rule (with-store store exp ...)
  288. "Bind STORE to an open connection to the store and evaluate EXPs;
  289. automatically close the store when the dynamic extent of EXP is left."
  290. (let ((store (open-connection)))
  291. (dynamic-wind
  292. (const #f)
  293. (lambda ()
  294. exp ...)
  295. (lambda ()
  296. (false-if-exception (close-connection store))))))
  297. (define current-build-output-port
  298. ;; The port where build output is sent.
  299. (make-parameter (current-error-port)))
  300. (define* (dump-port in out
  301. #:optional len
  302. #:key (buffer-size 16384))
  303. "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it
  304. to OUT, using chunks of BUFFER-SIZE bytes."
  305. (define buffer
  306. (make-bytevector buffer-size))
  307. (let loop ((total 0)
  308. (bytes (get-bytevector-n! in buffer 0
  309. (if len
  310. (min len buffer-size)
  311. buffer-size))))
  312. (or (eof-object? bytes)
  313. (and len (= total len))
  314. (let ((total (+ total bytes)))
  315. (put-bytevector out buffer 0 bytes)
  316. (loop total
  317. (get-bytevector-n! in buffer 0
  318. (if len
  319. (min (- len total) buffer-size)
  320. buffer-size)))))))
  321. (define %newlines
  322. ;; Newline characters triggering a flush of 'current-build-output-port'.
  323. ;; Unlike Guile's _IOLBF, we flush upon #\return so that progress reports
  324. ;; that use that trick are correctly displayed.
  325. (char-set #\newline #\return))
  326. (define* (process-stderr server #:optional user-port)
  327. "Read standard output and standard error from SERVER, writing it to
  328. CURRENT-BUILD-OUTPUT-PORT. Return #t when SERVER is done sending data, and
  329. #f otherwise; in the latter case, the caller should call `process-stderr'
  330. again until #t is returned or an error is raised.
  331. Since the build process's output cannot be assumed to be UTF-8, we
  332. conservatively consider it to be Latin-1, thereby avoiding possible
  333. encoding conversion errors."
  334. (define p
  335. (nix-server-socket server))
  336. ;; magic cookies from worker-protocol.hh
  337. (define %stderr-next #x6f6c6d67) ; "olmg", build log
  338. (define %stderr-read #x64617461) ; "data", data needed from source
  339. (define %stderr-write #x64617416) ; "dat\x16", data for sink
  340. (define %stderr-last #x616c7473) ; "alts", we're done
  341. (define %stderr-error #x63787470) ; "cxtp", error reporting
  342. (let ((k (read-int p)))
  343. (cond ((= k %stderr-write)
  344. ;; Write a byte stream to USER-PORT.
  345. (let* ((len (read-int p))
  346. (m (modulo len 8)))
  347. (dump-port p user-port len)
  348. (unless (zero? m)
  349. ;; Consume padding, as for strings.
  350. (get-bytevector-n p (- 8 m))))
  351. #f)
  352. ((= k %stderr-read)
  353. ;; Read a byte stream from USER-PORT.
  354. ;; Note: Avoid 'get-bytevector-n' to work around
  355. ;; <http://bugs.gnu.org/17591> in Guile up to 2.0.11.
  356. (let* ((max-len (read-int p))
  357. (data (make-bytevector max-len))
  358. (len (get-bytevector-n! user-port data 0 max-len)))
  359. (write-int len p)
  360. (put-bytevector p data 0 len)
  361. (write-padding len p)
  362. #f))
  363. ((= k %stderr-next)
  364. ;; Log a string.
  365. (let ((s (read-latin1-string p)))
  366. (display s (current-build-output-port))
  367. (when (string-any %newlines s)
  368. (flush-output-port (current-build-output-port)))
  369. #f))
  370. ((= k %stderr-error)
  371. ;; Report an error.
  372. (let ((error (read-latin1-string p))
  373. ;; Currently the daemon fails to send a status code for early
  374. ;; errors like DB schema version mismatches, so check for EOF.
  375. (status (if (and (>= (nix-server-minor-version server) 8)
  376. (not (eof-object? (lookahead-u8 p))))
  377. (read-int p)
  378. 1)))
  379. (raise (condition (&nix-protocol-error
  380. (message error)
  381. (status status))))))
  382. ((= k %stderr-last)
  383. ;; The daemon is done (see `stopWork' in `nix-worker.cc'.)
  384. #t)
  385. (else
  386. (raise (condition (&nix-protocol-error
  387. (message "invalid error code")
  388. (status k))))))))
  389. (define* (set-build-options server
  390. #:key keep-failed? keep-going? fallback?
  391. (verbosity 0)
  392. (max-build-jobs (current-processor-count))
  393. timeout
  394. (max-silent-time 3600)
  395. (use-build-hook? #t)
  396. (build-verbosity 0)
  397. (log-type 0)
  398. (print-build-trace #t)
  399. (build-cores 1)
  400. (use-substitutes? #t)
  401. (binary-caches '())) ; client "untrusted" cache URLs
  402. ;; Must be called after `open-connection'.
  403. (define socket
  404. (nix-server-socket server))
  405. (let-syntax ((send (syntax-rules ()
  406. ((_ (type option) ...)
  407. (begin
  408. (write-arg type option socket)
  409. ...)))))
  410. (write-int (operation-id set-options) socket)
  411. (send (boolean keep-failed?) (boolean keep-going?)
  412. (boolean fallback?) (integer verbosity)
  413. (integer max-build-jobs) (integer max-silent-time))
  414. (when (>= (nix-server-minor-version server) 2)
  415. (send (boolean use-build-hook?)))
  416. (when (>= (nix-server-minor-version server) 4)
  417. (send (integer build-verbosity) (integer log-type)
  418. (boolean print-build-trace)))
  419. (when (>= (nix-server-minor-version server) 6)
  420. (send (integer build-cores)))
  421. (when (>= (nix-server-minor-version server) 10)
  422. (send (boolean use-substitutes?)))
  423. (when (>= (nix-server-minor-version server) 12)
  424. (let ((pairs (if timeout
  425. `(("build-timeout" . ,(number->string timeout))
  426. ,@binary-caches)
  427. binary-caches)))
  428. (send (string-pairs pairs))))
  429. (let loop ((done? (process-stderr server)))
  430. (or done? (process-stderr server)))))
  431. (define-syntax operation
  432. (syntax-rules ()
  433. "Define a client-side RPC stub for the given operation."
  434. ((_ (name (type arg) ...) docstring return ...)
  435. (lambda (server arg ...)
  436. docstring
  437. (let ((s (nix-server-socket server)))
  438. (write-int (operation-id name) s)
  439. (write-arg type arg s)
  440. ...
  441. ;; Loop until the server is done sending error output.
  442. (let loop ((done? (process-stderr server)))
  443. (or done? (loop (process-stderr server))))
  444. (values (read-arg return s) ...))))))
  445. (define-syntax-rule (define-operation (name args ...)
  446. docstring return ...)
  447. (define name
  448. (operation (name args ...) docstring return ...)))
  449. (define-operation (valid-path? (string path))
  450. "Return #t when PATH is a valid store path."
  451. boolean)
  452. (define-operation (query-path-hash (store-path path))
  453. "Return the SHA256 hash of PATH as a bytevector."
  454. base16)
  455. (define hash-part->path
  456. (let ((query-path-from-hash-part
  457. (operation (query-path-from-hash-part (string hash))
  458. #f
  459. store-path)))
  460. (lambda (server hash-part)
  461. "Return the store path whose hash part is HASH-PART (a nix-base32
  462. string). Raise an error if no such path exists."
  463. ;; This RPC is primarily used by Hydra to reply to HTTP GETs of
  464. ;; /HASH.narinfo.
  465. (query-path-from-hash-part server hash-part))))
  466. (define add-text-to-store
  467. ;; A memoizing version of `add-to-store', to avoid repeated RPCs with
  468. ;; the very same arguments during a given session.
  469. (let ((add-text-to-store
  470. (operation (add-text-to-store (string name) (string text)
  471. (string-list references))
  472. #f
  473. store-path)))
  474. (lambda* (server name text #:optional (references '()))
  475. "Add TEXT under file NAME in the store, and return its store path.
  476. REFERENCES is the list of store paths referred to by the resulting store
  477. path."
  478. (let ((args `(,text ,name ,references))
  479. (cache (nix-server-add-text-to-store-cache server)))
  480. (or (hash-ref cache args)
  481. (let ((path (add-text-to-store server name text references)))
  482. (hash-set! cache args path)
  483. path))))))
  484. (define add-to-store
  485. ;; A memoizing version of `add-to-store'. This is important because
  486. ;; `add-to-store' leads to huge data transfers to the server, and
  487. ;; because it's often called many times with the very same argument.
  488. (let ((add-to-store (operation (add-to-store (string basename)
  489. (boolean fixed?) ; obsolete, must be #t
  490. (boolean recursive?)
  491. (string hash-algo)
  492. (file file-name))
  493. #f
  494. store-path)))
  495. (lambda (server basename recursive? hash-algo file-name)
  496. "Add the contents of FILE-NAME under BASENAME to the store. When
  497. RECURSIVE? is true and FILE-NAME designates a directory, the contents of
  498. FILE-NAME are added recursively; if FILE-NAME designates a flat file and
  499. RECURSIVE? is true, its contents are added, and its permission bits are
  500. kept. HASH-ALGO must be a string such as \"sha256\"."
  501. (let* ((st (stat file-name #f))
  502. (args `(,st ,basename ,recursive? ,hash-algo))
  503. (cache (nix-server-add-to-store-cache server)))
  504. (or (and st (hash-ref cache args))
  505. (let ((path (add-to-store server basename #t recursive?
  506. hash-algo file-name)))
  507. (hash-set! cache args path)
  508. path))))))
  509. (define-operation (build-derivations (string-list derivations))
  510. "Build DERIVATIONS, and return when the worker is done building them.
  511. Return #t on success."
  512. boolean)
  513. (define-operation (add-temp-root (store-path path))
  514. "Make PATH a temporary root for the duration of the current session.
  515. Return #t."
  516. boolean)
  517. (define-operation (add-indirect-root (string file-name))
  518. "Make the symlink FILE-NAME an indirect root for the garbage collector:
  519. whatever store item FILE-NAME points to will not be collected. Return #t on
  520. success.
  521. FILE-NAME can be anywhere on the file system, but it must be an absolute file
  522. name--it is the caller's responsibility to ensure that it is an absolute file
  523. name."
  524. boolean)
  525. (define %gc-roots-directory
  526. ;; The place where garbage collector roots (symlinks) are kept.
  527. (string-append %state-directory "/gcroots"))
  528. (define (add-permanent-root target)
  529. "Add a garbage collector root pointing to TARGET, an element of the store,
  530. preventing TARGET from even being collected. This can also be used if TARGET
  531. does not exist yet.
  532. Raise an error if the caller does not have write access to the GC root
  533. directory."
  534. (let* ((root (string-append %gc-roots-directory "/" (basename target))))
  535. (catch 'system-error
  536. (lambda ()
  537. (symlink target root))
  538. (lambda args
  539. ;; If ROOT already exists, this is fine; otherwise, re-throw.
  540. (unless (= EEXIST (system-error-errno args))
  541. (apply throw args))))))
  542. (define (remove-permanent-root target)
  543. "Remove the permanent garbage collector root pointing to TARGET. Raise an
  544. error if there is no such root."
  545. (delete-file (string-append %gc-roots-directory "/" (basename target))))
  546. (define references
  547. (operation (query-references (store-path path))
  548. "Return the list of references of PATH."
  549. store-path-list))
  550. (define* (fold-path store proc seed path
  551. #:optional (relatives (cut references store <>)))
  552. "Call PROC for each of the RELATIVES of PATH, exactly once, and return the
  553. result formed from the successive calls to PROC, the first of which is passed
  554. SEED."
  555. (let loop ((paths (list path))
  556. (result seed)
  557. (seen vlist-null))
  558. (match paths
  559. ((path rest ...)
  560. (if (vhash-assoc path seen)
  561. (loop rest result seen)
  562. (let ((seen (vhash-cons path #t seen))
  563. (rest (append rest (relatives path)))
  564. (result (proc path result)))
  565. (loop rest result seen))))
  566. (()
  567. result))))
  568. (define (requisites store path)
  569. "Return the requisites of PATH, including PATH---i.e., its closure (all its
  570. references, recursively)."
  571. (fold-path store cons '() path))
  572. (define (topologically-sorted store paths)
  573. "Return a list containing PATHS and all their references sorted in
  574. topological order."
  575. (define (traverse)
  576. ;; Do a simple depth-first traversal of all of PATHS.
  577. (let loop ((paths paths)
  578. (visited vlist-null)
  579. (result '()))
  580. (define (visit n)
  581. (vhash-cons n #t visited))
  582. (define (visited? n)
  583. (vhash-assoc n visited))
  584. (match paths
  585. ((head tail ...)
  586. (if (visited? head)
  587. (loop tail visited result)
  588. (call-with-values
  589. (lambda ()
  590. (loop (references store head)
  591. (visit head)
  592. result))
  593. (lambda (visited result)
  594. (loop tail
  595. visited
  596. (cons head result))))))
  597. (()
  598. (values visited result)))))
  599. (call-with-values traverse
  600. (lambda (_ result)
  601. (reverse result))))
  602. (define referrers
  603. (operation (query-referrers (store-path path))
  604. "Return the list of path that refer to PATH."
  605. store-path-list))
  606. (define valid-derivers
  607. (operation (query-valid-derivers (store-path path))
  608. "Return the list of valid \"derivers\" of PATH---i.e., all the
  609. .drv present in the store that have PATH among their outputs."
  610. store-path-list))
  611. (define query-derivation-outputs ; avoid name clash with `derivation-outputs'
  612. (operation (query-derivation-outputs (store-path path))
  613. "Return the list of outputs of PATH, a .drv file."
  614. store-path-list))
  615. (define-operation (has-substitutes? (store-path path))
  616. "Return #t if binary substitutes are available for PATH, and #f otherwise."
  617. boolean)
  618. (define substitutable-paths
  619. (operation (query-substitutable-paths (store-path-list paths))
  620. "Return the subset of PATHS that is substitutable."
  621. store-path-list))
  622. (define substitutable-path-info
  623. (operation (query-substitutable-path-infos (store-path-list paths))
  624. "Return information about the subset of PATHS that is
  625. substitutable. For each substitutable path, a `substitutable?' object is
  626. returned."
  627. substitutable-path-list))
  628. (define (run-gc server action to-delete min-freed)
  629. "Perform the garbage-collector operation ACTION, one of the
  630. `gc-action' values. When ACTION is `delete-specific', the TO-DELETE is
  631. the list of store paths to delete. IGNORE-LIVENESS? should always be
  632. #f. MIN-FREED is the minimum amount of disk space to be freed, in
  633. bytes, before the GC can stop. Return the list of store paths delete,
  634. and the number of bytes freed."
  635. (let ((s (nix-server-socket server)))
  636. (write-int (operation-id collect-garbage) s)
  637. (write-int action s)
  638. (write-store-path-list to-delete s)
  639. (write-arg boolean #f s) ; ignore-liveness?
  640. (write-long-long min-freed s)
  641. (write-int 0 s) ; obsolete
  642. (when (>= (nix-server-minor-version server) 5)
  643. ;; Obsolete `use-atime' and `max-atime' parameters.
  644. (write-int 0 s)
  645. (write-int 0 s))
  646. ;; Loop until the server is done sending error output.
  647. (let loop ((done? (process-stderr server)))
  648. (or done? (loop (process-stderr server))))
  649. (let ((paths (read-store-path-list s))
  650. (freed (read-long-long s))
  651. (obsolete (read-long-long s)))
  652. (values paths freed))))
  653. (define-syntax-rule (%long-long-max)
  654. ;; Maximum unsigned 64-bit integer.
  655. (- (expt 2 64) 1))
  656. (define (live-paths server)
  657. "Return the list of live store paths---i.e., store paths still
  658. referenced, and thus not subject to being garbage-collected."
  659. (run-gc server (gc-action return-live) '() (%long-long-max)))
  660. (define (dead-paths server)
  661. "Return the list of dead store paths---i.e., store paths no longer
  662. referenced, and thus subject to being garbage-collected."
  663. (run-gc server (gc-action return-dead) '() (%long-long-max)))
  664. (define* (collect-garbage server #:optional (min-freed (%long-long-max)))
  665. "Collect garbage from the store at SERVER. If MIN-FREED is non-zero,
  666. then collect at least MIN-FREED bytes. Return the paths that were
  667. collected, and the number of bytes freed."
  668. (run-gc server (gc-action delete-dead) '() min-freed))
  669. (define* (delete-paths server paths #:optional (min-freed (%long-long-max)))
  670. "Delete PATHS from the store at SERVER, if they are no longer
  671. referenced. If MIN-FREED is non-zero, then stop after at least
  672. MIN-FREED bytes have been collected. Return the paths that were
  673. collected, and the number of bytes freed."
  674. (run-gc server (gc-action delete-specific) paths min-freed))
  675. (define (import-paths server port)
  676. "Import the set of store paths read from PORT into SERVER's store. An error
  677. is raised if the set of paths read from PORT is not signed (as per
  678. 'export-path #:sign? #t'.) Return the list of store paths imported."
  679. (let ((s (nix-server-socket server)))
  680. (write-int (operation-id import-paths) s)
  681. (let loop ((done? (process-stderr server port)))
  682. (or done? (loop (process-stderr server port))))
  683. (read-store-path-list s)))
  684. (define* (export-path server path port #:key (sign? #t))
  685. "Export PATH to PORT. When SIGN? is true, sign it."
  686. (let ((s (nix-server-socket server)))
  687. (write-int (operation-id export-path) s)
  688. (write-store-path path s)
  689. (write-arg boolean sign? s)
  690. (let loop ((done? (process-stderr server port)))
  691. (or done? (loop (process-stderr server port))))
  692. (= 1 (read-int s))))
  693. (define* (export-paths server paths port #:key (sign? #t))
  694. "Export the store paths listed in PATHS to PORT, in topological order,
  695. signing them if SIGN? is true."
  696. (define ordered
  697. ;; Sort PATHS, but don't include their references.
  698. (filter (cut member <> paths)
  699. (topologically-sorted server paths)))
  700. (let ((s (nix-server-socket server)))
  701. (let loop ((paths ordered))
  702. (match paths
  703. (()
  704. (write-int 0 port))
  705. ((head tail ...)
  706. (write-int 1 port)
  707. (and (export-path server head port #:sign? sign?)
  708. (loop tail)))))))
  709. (define* (register-path path
  710. #:key (references '()) deriver prefix
  711. state-directory)
  712. "Register PATH as a valid store file, with REFERENCES as its list of
  713. references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
  714. not #f, it must be the name of the directory containing the new store to
  715. initialize; if STATE-DIRECTORY is not #f, it must be a string containing the
  716. absolute file name to the state directory of the store being initialized.
  717. Return #t on success.
  718. Use with care as it directly modifies the store! This is primarily meant to
  719. be used internally by the daemon's build hook."
  720. ;; Currently this is implemented by calling out to the fine C++ blob.
  721. (catch 'system-error
  722. (lambda ()
  723. (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program
  724. `(,@(if prefix
  725. `("--prefix" ,prefix)
  726. '())
  727. ,@(if state-directory
  728. `("--state-directory" ,state-directory)
  729. '())))))
  730. (and pipe
  731. (begin
  732. (format pipe "~a~%~a~%~a~%"
  733. path (or deriver "") (length references))
  734. (for-each (cut format pipe "~a~%" <>) references)
  735. (zero? (close-pipe pipe))))))
  736. (lambda args
  737. ;; Failed to run %GUIX-REGISTER-PROGRAM.
  738. #f)))
  739. ;;;
  740. ;;; Store paths.
  741. ;;;
  742. (define %store-prefix
  743. ;; Absolute path to the Nix store.
  744. (make-parameter %store-directory))
  745. (define (store-path? path)
  746. "Return #t if PATH is a store path."
  747. ;; This is a lightweight check, compared to using a regexp, but this has to
  748. ;; be fast as it's called often in `derivation', for instance.
  749. ;; `isStorePath' in Nix does something similar.
  750. (string-prefix? (%store-prefix) path))
  751. (define (direct-store-path? path)
  752. "Return #t if PATH is a store path, and not a sub-directory of a store path.
  753. This predicate is sometimes needed because files *under* a store path are not
  754. valid inputs."
  755. (and (store-path? path)
  756. (not (string=? path (%store-prefix)))
  757. (let ((len (+ 1 (string-length (%store-prefix)))))
  758. (not (string-index (substring path len) #\/)))))
  759. (define (derivation-path? path)
  760. "Return #t if PATH is a derivation path."
  761. (and (store-path? path) (string-suffix? ".drv" path)))
  762. (define store-regexp*
  763. ;; The substituter makes repeated calls to 'store-path-hash-part', hence
  764. ;; this optimization.
  765. (memoize
  766. (lambda (store)
  767. "Return a regexp matching a file in STORE."
  768. (make-regexp (string-append "^" (regexp-quote store)
  769. "/([0-9a-df-np-sv-z]{32})-([^/]+)$")))))
  770. (define (store-path-package-name path)
  771. "Return the package name part of PATH, a file name in the store."
  772. (let ((path-rx (store-regexp* (%store-prefix))))
  773. (and=> (regexp-exec path-rx path)
  774. (cut match:substring <> 2))))
  775. (define (store-path-hash-part path)
  776. "Return the hash part of PATH as a base32 string, or #f if PATH is not a
  777. syntactically valid store path."
  778. (let ((path-rx (store-regexp* (%store-prefix))))
  779. (and=> (regexp-exec path-rx path)
  780. (cut match:substring <> 1))))
  781. (define (log-file store file)
  782. "Return the build log file for FILE, or #f if none could be found. FILE
  783. must be an absolute store file name, or a derivation file name."
  784. (cond ((derivation-path? file)
  785. (let* ((base (basename file))
  786. (log (string-append (dirname %state-directory) ; XXX
  787. "/log/guix/drvs/"
  788. (string-take base 2) "/"
  789. (string-drop base 2)))
  790. (log.bz2 (string-append log ".bz2")))
  791. (cond ((file-exists? log.bz2) log.bz2)
  792. ((file-exists? log) log)
  793. (else #f))))
  794. (else
  795. (match (valid-derivers store file)
  796. ((derivers ...)
  797. ;; Return the first that works.
  798. (any (cut log-file store <>) derivers))
  799. (_ #f)))))