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