mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
Add a sha256 fallback that uses Coreutils instead of libchop.
* guix/utils.scm (compile-time-value): Move to the top. (sha256): Add an implementation that uses Coreutils, for when libchop is unavailable.
This commit is contained in:
parent
900f726734
commit
dba6b34bdd
1 changed files with 45 additions and 15 deletions
|
@ -23,15 +23,13 @@ (define-module (guix utils)
|
||||||
#:use-module (srfi srfi-39)
|
#:use-module (srfi srfi-39)
|
||||||
#:use-module (srfi srfi-60)
|
#:use-module (srfi srfi-60)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
|
#:use-module ((rnrs io ports) #:select (put-bytevector))
|
||||||
#:use-module (ice-9 vlist)
|
#:use-module (ice-9 vlist)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
#:autoload (ice-9 popen) (open-pipe*)
|
#:autoload (ice-9 popen) (open-pipe*)
|
||||||
#:autoload (ice-9 rdelim) (read-line)
|
#:autoload (ice-9 rdelim) (read-line)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module ((chop hash)
|
|
||||||
#:select (bytevector-hash
|
|
||||||
hash-method/sha256))
|
|
||||||
#:export (bytevector-quintet-length
|
#:export (bytevector-quintet-length
|
||||||
bytevector->base32-string
|
bytevector->base32-string
|
||||||
bytevector->nix-base32-string
|
bytevector->nix-base32-string
|
||||||
|
@ -50,6 +48,22 @@ (define-module (guix utils)
|
||||||
gnu-triplet->nix-system
|
gnu-triplet->nix-system
|
||||||
%current-system))
|
%current-system))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Compile-time computations.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-syntax compile-time-value
|
||||||
|
(syntax-rules ()
|
||||||
|
"Evaluate the given expression at compile time. The expression must
|
||||||
|
evaluate to a simple datum."
|
||||||
|
((_ exp)
|
||||||
|
(let-syntax ((v (lambda (s)
|
||||||
|
(let ((val exp))
|
||||||
|
(syntax-case s ()
|
||||||
|
(_ #`'#,(datum->syntax s val)))))))
|
||||||
|
v))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Base 32.
|
;;; Base 32.
|
||||||
|
@ -369,7 +383,34 @@ (define bv
|
||||||
|
|
||||||
(define (sha256 bv)
|
(define (sha256 bv)
|
||||||
"Return the SHA256 of BV as a bytevector."
|
"Return the SHA256 of BV as a bytevector."
|
||||||
|
(if (compile-time-value
|
||||||
|
(false-if-exception (resolve-interface '(chop hash))))
|
||||||
|
(let ((bytevector-hash (@ (chop hash) bytevector-hash))
|
||||||
|
(hash-method/sha256 (@ (chop hash) hash-method/sha256)))
|
||||||
(bytevector-hash hash-method/sha256 bv))
|
(bytevector-hash hash-method/sha256 bv))
|
||||||
|
;; XXX: Slow, poor programmer's implementation that uses Coreutils.
|
||||||
|
(let ((in (pipe))
|
||||||
|
(out (pipe))
|
||||||
|
(pid (primitive-fork)))
|
||||||
|
(if (= 0 pid)
|
||||||
|
(begin ; child
|
||||||
|
(close (cdr in))
|
||||||
|
(close (car out))
|
||||||
|
(close 0)
|
||||||
|
(close 1)
|
||||||
|
(dup2 (fileno (car in)) 0)
|
||||||
|
(dup2 (fileno (cdr out)) 1)
|
||||||
|
(execlp "sha256sum" "sha256sum"))
|
||||||
|
(begin ; parent
|
||||||
|
(close (car in))
|
||||||
|
(close (cdr out))
|
||||||
|
(put-bytevector (cdr in) bv)
|
||||||
|
(close (cdr in)) ; EOF
|
||||||
|
(let ((line (car (string-tokenize (read-line (car out))))))
|
||||||
|
(close (car out))
|
||||||
|
(and (and=> (status:exit-val (cdr (waitpid pid)))
|
||||||
|
zero?)
|
||||||
|
(base16-string->bytevector line))))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -377,17 +418,6 @@ (define (sha256 bv)
|
||||||
;;; Nixpkgs.
|
;;; Nixpkgs.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define-syntax compile-time-value
|
|
||||||
(syntax-rules ()
|
|
||||||
"Evaluate the given expression at compile time. The expression must
|
|
||||||
evaluate to a simple datum."
|
|
||||||
((_ exp)
|
|
||||||
(let-syntax ((v (lambda (s)
|
|
||||||
(let ((val exp))
|
|
||||||
(syntax-case s ()
|
|
||||||
(_ #`'#,(datum->syntax s val)))))))
|
|
||||||
v))))
|
|
||||||
|
|
||||||
(define %nixpkgs-directory
|
(define %nixpkgs-directory
|
||||||
(make-parameter
|
(make-parameter
|
||||||
;; Capture the build-time value of $NIXPKGS.
|
;; Capture the build-time value of $NIXPKGS.
|
||||||
|
|
Loading…
Reference in a new issue