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.
 
 
 
 
 
 

417 lines
15 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 (test-nar)
  19. #:use-module (guix tests)
  20. #:use-module (guix nar)
  21. #:use-module (guix serialization)
  22. #:use-module (guix store)
  23. #:use-module ((gcrypt hash)
  24. #:select (open-sha256-port open-sha256-input-port))
  25. #:use-module ((guix packages)
  26. #:select (base32))
  27. #:use-module (rnrs bytevectors)
  28. #:use-module (rnrs io ports)
  29. #:use-module (srfi srfi-1)
  30. #:use-module (srfi srfi-11)
  31. #:use-module (srfi srfi-26)
  32. #:use-module (srfi srfi-34)
  33. #:use-module (srfi srfi-35)
  34. #:use-module (srfi srfi-64)
  35. #:use-module (ice-9 ftw)
  36. #:use-module (ice-9 regex)
  37. #:use-module ((ice-9 control) #:select (let/ec))
  38. #:use-module (ice-9 match))
  39. ;; Test the (guix nar) module.
  40. ;;;
  41. ;;; File system testing tools, initially contributed to Guile, then libchop.
  42. ;;;
  43. (define (random-file-size)
  44. (define %average (* 1024 512)) ; 512 KiB
  45. (define %stddev (* 1024 64)) ; 64 KiB
  46. (inexact->exact
  47. (max 0 (round (+ %average (* %stddev (random:normal)))))))
  48. (define (make-file-tree dir tree)
  49. "Make file system TREE at DIR."
  50. (let loop ((dir dir)
  51. (tree tree))
  52. (define (scope file)
  53. (string-append dir "/" file))
  54. (match tree
  55. (('directory name (body ...))
  56. (mkdir (scope name))
  57. (for-each (cute loop (scope name) <>) body))
  58. (('directory name (? integer? mode) (body ...))
  59. (mkdir (scope name))
  60. (for-each (cute loop (scope name) <>) body)
  61. (chmod (scope name) mode))
  62. ((file)
  63. (populate-file (scope file) (random-file-size)))
  64. ((file (? integer? mode))
  65. (populate-file (scope file) (random-file-size))
  66. (chmod (scope file) mode))
  67. ((from '-> to)
  68. (symlink to (scope from))))))
  69. (define (delete-file-tree dir tree)
  70. "Delete file TREE from DIR."
  71. (let loop ((dir dir)
  72. (tree tree))
  73. (define (scope file)
  74. (string-append dir "/" file))
  75. (match tree
  76. (('directory name (body ...))
  77. (for-each (cute loop (scope name) <>) body)
  78. (rmdir (scope name)))
  79. (('directory name (? integer? mode) (body ...))
  80. (chmod (scope name) #o755) ; make sure it can be entered
  81. (for-each (cute loop (scope name) <>) body)
  82. (rmdir (scope name)))
  83. ((from '-> _)
  84. (delete-file (scope from)))
  85. ((file _ ...)
  86. (delete-file (scope file))))))
  87. (define-syntax-rule (with-file-tree dir tree body ...)
  88. (dynamic-wind
  89. (lambda ()
  90. (make-file-tree dir 'tree))
  91. (lambda ()
  92. body ...)
  93. (lambda ()
  94. (delete-file-tree dir 'tree))))
  95. (define (file-tree-equal? input output)
  96. "Return #t if the file trees at INPUT and OUTPUT are equal."
  97. (define strip
  98. (cute string-drop <> (string-length input)))
  99. (define sibling
  100. (compose (cut string-append output <>) strip))
  101. (file-system-fold (const #t)
  102. (lambda (name stat result) ; leaf
  103. (and result
  104. (file=? name (sibling name))))
  105. (lambda (name stat result) ; down
  106. result)
  107. (lambda (name stat result) ; up
  108. result)
  109. (const #f) ; skip
  110. (lambda (name stat errno result)
  111. (pk 'error name stat errno)
  112. #f)
  113. #t ; result
  114. input
  115. lstat))
  116. (define (populate-file file size)
  117. (call-with-output-file file
  118. (lambda (p)
  119. (put-bytevector p (random-bytevector size)))))
  120. (define (rm-rf dir)
  121. (file-system-fold (const #t) ; enter?
  122. (lambda (file stat result) ; leaf
  123. (delete-file file))
  124. (const #t) ; down
  125. (lambda (dir stat result) ; up
  126. (rmdir dir))
  127. (const #t) ; skip
  128. (const #t) ; error
  129. #t
  130. dir
  131. lstat))
  132. (define %test-dir
  133. ;; An output directory under $top_builddir.
  134. (string-append (dirname (search-path %load-path "pre-inst-env"))
  135. "/test-nar-" (number->string (getpid))))
  136. (test-begin "nar")
  137. (test-assert "write-file-tree + restore-file"
  138. (let* ((file1 (search-path %load-path "guix.scm"))
  139. (file2 (search-path %load-path "guix/base32.scm"))
  140. (file3 "#!/bin/something")
  141. (output (string-append %test-dir "/output")))
  142. (dynamic-wind
  143. (lambda () #t)
  144. (lambda ()
  145. (define-values (port get-bytevector)
  146. (open-bytevector-output-port))
  147. (write-file-tree "root" port
  148. #:file-type+size
  149. (match-lambda
  150. ("root"
  151. (values 'directory 0))
  152. ("root/foo"
  153. (values 'regular (stat:size (stat file1))))
  154. ("root/lnk"
  155. (values 'symlink 0))
  156. ("root/dir"
  157. (values 'directory 0))
  158. ("root/dir/bar"
  159. (values 'regular (stat:size (stat file2))))
  160. ("root/dir/exe"
  161. (values 'executable (string-length file3))))
  162. #:file-port
  163. (match-lambda
  164. ("root/foo" (open-input-file file1))
  165. ("root/dir/bar" (open-input-file file2))
  166. ("root/dir/exe" (open-input-string file3)))
  167. #:symlink-target
  168. (match-lambda
  169. ("root/lnk" "foo"))
  170. #:directory-entries
  171. (match-lambda
  172. ("root" '("foo" "dir" "lnk"))
  173. ("root/dir" '("bar" "exe"))))
  174. (close-port port)
  175. (rm-rf %test-dir)
  176. (mkdir %test-dir)
  177. (restore-file (open-bytevector-input-port (get-bytevector))
  178. output)
  179. (and (file=? (string-append output "/foo") file1)
  180. (string=? (readlink (string-append output "/lnk"))
  181. "foo")
  182. (file=? (string-append output "/dir/bar") file2)
  183. (string=? (call-with-input-file (string-append output "/dir/exe")
  184. get-string-all)
  185. file3)
  186. (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
  187. #o100)
  188. 0)
  189. (equal? '("." ".." "bar" "exe")
  190. (scandir (string-append output "/dir")))
  191. (equal? '("." ".." "dir" "foo" "lnk")
  192. (scandir output))))
  193. (lambda ()
  194. (false-if-exception (rm-rf %test-dir))))))
  195. (test-assert "write-file supports non-file output ports"
  196. (let ((input (string-append (dirname (search-path %load-path "guix.scm"))
  197. "/guix"))
  198. (output (%make-void-port "w")))
  199. (write-file input output)
  200. #t))
  201. (test-equal "write-file puts file in C locale collation order"
  202. (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
  203. (let ((input (string-append %test-dir ".input")))
  204. (dynamic-wind
  205. (lambda ()
  206. (define (touch file)
  207. (call-with-output-file (string-append input "/" file)
  208. (const #t)))
  209. (mkdir input)
  210. (touch "B")
  211. (touch "Z")
  212. (touch "a")
  213. (symlink "B" (string-append input "/z")))
  214. (lambda ()
  215. (let-values (((port get-hash) (open-sha256-port)))
  216. (write-file input port)
  217. (close-port port)
  218. (get-hash)))
  219. (lambda ()
  220. (rm-rf input)))))
  221. (test-equal "restore-file with incomplete input"
  222. (string-append %test-dir "/foo")
  223. (let ((port (open-bytevector-input-port #vu8(1 2 3))))
  224. (guard (c ((nar-error? c)
  225. (and (eq? port (nar-error-port c))
  226. (nar-error-file c))))
  227. (restore-file port (string-append %test-dir "/foo"))
  228. #f)))
  229. (test-assert "write-file + restore-file"
  230. (let* ((input (string-append (dirname (search-path %load-path "guix.scm"))
  231. "/guix"))
  232. (output %test-dir)
  233. (nar (string-append output ".nar")))
  234. (dynamic-wind
  235. (lambda () #t)
  236. (lambda ()
  237. (call-with-output-file nar
  238. (cut write-file input <>))
  239. (call-with-input-file nar
  240. (cut restore-file <> output))
  241. (file-tree-equal? input output))
  242. (lambda ()
  243. (false-if-exception (delete-file nar))
  244. (false-if-exception (rm-rf output))))))
  245. (test-assert "write-file + restore-file with symlinks"
  246. (let ((input (string-append %test-dir ".input")))
  247. (mkdir input)
  248. (dynamic-wind
  249. (const #t)
  250. (lambda ()
  251. (with-file-tree input
  252. (directory "root"
  253. (("reg") ("exe" #o777) ("sym" -> "reg")))
  254. (let* ((output %test-dir)
  255. (nar (string-append output ".nar")))
  256. (dynamic-wind
  257. (lambda () #t)
  258. (lambda ()
  259. (call-with-output-file nar
  260. (cut write-file input <>))
  261. (call-with-input-file nar
  262. (cut restore-file <> output))
  263. (file-tree-equal? input output))
  264. (lambda ()
  265. (false-if-exception (delete-file nar))
  266. (false-if-exception (rm-rf output)))))))
  267. (lambda ()
  268. (rmdir input)))))
  269. (test-assert "write-file #:select? + restore-file"
  270. (let ((input (string-append %test-dir ".input")))
  271. (mkdir input)
  272. (dynamic-wind
  273. (const #t)
  274. (lambda ()
  275. (with-file-tree input
  276. (directory "root"
  277. ((directory "a" (("x") ("y") ("z")))
  278. ("b") ("c") ("d" -> "b")))
  279. (let* ((output %test-dir)
  280. (nar (string-append output ".nar")))
  281. (dynamic-wind
  282. (lambda () #t)
  283. (lambda ()
  284. (call-with-output-file nar
  285. (lambda (port)
  286. (write-file input port
  287. #:select?
  288. (lambda (file stat)
  289. (and (not (string=? (basename file)
  290. "a"))
  291. (not (eq? (stat:type stat)
  292. 'symlink)))))))
  293. (call-with-input-file nar
  294. (cut restore-file <> output))
  295. ;; Make sure "a" and "d" have been filtered out.
  296. (and (not (file-exists? (string-append output "/root/a")))
  297. (file=? (string-append output "/root/b")
  298. (string-append input "/root/b"))
  299. (file=? (string-append output "/root/c")
  300. (string-append input "/root/c"))
  301. (not (file-exists? (string-append output "/root/d")))))
  302. (lambda ()
  303. (false-if-exception (delete-file nar))
  304. (false-if-exception (rm-rf output)))))))
  305. (lambda ()
  306. (rmdir input)))))
  307. ;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
  308. ;; relies on a Guile 2.0.10+ feature.
  309. (test-skip (if (false-if-exception
  310. (open-sha256-input-port (%make-void-port "r")))
  311. 0
  312. 3))
  313. (test-assert "restore-file-set (signed, valid)"
  314. (with-store store
  315. (let* ((texts (unfold (cut >= <> 10)
  316. (lambda _ (random-text))
  317. 1+
  318. 0))
  319. (files (map (cut add-text-to-store store "text" <>) texts))
  320. (dump (call-with-bytevector-output-port
  321. (cut export-paths store files <>))))
  322. (delete-paths store files)
  323. (and (every (negate file-exists?) files)
  324. (let* ((source (open-bytevector-input-port dump))
  325. (imported (restore-file-set source)))
  326. (and (equal? imported files)
  327. (every (lambda (file)
  328. (and (file-exists? file)
  329. (valid-path? store file)))
  330. files)
  331. (equal? texts
  332. (map (lambda (file)
  333. (call-with-input-file file
  334. get-string-all))
  335. files))))))))
  336. (test-assert "restore-file-set (missing signature)"
  337. (let/ec return
  338. (with-store store
  339. (let* ((file (add-text-to-store store "foo" (random-text)))
  340. (dump (call-with-bytevector-output-port
  341. (cute export-paths store (list file) <>
  342. #:sign? #f))))
  343. (delete-paths store (list file))
  344. (and (not (file-exists? file))
  345. (let ((source (open-bytevector-input-port dump)))
  346. (guard (c ((nar-signature-error? c)
  347. (let ((message (condition-message c))
  348. (port (nar-error-port c)))
  349. (return
  350. (and (string-match "lacks.*signature" message)
  351. (string=? file (nar-error-file c))
  352. (eq? source port))))))
  353. (restore-file-set source))
  354. #f))))))
  355. (test-assert "restore-file-set (corrupt)"
  356. (let/ec return
  357. (with-store store
  358. (let* ((file (add-text-to-store store "foo"
  359. (random-text)))
  360. (dump (call-with-bytevector-output-port
  361. (cute export-paths store (list file) <>))))
  362. (delete-paths store (list file))
  363. ;; Flip a byte in the file contents.
  364. (let* ((index 120)
  365. (byte (bytevector-u8-ref dump index)))
  366. (bytevector-u8-set! dump index (logxor #xff byte)))
  367. (and (not (file-exists? file))
  368. (let ((source (open-bytevector-input-port dump)))
  369. (guard (c ((nar-invalid-hash-error? c)
  370. (let ((message (condition-message c))
  371. (port (nar-error-port c)))
  372. (return
  373. (and (string-contains message "hash")
  374. (string=? file (nar-error-file c))
  375. (eq? source port))))))
  376. (restore-file-set source))
  377. #f))))))
  378. (test-end "nar")
  379. ;;; Local Variables:
  380. ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
  381. ;;; End: