guix/store.scm

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