guix/store.scm

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