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.
 
 
 
 
 
 

495 lines
18 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
  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. (define-module (guix nar)
  20. #:use-module (guix utils)
  21. #:use-module (guix serialization)
  22. #:use-module ((guix build utils)
  23. #:select (delete-file-recursively with-directory-excursion))
  24. #:use-module (guix store)
  25. #:use-module (guix ui) ; for '_'
  26. #:use-module (guix hash)
  27. #:use-module (guix pki)
  28. #:use-module (guix pk-crypto)
  29. #:use-module (rnrs bytevectors)
  30. #:use-module (rnrs io ports)
  31. #:use-module (srfi srfi-1)
  32. #:use-module (srfi srfi-11)
  33. #:use-module (srfi srfi-26)
  34. #:use-module (srfi srfi-34)
  35. #:use-module (srfi srfi-35)
  36. #:use-module (ice-9 ftw)
  37. #:use-module (ice-9 match)
  38. #:export (nar-error?
  39. nar-error-port
  40. nar-error-file
  41. nar-read-error?
  42. nar-read-error-token
  43. nar-invalid-hash-error?
  44. nar-invalid-hash-error-expected
  45. nar-invalid-hash-error-actual
  46. nar-signature-error?
  47. nar-signature-error-signature
  48. write-file
  49. restore-file
  50. restore-file-set))
  51. ;;; Comment:
  52. ;;;
  53. ;;; Read and write Nix archives, aka. ‘nar’.
  54. ;;;
  55. ;;; Code:
  56. (define-condition-type &nar-error &error ; XXX: inherit from &nix-error ?
  57. nar-error?
  58. (file nar-error-file) ; file we were restoring, or #f
  59. (port nar-error-port)) ; port from which we read
  60. (define-condition-type &nar-read-error &nar-error
  61. nar-read-error?
  62. (token nar-read-error-token)) ; faulty token, or #f
  63. (define-condition-type &nar-signature-error &nar-error
  64. nar-signature-error?
  65. (signature nar-signature-error-signature)) ; faulty signature or #f
  66. (define-condition-type &nar-invalid-hash-error &nar-signature-error
  67. nar-invalid-hash-error?
  68. (expected nar-invalid-hash-error-expected) ; expected hash (a bytevector)
  69. (actual nar-invalid-hash-error-actual)) ; actual hash
  70. (define (dump in out size)
  71. "Copy SIZE bytes from IN to OUT."
  72. (define buf-size 65536)
  73. (define buf (make-bytevector buf-size))
  74. (let loop ((left size))
  75. (if (<= left 0)
  76. 0
  77. (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
  78. (if (eof-object? read)
  79. left
  80. (begin
  81. (put-bytevector out buf 0 read)
  82. (loop (- left read))))))))
  83. (define (write-contents file p size)
  84. "Write SIZE bytes from FILE to output port P."
  85. (define (call-with-binary-input-file file proc)
  86. ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus
  87. ;; avoids any initial buffering. Disable file name canonicalization to
  88. ;; avoid stat'ing like crazy.
  89. (with-fluids ((%file-port-name-canonicalization #f))
  90. (let ((port (open-file file "rb")))
  91. (dynamic-wind
  92. (const #t)
  93. (cut proc port)
  94. (lambda ()
  95. (close-port port))))))
  96. (write-string "contents" p)
  97. (write-long-long size p)
  98. (call-with-binary-input-file file
  99. ;; Use `sendfile' when available (Guile 2.0.8+).
  100. (if (and (compile-time-value (defined? 'sendfile))
  101. (file-port? p))
  102. (cut sendfile p <> size 0)
  103. (cut dump <> p size)))
  104. (write-padding size p))
  105. (define (read-contents in out)
  106. "Read the contents of a file from the Nar at IN, write it to OUT, and return
  107. the size in bytes."
  108. (define executable?
  109. (match (read-string in)
  110. ("contents"
  111. #f)
  112. ("executable"
  113. (match (list (read-string in) (read-string in))
  114. (("" "contents") #t)
  115. (x (raise
  116. (condition (&message
  117. (message "unexpected executable file marker"))
  118. (&nar-read-error (port in)
  119. (file #f)
  120. (token x))))))
  121. #t)
  122. (x
  123. (raise
  124. (condition (&message (message "unsupported nar file type"))
  125. (&nar-read-error (port in) (file #f) (token x)))))))
  126. (let ((size (read-long-long in)))
  127. ;; Note: `sendfile' cannot be used here because of port buffering on IN.
  128. (dump in out size)
  129. (when executable?
  130. (chmod out #o755))
  131. (let ((m (modulo size 8)))
  132. (unless (zero? m)
  133. (get-bytevector-n in (- 8 m))))
  134. size))
  135. (define %archive-version-1
  136. ;; Magic cookie for Nix archives.
  137. "nix-archive-1")
  138. (define (write-file file port)
  139. "Write the contents of FILE to PORT in Nar format, recursing into
  140. sub-directories of FILE as needed."
  141. (define p port)
  142. (write-string %archive-version-1 p)
  143. (let dump ((f file))
  144. (let ((s (lstat f)))
  145. (write-string "(" p)
  146. (case (stat:type s)
  147. ((regular)
  148. (write-string "type" p)
  149. (write-string "regular" p)
  150. (if (not (zero? (logand (stat:mode s) #o100)))
  151. (begin
  152. (write-string "executable" p)
  153. (write-string "" p)))
  154. (write-contents f p (stat:size s)))
  155. ((directory)
  156. (write-string "type" p)
  157. (write-string "directory" p)
  158. (let ((entries
  159. ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories
  160. ;; unconditionally, including "." and "..", regardless of the
  161. ;; 'select?' predicate passed to it, so we have to filter
  162. ;; those out externally.
  163. (filter (negate (cut member <> '("." "..")))
  164. ;; 'scandir' defaults to 'string-locale<?' to sort
  165. ;; files, but this happens to be case-insensitive (at
  166. ;; least in 'en_US' locale on libc 2.18.) Conversely,
  167. ;; we want files to be sorted in a case-sensitive
  168. ;; fashion.
  169. (scandir f (const #t) string<?))))
  170. (for-each (lambda (e)
  171. (let ((f (string-append f "/" e)))
  172. (write-string "entry" p)
  173. (write-string "(" p)
  174. (write-string "name" p)
  175. (write-string e p)
  176. (write-string "node" p)
  177. (dump f)
  178. (write-string ")" p)))
  179. entries)))
  180. ((symlink)
  181. (write-string "type" p)
  182. (write-string "symlink" p)
  183. (write-string "target" p)
  184. (write-string (readlink f) p))
  185. (else
  186. (raise (condition (&message (message "unsupported file type"))
  187. (&nar-error (file f) (port port))))))
  188. (write-string ")" p))))
  189. (define (restore-file port file)
  190. "Read a file (possibly a directory structure) in Nar format from PORT.
  191. Restore it as FILE."
  192. (let ((signature (read-string port)))
  193. (unless (equal? signature %archive-version-1)
  194. (raise
  195. (condition (&message (message "invalid nar signature"))
  196. (&nar-read-error (port port)
  197. (token signature)
  198. (file #f))))))
  199. (let restore ((file file))
  200. (define (read-eof-marker)
  201. (match (read-string port)
  202. (")" #t)
  203. (x (raise
  204. (condition
  205. (&message (message "invalid nar end-of-file marker"))
  206. (&nar-read-error (port port) (file file) (token x)))))))
  207. (match (list (read-string port) (read-string port) (read-string port))
  208. (("(" "type" "regular")
  209. (call-with-output-file file (cut read-contents port <>))
  210. (read-eof-marker))
  211. (("(" "type" "symlink")
  212. (match (list (read-string port) (read-string port))
  213. (("target" target)
  214. (symlink target file)
  215. (read-eof-marker))
  216. (x (raise
  217. (condition
  218. (&message (message "invalid symlink tokens"))
  219. (&nar-read-error (port port) (file file) (token x)))))))
  220. (("(" "type" "directory")
  221. (let ((dir file))
  222. (mkdir dir)
  223. (let loop ((prefix (read-string port)))
  224. (match prefix
  225. ("entry"
  226. (match (list (read-string port)
  227. (read-string port) (read-string port)
  228. (read-string port))
  229. (("(" "name" file "node")
  230. (restore (string-append dir "/" file))
  231. (match (read-string port)
  232. (")" #t)
  233. (x
  234. (raise
  235. (condition
  236. (&message
  237. (message "unexpected directory entry termination"))
  238. (&nar-read-error (port port)
  239. (file file)
  240. (token x))))))
  241. (loop (read-string port)))))
  242. (")" #t) ; done with DIR
  243. (x
  244. (raise
  245. (condition
  246. (&message (message "unexpected directory inter-entry marker"))
  247. (&nar-read-error (port port) (file file) (token x)))))))))
  248. (x
  249. (raise
  250. (condition
  251. (&message (message "unsupported nar entry type"))
  252. (&nar-read-error (port port) (file file) (token x))))))))
  253. ;;;
  254. ;;; Restoring a file set into the store.
  255. ;;;
  256. ;; The code below accesses the store directly and is meant to be run from
  257. ;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
  258. ;; (1) the locks on the files to be restored as already held, and (2) the
  259. ;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
  260. ;;
  261. ;; So we're really duplicating that functionality of the daemon (well, until
  262. ;; most of the daemon is in Scheme :-)). But note that we do use a couple of
  263. ;; RPCs for functionality not available otherwise, like 'valid-path?'.
  264. (define (lock-store-file file)
  265. "Acquire exclusive access to FILE, a store file."
  266. (call-with-output-file (string-append file ".lock")
  267. (cut fcntl-flock <> 'write-lock)))
  268. (define (unlock-store-file file)
  269. "Release access to FILE."
  270. (call-with-input-file (string-append file ".lock")
  271. (cut fcntl-flock <> 'unlock)))
  272. (define* (finalize-store-file source target
  273. #:key (references '()) deriver (lock? #t))
  274. "Rename SOURCE to TARGET and register TARGET as a valid store item, with
  275. REFERENCES and DERIVER. When LOCK? is true, acquire exclusive locks on TARGET
  276. before attempting to register it; otherwise, assume TARGET's locks are already
  277. held."
  278. ;; XXX: Currently we have to call out to the daemon to check whether TARGET
  279. ;; is valid.
  280. (with-store store
  281. (unless (valid-path? store target)
  282. (when lock?
  283. (lock-store-file target))
  284. (unless (valid-path? store target)
  285. ;; If FILE already exists, delete it (it's invalid anyway.)
  286. (when (file-exists? target)
  287. (delete-file-recursively target))
  288. ;; Install the new TARGET.
  289. (rename-file source target)
  290. ;; Register TARGET. As a side effect, it resets the timestamps of all
  291. ;; its files, recursively, and runs a deduplication pass.
  292. (register-path target
  293. #:references references
  294. #:deriver deriver))
  295. (when lock?
  296. (unlock-store-file target)))))
  297. (define (temporary-store-file)
  298. "Return the file name of a temporary file created in the store."
  299. (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
  300. (port (mkstemp! template)))
  301. (close-port port)
  302. template))
  303. (define-syntax-rule (with-temporary-store-file name body ...)
  304. "Evaluate BODY with NAME bound to the file name of a temporary store item
  305. protected from GC."
  306. (let loop ((name (temporary-store-file)))
  307. (with-store store
  308. ;; Add NAME to the current process' roots. (Opening this connection to
  309. ;; the daemon allows us to reuse its code that deals with the
  310. ;; per-process roots file.)
  311. (add-temp-root store name)
  312. ;; There's a window during which GC could delete NAME. Try again when
  313. ;; that happens.
  314. (if (file-exists? name)
  315. (begin
  316. (delete-file name)
  317. body ...)
  318. (loop (temporary-store-file))))))
  319. (define* (restore-one-item port
  320. #:key acl (verify-signature? #t) (lock? #t)
  321. (log-port (current-error-port)))
  322. "Restore one store item from PORT; return its file name on success."
  323. (define (assert-valid-signature signature hash file)
  324. ;; Bail out if SIGNATURE, which must be a string as produced by
  325. ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
  326. ;; the expected hash for FILE.
  327. (let ((signature (catch 'gcry-error
  328. (lambda ()
  329. (string->canonical-sexp signature))
  330. (lambda (key proc err)
  331. (raise (condition
  332. (&message
  333. (message "signature is not a valid \
  334. s-expression"))
  335. (&nar-signature-error
  336. (file file)
  337. (signature signature) (port port))))))))
  338. (signature-case (signature hash (current-acl))
  339. (valid-signature #t)
  340. (invalid-signature
  341. (raise (condition
  342. (&message (message "invalid signature"))
  343. (&nar-signature-error
  344. (file file) (signature signature) (port port)))))
  345. (hash-mismatch
  346. (raise (condition (&message (message "invalid hash"))
  347. (&nar-invalid-hash-error
  348. (port port) (file file)
  349. (signature signature)
  350. (expected (hash-data->bytevector
  351. (signature-signed-data signature)))
  352. (actual hash)))))
  353. (unauthorized-key
  354. (raise (condition (&message (message "unauthorized public key"))
  355. (&nar-signature-error
  356. (signature signature) (file file) (port port)))))
  357. (corrupt-signature
  358. (raise (condition
  359. (&message (message "corrupt signature data"))
  360. (&nar-signature-error
  361. (signature signature) (file file) (port port))))))))
  362. (define %export-magic
  363. ;; Number used to identify genuine file set archives.
  364. #x4558494e)
  365. (define port*
  366. ;; Keep that one around, for error conditions.
  367. port)
  368. (let-values (((port get-hash)
  369. (open-sha256-input-port port)))
  370. (with-temporary-store-file temp
  371. (restore-file port temp)
  372. (let ((magic (read-int port)))
  373. (unless (= magic %export-magic)
  374. (raise (condition
  375. (&message (message "corrupt file set archive"))
  376. (&nar-read-error
  377. (port port*) (file #f) (token #f))))))
  378. (let ((file (read-store-path port))
  379. (refs (read-store-path-list port))
  380. (deriver (read-string port))
  381. (hash (get-hash))
  382. (has-sig? (= 1 (read-int port))))
  383. (format log-port
  384. (_ "importing file or directory '~a'...~%")
  385. file)
  386. (let ((sig (and has-sig? (read-string port))))
  387. (when verify-signature?
  388. (if sig
  389. (begin
  390. (assert-valid-signature sig hash file)
  391. (format log-port
  392. (_ "found valid signature for '~a'~%")
  393. file)
  394. (finalize-store-file temp file
  395. #:references refs
  396. #:deriver deriver
  397. #:lock? lock?))
  398. (raise (condition
  399. (&message (message "imported file lacks \
  400. a signature"))
  401. (&nar-signature-error
  402. (port port*) (file file) (signature #f))))))
  403. file)))))
  404. (define* (restore-file-set port
  405. #:key (verify-signature? #t) (lock? #t)
  406. (log-port (current-error-port)))
  407. "Restore the file set read from PORT to the store. The format of the data
  408. on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted
  409. archives with interspersed meta-data joining them together, possibly with a
  410. digital signature at the end. Log progress to LOG-PORT. Return the list of
  411. files restored.
  412. When LOCK? is #f, assume locks for the files to be restored are already held.
  413. This is the case when the daemon calls a build hook.
  414. Note that this procedure accesses the store directly, so it's only meant to be
  415. used by the daemon's build hooks since they cannot call back to the daemon
  416. while the locks are held."
  417. (define acl
  418. (current-acl))
  419. (let loop ((n (read-long-long port))
  420. (files '()))
  421. (case n
  422. ((0)
  423. (reverse files))
  424. ((1)
  425. (let ((file
  426. (restore-one-item port
  427. #:acl acl #:verify-signature? verify-signature?
  428. #:lock? lock? #:log-port log-port)))
  429. (loop (read-long-long port)
  430. (cons file files))))
  431. (else
  432. ;; Neither 0 nor 1.
  433. (raise (condition
  434. (&message (message "invalid inter-file archive mark"))
  435. (&nar-read-error
  436. (port port) (file #f) (token #f))))))))
  437. ;;; Local Variables:
  438. ;;; eval: (put 'with-temporary-store-file 'scheme-indent-function 1)
  439. ;;; End:
  440. ;;; nar.scm ends here