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.
 
 
 
 
 
 

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