You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

253 lines
8.6 KiB

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