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.
 
 
 
 
 
 

764 lines
26 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013 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 utils)
  20. #:use-module (guix config)
  21. #:use-module (rnrs bytevectors)
  22. #:use-module (rnrs io ports)
  23. #:use-module (srfi srfi-1)
  24. #:use-module (srfi srfi-9)
  25. #:use-module (srfi srfi-26)
  26. #:use-module (srfi srfi-34)
  27. #:use-module (srfi srfi-35)
  28. #:use-module (srfi srfi-39)
  29. #:use-module (ice-9 match)
  30. #:use-module (ice-9 rdelim)
  31. #:use-module (ice-9 ftw)
  32. #:use-module (ice-9 regex)
  33. #:export (%daemon-socket-file
  34. nix-server?
  35. nix-server-major-version
  36. nix-server-minor-version
  37. nix-server-socket
  38. &nix-error nix-error?
  39. &nix-connection-error nix-connection-error?
  40. nix-connection-error-file
  41. nix-connection-error-code
  42. &nix-protocol-error nix-protocol-error?
  43. nix-protocol-error-message
  44. nix-protocol-error-status
  45. hash-algo
  46. open-connection
  47. close-connection
  48. set-build-options
  49. valid-path?
  50. query-path-hash
  51. add-text-to-store
  52. add-to-store
  53. build-derivations
  54. add-temp-root
  55. add-indirect-root
  56. substitutable?
  57. substitutable-path
  58. substitutable-deriver
  59. substitutable-references
  60. substitutable-download-size
  61. substitutable-nar-size
  62. has-substitutes?
  63. substitutable-paths
  64. substitutable-path-info
  65. references
  66. referrers
  67. valid-derivers
  68. query-derivation-outputs
  69. live-paths
  70. dead-paths
  71. collect-garbage
  72. delete-paths
  73. current-build-output-port
  74. %store-prefix
  75. store-path?
  76. derivation-path?
  77. store-path-package-name
  78. store-path-hash-part))
  79. (define %protocol-version #x10c)
  80. (define %worker-magic-1 #x6e697863)
  81. (define %worker-magic-2 #x6478696f)
  82. (define (protocol-major magic)
  83. (logand magic #xff00))
  84. (define (protocol-minor magic)
  85. (logand magic #x00ff))
  86. (define-syntax define-enumerate-type
  87. (syntax-rules ()
  88. ((_ name->int (name id) ...)
  89. (define-syntax name->int
  90. (syntax-rules (name ...)
  91. ((_ name) id) ...)))))
  92. (define-enumerate-type operation-id
  93. ;; operation numbers from worker-protocol.hh
  94. (quit 0)
  95. (valid-path? 1)
  96. (has-substitutes? 3)
  97. (query-path-hash 4)
  98. (query-references 5)
  99. (query-referrers 6)
  100. (add-to-store 7)
  101. (add-text-to-store 8)
  102. (build-derivations 9)
  103. (ensure-path 10)
  104. (add-temp-root 11)
  105. (add-indirect-root 12)
  106. (sync-with-gc 13)
  107. (find-roots 14)
  108. (export-path 16)
  109. (query-deriver 18)
  110. (set-options 19)
  111. (collect-garbage 20)
  112. ;;(query-substitutable-path-info 21) ; obsolete as of #x10c
  113. (query-derivation-outputs 22)
  114. (query-all-valid-paths 23)
  115. (query-failed-paths 24)
  116. (clear-failed-paths 25)
  117. (query-path-info 26)
  118. (import-paths 27)
  119. (query-derivation-output-names 28)
  120. (query-path-from-hash-part 29)
  121. (query-substitutable-path-infos 30)
  122. (query-valid-paths 31)
  123. (query-substitutable-paths 32)
  124. (query-valid-derivers 33))
  125. (define-enumerate-type hash-algo
  126. ;; hash.hh
  127. (md5 1)
  128. (sha1 2)
  129. (sha256 3))
  130. (define-enumerate-type gc-action
  131. ;; store-api.hh
  132. (return-live 0)
  133. (return-dead 1)
  134. (delete-dead 2)
  135. (delete-specific 3))
  136. (define %default-socket-path
  137. (string-append (or (getenv "NIX_STATE_DIR") %state-directory)
  138. "/daemon-socket/socket"))
  139. (define %daemon-socket-file
  140. ;; File name of the socket the daemon listens too.
  141. (make-parameter (or (getenv "GUIX_DAEMON_SOCKET")
  142. %default-socket-path)))
  143. ;; serialize.cc
  144. (define (write-int n p)
  145. (let ((b (make-bytevector 8 0)))
  146. (bytevector-u32-set! b 0 n (endianness little))
  147. (put-bytevector p b)))
  148. (define (read-int p)
  149. (let ((b (get-bytevector-n p 8)))
  150. (bytevector-u32-ref b 0 (endianness little))))
  151. (define (write-long-long n p)
  152. (let ((b (make-bytevector 8 0)))
  153. (bytevector-u64-set! b 0 n (endianness little))
  154. (put-bytevector p b)))
  155. (define (read-long-long p)
  156. (let ((b (get-bytevector-n p 8)))
  157. (bytevector-u64-ref b 0 (endianness little))))
  158. (define write-padding
  159. (let ((zero (make-bytevector 8 0)))
  160. (lambda (n p)
  161. (let ((m (modulo n 8)))
  162. (or (zero? m)
  163. (put-bytevector p zero 0 (- 8 m)))))))
  164. (define (write-string s p)
  165. (let* ((s (string->utf8 s))
  166. (l (bytevector-length s))
  167. (m (modulo l 8))
  168. (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
  169. (bytevector-u32-set! b 0 l (endianness little))
  170. (bytevector-copy! s 0 b 8 l)
  171. (put-bytevector p b)))
  172. (define (read-string p)
  173. (let* ((len (read-int p))
  174. (m (modulo len 8))
  175. (bv (get-bytevector-n p len))
  176. (str (utf8->string bv)))
  177. (or (zero? m)
  178. (get-bytevector-n p (- 8 m)))
  179. str))
  180. (define (read-latin1-string p)
  181. (let* ((len (read-int p))
  182. (m (modulo len 8))
  183. (str (get-string-n p len)))
  184. (or (zero? m)
  185. (get-bytevector-n p (- 8 m)))
  186. str))
  187. (define (write-string-list l p)
  188. (write-int (length l) p)
  189. (for-each (cut write-string <> p) l))
  190. (define (read-string-list p)
  191. (let ((len (read-int p)))
  192. (unfold (cut >= <> len)
  193. (lambda (i)
  194. (read-string p))
  195. 1+
  196. 0)))
  197. (define (write-store-path f p)
  198. (write-string f p)) ; TODO: assert path
  199. (define (read-store-path p)
  200. (read-string p)) ; TODO: assert path
  201. (define write-store-path-list write-string-list)
  202. (define read-store-path-list read-string-list)
  203. (define (write-contents file p size)
  204. "Write SIZE bytes from FILE to output port P."
  205. (define (call-with-binary-input-file file proc)
  206. ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus
  207. ;; avoids any initial buffering. Disable file name canonicalization to
  208. ;; avoid stat'ing like crazy.
  209. (with-fluids ((%file-port-name-canonicalization #f))
  210. (let ((port (open-file file "rb")))
  211. (catch #t (cut proc port)
  212. (lambda args
  213. (close-port port)
  214. (apply throw args))))))
  215. (define (dump in size)
  216. (define buf-size 65536)
  217. (define buf (make-bytevector buf-size))
  218. (let loop ((left size))
  219. (if (<= left 0)
  220. 0
  221. (let ((read (get-bytevector-n! in buf 0 buf-size)))
  222. (if (eof-object? read)
  223. left
  224. (begin
  225. (put-bytevector p buf 0 read)
  226. (loop (- left read))))))))
  227. (write-string "contents" p)
  228. (write-long-long size p)
  229. (call-with-binary-input-file file
  230. ;; Use `sendfile' when available (Guile 2.0.8+).
  231. (if (compile-time-value (defined? 'sendfile))
  232. (cut sendfile p <> size 0)
  233. (cut dump <> size)))
  234. (write-padding size p))
  235. (define (write-file f p)
  236. (define %archive-version-1 "nix-archive-1")
  237. (write-string %archive-version-1 p)
  238. (let dump ((f f))
  239. (let ((s (lstat f)))
  240. (write-string "(" p)
  241. (case (stat:type s)
  242. ((regular)
  243. (write-string "type" p)
  244. (write-string "regular" p)
  245. (if (not (zero? (logand (stat:mode s) #o100)))
  246. (begin
  247. (write-string "executable" p)
  248. (write-string "" p)))
  249. (write-contents f p (stat:size s)))
  250. ((directory)
  251. (write-string "type" p)
  252. (write-string "directory" p)
  253. (let ((entries (remove (cut member <> '("." ".."))
  254. (scandir f))))
  255. (for-each (lambda (e)
  256. (let ((f (string-append f "/" e)))
  257. (write-string "entry" p)
  258. (write-string "(" p)
  259. (write-string "name" p)
  260. (write-string e p)
  261. (write-string "node" p)
  262. (dump f)
  263. (write-string ")" p)))
  264. entries)))
  265. (else
  266. (error "ENOSYS")))
  267. (write-string ")" p))))
  268. ;; Information about a substitutable store path.
  269. (define-record-type <substitutable>
  270. (substitutable path deriver refs dl-size nar-size)
  271. substitutable?
  272. (path substitutable-path)
  273. (deriver substitutable-deriver)
  274. (refs substitutable-references)
  275. (dl-size substitutable-download-size)
  276. (nar-size substitutable-nar-size))
  277. (define (read-substitutable-path-list p)
  278. (let loop ((len (read-int p))
  279. (result '()))
  280. (if (zero? len)
  281. (reverse result)
  282. (let ((path (read-store-path p))
  283. (deriver (read-store-path p))
  284. (refs (read-store-path-list p))
  285. (dl-size (read-long-long p))
  286. (nar-size (read-long-long p)))
  287. (loop (- len 1)
  288. (cons (substitutable path deriver refs dl-size nar-size)
  289. result))))))
  290. (define-syntax write-arg
  291. (syntax-rules (integer boolean file string string-list
  292. store-path store-path-list base16)
  293. ((_ integer arg p)
  294. (write-int arg p))
  295. ((_ boolean arg p)
  296. (write-int (if arg 1 0) p))
  297. ((_ file arg p)
  298. (write-file arg p))
  299. ((_ string arg p)
  300. (write-string arg p))
  301. ((_ string-list arg p)
  302. (write-string-list arg p))
  303. ((_ store-path arg p)
  304. (write-store-path arg p))
  305. ((_ store-path-list arg p)
  306. (write-store-path-list arg p))
  307. ((_ base16 arg p)
  308. (write-string (bytevector->base16-string arg) p))))
  309. (define-syntax read-arg
  310. (syntax-rules (integer boolean string store-path store-path-list
  311. substitutable-path-list base16)
  312. ((_ integer p)
  313. (read-int p))
  314. ((_ boolean p)
  315. (not (zero? (read-int p))))
  316. ((_ string p)
  317. (read-string p))
  318. ((_ store-path p)
  319. (read-store-path p))
  320. ((_ store-path-list p)
  321. (read-store-path-list p))
  322. ((_ substitutable-path-list p)
  323. (read-substitutable-path-list p))
  324. ((_ base16 p)
  325. (base16-string->bytevector (read-string p)))))
  326. ;; remote-store.cc
  327. (define-record-type <nix-server>
  328. (%make-nix-server socket major minor
  329. ats-cache atts-cache)
  330. nix-server?
  331. (socket nix-server-socket)
  332. (major nix-server-major-version)
  333. (minor nix-server-minor-version)
  334. ;; Caches. We keep them per-connection, because store paths build
  335. ;; during the session are temporary GC roots kept for the duration of
  336. ;; the session.
  337. (ats-cache nix-server-add-to-store-cache)
  338. (atts-cache nix-server-add-text-to-store-cache))
  339. (define-condition-type &nix-error &error
  340. nix-error?)
  341. (define-condition-type &nix-connection-error &nix-error
  342. nix-connection-error?
  343. (file nix-connection-error-file)
  344. (errno nix-connection-error-code))
  345. (define-condition-type &nix-protocol-error &nix-error
  346. nix-protocol-error?
  347. (message nix-protocol-error-message)
  348. (status nix-protocol-error-status))
  349. (define* (open-connection #:optional (file (%daemon-socket-file))
  350. #:key (reserve-space? #t))
  351. "Connect to the daemon over the Unix-domain socket at FILE. When
  352. RESERVE-SPACE? is true, instruct it to reserve a little bit of extra
  353. space on the file system so that the garbage collector can still
  354. operate, should the disk become full. Return a server object."
  355. (let ((s (with-fluids ((%default-port-encoding #f))
  356. ;; This trick allows use of the `scm_c_read' optimization.
  357. (socket PF_UNIX SOCK_STREAM 0)))
  358. (a (make-socket-address PF_UNIX file)))
  359. ;; Enlarge the receive buffer.
  360. (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
  361. (catch 'system-error
  362. (cut connect s a)
  363. (lambda args
  364. ;; Translate the error to something user-friendly.
  365. (let ((errno (system-error-errno args)))
  366. (raise (condition (&nix-connection-error
  367. (file file)
  368. (errno errno)))))))
  369. (write-int %worker-magic-1 s)
  370. (let ((r (read-int s)))
  371. (and (eqv? r %worker-magic-2)
  372. (let ((v (read-int s)))
  373. (and (eqv? (protocol-major %protocol-version)
  374. (protocol-major v))
  375. (begin
  376. (write-int %protocol-version s)
  377. (if (>= (protocol-minor v) 11)
  378. (write-int (if reserve-space? 1 0) s))
  379. (let ((s (%make-nix-server s
  380. (protocol-major v)
  381. (protocol-minor v)
  382. (make-hash-table 100)
  383. (make-hash-table 100))))
  384. (let loop ((done? (process-stderr s)))
  385. (or done? (process-stderr s)))
  386. s))))))))
  387. (define (close-connection server)
  388. "Close the connection to SERVER."
  389. (close (nix-server-socket server)))
  390. (define current-build-output-port
  391. ;; The port where build output is sent.
  392. (make-parameter (current-error-port)))
  393. (define (process-stderr server)
  394. "Read standard output and standard error from SERVER, writing it to
  395. CURRENT-BUILD-OUTPUT-PORT. Return #t when SERVER is done sending data, and
  396. #f otherwise; in the latter case, the caller should call `process-stderr'
  397. again until #t is returned or an error is raised.
  398. Since the build process's output cannot be assumed to be UTF-8, we
  399. conservatively consider it to be Latin-1, thereby avoiding possible
  400. encoding conversion errors."
  401. (define p
  402. (nix-server-socket server))
  403. ;; magic cookies from worker-protocol.hh
  404. (define %stderr-next #x6f6c6d67)
  405. (define %stderr-read #x64617461) ; data needed from source
  406. (define %stderr-write #x64617416) ; data for sink
  407. (define %stderr-last #x616c7473)
  408. (define %stderr-error #x63787470)
  409. (let ((k (read-int p)))
  410. (cond ((= k %stderr-write)
  411. (read-latin1-string p)
  412. #f)
  413. ((= k %stderr-read)
  414. (let ((len (read-int p)))
  415. (read-latin1-string p) ; FIXME: what to do?
  416. #f))
  417. ((= k %stderr-next)
  418. (let ((s (read-latin1-string p)))
  419. (display s (current-build-output-port))
  420. #f))
  421. ((= k %stderr-error)
  422. (let ((error (read-latin1-string p))
  423. (status (if (>= (nix-server-minor-version server) 8)
  424. (read-int p)
  425. 1)))
  426. (raise (condition (&nix-protocol-error
  427. (message error)
  428. (status status))))))
  429. ((= k %stderr-last)
  430. ;; The daemon is done (see `stopWork' in `nix-worker.cc'.)
  431. #t)
  432. (else
  433. (raise (condition (&nix-protocol-error
  434. (message "invalid error code")
  435. (status k))))))))
  436. (define* (set-build-options server
  437. #:key keep-failed? keep-going? try-fallback?
  438. (verbosity 0)
  439. (max-build-jobs (current-processor-count))
  440. (max-silent-time 3600)
  441. (use-build-hook? #t)
  442. (build-verbosity 0)
  443. (log-type 0)
  444. (print-build-trace #t)
  445. (build-cores 1)
  446. (use-substitutes? #t)
  447. (binary-caches '())) ; client "untrusted" cache URLs
  448. ;; Must be called after `open-connection'.
  449. (define socket
  450. (nix-server-socket server))
  451. (let-syntax ((send (syntax-rules ()
  452. ((_ (type option) ...)
  453. (begin
  454. (write-arg type option socket)
  455. ...)))))
  456. (write-int (operation-id set-options) socket)
  457. (send (boolean keep-failed?) (boolean keep-going?)
  458. (boolean try-fallback?) (integer verbosity)
  459. (integer max-build-jobs) (integer max-silent-time))
  460. (if (>= (nix-server-minor-version server) 2)
  461. (send (boolean use-build-hook?)))
  462. (if (>= (nix-server-minor-version server) 4)
  463. (send (integer build-verbosity) (integer log-type)
  464. (boolean print-build-trace)))
  465. (if (>= (nix-server-minor-version server) 6)
  466. (send (integer build-cores)))
  467. (if (>= (nix-server-minor-version server) 10)
  468. (send (boolean use-substitutes?)))
  469. (if (>= (nix-server-minor-version server) 12)
  470. (send (string-list (fold-right (lambda (pair result)
  471. (match pair
  472. ((h . t)
  473. (cons* h t result))))
  474. '()
  475. binary-caches))))
  476. (let loop ((done? (process-stderr server)))
  477. (or done? (process-stderr server)))))
  478. (define-syntax operation
  479. (syntax-rules ()
  480. "Define a client-side RPC stub for the given operation."
  481. ((_ (name (type arg) ...) docstring return ...)
  482. (lambda (server arg ...)
  483. docstring
  484. (let ((s (nix-server-socket server)))
  485. (write-int (operation-id name) s)
  486. (write-arg type arg s)
  487. ...
  488. ;; Loop until the server is done sending error output.
  489. (let loop ((done? (process-stderr server)))
  490. (or done? (loop (process-stderr server))))
  491. (values (read-arg return s) ...))))))
  492. (define-syntax-rule (define-operation (name args ...)
  493. docstring return ...)
  494. (define name
  495. (operation (name args ...) docstring return ...)))
  496. (define-operation (valid-path? (string path))
  497. "Return #t when PATH is a valid store path."
  498. boolean)
  499. (define-operation (query-path-hash (store-path path))
  500. "Return the SHA256 hash of PATH as a bytevector."
  501. base16)
  502. (define add-text-to-store
  503. ;; A memoizing version of `add-to-store', to avoid repeated RPCs with
  504. ;; the very same arguments during a given session.
  505. (let ((add-text-to-store
  506. (operation (add-text-to-store (string name) (string text)
  507. (string-list references))
  508. #f
  509. store-path)))
  510. (lambda (server name text references)
  511. "Add TEXT under file NAME in the store, and return its store path.
  512. REFERENCES is the list of store paths referred to by the resulting store
  513. path."
  514. (let ((args `(,text ,name ,references))
  515. (cache (nix-server-add-text-to-store-cache server)))
  516. (or (hash-ref cache args)
  517. (let ((path (add-text-to-store server name text references)))
  518. (hash-set! cache args path)
  519. path))))))
  520. (define add-to-store
  521. ;; A memoizing version of `add-to-store'. This is important because
  522. ;; `add-to-store' leads to huge data transfers to the server, and
  523. ;; because it's often called many times with the very same argument.
  524. (let ((add-to-store (operation (add-to-store (string basename)
  525. (boolean fixed?) ; obsolete, must be #t
  526. (boolean recursive?)
  527. (string hash-algo)
  528. (file file-name))
  529. #f
  530. store-path)))
  531. (lambda (server basename recursive? hash-algo file-name)
  532. "Add the contents of FILE-NAME under BASENAME to the store. When
  533. RECURSIVE? is true and FILE-NAME designates a directory, the contents of
  534. FILE-NAME are added recursively; if FILE-NAME designates a flat file and
  535. RECURSIVE? is true, its contents are added, and its permission bits are
  536. kept. HASH-ALGO must be a string such as \"sha256\"."
  537. (let* ((st (stat file-name #f))
  538. (args `(,st ,basename ,recursive? ,hash-algo))
  539. (cache (nix-server-add-to-store-cache server)))
  540. (or (and st (hash-ref cache args))
  541. (let ((path (add-to-store server basename #t recursive?
  542. hash-algo file-name)))
  543. (hash-set! cache args path)
  544. path))))))
  545. (define-operation (build-derivations (string-list derivations))
  546. "Build DERIVATIONS, and return when the worker is done building them.
  547. Return #t on success."
  548. boolean)
  549. (define-operation (add-temp-root (store-path path))
  550. "Make PATH a temporary root for the duration of the current session.
  551. Return #t."
  552. boolean)
  553. (define-operation (add-indirect-root (string file-name))
  554. "Make FILE-NAME an indirect root for the garbage collector; FILE-NAME
  555. can be anywhere on the file system, but it must be an absolute file
  556. name--it is the caller's responsibility to ensure that it is an absolute
  557. file name. Return #t on success."
  558. boolean)
  559. (define references
  560. (operation (query-references (store-path path))
  561. "Return the list of references of PATH."
  562. store-path-list))
  563. (define referrers
  564. (operation (query-referrers (store-path path))
  565. "Return the list of path that refer to PATH."
  566. store-path-list))
  567. (define valid-derivers
  568. (operation (query-valid-derivers (store-path path))
  569. "Return the list of valid \"derivers\" of PATH---i.e., all the
  570. .drv present in the store that have PATH among their outputs."
  571. store-path-list))
  572. (define query-derivation-outputs ; avoid name clash with `derivation-outputs'
  573. (operation (query-derivation-outputs (store-path path))
  574. "Return the list of outputs of PATH, a .drv file."
  575. store-path-list))
  576. (define-operation (has-substitutes? (store-path path))
  577. "Return #t if binary substitutes are available for PATH, and #f otherwise."
  578. boolean)
  579. (define substitutable-paths
  580. (operation (query-substitutable-paths (store-path-list paths))
  581. "Return the subset of PATHS that is substitutable."
  582. store-path-list))
  583. (define substitutable-path-info
  584. (operation (query-substitutable-path-infos (store-path-list paths))
  585. "Return information about the subset of PATHS that is
  586. substitutable. For each substitutable path, a `substitutable?' object is
  587. returned."
  588. substitutable-path-list))
  589. (define (run-gc server action to-delete min-freed)
  590. "Perform the garbage-collector operation ACTION, one of the
  591. `gc-action' values. When ACTION is `delete-specific', the TO-DELETE is
  592. the list of store paths to delete. IGNORE-LIVENESS? should always be
  593. #f. MIN-FREED is the minimum amount of disk space to be freed, in
  594. bytes, before the GC can stop. Return the list of store paths delete,
  595. and the number of bytes freed."
  596. (let ((s (nix-server-socket server)))
  597. (write-int (operation-id collect-garbage) s)
  598. (write-int action s)
  599. (write-store-path-list to-delete s)
  600. (write-arg boolean #f s) ; ignore-liveness?
  601. (write-long-long min-freed s)
  602. (write-int 0 s) ; obsolete
  603. (when (>= (nix-server-minor-version server) 5)
  604. ;; Obsolete `use-atime' and `max-atime' parameters.
  605. (write-int 0 s)
  606. (write-int 0 s))
  607. ;; Loop until the server is done sending error output.
  608. (let loop ((done? (process-stderr server)))
  609. (or done? (loop (process-stderr server))))
  610. (let ((paths (read-store-path-list s))
  611. (freed (read-long-long s))
  612. (obsolete (read-long-long s)))
  613. (values paths freed))))
  614. (define-syntax-rule (%long-long-max)
  615. ;; Maximum unsigned 64-bit integer.
  616. (- (expt 2 64) 1))
  617. (define (live-paths server)
  618. "Return the list of live store paths---i.e., store paths still
  619. referenced, and thus not subject to being garbage-collected."
  620. (run-gc server (gc-action return-live) '() (%long-long-max)))
  621. (define (dead-paths server)
  622. "Return the list of dead store paths---i.e., store paths no longer
  623. referenced, and thus subject to being garbage-collected."
  624. (run-gc server (gc-action return-dead) '() (%long-long-max)))
  625. (define* (collect-garbage server #:optional (min-freed (%long-long-max)))
  626. "Collect garbage from the store at SERVER. If MIN-FREED is non-zero,
  627. then collect at least MIN-FREED bytes. Return the paths that were
  628. collected, and the number of bytes freed."
  629. (run-gc server (gc-action delete-dead) '() min-freed))
  630. (define* (delete-paths server paths #:optional (min-freed (%long-long-max)))
  631. "Delete PATHS from the store at SERVER, if they are no longer
  632. referenced. If MIN-FREED is non-zero, then stop after at least
  633. MIN-FREED bytes have been collected. Return the paths that were
  634. collected, and the number of bytes freed."
  635. (run-gc server (gc-action delete-specific) paths min-freed))
  636. ;;;
  637. ;;; Store paths.
  638. ;;;
  639. (define %store-prefix
  640. ;; Absolute path to the Nix store.
  641. (make-parameter (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
  642. %store-directory)))
  643. (define (store-path? path)
  644. "Return #t if PATH is a store path."
  645. ;; This is a lightweight check, compared to using a regexp, but this has to
  646. ;; be fast as it's called often in `derivation', for instance.
  647. ;; `isStorePath' in Nix does something similar.
  648. (string-prefix? (%store-prefix) path))
  649. (define (derivation-path? path)
  650. "Return #t if PATH is a derivation path."
  651. (and (store-path? path) (string-suffix? ".drv" path)))
  652. (define (store-path-package-name path)
  653. "Return the package name part of PATH, a file name in the store."
  654. (define store-path-rx
  655. (make-regexp (string-append "^.*" (regexp-quote (%store-prefix))
  656. "/[^-]+-(.+)$")))
  657. (and=> (regexp-exec store-path-rx path)
  658. (cut match:substring <> 1)))
  659. (define (store-path-hash-part path)
  660. "Return the hash part of PATH as a base32 string, or #f if PATH is not a
  661. syntactically valid store path."
  662. (let ((path-rx (make-regexp
  663. (string-append"^" (regexp-quote (%store-prefix))
  664. "/([0-9a-df-np-sv-z]{32})-[^/]+$"))))
  665. (and=> (regexp-exec path-rx path)
  666. (cut match:substring <> 1))))