guix/cpio.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 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 cpio)
  20   #:use-module ((guix build utils) #:select (dump-port))
  21   #:use-module (srfi srfi-9)
  22   #:use-module (srfi srfi-11)
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (rnrs io ports)
  25   #:use-module (ice-9 match)
  26   #:export (cpio-header?
  27             make-cpio-header
  28             file->cpio-header
  29             file->cpio-header*
  30             write-cpio-header
  31             read-cpio-header
  32
  33             write-cpio-archive))
  34
  35 ;;; Commentary:
  36 ;;;
  37 ;;; This module implements the cpio "new ASCII" format, bit-for-bit identical
  38 ;;; to GNU cpio with the '-H newc' option.
  39 ;;;
  40 ;;; Code:
  41
  42 ;; Values for 'mode', OR'd together.
  43
  44 (define C_IRUSR #o000400)
  45 (define C_IWUSR #o000200)
  46 (define C_IXUSR #o000100)
  47 (define C_IRGRP #o000040)
  48 (define C_IWGRP #o000020)
  49 (define C_IXGRP #o000010)
  50 (define C_IROTH #o000004)
  51 (define C_IWOTH #o000002)
  52 (define C_IXOTH #o000001)
  53
  54 (define C_ISUID #o004000)
  55 (define C_ISGID #o002000)
  56 (define C_ISVTX #o001000)
  57
  58 (define C_FMT   #o170000)                         ;bit mask
  59 (define C_ISBLK #o060000)
  60 (define C_ISCHR #o020000)
  61 (define C_ISDIR #o040000)
  62 (define C_ISFIFO #o010000)
  63 (define C_ISSOCK #o0140000)
  64 (define C_ISLNK #o0120000)
  65 (define C_ISCTG #o0110000)
  66 (define C_ISREG #o0100000)
  67
  68
  69 (define MAGIC
  70   ;; The "new" portable format with ASCII header, as produced by GNU cpio with
  71   ;; '-H newc'.
  72   (string->number "070701" 16))
  73
  74 (define (read-header-field size port)
  75   (string->number (get-string-n port size) 16))
  76
  77 (define (write-header-field value size port)
  78   (put-bytevector port
  79                   (string->utf8
  80                    (string-pad (string-upcase (number->string value 16))
  81                                size #\0))))
  82
  83 (define-syntax define-pack
  84   (syntax-rules ()
  85     ((_ type ctor pred write read (field-names field-sizes field-getters) ...)
  86      (begin
  87        (define-record-type type
  88          (ctor field-names ...)
  89          pred
  90          (field-names field-getters) ...)
  91
  92        (define (read port)
  93          (set-port-encoding! port "ISO-8859-1")
  94          (ctor (read-header-field field-sizes port)
  95                ...))
  96
  97        (define (write obj port)
  98          (let* ((size (+ field-sizes ...)))
  99            (match obj
 100              (($ type field-names ...)
 101               (write-header-field field-names field-sizes port)
 102               ...))))))))
 103
 104 ;; cpio header in "new ASCII" format, without checksum.
 105 (define-pack <cpio-header>
 106   %make-cpio-header cpio-header?
 107   write-cpio-header read-cpio-header
 108   (magic     6  cpio-header-magic)
 109   (ino       8  cpio-header-inode)
 110   (mode      8  cpio-header-mode)
 111   (uid       8  cpio-header-uid)
 112   (gid       8  cpio-header-gid)
 113   (nlink     8  cpio-header-nlink)
 114   (mtime     8  cpio-header-mtime)
 115   (file-size 8  cpio-header-file-size)
 116   (dev-maj   8  cpio-header-device-major)
 117   (dev-min   8  cpio-header-device-minor)
 118   (rdev-maj  8  cpio-header-rdevice-major)
 119   (rdev-min  8  cpio-header-rdevice-minor)
 120   (name-size 8  cpio-header-name-size)
 121   (checksum  8  cpio-header-checksum))            ;0 for "newc" format
 122
 123 (define* (make-cpio-header #:key
 124                            (inode 0)
 125                            (mode (logior C_ISREG C_IRUSR))
 126                            (uid 0) (gid 0)
 127                            (nlink 1) (mtime 0) (size 0)
 128                            (dev 0) (rdev 0) (name-size 0))
 129   "Return a new cpio file header."
 130   (let-values (((major minor)   (device->major+minor dev))
 131                ((rmajor rminor) (device->major+minor rdev)))
 132     (%make-cpio-header MAGIC
 133                        inode mode uid gid
 134                        nlink mtime
 135                        (if (= C_ISDIR (logand mode C_FMT))
 136                            0
 137                            size)
 138                        major minor rmajor rminor
 139                        (+ name-size 1)              ;include trailing zero
 140                        0)))                          ;checksum
 141
 142 (define (mode->type mode)
 143   "Given the number MODE, return a symbol representing the kind of file MODE
 144 denotes, similar to 'stat:type'."
 145   (let ((fmt (logand mode C_FMT)))
 146     (cond ((= C_ISREG fmt) 'regular)
 147           ((= C_ISDIR fmt) 'directory)
 148           ((= C_ISLNK fmt) 'symlink)
 149           (else
 150            (error "unsupported file type" mode)))))
 151
 152 (define (device-number major minor)               ;see <sys/sysmacros.h>
 153   "Return the device number for the device with MAJOR and MINOR, for use as
 154 the last argument of `mknod'."
 155   (+ (* major 256) minor))
 156
 157 (define (device->major+minor device)
 158   "Return two values: the major and minor device numbers that make up DEVICE."
 159   (values (ash device -8)
 160           (logand device #xff)))
 161
 162 (define* (file->cpio-header file #:optional (file-name file)
 163                             #:key (stat lstat))
 164   "Return a cpio header corresponding to the info returned by STAT for FILE,
 165 using FILE-NAME as its file name."
 166   (let ((st (stat file)))
 167     (make-cpio-header #:inode (stat:ino st)
 168                       #:mode (stat:mode st)
 169                       #:uid (stat:uid st)
 170                       #:gid (stat:gid st)
 171                       #:nlink (stat:nlink st)
 172                       #:mtime (stat:mtime st)
 173                       #:size (stat:size st)
 174                       #:dev (stat:dev st)
 175                       #:rdev (stat:rdev st)
 176                       #:name-size (string-length file-name))))
 177
 178 (define* (file->cpio-header* file
 179                              #:optional (file-name file)
 180                              #:key (stat lstat))
 181   "Similar to 'file->cpio-header', but return a header with a zeroed
 182 modification time, inode number, UID/GID, etc.  This allows archives to be
 183 produced in a deterministic fashion."
 184   (let ((st (stat file)))
 185     (make-cpio-header #:mode (stat:mode st)
 186                       #:nlink (stat:nlink st)
 187                       #:size (stat:size st)
 188                       #:name-size (string-length file-name))))
 189
 190 (define %trailer
 191   "TRAILER!!!")
 192
 193 (define %last-header
 194   ;; The header that marks the end of the archive.
 195   (make-cpio-header #:mode 0
 196                     #:name-size (string-length %trailer)))
 197
 198 (define* (write-cpio-archive files port
 199                              #:key (file->header file->cpio-header))
 200   "Write to PORT a cpio archive in \"new ASCII\" format containing all of FILES.
 201
 202 The archive written to PORT is intended to be bit-identical to what GNU cpio
 203 produces with the '-H newc' option."
 204   (define (write-padding offset port)
 205     (let ((padding (modulo (- 4 (modulo offset 4)) 4)))
 206       (put-bytevector port (make-bytevector padding))))
 207
 208   (define (pad-block port)
 209     ;; Write padding to PORT such that we finish with a 512-byte block.
 210     ;; XXX: We rely on PORT's internal state, assuming it's a file port.
 211     (let* ((offset  (seek port 0 SEEK_CUR))
 212            (padding (modulo (- 512 (modulo offset 512)) 512)))
 213       (put-bytevector port (make-bytevector padding))))
 214
 215   (define (dump-file file)
 216     (let* ((header (file->header file))
 217            (size   (cpio-header-file-size header)))
 218       (write-cpio-header header port)
 219       (put-bytevector port (string->utf8 file))
 220       (put-u8 port 0)
 221
 222       ;; We're padding the header + following file name + trailing zero, and
 223       ;; the header is 110 byte long.
 224       (write-padding (+ 110 1 (string-length file)) port)
 225
 226       (case (mode->type (cpio-header-mode header))
 227         ((regular)
 228          (call-with-input-file file
 229            (lambda (input)
 230              (dump-port input port))))
 231         ((symlink)
 232          (let ((target (readlink file)))
 233            (put-string port target)))
 234         ((directory)
 235          #t)
 236         (else
 237          (error "file type not supported")))
 238
 239       ;; Pad the file content.
 240       (write-padding size port)))
 241
 242   (set-port-encoding! port "ISO-8859-1")
 243
 244   (for-each dump-file files)
 245
 246   (write-cpio-header %last-header port)
 247   (put-bytevector port (string->utf8 %trailer))
 248   (write-padding (string-length %trailer) port)
 249
 250   ;; Pad so the last block is 512-byte long.
 251   (pad-block port))
 252
 253 ;;; cpio.scm ends here