diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | guix/nar.scm | 110 | ||||
| -rw-r--r-- | guix/serialization.scm | 114 | ||||
| -rw-r--r-- | guix/store.scm | 149 |
4 files changed, 228 insertions, 147 deletions
diff --git a/Makefile.am b/Makefile.am index 8b3057fd0b..e4afb74310 100644 --- a/Makefile.am +++ b/Makefile.am @@ -34,6 +34,8 @@ MODULES = \ guix/scripts/substitute-binary.scm \ guix/base32.scm \ guix/utils.scm \ + guix/serialization.scm \ + guix/nar.scm \ guix/derivations.scm \ guix/download.scm \ guix/gnu-maintenance.scm \ diff --git a/guix/nar.scm b/guix/nar.scm new file mode 100644 index 0000000000..b42f03c514 --- /dev/null +++ b/guix/nar.scm @@ -0,0 +1,110 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix nar) + #:use-module (guix utils) + #:use-module (guix serialization) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 ftw) + #:export (write-file)) + +;;; Comment: +;;; +;;; Read and write Nix archives, aka. ‘nar’. +;;; +;;; Code: + +(define (write-contents file p size) + "Write SIZE bytes from FILE to output port P." + (define (call-with-binary-input-file file proc) + ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus + ;; avoids any initial buffering. Disable file name canonicalization to + ;; avoid stat'ing like crazy. + (with-fluids ((%file-port-name-canonicalization #f)) + (let ((port (open-file file "rb"))) + (catch #t (cut proc port) + (lambda args + (close-port port) + (apply throw args)))))) + + (define (dump in size) + (define buf-size 65536) + (define buf (make-bytevector buf-size)) + + (let loop ((left size)) + (if (<= left 0) + 0 + (let ((read (get-bytevector-n! in buf 0 buf-size))) + (if (eof-object? read) + left + (begin + (put-bytevector p buf 0 read) + (loop (- left read)))))))) + + (write-string "contents" p) + (write-long-long size p) + (call-with-binary-input-file file + ;; Use `sendfile' when available (Guile 2.0.8+). + (if (compile-time-value (defined? 'sendfile)) + (cut sendfile p <> size 0) + (cut dump <> size))) + (write-padding size p)) + +(define (write-file file port) + "Write the contents of FILE to PORT in Nar format, recursing into +sub-directories of FILE as needed." + (define %archive-version-1 "nix-archive-1") + (define p port) + + (write-string %archive-version-1 p) + + (let dump ((f file)) + (let ((s (lstat f))) + (write-string "(" p) + (case (stat:type s) + ((regular) + (write-string "type" p) + (write-string "regular" p) + (if (not (zero? (logand (stat:mode s) #o100))) + (begin + (write-string "executable" p) + (write-string "" p))) + (write-contents f p (stat:size s))) + ((directory) + (write-string "type" p) + (write-string "directory" p) + (let ((entries (remove (cut member <> '("." "..")) + (scandir f)))) + (for-each (lambda (e) + (let ((f (string-append f "/" e))) + (write-string "entry" p) + (write-string "(" p) + (write-string "name" p) + (write-string e p) + (write-string "node" p) + (dump f) + (write-string ")" p))) + entries))) + (else + (error "ENOSYS"))) + (write-string ")" p)))) + +;;; nar.scm ends here diff --git a/guix/serialization.scm b/guix/serialization.scm new file mode 100644 index 0000000000..474dc69de5 --- /dev/null +++ b/guix/serialization.scm @@ -0,0 +1,114 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix serialization) + #:use-module (guix utils) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (write-int read-int + write-long-long read-long-long + write-padding + write-string read-string read-latin1-string + write-string-list read-string-list + write-store-path read-store-path + write-store-path-list read-store-path-list)) + +;;; Comment: +;;; +;;; Serialization procedures used by the RPCs and the Nar format. This module +;;; is for internal consumption. +;;; +;;; Code: + +;; Similar to serialize.cc in Nix. + +(define (write-int n p) + (let ((b (make-bytevector 8 0))) + (bytevector-u32-set! b 0 n (endianness little)) + (put-bytevector p b))) + +(define (read-int p) + (let ((b (get-bytevector-n p 8))) + (bytevector-u32-ref b 0 (endianness little)))) + +(define (write-long-long n p) + (let ((b (make-bytevector 8 0))) + (bytevector-u64-set! b 0 n (endianness little)) + (put-bytevector p b))) + +(define (read-long-long p) + (let ((b (get-bytevector-n p 8))) + (bytevector-u64-ref b 0 (endianness little)))) + +(define write-padding + (let ((zero (make-bytevector 8 0))) + (lambda (n p) + (let ((m (modulo n 8))) + (or (zero? m) + (put-bytevector p zero 0 (- 8 m))))))) + +(define (write-string s p) + (let* ((s (string->utf8 s)) + (l (bytevector-length s)) + (m (modulo l 8)) + (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m)))))) + (bytevector-u32-set! b 0 l (endianness little)) + (bytevector-copy! s 0 b 8 l) + (put-bytevector p b))) + +(define (read-string p) + (let* ((len (read-int p)) + (m (modulo len 8)) + (bv (get-bytevector-n p len)) + (str (utf8->string bv))) + (or (zero? m) + (get-bytevector-n p (- 8 m))) + str)) + +(define (read-latin1-string p) + (let* ((len (read-int p)) + (m (modulo len 8)) + (str (get-string-n p len))) + (or (zero? m) + (get-bytevector-n p (- 8 m))) + str)) + +(define (write-string-list l p) + (write-int (length l) p) + (for-each (cut write-string <> p) l)) + +(define (read-string-list p) + (let ((len (read-int p))) + (unfold (cut >= <> len) + (lambda (i) + (read-string p)) + 1+ + 0))) + +(define (write-store-path f p) + (write-string f p)) ; TODO: assert path + +(define (read-store-path p) + (read-string p)) ; TODO: assert path + +(define write-store-path-list write-string-list) +(define read-store-path-list read-string-list) + +;;; serialization.scm ends here diff --git a/guix/store.scm b/guix/store.scm index de9785c835..cc21af84e4 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -17,8 +17,10 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix store) + #:use-module (guix nar) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix serialization) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) @@ -29,7 +31,6 @@ #:use-module (srfi srfi-39) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) - #:use-module (ice-9 ftw) #:use-module (ice-9 regex) #:export (%daemon-socket-file @@ -161,152 +162,6 @@ -;; serialize.cc - -(define (write-int n p) - (let ((b (make-bytevector 8 0))) - (bytevector-u32-set! b 0 n (endianness little)) - (put-bytevector p b))) - -(define (read-int p) - (let ((b (get-bytevector-n p 8))) - (bytevector-u32-ref b 0 (endianness little)))) - -(define (write-long-long n p) - (let ((b (make-bytevector 8 0))) - (bytevector-u64-set! b 0 n (endianness little)) - (put-bytevector p b))) - -(define (read-long-long p) - (let ((b (get-bytevector-n p 8))) - (bytevector-u64-ref b 0 (endianness little)))) - -(define write-padding - (let ((zero (make-bytevector 8 0))) - (lambda (n p) - (let ((m (modulo n 8))) - (or (zero? m) - (put-bytevector p zero 0 (- 8 m))))))) - -(define (write-string s p) - (let* ((s (string->utf8 s)) - (l (bytevector-length s)) - (m (modulo l 8)) - (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m)))))) - (bytevector-u32-set! b 0 l (endianness little)) - (bytevector-copy! s 0 b 8 l) - (put-bytevector p b))) - -(define (read-string p) - (let* ((len (read-int p)) - (m (modulo len 8)) - (bv (get-bytevector-n p len)) - (str (utf8->string bv))) - (or (zero? m) - (get-bytevector-n p (- 8 m))) - str)) - -(define (read-latin1-string p) - (let* ((len (read-int p)) - (m (modulo len 8)) - (str (get-string-n p len))) - (or (zero? m) - (get-bytevector-n p (- 8 m))) - str)) - -(define (write-string-list l p) - (write-int (length l) p) - (for-each (cut write-string <> p) l)) - -(define (read-string-list p) - (let ((len (read-int p))) - (unfold (cut >= <> len) - (lambda (i) - (read-string p)) - 1+ - 0))) - -(define (write-store-path f p) - (write-string f p)) ; TODO: assert path - -(define (read-store-path p) - (read-string p)) ; TODO: assert path - -(define write-store-path-list write-string-list) -(define read-store-path-list read-string-list) - -(define (write-contents file p size) - "Write SIZE bytes from FILE to output port P." - (define (call-with-binary-input-file file proc) - ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus - ;; avoids any initial buffering. Disable file name canonicalization to - ;; avoid stat'ing like crazy. - (with-fluids ((%file-port-name-canonicalization #f)) - (let ((port (open-file file "rb"))) - (catch #t (cut proc port) - (lambda args - (close-port port) - (apply throw args)))))) - - (define (dump in size) - (define buf-size 65536) - (define buf (make-bytevector buf-size)) - - (let loop ((left size)) - (if (<= left 0) - 0 - (let ((read (get-bytevector-n! in buf 0 buf-size))) - (if (eof-object? read) - left - (begin - (put-bytevector p buf 0 read) - (loop (- left read)))))))) - - (write-string "contents" p) - (write-long-long size p) - (call-with-binary-input-file file - ;; Use `sendfile' when available (Guile 2.0.8+). - (if (compile-time-value (defined? 'sendfile)) - (cut sendfile p <> size 0) - (cut dump <> size))) - (write-padding size p)) - -(define (write-file f p) - (define %archive-version-1 "nix-archive-1") - - (write-string %archive-version-1 p) - - (let dump ((f f)) - (let ((s (lstat f))) - (write-string "(" p) - (case (stat:type s) - ((regular) - (write-string "type" p) - (write-string "regular" p) - (if (not (zero? (logand (stat:mode s) #o100))) - (begin - (write-string "executable" p) - (write-string "" p))) - (write-contents f p (stat:size s))) - ((directory) - (write-string "type" p) - (write-string "directory" p) - (let ((entries (remove (cut member <> '("." "..")) - (scandir f)))) - (for-each (lambda (e) - (let ((f (string-append f "/" e))) - (write-string "entry" p) - (write-string "(" p) - (write-string "name" p) - (write-string e p) - (write-string "node" p) - (dump f) - (write-string ")" p))) - entries))) - (else - (error "ENOSYS"))) - (write-string ")" p)))) - ;; Information about a substitutable store path. (define-record-type <substitutable> (substitutable path deriver refs dl-size nar-size) |