guix/nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix nar)
  20   #:use-module (guix utils)
  21   #:use-module (guix serialization)
  22   #:use-module ((guix build utils) #:select (with-directory-excursion))
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (rnrs io ports)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (srfi srfi-34)
  28   #:use-module (srfi srfi-35)
  29   #:use-module (ice-9 ftw)
  30   #:use-module (ice-9 match)
  31   #:export (nar-error?
  32             nar-read-error?
  33             nar-read-error-file
  34             nar-read-error-port
  35             nar-read-error-token
  36
  37             write-file
  38             restore-file))
  39
  40 ;;; Comment:
  41 ;;;
  42 ;;; Read and write Nix archives, aka. ‘nar’.
  43 ;;;
  44 ;;; Code:
  45
  46 (define-condition-type &nar-error &error      ; XXX: inherit from &nix-error ?
  47   nar-error?)
  48
  49 (define-condition-type &nar-read-error &nar-error
  50   nar-read-error?
  51   (port  nar-read-error-port)                   ; port from which we read
  52   (file  nar-read-error-file)                   ; file we were restoring, or #f
  53   (token nar-read-error-token))                 ; faulty token, or #f
  54
  55
  56 (define (dump in out size)
  57   "Copy SIZE bytes from IN to OUT."
  58   (define buf-size 65536)
  59   (define buf (make-bytevector buf-size))
  60
  61   (let loop ((left size))
  62     (if (<= left 0)
  63         0
  64         (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
  65           (if (eof-object? read)
  66               left
  67               (begin
  68                 (put-bytevector out buf 0 read)
  69                 (loop (- left read))))))))
  70
  71 (define (write-contents file p size)
  72   "Write SIZE bytes from FILE to output port P."
  73   (define (call-with-binary-input-file file proc)
  74     ;; Open FILE as a binary file.  This avoids scan-for-encoding, and thus
  75     ;; avoids any initial buffering.  Disable file name canonicalization to
  76     ;; avoid stat'ing like crazy.
  77     (with-fluids ((%file-port-name-canonicalization #f))
  78       (let ((port (open-file file "rb")))
  79         (dynamic-wind
  80           (const #t)
  81           (cut proc port)
  82           (lambda ()
  83             (close-port port))))))
  84
  85   (write-string "contents" p)
  86   (write-long-long size p)
  87   (call-with-binary-input-file file
  88     ;; Use `sendfile' when available (Guile 2.0.8+).
  89     (if (compile-time-value (defined? 'sendfile))
  90         (cut sendfile p <> size 0)
  91         (cut dump <> p size)))
  92   (write-padding size p))
  93
  94 (define (read-contents in out)
  95   "Read the contents of a file from the Nar at IN, write it to OUT, and return
  96 the size in bytes."
  97   (define executable?
  98     (match (read-string in)
  99       ("contents"
 100        #f)
 101       ("executable"
 102        (match (list (read-string in) (read-string in))
 103          (("" "contents") #t)
 104          (x (raise
 105              (condition (&message
 106                          (message "unexpected executable file marker"))
 107                         (&nar-read-error (port in)
 108                                          (file #f)
 109                                          (token x))))))
 110        #t)
 111       (x
 112        (raise
 113         (condition (&message (message "unsupported nar file type"))
 114                    (&nar-read-error (port in) (file #f) (token x)))))))
 115
 116   (let ((size (read-long-long in)))
 117     ;; Note: `sendfile' cannot be used here because of port buffering on IN.
 118     (dump in out size)
 119
 120     (when executable?
 121       (chmod out #o755))
 122     (let ((m (modulo size 8)))
 123       (unless (zero? m)
 124         (get-bytevector-n in (- 8 m))))
 125     size))
 126
 127 (define %archive-version-1
 128   ;; Magic cookie for Nix archives.
 129   "nix-archive-1")
 130
 131 (define (write-file file port)
 132   "Write the contents of FILE to PORT in Nar format, recursing into
 133 sub-directories of FILE as needed."
 134   (define p port)
 135
 136   (write-string %archive-version-1 p)
 137
 138   (let dump ((f file))
 139     (let ((s (lstat f)))
 140       (write-string "(" p)
 141       (case (stat:type s)
 142         ((regular)
 143          (write-string "type" p)
 144          (write-string "regular" p)
 145          (if (not (zero? (logand (stat:mode s) #o100)))
 146              (begin
 147                (write-string "executable" p)
 148                (write-string "" p)))
 149          (write-contents f p (stat:size s)))
 150         ((directory)
 151          (write-string "type" p)
 152          (write-string "directory" p)
 153          (let ((entries (remove (cut member <> '("." ".."))
 154                                 (scandir f))))
 155            (for-each (lambda (e)
 156                        (let ((f (string-append f "/" e)))
 157                          (write-string "entry" p)
 158                          (write-string "(" p)
 159                          (write-string "name" p)
 160                          (write-string e p)
 161                          (write-string "node" p)
 162                          (dump f)
 163                          (write-string ")" p)))
 164                      entries)))
 165         ((symlink)
 166          (write-string "type" p)
 167          (write-string "symlink" p)
 168          (write-string "target" p)
 169          (write-string (readlink f) p))
 170         (else
 171          (raise (condition (&message (message "ENOSYS"))
 172                            (&nar-error)))))
 173       (write-string ")" p))))
 174
 175 (define (restore-file port file)
 176   "Read a file (possibly a directory structure) in Nar format from PORT.
 177 Restore it as FILE."
 178   (let ((signature (read-string port)))
 179     (unless (equal? signature %archive-version-1)
 180       (raise
 181        (condition (&message (message "invalid nar signature"))
 182                   (&nar-read-error (port port)
 183                                    (token signature)
 184                                    (file #f))))))
 185
 186   (let restore ((file file))
 187     (define (read-eof-marker)
 188       (match (read-string port)
 189         (")" #t)
 190         (x (raise
 191             (condition
 192              (&message (message "invalid nar end-of-file marker"))
 193              (&nar-read-error (port port) (file file) (token x)))))))
 194
 195     (match (list (read-string port) (read-string port) (read-string port))
 196       (("(" "type" "regular")
 197        (call-with-output-file file (cut read-contents port <>))
 198        (read-eof-marker))
 199       (("(" "type" "symlink")
 200        (match (list (read-string port) (read-string port))
 201          (("target" target)
 202           (symlink target file)
 203           (read-eof-marker))
 204          (x (raise
 205              (condition
 206               (&message (message "invalid symlink tokens"))
 207               (&nar-read-error (port port) (file file) (token x)))))))
 208       (("(" "type" "directory")
 209        (let ((dir file))
 210          (mkdir dir)
 211          (let loop ((prefix (read-string port)))
 212            (match prefix
 213              ("entry"
 214               (match (list (read-string port)
 215                            (read-string port) (read-string port)
 216                            (read-string port))
 217                 (("(" "name" file "node")
 218                  (restore (string-append dir "/" file))
 219                  (match (read-string port)
 220                    (")" #t)
 221                    (x
 222                     (raise
 223                      (condition
 224                       (&message
 225                        (message "unexpected directory entry termination"))
 226                       (&nar-read-error (port port)
 227                                        (file file)
 228                                        (token x))))))
 229                  (loop (read-string port)))))
 230              (")" #t)                             ; done with DIR
 231              (x
 232               (raise
 233                (condition
 234                 (&message (message "unexpected directory inter-entry marker"))
 235                 (&nar-read-error (port port) (file file) (token x)))))))))
 236       (x
 237        (raise
 238         (condition
 239          (&message (message "unsupported nar entry type"))
 240          (&nar-read-error (port port) (file file) (token x))))))))
 241
 242 ;;; nar.scm ends here