Mirror of GNU Guix
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.

382 lines
13 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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 serialization)
  19. #:use-module (guix combinators)
  20. #:use-module (rnrs bytevectors)
  21. #:use-module (srfi srfi-1)
  22. #:use-module (srfi srfi-26)
  23. #:use-module (srfi srfi-34)
  24. #:use-module (srfi srfi-35)
  25. #:use-module (ice-9 binary-ports)
  26. #:use-module ((ice-9 rdelim) #:prefix rdelim:)
  27. #:use-module (ice-9 match)
  28. #:use-module (ice-9 ftw)
  29. #:export (write-int read-int
  30. write-long-long read-long-long
  31. write-padding
  32. write-bytevector write-string
  33. read-string read-latin1-string read-maybe-utf8-string
  34. write-string-list read-string-list
  35. write-string-pairs
  36. write-store-path read-store-path
  37. write-store-path-list read-store-path-list
  38. &nar-error
  39. nar-error?
  40. nar-error-port
  41. nar-error-file
  42. &nar-read-error
  43. nar-read-error?
  44. nar-read-error-token
  45. write-file
  46. restore-file))
  47. ;;; Comment:
  48. ;;;
  49. ;;; Serialization procedures used by the RPCs and the Nar format. This module
  50. ;;; is for internal consumption.
  51. ;;;
  52. ;;; Code:
  53. ;; Similar to serialize.cc in Nix.
  54. (define-condition-type &nar-error &error ; XXX: inherit from &nix-error ?
  55. nar-error?
  56. (file nar-error-file) ; file we were restoring, or #f
  57. (port nar-error-port)) ; port from which we read
  58. (define currently-restored-file
  59. ;; Name of the file being restored. Used internally for error reporting.
  60. (make-parameter #f))
  61. (define (get-bytevector-n* port count)
  62. (let ((bv (get-bytevector-n port count)))
  63. (when (or (eof-object? bv)
  64. (< (bytevector-length bv) count))
  65. (raise (condition (&nar-error
  66. (file (currently-restored-file))
  67. (port port)))))
  68. bv))
  69. (define (write-int n p)
  70. (let ((b (make-bytevector 8 0)))
  71. (bytevector-u32-set! b 0 n (endianness little))
  72. (put-bytevector p b)))
  73. (define (read-int p)
  74. (let ((b (get-bytevector-n* p 8)))
  75. (bytevector-u32-ref b 0 (endianness little))))
  76. (define (write-long-long n p)
  77. (let ((b (make-bytevector 8 0)))
  78. (bytevector-u64-set! b 0 n (endianness little))
  79. (put-bytevector p b)))
  80. (define (read-long-long p)
  81. (let ((b (get-bytevector-n* p 8)))
  82. (bytevector-u64-ref b 0 (endianness little))))
  83. (define write-padding
  84. (let ((zero (make-bytevector 8 0)))
  85. (lambda (n p)
  86. (let ((m (modulo n 8)))
  87. (or (zero? m)
  88. (put-bytevector p zero 0 (- 8 m)))))))
  89. (define* (write-bytevector s p
  90. #:optional (l (bytevector-length s)))
  91. (let* ((m (modulo l 8))
  92. (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
  93. (bytevector-u32-set! b 0 l (endianness little))
  94. (bytevector-copy! s 0 b 8 l)
  95. (put-bytevector p b)))
  96. (define (write-string s p)
  97. (write-bytevector (string->utf8 s) p))
  98. (define (read-byte-string p)
  99. (let* ((len (read-int p))
  100. (m (modulo len 8))
  101. (bv (get-bytevector-n* p len)))
  102. (or (zero? m)
  103. (get-bytevector-n* p (- 8 m)))
  104. bv))
  105. (define (read-string p)
  106. (utf8->string (read-byte-string p)))
  107. (define (read-latin1-string p)
  108. "Read an ISO-8859-1 string from P."
  109. ;; Note: do not use 'get-string-n' to work around Guile bug
  110. ;; <http://bugs.gnu.org/19621>. See <http://bugs.gnu.org/19610> for
  111. ;; a discussion.
  112. (let ((bv (read-byte-string p)))
  113. ;; XXX: Rewrite using (ice-9 iconv).
  114. (list->string (map integer->char (bytevector->u8-list bv)))))
  115. (define (read-maybe-utf8-string p)
  116. "Read a serialized string from port P. Attempt to decode it as UTF-8 and
  117. substitute invalid byte sequences with question marks. This is a
  118. \"permissive\" UTF-8 decoder."
  119. ;; XXX: We rely on the port's decoding mechanism to do permissive decoding
  120. ;; and substitute invalid byte sequences with question marks, but this is
  121. ;; not very efficient. Eventually Guile may provide a lightweight
  122. ;; permissive UTF-8 decoder.
  123. (let* ((bv (read-byte-string p))
  124. (port (open-bytevector-input-port bv)))
  125. (set-port-encoding! port "UTF-8")
  126. (set-port-conversion-strategy! port 'substitute)
  127. (rdelim:read-string port)))
  128. (define (write-string-list l p)
  129. (write-int (length l) p)
  130. (for-each (cut write-string <> p) l))
  131. (define (write-string-pairs l p)
  132. (write-int (length l) p)
  133. (for-each (match-lambda
  134. ((first . second)
  135. (write-string first p)
  136. (write-string second p)))
  137. l))
  138. (define (read-string-list p)
  139. (let ((len (read-int p)))
  140. (unfold (cut >= <> len)
  141. (lambda (i)
  142. (read-string p))
  143. 1+
  144. 0)))
  145. (define (write-store-path f p)
  146. (write-string f p)) ; TODO: assert path
  147. (define (read-store-path p)
  148. (read-string p)) ; TODO: assert path
  149. (define write-store-path-list write-string-list)
  150. (define read-store-path-list read-string-list)
  151. (define-condition-type &nar-read-error &nar-error
  152. nar-read-error?
  153. (token nar-read-error-token)) ; faulty token, or #f
  154. (define (dump in out size)
  155. "Copy SIZE bytes from IN to OUT."
  156. (define buf-size 65536)
  157. (define buf (make-bytevector buf-size))
  158. (let loop ((left size))
  159. (if (<= left 0)
  160. 0
  161. (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
  162. (if (eof-object? read)
  163. left
  164. (begin
  165. (put-bytevector out buf 0 read)
  166. (loop (- left read))))))))
  167. (define (write-contents file p size)
  168. "Write SIZE bytes from FILE to output port P."
  169. (define (call-with-binary-input-file file proc)
  170. ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus
  171. ;; avoids any initial buffering. Disable file name canonicalization to
  172. ;; avoid stat'ing like crazy.
  173. (with-fluids ((%file-port-name-canonicalization #f))
  174. (let ((port (open-file file "rb")))
  175. (dynamic-wind
  176. (const #t)
  177. (cut proc port)
  178. (lambda ()
  179. (close-port port))))))
  180. (write-string "contents" p)
  181. (write-long-long size p)
  182. (call-with-binary-input-file file
  183. ;; Use 'sendfile' when P is a file port.
  184. (if (file-port? p)
  185. (cut sendfile p <> size 0)
  186. (cut dump <> p size)))
  187. (write-padding size p))
  188. (define (read-contents in out)
  189. "Read the contents of a file from the Nar at IN, write it to OUT, and return
  190. the size in bytes."
  191. (define executable?
  192. (match (read-string in)
  193. ("contents"
  194. #f)
  195. ("executable"
  196. (match (list (read-string in) (read-string in))
  197. (("" "contents") #t)
  198. (x (raise
  199. (condition (&message
  200. (message "unexpected executable file marker"))
  201. (&nar-read-error (port in)
  202. (file #f)
  203. (token x))))))
  204. #t)
  205. (x
  206. (raise
  207. (condition (&message (message "unsupported nar file type"))
  208. (&nar-read-error (port in) (file #f) (token x)))))))
  209. (let ((size (read-long-long in)))
  210. ;; Note: `sendfile' cannot be used here because of port buffering on IN.
  211. (dump in out size)
  212. (when executable?
  213. (chmod out #o755))
  214. (let ((m (modulo size 8)))
  215. (unless (zero? m)
  216. (get-bytevector-n* in (- 8 m))))
  217. size))
  218. (define %archive-version-1
  219. ;; Magic cookie for Nix archives.
  220. "nix-archive-1")
  221. (define* (write-file file port
  222. #:key (select? (const #t)))
  223. "Write the contents of FILE to PORT in Nar format, recursing into
  224. sub-directories of FILE as needed. For each directory entry, call (SELECT?
  225. FILE STAT), where FILE is the entry's absolute file name and STAT is the
  226. result of 'lstat'; exclude entries for which SELECT? does not return true."
  227. (define p port)
  228. (write-string %archive-version-1 p)
  229. (let dump ((f file) (s (lstat file)))
  230. (write-string "(" p)
  231. (case (stat:type s)
  232. ((regular)
  233. (write-string "type" p)
  234. (write-string "regular" p)
  235. (if (not (zero? (logand (stat:mode s) #o100)))
  236. (begin
  237. (write-string "executable" p)
  238. (write-string "" p)))
  239. (write-contents f p (stat:size s)))
  240. ((directory)
  241. (write-string "type" p)
  242. (write-string "directory" p)
  243. (let ((entries
  244. ;; 'scandir' defaults to 'string-locale<?' to sort files, but
  245. ;; this happens to be case-insensitive (at least in 'en_US'
  246. ;; locale on libc 2.18.) Conversely, we want files to be
  247. ;; sorted in a case-sensitive fashion.
  248. (scandir f (negate (cut member <> '("." ".."))) string<?)))
  249. (for-each (lambda (e)
  250. (let* ((f (string-append f "/" e))
  251. (s (lstat f)))
  252. (when (select? f s)
  253. (write-string "entry" p)
  254. (write-string "(" p)
  255. (write-string "name" p)
  256. (write-string e p)
  257. (write-string "node" p)
  258. (dump f s)
  259. (write-string ")" p))))
  260. entries)))
  261. ((symlink)
  262. (write-string "type" p)
  263. (write-string "symlink" p)
  264. (write-string "target" p)
  265. (write-string (readlink f) p))
  266. (else
  267. (raise (condition (&message (message "unsupported file type"))
  268. (&nar-error (file f) (port port))))))
  269. (write-string ")" p)))
  270. (define (restore-file port file)
  271. "Read a file (possibly a directory structure) in Nar format from PORT.
  272. Restore it as FILE."
  273. (parameterize ((currently-restored-file file))
  274. (let ((signature (read-string port)))
  275. (unless (equal? signature %archive-version-1)
  276. (raise
  277. (condition (&message (message "invalid nar signature"))
  278. (&nar-read-error (port port)
  279. (token signature)
  280. (file #f))))))
  281. (let restore ((file file))
  282. (define (read-eof-marker)
  283. (match (read-string port)
  284. (")" #t)
  285. (x (raise
  286. (condition
  287. (&message (message "invalid nar end-of-file marker"))
  288. (&nar-read-error (port port) (file file) (token x)))))))
  289. (currently-restored-file file)
  290. (match (list (read-string port) (read-string port) (read-string port))
  291. (("(" "type" "regular")
  292. (call-with-output-file file (cut read-contents port <>))
  293. (read-eof-marker))
  294. (("(" "type" "symlink")
  295. (match (list (read-string port) (read-string port))
  296. (("target" target)
  297. (symlink target file)
  298. (read-eof-marker))
  299. (x (raise
  300. (condition
  301. (&message (message "invalid symlink tokens"))
  302. (&nar-read-error (port port) (file file) (token x)))))))
  303. (("(" "type" "directory")
  304. (let ((dir file))
  305. (mkdir dir)
  306. (let loop ((prefix (read-string port)))
  307. (match prefix
  308. ("entry"
  309. (match (list (read-string port)
  310. (read-string port) (read-string port)
  311. (read-string port))
  312. (("(" "name" file "node")
  313. (restore (string-append dir "/" file))
  314. (match (read-string port)
  315. (")" #t)
  316. (x
  317. (raise
  318. (condition
  319. (&message
  320. (message "unexpected directory entry termination"))
  321. (&nar-read-error (port port)
  322. (file file)
  323. (token x))))))
  324. (loop (read-string port)))))
  325. (")" #t) ; done with DIR
  326. (x
  327. (raise
  328. (condition
  329. (&message (message "unexpected directory inter-entry marker"))
  330. (&nar-read-error (port port) (file file) (token x)))))))))
  331. (x
  332. (raise
  333. (condition
  334. (&message (message "unsupported nar entry type"))
  335. (&nar-read-error (port port) (file file) (token x)))))))))
  336. ;;; serialization.scm ends here