[jackhill/guix/guix.git] / guix / cpio.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix cpio)
  #:use-module ((guix build syscalls) #:select (device-number
                                                device-number->major+minor))
  #:use-module ((guix build utils) #:select (dump-port))
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:export (cpio-header?
            make-cpio-header
            file->cpio-header
            file->cpio-header*
            special-file->cpio-header*
            write-cpio-header
            read-cpio-header

            write-cpio-archive))

;;; Commentary:
;;;
;;; This module implements the cpio "new ASCII" format, bit-for-bit identical
;;; to GNU cpio with the '-H newc' option.
;;;
;;; Code:

;; Values for 'mode', OR'd together.

(define C_IRUSR #o000400)
(define C_IWUSR #o000200)
(define C_IXUSR #o000100)
(define C_IRGRP #o000040)
(define C_IWGRP #o000020)
(define C_IXGRP #o000010)
(define C_IROTH #o000004)
(define C_IWOTH #o000002)
(define C_IXOTH #o000001)

(define C_ISUID #o004000)
(define C_ISGID #o002000)
(define C_ISVTX #o001000)

(define C_FMT   #o170000)                         ;bit mask
(define C_ISBLK #o060000)
(define C_ISCHR #o020000)
(define C_ISDIR #o040000)
(define C_ISFIFO #o010000)
(define C_ISSOCK #o0140000)
(define C_ISLNK #o0120000)
(define C_ISCTG #o0110000)
(define C_ISREG #o0100000)


(define MAGIC
  ;; The "new" portable format with ASCII header, as produced by GNU cpio with
  ;; '-H newc'.
  (string->number "070701" 16))

(define (read-header-field size port)
  (string->number (get-string-n port size) 16))

(define (write-header-field value size port)
  (put-bytevector port
                  (string->utf8
                   (string-pad (string-upcase (number->string value 16))
                               size #\0))))

(define-syntax define-pack
  (syntax-rules ()
    ((_ type ctor pred write read (field-names field-sizes field-getters) ...)
     (begin
       (define-record-type type
         (ctor field-names ...)
         pred
         (field-names field-getters) ...)

       (define (read port)
         (set-port-encoding! port "ISO-8859-1")
         (ctor (read-header-field field-sizes port)
               ...))

       (define (write obj port)
         (let* ((size (+ field-sizes ...)))
           (match obj
             (($ type field-names ...)
              (write-header-field field-names field-sizes port)
              ...))))))))

;; cpio header in "new ASCII" format, without checksum.
(define-pack <cpio-header>
  %make-cpio-header cpio-header?
  write-cpio-header read-cpio-header
  (magic     6  cpio-header-magic)
  (ino       8  cpio-header-inode)
  (mode      8  cpio-header-mode)
  (uid       8  cpio-header-uid)
  (gid       8  cpio-header-gid)
  (nlink     8  cpio-header-nlink)
  (mtime     8  cpio-header-mtime)
  (file-size 8  cpio-header-file-size)
  (dev-maj   8  cpio-header-device-major)
  (dev-min   8  cpio-header-device-minor)
  (rdev-maj  8  cpio-header-rdevice-major)
  (rdev-min  8  cpio-header-rdevice-minor)
  (name-size 8  cpio-header-name-size)
  (checksum  8  cpio-header-checksum))            ;0 for "newc" format

(define* (make-cpio-header #:key
                           (inode 0)
                           (mode (logior C_ISREG C_IRUSR))
                           (uid 0) (gid 0)
                           (nlink 1) (mtime 0) (size 0)
                           (dev 0) (rdev 0) (name-size 0))
  "Return a new cpio file header."
  (let-values (((major minor)   (device-number->major+minor dev))
               ((rmajor rminor) (device-number->major+minor rdev)))
    (%make-cpio-header MAGIC
                       inode mode uid gid
                       nlink mtime
                       (if (or (= C_ISLNK (logand mode C_FMT))
                               (= C_ISREG (logand mode C_FMT)))
                           size
                           0)
                       major minor rmajor rminor
                       (+ name-size 1)              ;include trailing zero
                       0)))                          ;checksum

(define (mode->type mode)
  "Given the number MODE, return a symbol representing the kind of file MODE
denotes, similar to 'stat:type'."
  (let ((fmt (logand mode C_FMT)))
    (cond ((= C_ISREG fmt) 'regular)
          ((= C_ISDIR fmt) 'directory)
          ((= C_ISLNK fmt) 'symlink)
          ((= C_ISBLK fmt) 'block-special)
          ((= C_ISCHR fmt) 'char-special)
          (else
           (error "unsupported file type" mode)))))

(define* (file->cpio-header file #:optional (file-name file)
                            #:key (stat lstat))
  "Return a cpio header corresponding to the info returned by STAT for FILE,
using FILE-NAME as its file name."
  (let ((st (stat file)))
    (make-cpio-header #:inode (stat:ino st)
                      #:mode (stat:mode st)
                      #:uid (stat:uid st)
                      #:gid (stat:gid st)
                      #:nlink (stat:nlink st)
                      #:mtime (stat:mtime st)
                      #:size (stat:size st)
                      #:dev (stat:dev st)
                      #:rdev (stat:rdev st)
                      #:name-size (string-length file-name))))

(define* (file->cpio-header* file
                             #:optional (file-name file)
                             #:key (stat lstat))
  "Similar to 'file->cpio-header', but return a header with a zeroed
modification time, inode number, UID/GID, etc.  This allows archives to be
produced in a deterministic fashion."
  (let ((st (stat file)))
    (make-cpio-header #:mode (stat:mode st)
                      #:nlink (stat:nlink st)
                      #:size (stat:size st)
                      #:name-size (string-length file-name))))

(define* (special-file->cpio-header* file
                                     device-type
                                     device-major
                                     device-minor
                                     permission-bits
                                     #:optional (file-name file))
  "Create a character or block device header.

DEVICE-TYPE is either 'char-special or 'block-special.

The number of hard links is assumed to be 1."
  (make-cpio-header #:mode (logior (match device-type
                                    ('block-special C_ISBLK)
                                    ('char-special C_ISCHR))
                                    permission-bits)
                    #:nlink 1
                    #:rdev (device-number device-major device-minor)
                    #:name-size (string-length file-name)))

(define %trailer
  "TRAILER!!!")

(define %last-header
  ;; The header that marks the end of the archive.
  (make-cpio-header #:mode 0
                    #:name-size (string-length %trailer)))

(define* (write-cpio-archive files port
                             #:key (file->header file->cpio-header))
  "Write to PORT a cpio archive in \"new ASCII\" format containing all of FILES.

The archive written to PORT is intended to be bit-identical to what GNU cpio
produces with the '-H newc' option."
  (define (write-padding offset port)
    (let ((padding (modulo (- 4 (modulo offset 4)) 4)))
      (put-bytevector port (make-bytevector padding))))

  (define (pad-block port)
    ;; Write padding to PORT such that we finish with a 512-byte block.
    ;; XXX: We rely on PORT's internal state, assuming it's a file port.
    (let* ((offset  (seek port 0 SEEK_CUR))
           (padding (modulo (- 512 (modulo offset 512)) 512)))
      (put-bytevector port (make-bytevector padding))))

  (define (dump-file file)
    (let* ((header (file->header file))
           (size   (cpio-header-file-size header)))
      (write-cpio-header header port)
      (put-bytevector port (string->utf8 file))
      (put-u8 port 0)

      ;; We're padding the header + following file name + trailing zero, and
      ;; the header is 110 byte long.
      (write-padding (+ 110 1 (string-length file)) port)

      (case (mode->type (cpio-header-mode header))
        ((regular)
         (call-with-input-file file
           (lambda (input)
             (dump-port input port))))
        ((symlink)
         (let ((target (readlink file)))
           (put-string port target)))
        ((directory)
         #t)
        ((block-special)
         #t)
        ((char-special)
         #t)
        (else
         (error "file type not supported")))

      ;; Pad the file content.
      (write-padding size port)))

  (set-port-encoding! port "ISO-8859-1")

  (for-each dump-file files)

  (write-cpio-header %last-header port)
  (put-bytevector port (string->utf8 %trailer))
  (write-padding (string-length %trailer) port)

  ;; Pad so the last block is 512-byte long.
  (pad-block port))

;;; cpio.scm ends here
Commit	Line	Data
7a18c3cc LC	1	;;; GNU Guix --- Functional package management for GNU
7a18c3cc LC	2	;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
f7e14782	3	;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
7a18c3cc LC	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)
348f0c61 TGR	21	#:use-module ((guix build syscalls) #:select (device-number
348f0c61 TGR	22	device-number->major+minor))
7a18c3cc LC	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
eae5b3ff	32	file->cpio-header*
8e7c9896	33	special-file->cpio-header*
7a18c3cc LC	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."
348f0c61 TGR	134	(let-values (((major minor) (device-number->major+minor dev))
348f0c61 TGR	135	((rmajor rminor) (device-number->major+minor rdev)))
7a18c3cc LC	136	(%make-cpio-header MAGIC
	137	inode mode uid gid
	138	nlink mtime
b1dfc645 DM	139	(if (or (= C_ISLNK (logand mode C_FMT))
	140	(= C_ISREG (logand mode C_FMT)))
	141	size
	142	0)
7a18c3cc LC	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)
b1dfc645 DM	154	((= C_ISBLK fmt) 'block-special)
b1dfc645 DM	155	((= C_ISCHR fmt) 'char-special)
7a18c3cc LC	156	(else
	157	(error "unsupported file type" mode)))))
	158
7a18c3cc LC	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
eae5b3ff LC	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
8e7c9896 DM	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
7a18c3cc LC	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)
b1dfc645 DM	252	((block-special)
	253	#t)
	254	((char-special)
	255	#t)
7a18c3cc LC	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