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