| 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 |