guix.scm

   1 ;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
   2 ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of Guix.
   5 ;;;
   6 ;;; 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 ;;; 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 Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix)
  20   #:use-module (rnrs bytevectors)
  21   #:use-module (rnrs io ports)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-9)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 rdelim)
  27   #:export (nix-server?
  28             nix-server-major-version
  29             nix-server-minor-version
  30             nix-server-socket
  31
  32             open-connection
  33             set-build-options
  34             add-text-to-store
  35             add-to-store))
  36
  37 (define %protocol-version #x109)
  38
  39 (define %worker-magic-1 #x6e697863)
  40 (define %worker-magic-2 #x6478696f)
  41
  42 (define (protocol-major magic)
  43   (logand magic #xff00))
  44 (define (protocol-minor magic)
  45   (logand magic #x00ff))
  46
  47 (define-syntax define-enumerate-type
  48   (syntax-rules ()
  49     ((_ name->int (name id) ...)
  50      (define-syntax name->int
  51        (syntax-rules (name ...)
  52          ((_ name) id) ...)))))
  53
  54 (define-enumerate-type operation-id
  55   ;; operation numbers from worker-protocol.hh
  56   (quit 0)
  57   (valid-path? 1)
  58   (has-substitutes? 3)
  59   (query-path-hash 4)
  60   (query-references 5)
  61   (query-referrers 6)
  62   (add-to-store 7)
  63   (add-text-to-store 8)
  64   (build-derivations 9)
  65   (ensure-path 10)
  66   (add-temp-root 11)
  67   (add-indirect-root 12)
  68   (sync-with-gc 13)
  69   (find-roots 14)
  70   (export-path 16)
  71   (query-deriver 18)
  72   (set-options 19)
  73   (collect-garbage 20)
  74   (query-substitutable-path-info 21)
  75   (query-derivation-outputs 22)
  76   (query-valid-paths 23)
  77   (query-failed-paths 24)
  78   (clear-failed-paths 25)
  79   (query-path-info 26)
  80   (import-paths 27)
  81   (query-derivation-output-names 28))
  82
  83 (define-enumerate-type hash-algo
  84   ;; hash.hh
  85   (md5 1)
  86   (sha1 2)
  87   (sha256 3))
  88
  89 (define %nix-state-dir "/nix/var/nix")
  90 (define %default-socket-path
  91   (string-append %nix-state-dir "/daemon-socket/socket"))
  92
  93 \f
  94 ;; serialize.cc
  95
  96 (define (write-int n p)
  97   (let ((b (make-bytevector 8 0)))
  98     (bytevector-u32-set! b 0 n (endianness little))
  99     (put-bytevector p b)))
 100
 101 (define (read-int p)
 102   (let ((b (get-bytevector-n p 8)))
 103     (bytevector-u32-ref b 0 (endianness little))))
 104
 105 (define (write-long-long n p)
 106   (let ((b (make-bytevector 8 0)))
 107     (bytevector-u64-set! b 0 n (endianness little))
 108     (put-bytevector p b)))
 109
 110 (define write-padding
 111   (let ((zero (make-bytevector 8 0)))
 112     (lambda (n p)
 113       (let ((m (modulo n 8)))
 114         (or (zero? m)
 115             (put-bytevector p zero 0 (- 8 m)))))))
 116
 117 (define (write-string s p)
 118   (let ((b (string->utf8 s)))
 119     (write-int (bytevector-length b) p)
 120     (put-bytevector p b)
 121     (write-padding (bytevector-length b) p)))
 122
 123 (define (read-string p)
 124   (let* ((len (read-int p))
 125          (m   (modulo len 8))
 126          (bv  (get-bytevector-n p len))
 127          (str (utf8->string bv)))
 128     (or (zero? m)
 129         (get-bytevector-n p (- 8 m)))
 130     str))
 131
 132 (define (write-string-list l p)
 133   (write-int (length l) p)
 134   (for-each (cut write-string <> p) l))
 135
 136 (define (read-store-path p)
 137   (read-string p))                                ; TODO: assert path
 138
 139 (define (write-contents file p)
 140   "Write the contents of FILE to output port P."
 141   (define (dump in size)
 142     (define buf-size 65536)
 143     (define buf (make-bytevector buf-size))
 144
 145     (let loop ((left size))
 146       (if (<= left 0)
 147           0
 148           (let ((read (get-bytevector-n! in buf 0 buf-size)))
 149             (if (eof-object? read)
 150                 left
 151                 (begin
 152                   (put-bytevector p buf 0 read)
 153                   (loop (- left read))))))))
 154
 155   (let ((size (stat:size (lstat file))))
 156     (write-string "contents" p)
 157     (write-long-long size p)
 158     (call-with-input-file file
 159       (lambda (p)
 160         (dump p size)))
 161     (write-padding size p)))
 162
 163 (define (write-file f p)
 164   (define %archive-version-1 "nix-archive-1")
 165
 166   (let ((s (lstat f)))
 167     (write-string %archive-version-1 p)
 168     (write-string "(" p)
 169     (case (stat:type s)
 170       ((regular)
 171        (write-string "type" p)
 172        (write-string "regular" p)
 173        (if (not (zero? (logand (stat:mode s) #o100)))
 174            (begin
 175              (write-string "executable" p)
 176              (write-string "" p)))
 177        (write-contents f p)
 178        (write-string ")" p))
 179       ((directory)
 180        (write-string "type" p)
 181        (write-string "directory" p)
 182        (error "ENOSYS"))
 183       (else
 184        (error "ENOSYS")))))
 185
 186 (define-syntax write-arg
 187   (syntax-rules (integer boolean file string string-list)
 188     ((_ integer arg p)
 189      (write-int arg p))
 190     ((_ boolean arg p)
 191      (write-int (if arg 1 0) p))
 192     ((_ file arg p)
 193      (write-file arg p))
 194     ((_ string arg p)
 195      (write-string arg p))
 196     ((_ string-list arg p)
 197      (write-string-list arg p))))
 198
 199 (define-syntax read-arg
 200   (syntax-rules (integer boolean string store-path)
 201     ((_ integer p)
 202      (read-int p))
 203     ((_ boolean p)
 204      (not (zero? (read-int p))))
 205     ((_ string p)
 206      (read-string p))
 207     ((_ store-path p)
 208      (read-store-path p))))
 209
 210 \f
 211 ;; remote-store.cc
 212
 213 (define-record-type <nix-server>
 214   (%make-nix-server socket major minor)
 215   nix-server?
 216   (socket nix-server-socket)
 217   (major  nix-server-major-version)
 218   (minor  nix-server-minor-version))
 219
 220 (define* (open-connection #:optional (file %default-socket-path))
 221   (let ((s (with-fluids ((%default-port-encoding #f))
 222              ;; This trick allows use of the `scm_c_read' optimization.
 223              (socket PF_UNIX SOCK_STREAM 0)))
 224         (a (make-socket-address PF_UNIX file)))
 225     (connect s a)
 226     (write-int %worker-magic-1 s)
 227     (let ((r (read-int s)))
 228       (and (eqv? r %worker-magic-2)
 229            (let ((v (read-int s)))
 230              (and (eqv? (protocol-major %protocol-version)
 231                         (protocol-major v))
 232                   (begin
 233                     (write-int %protocol-version s)
 234                     (let ((s (%make-nix-server s
 235                                                (protocol-major v)
 236                                                (protocol-minor v))))
 237                       (process-stderr s)
 238                       s))))))))
 239
 240 (define (process-stderr server)
 241   (define p
 242     (nix-server-socket server))
 243
 244   ;; magic cookies from worker-protocol.hh
 245   (define %stderr-next  #x6f6c6d67)
 246   (define %stderr-read  #x64617461)               ; data needed from source
 247   (define %stderr-write #x64617416)               ; data for sink
 248   (define %stderr-last  #x616c7473)
 249   (define %stderr-error #x63787470)
 250
 251   (let ((k (read-int p)))
 252     (cond ((= k %stderr-write)
 253            (read-string p))
 254           ((= k %stderr-read)
 255            (let ((len (read-int p)))
 256              (read-string p)                      ; FIXME: what to do?
 257              ))
 258           ((= k %stderr-next)
 259            (let ((s (read-string p)))
 260              (display s (current-error-port))
 261              s))
 262           ((= k %stderr-error)
 263            (let ((error  (read-string p))
 264                  (status (if (>= (nix-server-minor-version server) 8)
 265                              (read-int p)
 266                              1)))
 267              (format (current-error-port) "error: ~a (status: ~a)~%"
 268                      error status)
 269              error))
 270           ((= k %stderr-last)
 271            #t)
 272           (else
 273            (error "invalid standard error code" k)))))
 274
 275 (define* (set-build-options server
 276                             #:key keep-failed? keep-going? try-fallback?
 277                             (verbosity 0)
 278                             (max-build-jobs (current-processor-count))
 279                             (max-silent-time 3600)
 280                             (use-build-hook? #t)
 281                             (build-verbosity 0)
 282                             (log-type 0)
 283                             (print-build-trace #t))
 284   ;; Must be called after `open-connection'.
 285
 286   (define socket
 287     (nix-server-socket server))
 288
 289   (let-syntax ((send (syntax-rules ()
 290                        ((_ option ...)
 291                         (for-each (lambda (i)
 292                                     (cond ((boolean? i)
 293                                            (write-int (if i 1 0) socket))
 294                                           ((integer? i)
 295                                            (write-int i socket))
 296                                           (else
 297                                            (error "invalid build option"
 298                                                   i))))
 299                                   (list option ...))))))
 300     (send (operation-id set-options)
 301           keep-failed? keep-going? try-fallback? verbosity
 302           max-build-jobs max-silent-time)
 303     (if (>= (nix-server-minor-version server) 2)
 304         (send use-build-hook?))
 305     (if (>= (nix-server-minor-version server) 4)
 306         (send build-verbosity log-type print-build-trace))
 307     (process-stderr server)))
 308
 309 (define-syntax define-operation
 310   (syntax-rules ()
 311     ((_ (name (type arg) ...) docstring return)
 312      (define (name server arg ...)
 313        docstring
 314        (let ((s (nix-server-socket server)))
 315          (write-int (operation-id name) s)
 316          (write-arg type arg s)
 317          ...
 318          (process-stderr server)
 319          (read-arg return s))))))
 320
 321 (define-operation (add-text-to-store (string name) (string text)
 322                                      (string-list references))
 323   "Add TEXT under file NAME in the store."
 324   store-path)
 325
 326 (define-operation (add-to-store (string basename)
 327                                 (integer algo)
 328                                 (boolean sha256-and-recursive?)
 329                                 (boolean recursive?)
 330                                 (file file-name))
 331   "Add the contents of FILE-NAME under BASENAME to the store."
 332   store-path)
 333
 334 (define-operation (build-derivations (string-list derivations))
 335   "Build DERIVATIONS; return #t on success."
 336   boolean)
 337
 338 \f
 339 ;; derivations
 340
 341 (define-record-type <derivation>
 342   (make-derivation outputs inputs sources system builder args env-vars)
 343   derivation?
 344   (outputs  derivation-outputs)      ; list of name/<derivation-output> pairs
 345   (inputs   derivation-inputs)       ; list of <derivation-input>
 346   (sources  derivation-sources)      ; list of store paths
 347   (system   derivation-system)       ; string
 348   (builder  derivation-builder)      ; store path
 349   (args     derivation-builder-arguments)         ; list of strings
 350   (env-vars derivation-builder-environment-vars)) ; list of name/value pairs
 351
 352 (define-record-type <derivation-output>
 353   (make-derivation-output path hash-algo hash)
 354   derivation-output?
 355   (path       derivation-output-path)             ; store path
 356   (hash-algo  derivation-output-hash-algo)        ; symbol | #f
 357   (hash       derivation-output-hash))            ; symbol | #f
 358
 359 (define-record-type <derivation-input>
 360   (make-derivation-input path sub-derivations)
 361   derivation-input?
 362   (path            derivation-input-path)             ; store path
 363   (sub-derivations derivation-input-sub-derivations)) ; list of strings
 364
 365 (define (fixed-output-derivation? drv)
 366   "Return #t if DRV is a fixed-output derivation, such as the result of a
 367 download with a fixed hash (aka. `fetchurl')."
 368   (match drv
 369     (($ <derivation>
 370         (($ <derivation-output> _ (? symbol?) (? string?))))
 371      #t)
 372     (_ #f)))
 373
 374 (define (read-derivation drv-port)
 375   "Read the derivation from DRV-PORT and return the corresponding
 376 <derivation> object."
 377
 378   (define comma (string->symbol ","))
 379
 380   (define (ununquote x)
 381     (match x
 382       (('unquote x) (ununquote x))
 383       ((x ...)      (map ununquote x))
 384       (_            x)))
 385
 386   (define (outputs->alist x)
 387     (fold-right (lambda (output result)
 388                   (match output
 389                     ((name path "" "")
 390                      (alist-cons name
 391                                  (make-derivation-output path #f #f)
 392                                  result))
 393                     ((name path hash-algo hash)
 394                      ;; fixed-output
 395                      (let ((algo (string->symbol hash-algo)))
 396                        (alist-cons name
 397                                    (make-derivation-output path algo hash)
 398                                    result)))))
 399                 '()
 400                 x))
 401
 402   (define (make-input-drvs x)
 403     (fold-right (lambda (input result)
 404                   (match input
 405                     ((path (sub-drvs ...))
 406                      (cons (make-derivation-input path sub-drvs)
 407                            result))))
 408                 '()
 409                 x))
 410
 411   (let loop ((exp    (read drv-port))
 412              (result '()))
 413     (match exp
 414       ((? eof-object?)
 415        (let ((result (reverse result)))
 416          (match result
 417            (('Derive ((outputs ...) (input-drvs ...)
 418                       (input-srcs ...)
 419                       (? string? system)
 420                       (? string? builder)
 421                       ((? string? args) ...)
 422                       ((var value) ...)))
 423             (make-derivation (outputs->alist outputs)
 424                              (make-input-drvs input-drvs)
 425                              input-srcs
 426                              system builder args
 427                              (fold-right alist-cons '() var value)))
 428            (_
 429             (error "failed to parse derivation" drv-port result)))))
 430       ((? (cut eq? <> comma))
 431        (loop (read drv-port) result))
 432       (_
 433        (loop (read drv-port)
 434              (cons (ununquote exp) result))))))
 435
 436 (define (write-derivation drv port)
 437   "Write the ATerm-like serialization of DRV to PORT."
 438   (define (list->string lst)
 439     (string-append "[" (string-join lst ",") "]"))
 440
 441   (define (write-list lst)
 442     (display (list->string lst) port))
 443
 444   (match drv
 445     (($ <derivation> outputs inputs sources
 446         system builder args env-vars)
 447      (display "Derive(" port)
 448      (write-list (map (match-lambda
 449                        ((name . ($ <derivation-output> path hash-algo hash))
 450                         (format #f "(~s,~s,~s,~s)"
 451                                 name path (or hash-algo "")
 452                                 (or hash ""))))
 453                       outputs))
 454      (display "," port)
 455      (write-list (map (match-lambda
 456                        (($ <derivation-input> path sub-drvs)
 457                         (format #f "(~s,~a)" path
 458                                 (list->string (map object->string sub-drvs)))))
 459                       inputs))
 460      (display "," port)
 461      (write-list sources)
 462      (format port ",~s,~s," system builder)
 463      (write-list (map object->string args))
 464      (display "," port)
 465      (write-list (map (match-lambda
 466                        ((name . value)
 467                         (format #f "(~s,~s)" name value)))
 468                       env-vars))
 469      (display ")" port))))
 470
 471 (define (sha256 bv)
 472   "Return the SHA256 of BV as an string of hexadecimal digits."
 473   ;; XXX: Poor programmer's implementation that uses Coreutils.
 474   (let ((in  (pipe))
 475         (out (pipe))
 476         (pid (primitive-fork)))
 477     (if (= 0 pid)
 478         (begin                                      ; child
 479           (close (cdr in))
 480           (close (car out))
 481           (close 0)
 482           (close 1)
 483           (dup2 (fileno (car in)) 0)
 484           (dup2 (fileno (cdr out)) 1)
 485           (execlp "sha256sum" "sha256sum"))
 486         (begin                                      ; parent
 487           (close (car in))
 488           (close (cdr out))
 489           (put-bytevector (cdr in) bv)
 490           (close (cdr in))                        ; EOF
 491           (let ((line (car (string-tokenize (read-line (car out))))))
 492             (close (car out))
 493             (and (and=> (status:exit-val (cdr (waitpid pid)))
 494                         zero?)
 495                  line))))))
 496
 497 (define (derivation-hash drv)      ; `hashDerivationModulo' in derivations.cc
 498   (match drv
 499     (($ <derivation> ((_ . ($ <derivation-output> path
 500                               (? symbol? hash-algo) (? string? hash)))))
 501      ;; A fixed-output derivation.
 502      (sha256
 503       (string->utf8
 504        (string-append "fixed:out:" hash-algo ":" hash ":" path))))
 505     (($ <derivation> outputs inputs sources
 506         system builder args env-vars)
 507      ;; A regular derivation: replace that path of each input with that
 508      ;; inputs hash; return the hash of serialization of the resulting
 509      ;; derivation.
 510      (let* ((inputs (map (match-lambda
 511                           (($ <derivation-input> path sub-drvs)
 512                            (let ((hash (call-with-input-file path
 513                                          (compose derivation-hash
 514                                                   read-derivation))))
 515                              (make-derivation-input hash sub-drvs))))
 516                          inputs))
 517             (drv     (make-derivation outputs inputs sources
 518                                       system builder args env-vars)))
 519        (sha256
 520         (string->utf8 (call-with-output-string
 521                        (cut write-derivation drv <>))))))))
 522
 523 (define (instantiate server derivation)
 524   #f
 525   )