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.
 
 
 
 
 
 

584 lines
23 KiB

  1. ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
  2. ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of Guix.
  5. ;;;
  6. ;;; 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. ;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix utils)
  19. #:use-module (srfi srfi-1)
  20. #:use-module (srfi srfi-9)
  21. #:use-module (srfi srfi-26)
  22. #:use-module (srfi srfi-39)
  23. #:use-module (srfi srfi-60)
  24. #:use-module (rnrs bytevectors)
  25. #:use-module ((rnrs io ports) #:select (put-bytevector))
  26. #:use-module (ice-9 vlist)
  27. #:use-module (ice-9 format)
  28. #:autoload (ice-9 popen) (open-pipe*)
  29. #:autoload (ice-9 rdelim) (read-line)
  30. #:use-module (ice-9 regex)
  31. #:use-module (ice-9 match)
  32. #:use-module (ice-9 format)
  33. #:autoload (system foreign) (pointer->procedure)
  34. #:export (bytevector-quintet-length
  35. bytevector->base32-string
  36. bytevector->nix-base32-string
  37. bytevector->base16-string
  38. base32-string->bytevector
  39. nix-base32-string->bytevector
  40. base16-string->bytevector
  41. sha256
  42. %nixpkgs-directory
  43. nixpkgs-derivation
  44. nixpkgs-derivation*
  45. define-record-type*
  46. compile-time-value
  47. memoize
  48. gnu-triplet->nix-system
  49. %current-system))
  50. ;;;
  51. ;;; Compile-time computations.
  52. ;;;
  53. (define-syntax compile-time-value
  54. (syntax-rules ()
  55. "Evaluate the given expression at compile time. The expression must
  56. evaluate to a simple datum."
  57. ((_ exp)
  58. (let-syntax ((v (lambda (s)
  59. (let ((val exp))
  60. (syntax-case s ()
  61. (_ #`'#,(datum->syntax s val)))))))
  62. v))))
  63. ;;;
  64. ;;; Base 32.
  65. ;;;
  66. (define bytevector-quintet-ref
  67. (let* ((ref bytevector-u8-ref)
  68. (ref+ (lambda (bv offset)
  69. (let ((o (+ 1 offset)))
  70. (if (>= o (bytevector-length bv))
  71. 0
  72. (bytevector-u8-ref bv o)))))
  73. (ref0 (lambda (bv offset)
  74. (bit-field (ref bv offset) 3 8)))
  75. (ref1 (lambda (bv offset)
  76. (logior (ash (bit-field (ref bv offset) 0 3) 2)
  77. (bit-field (ref+ bv offset) 6 8))))
  78. (ref2 (lambda (bv offset)
  79. (bit-field (ref bv offset) 1 6)))
  80. (ref3 (lambda (bv offset)
  81. (logior (ash (bit-field (ref bv offset) 0 1) 4)
  82. (bit-field (ref+ bv offset) 4 8))))
  83. (ref4 (lambda (bv offset)
  84. (logior (ash (bit-field (ref bv offset) 0 4) 1)
  85. (bit-field (ref+ bv offset) 7 8))))
  86. (ref5 (lambda (bv offset)
  87. (bit-field (ref bv offset) 2 7)))
  88. (ref6 (lambda (bv offset)
  89. (logior (ash (bit-field (ref bv offset) 0 2) 3)
  90. (bit-field (ref+ bv offset) 5 8))))
  91. (ref7 (lambda (bv offset)
  92. (bit-field (ref bv offset) 0 5)))
  93. (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
  94. (lambda (bv index)
  95. "Return the INDEXth quintet of BV."
  96. (let ((p (vector-ref refs (modulo index 8))))
  97. (p bv (quotient (* index 5) 8))))))
  98. (define bytevector-quintet-ref-right
  99. (let* ((ref bytevector-u8-ref)
  100. (ref+ (lambda (bv offset)
  101. (let ((o (+ 1 offset)))
  102. (if (>= o (bytevector-length bv))
  103. 0
  104. (bytevector-u8-ref bv o)))))
  105. (ref0 (lambda (bv offset)
  106. (bit-field (ref bv offset) 0 5)))
  107. (ref1 (lambda (bv offset)
  108. (logior (bit-field (ref bv offset) 5 8)
  109. (ash (bit-field (ref+ bv offset) 0 2) 3))))
  110. (ref2 (lambda (bv offset)
  111. (bit-field (ref bv offset) 2 7)))
  112. (ref3 (lambda (bv offset)
  113. (logior (bit-field (ref bv offset) 7 8)
  114. (ash (bit-field (ref+ bv offset) 0 4) 1))))
  115. (ref4 (lambda (bv offset)
  116. (logior (bit-field (ref bv offset) 4 8)
  117. (ash (bit-field (ref+ bv offset) 0 1) 4))))
  118. (ref5 (lambda (bv offset)
  119. (bit-field (ref bv offset) 1 6)))
  120. (ref6 (lambda (bv offset)
  121. (logior (bit-field (ref bv offset) 6 8)
  122. (ash (bit-field (ref+ bv offset) 0 3) 2))))
  123. (ref7 (lambda (bv offset)
  124. (bit-field (ref bv offset) 3 8)))
  125. (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
  126. (lambda (bv index)
  127. "Return the INDEXth quintet of BV, assuming quintets start from the
  128. least-significant bits, contrary to what RFC 4648 describes."
  129. (let ((p (vector-ref refs (modulo index 8))))
  130. (p bv (quotient (* index 5) 8))))))
  131. (define (bytevector-quintet-length bv)
  132. "Return the number of quintets (including truncated ones) available in BV."
  133. (ceiling (/ (* (bytevector-length bv) 8) 5)))
  134. (define (bytevector-quintet-fold proc init bv)
  135. "Return the result of applying PROC to each quintet of BV and the result of
  136. the previous application or INIT."
  137. (define len
  138. (bytevector-quintet-length bv))
  139. (let loop ((i 0)
  140. (r init))
  141. (if (= i len)
  142. r
  143. (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))
  144. (define (bytevector-quintet-fold-right proc init bv)
  145. "Return the result of applying PROC to each quintet of BV and the result of
  146. the previous application or INIT."
  147. (define len
  148. (bytevector-quintet-length bv))
  149. (let loop ((i len)
  150. (r init))
  151. (if (zero? i)
  152. r
  153. (let ((j (- i 1)))
  154. (loop j (proc (bytevector-quintet-ref-right bv j) r))))))
  155. (define (make-bytevector->base32-string quintet-fold base32-chars)
  156. (lambda (bv)
  157. "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
  158. (let ((chars (quintet-fold (lambda (q r)
  159. (cons (vector-ref base32-chars q)
  160. r))
  161. '()
  162. bv)))
  163. (list->string (reverse chars)))))
  164. (define %nix-base32-chars
  165. ;; See `libutil/hash.cc'.
  166. #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
  167. #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
  168. #\p #\q #\r #\s #\v #\w #\x #\y #\z))
  169. (define %rfc4648-base32-chars
  170. #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
  171. #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
  172. #\2 #\3 #\4 #\5 #\6 #\7))
  173. (define bytevector->base32-string
  174. (make-bytevector->base32-string bytevector-quintet-fold
  175. %rfc4648-base32-chars))
  176. (define bytevector->nix-base32-string
  177. (make-bytevector->base32-string bytevector-quintet-fold-right
  178. %nix-base32-chars))
  179. (define bytevector-quintet-set!
  180. (let* ((setq! (lambda (bv offset start stop value)
  181. (let ((v (bytevector-u8-ref bv offset))
  182. (w (arithmetic-shift value start))
  183. (m (bitwise-xor (1- (expt 2 stop))
  184. (1- (expt 2 start)))))
  185. (bytevector-u8-set! bv offset
  186. (bitwise-merge m w v)))))
  187. (set0! (lambda (bv offset value)
  188. (setq! bv offset 3 8 value)))
  189. (set1! (lambda (bv offset value)
  190. (setq! bv offset 0 3 (bit-field value 2 5))
  191. (or (= (+ 1 offset) (bytevector-length bv))
  192. (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
  193. (set2! (lambda (bv offset value)
  194. (setq! bv offset 1 6 value)))
  195. (set3! (lambda (bv offset value)
  196. (setq! bv offset 0 1 (bit-field value 4 5))
  197. (or (= (+ 1 offset) (bytevector-length bv))
  198. (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
  199. (set4! (lambda (bv offset value)
  200. (setq! bv offset 0 4 (bit-field value 1 5))
  201. (or (= (+ 1 offset) (bytevector-length bv))
  202. (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1)))))
  203. (set5! (lambda (bv offset value)
  204. (setq! bv offset 2 7 value)))
  205. (set6! (lambda (bv offset value)
  206. (setq! bv offset 0 2 (bit-field value 3 5))
  207. (or (= (+ 1 offset) (bytevector-length bv))
  208. (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
  209. (set7! (lambda (bv offset value)
  210. (setq! bv offset 0 5 value)))
  211. (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
  212. (lambda (bv index value)
  213. "Set the INDEXth quintet of BV to VALUE."
  214. (let ((p (vector-ref sets (modulo index 8))))
  215. (p bv (quotient (* index 5) 8) (logand value #x1f))))))
  216. (define bytevector-quintet-set-right!
  217. (let* ((setq! (lambda (bv offset start stop value)
  218. (let ((v (bytevector-u8-ref bv offset))
  219. (w (arithmetic-shift value start))
  220. (m (bitwise-xor (1- (expt 2 stop))
  221. (1- (expt 2 start)))))
  222. (bytevector-u8-set! bv offset
  223. (bitwise-merge m w v)))))
  224. (set0! (lambda (bv offset value)
  225. (setq! bv offset 0 5 value)))
  226. (set1! (lambda (bv offset value)
  227. (setq! bv offset 5 8 (bit-field value 0 3))
  228. (or (= (+ 1 offset) (bytevector-length bv))
  229. (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
  230. (set2! (lambda (bv offset value)
  231. (setq! bv offset 2 7 value)))
  232. (set3! (lambda (bv offset value)
  233. (setq! bv offset 7 8 (bit-field value 0 1))
  234. (or (= (+ 1 offset) (bytevector-length bv))
  235. (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
  236. (set4! (lambda (bv offset value)
  237. (setq! bv offset 4 8 (bit-field value 0 4))
  238. (or (= (+ 1 offset) (bytevector-length bv))
  239. (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
  240. (set5! (lambda (bv offset value)
  241. (setq! bv offset 1 6 value)))
  242. (set6! (lambda (bv offset value)
  243. (setq! bv offset 6 8 (bit-field value 0 2))
  244. (or (= (+ 1 offset) (bytevector-length bv))
  245. (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
  246. (set7! (lambda (bv offset value)
  247. (setq! bv offset 3 8 value)))
  248. (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
  249. (lambda (bv index value)
  250. "Set the INDEXth quintet of BV to VALUE, assuming quintets start from
  251. the least-significant bits."
  252. (let ((p (vector-ref sets (modulo index 8))))
  253. (p bv (quotient (* index 5) 8) (logand value #x1f))))))
  254. (define (base32-string-unfold f s)
  255. "Given procedure F which, when applied to a character, returns the
  256. corresponding quintet, return the bytevector corresponding to string S."
  257. (define len (string-length s))
  258. (let ((bv (make-bytevector (quotient (* len 5) 8))))
  259. (string-fold (lambda (chr index)
  260. (bytevector-quintet-set! bv index (f chr))
  261. (+ 1 index))
  262. 0
  263. s)
  264. bv))
  265. (define (base32-string-unfold-right f s)
  266. "Given procedure F which, when applied to a character, returns the
  267. corresponding quintet, return the bytevector corresponding to string S,
  268. starting from the right of S."
  269. (define len (string-length s))
  270. (let ((bv (make-bytevector (quotient (* len 5) 8))))
  271. (string-fold-right (lambda (chr index)
  272. (bytevector-quintet-set-right! bv index (f chr))
  273. (+ 1 index))
  274. 0
  275. s)
  276. bv))
  277. (define (make-base32-string->bytevector base32-string-unfold base32-chars)
  278. (let ((char->value (let loop ((i 0)
  279. (v vlist-null))
  280. (if (= i (vector-length base32-chars))
  281. v
  282. (loop (+ 1 i)
  283. (vhash-consv (vector-ref base32-chars i)
  284. i v))))))
  285. (lambda (s)
  286. "Return the binary representation of base32 string S as a bytevector."
  287. (base32-string-unfold (lambda (chr)
  288. (or (and=> (vhash-assv chr char->value) cdr)
  289. (error "invalid base32 character" chr)))
  290. s))))
  291. (define base32-string->bytevector
  292. (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))
  293. (define nix-base32-string->bytevector
  294. (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))
  295. ;;;
  296. ;;; Base 16.
  297. ;;;
  298. (define (bytevector->base16-string bv)
  299. "Return the hexadecimal representation of BV's contents."
  300. (define len
  301. (bytevector-length bv))
  302. (let-syntax ((base16-chars (lambda (s)
  303. (syntax-case s ()
  304. (_
  305. (let ((v (list->vector
  306. (unfold (cut > <> 255)
  307. (lambda (n)
  308. (format #f "~2,'0x" n))
  309. 1+
  310. 0))))
  311. v))))))
  312. (define chars base16-chars)
  313. (let loop ((i 0)
  314. (r '()))
  315. (if (= i len)
  316. (string-concatenate-reverse r)
  317. (loop (+ 1 i)
  318. (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))
  319. (define base16-string->bytevector
  320. (let ((chars->value (fold (lambda (i r)
  321. (vhash-consv (string-ref (number->string i 16)
  322. 0)
  323. i r))
  324. vlist-null
  325. (iota 16))))
  326. (lambda (s)
  327. "Return the bytevector whose hexadecimal representation is string S."
  328. (define bv
  329. (make-bytevector (quotient (string-length s) 2) 0))
  330. (string-fold (lambda (chr i)
  331. (let ((j (quotient i 2))
  332. (v (and=> (vhash-assv chr chars->value) cdr)))
  333. (if v
  334. (if (zero? (logand i 1))
  335. (bytevector-u8-set! bv j
  336. (arithmetic-shift v 4))
  337. (let ((w (bytevector-u8-ref bv j)))
  338. (bytevector-u8-set! bv j (logior v w))))
  339. (error "invalid hexadecimal character" chr)))
  340. (+ i 1))
  341. 0
  342. s)
  343. bv)))
  344. ;;;
  345. ;;; Hash.
  346. ;;;
  347. (define %libgcrypt
  348. ;; Name of the libgcrypt shared library.
  349. (compile-time-value (or (getenv "LIBGCRYPT") "libgcrypt")))
  350. (define sha256
  351. (cond
  352. ((compile-time-value
  353. (false-if-exception (dynamic-link %libgcrypt)))
  354. ;; Using libgcrypt.
  355. (let ((hash (pointer->procedure void
  356. (dynamic-func "gcry_md_hash_buffer"
  357. (dynamic-link %libgcrypt))
  358. `(,int * * ,size_t)))
  359. (sha256 8)) ; GCRY_MD_SHA256, as of 1.5.0
  360. (lambda (bv)
  361. "Return the SHA256 of BV as a bytevector."
  362. (let ((digest (make-bytevector (/ 256 8))))
  363. (hash sha256 (bytevector->pointer digest)
  364. (bytevector->pointer bv) (bytevector-length bv))
  365. digest))))
  366. ((compile-time-value
  367. (false-if-exception (resolve-interface '(chop hash))))
  368. ;; Using libchop.
  369. (let ((bytevector-hash (@ (chop hash) bytevector-hash))
  370. (hash-method/sha256 (@ (chop hash) hash-method/sha256)))
  371. (lambda (bv)
  372. "Return the SHA256 of BV as a bytevector."
  373. (bytevector-hash hash-method/sha256 bv))))
  374. (else
  375. ;; Slow, poor programmer's implementation that uses Coreutils.
  376. (lambda (bv)
  377. "Return the SHA256 of BV as a bytevector."
  378. (let ((in (pipe))
  379. (out (pipe))
  380. (pid (primitive-fork)))
  381. (if (= 0 pid)
  382. (begin ; child
  383. (close (cdr in))
  384. (close (car out))
  385. (close 0)
  386. (close 1)
  387. (dup2 (fileno (car in)) 0)
  388. (dup2 (fileno (cdr out)) 1)
  389. (execlp "sha256sum" "sha256sum"))
  390. (begin ; parent
  391. (close (car in))
  392. (close (cdr out))
  393. (put-bytevector (cdr in) bv)
  394. (close (cdr in)) ; EOF
  395. (let ((line (car (string-tokenize (read-line (car out))))))
  396. (close (car out))
  397. (and (and=> (status:exit-val (cdr (waitpid pid)))
  398. zero?)
  399. (base16-string->bytevector line))))))))))
  400. ;;;
  401. ;;; Nixpkgs.
  402. ;;;
  403. (define %nixpkgs-directory
  404. (make-parameter
  405. ;; Capture the build-time value of $NIXPKGS.
  406. (compile-time-value (getenv "NIXPKGS"))))
  407. (define (nixpkgs-derivation attribute)
  408. "Return the derivation path of ATTRIBUTE in Nixpkgs."
  409. (let* ((p (open-pipe* OPEN_READ (or (getenv "NIX_INSTANTIATE")
  410. "nix-instantiate")
  411. "-A" attribute (%nixpkgs-directory)))
  412. (l (read-line p))
  413. (s (close-pipe p)))
  414. (and (zero? (status:exit-val s))
  415. (not (eof-object? l))
  416. l)))
  417. (define-syntax-rule (nixpkgs-derivation* attribute)
  418. "Evaluate the given Nixpkgs derivation at compile-time."
  419. (compile-time-value (nixpkgs-derivation attribute)))
  420. ;;;
  421. ;;; Miscellaneous.
  422. ;;;
  423. (define-syntax define-record-type*
  424. (lambda (s)
  425. "Define the given record type such that an additional \"syntactic
  426. constructor\" is defined, which allows instances to be constructed with named
  427. field initializers, à la SRFI-35, as well as default values."
  428. (define (make-syntactic-constructor name ctor fields defaults)
  429. "Make the syntactic constructor NAME that calls CTOR, and expects all
  430. of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE
  431. tuples."
  432. (with-syntax ((name name)
  433. (ctor ctor)
  434. (expected fields)
  435. (defaults defaults))
  436. #'(define-syntax name
  437. (lambda (s)
  438. (syntax-case s expected
  439. ((_ (field value) (... ...))
  440. (let ((fields (map syntax->datum #'(field (... ...))))
  441. (dflt (map (match-lambda
  442. ((f v)
  443. (list (syntax->datum f) v)))
  444. #'defaults)))
  445. (define (field-value f)
  446. (or (and=> (find (lambda (x)
  447. (eq? f (car (syntax->datum x))))
  448. #'((field value) (... ...)))
  449. car)
  450. (car (assoc-ref dflt (syntax->datum f)))))
  451. (let-syntax ((error*
  452. (syntax-rules ()
  453. ((_ fmt args (... ...))
  454. (syntax-violation 'name
  455. (format #f fmt args
  456. (... ...))
  457. s)))))
  458. (let ((fields (append fields (map car dflt))))
  459. (cond ((lset= eq? fields 'expected)
  460. #`(letrec* ((field value) (... ...))
  461. (ctor #,@(map field-value 'expected))))
  462. ((pair? (lset-difference eq? fields 'expected))
  463. (error* "extraneous field initializers ~a"
  464. (lset-difference eq? fields 'expected)))
  465. (else
  466. (error* "missing field initializers ~a"
  467. (lset-difference eq? 'expected
  468. fields)))))))))))))
  469. (define (field-default-value s)
  470. (syntax-case s (default)
  471. ((field (default val) _ ...)
  472. (list #'field #'val))
  473. ((field _ options ...)
  474. (field-default-value #'(field options ...)))
  475. (_ #f)))
  476. (syntax-case s ()
  477. ((_ type syntactic-ctor ctor pred
  478. (field get options ...) ...)
  479. #`(begin
  480. (define-record-type type
  481. (ctor field ...)
  482. pred
  483. (field get) ...)
  484. #,(make-syntactic-constructor #'syntactic-ctor #'ctor
  485. #'(field ...)
  486. (filter-map field-default-value
  487. #'((field options ...)
  488. ...))))))))
  489. (define (memoize proc)
  490. "Return a memoizing version of PROC."
  491. (let ((cache (make-hash-table)))
  492. (lambda args
  493. (let ((results (hash-ref cache args)))
  494. (if results
  495. (apply values results)
  496. (let ((results (call-with-values (lambda ()
  497. (apply proc args))
  498. list)))
  499. (hash-set! cache args results)
  500. (apply values results)))))))
  501. (define (gnu-triplet->nix-system triplet)
  502. "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
  503. returned by `config.guess'."
  504. (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
  505. =>
  506. (lambda (m)
  507. (string-append "i686-" (match:substring m 1))))
  508. (else triplet))))
  509. (cond ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
  510. =>
  511. (lambda (m)
  512. ;; Nix omits `-gnu' for GNU/Linux.
  513. (string-append (match:substring m 1) "-linux")))
  514. ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
  515. =>
  516. (lambda (m)
  517. ;; Nix strip the version number from names such as `gnu0.3',
  518. ;; `darwin10.2.0', etc., and always strips the vendor part.
  519. (string-append (match:substring m 1) "-"
  520. (match:substring m 3))))
  521. (else triplet))))
  522. (define %current-system
  523. ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
  524. (make-parameter (gnu-triplet->nix-system %host-type)))