guix/cpio.scm

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