mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
hash: Add 'open-sha256-input-port', for Guile > 2.0.9.
* guix/hash.scm (open-sha256-input-port): New procedure. * tests/hash.scm (supports-unbuffered-cbip?): New procedure. ("open-sha256-input-port, empty", "open-sha256-input-port, hello", "open-sha256-input-port, hello, one two", "open-sha256-input-port, hello, read from wrapped port"): New tests.
This commit is contained in:
parent
d28684b5a5
commit
045111e10c
2 changed files with 98 additions and 3 deletions
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -25,7 +25,8 @@ (define-module (guix hash)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:export (sha256
|
#:export (sha256
|
||||||
open-sha256-port
|
open-sha256-port
|
||||||
port-sha256))
|
port-sha256
|
||||||
|
open-sha256-input-port))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
@ -128,4 +129,41 @@ (define (port-sha256 port)
|
||||||
(close-port out)
|
(close-port out)
|
||||||
(get)))
|
(get)))
|
||||||
|
|
||||||
|
(define (open-sha256-input-port port)
|
||||||
|
"Return an input port that wraps PORT and a thunk to get the hash of all the
|
||||||
|
data read from PORT. The thunk always returns the same value."
|
||||||
|
(define md
|
||||||
|
(open-sha256-md))
|
||||||
|
|
||||||
|
(define (read! bv start count)
|
||||||
|
(let ((n (get-bytevector-n! port bv start count)))
|
||||||
|
(if (eof-object? n)
|
||||||
|
0
|
||||||
|
(begin
|
||||||
|
(unless digest
|
||||||
|
(let ((ptr (bytevector->pointer bv start)))
|
||||||
|
(md-write md ptr n)))
|
||||||
|
n))))
|
||||||
|
|
||||||
|
(define digest #f)
|
||||||
|
|
||||||
|
(define (finalize!)
|
||||||
|
(let ((ptr (md-read md 0)))
|
||||||
|
(set! digest (bytevector-copy (pointer->bytevector ptr 32)))
|
||||||
|
(md-close md)))
|
||||||
|
|
||||||
|
(define (get-hash)
|
||||||
|
(unless digest
|
||||||
|
(finalize!))
|
||||||
|
digest)
|
||||||
|
|
||||||
|
(define (unbuffered port)
|
||||||
|
;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports.
|
||||||
|
;; If you get a wrong-type-arg error here, the fix is to upgrade Guile. :-)
|
||||||
|
(setvbuf port _IONBF)
|
||||||
|
port)
|
||||||
|
|
||||||
|
(values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f))
|
||||||
|
get-hash))
|
||||||
|
|
||||||
;;; hash.scm ends here
|
;;; hash.scm ends here
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -37,6 +37,14 @@ (define %hello-sha256
|
||||||
(base16-string->bytevector
|
(base16-string->bytevector
|
||||||
"b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9"))
|
"b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9"))
|
||||||
|
|
||||||
|
(define (supports-unbuffered-cbip?)
|
||||||
|
"Return #t if unbuffered custom binary input ports (CBIPs) are supported.
|
||||||
|
In Guile <= 2.0.9, CBIPs were always fully buffered, so the
|
||||||
|
'open-sha256-input-port' does not work there."
|
||||||
|
(false-if-exception
|
||||||
|
(setvbuf (make-custom-binary-input-port "foo" pk #f #f #f) _IONBF)))
|
||||||
|
|
||||||
|
|
||||||
(test-begin "hash")
|
(test-begin "hash")
|
||||||
|
|
||||||
(test-equal "sha256, empty"
|
(test-equal "sha256, empty"
|
||||||
|
@ -68,6 +76,55 @@ (define %hello-sha256
|
||||||
(equal? (sha256 contents)
|
(equal? (sha256 contents)
|
||||||
(call-with-input-file file port-sha256))))
|
(call-with-input-file file port-sha256))))
|
||||||
|
|
||||||
|
(test-skip (if (supports-unbuffered-cbip?) 0 4))
|
||||||
|
|
||||||
|
(test-equal "open-sha256-input-port, empty"
|
||||||
|
`("" ,%empty-sha256)
|
||||||
|
(let-values (((port get)
|
||||||
|
(open-sha256-input-port (open-string-input-port ""))))
|
||||||
|
(let ((str (get-string-all port)))
|
||||||
|
(list str (get)))))
|
||||||
|
|
||||||
|
(test-equal "open-sha256-input-port, hello"
|
||||||
|
`("hello world" ,%hello-sha256)
|
||||||
|
(let-values (((port get)
|
||||||
|
(open-sha256-input-port
|
||||||
|
(open-bytevector-input-port
|
||||||
|
(string->utf8 "hello world")))))
|
||||||
|
(let ((str (get-string-all port)))
|
||||||
|
(list str (get)))))
|
||||||
|
|
||||||
|
(test-equal "open-sha256-input-port, hello, one two"
|
||||||
|
(list (string->utf8 "hel") (string->utf8 "lo")
|
||||||
|
(base16-string->bytevector ; echo -n hello | sha256sum
|
||||||
|
"2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824")
|
||||||
|
" world")
|
||||||
|
(let-values (((port get)
|
||||||
|
(open-sha256-input-port
|
||||||
|
(open-bytevector-input-port (string->utf8 "hello world")))))
|
||||||
|
(let* ((one (get-bytevector-n port 3))
|
||||||
|
(two (get-bytevector-n port 2))
|
||||||
|
(hash (get))
|
||||||
|
(three (get-string-all port)))
|
||||||
|
(list one two hash three))))
|
||||||
|
|
||||||
|
(test-equal "open-sha256-input-port, hello, read from wrapped port"
|
||||||
|
(list (string->utf8 "hello")
|
||||||
|
(base16-string->bytevector ; echo -n hello | sha256sum
|
||||||
|
"2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824")
|
||||||
|
" world")
|
||||||
|
(let*-values (((wrapped)
|
||||||
|
(open-bytevector-input-port (string->utf8 "hello world")))
|
||||||
|
((port get)
|
||||||
|
(open-sha256-input-port wrapped)))
|
||||||
|
(let* ((hello (get-bytevector-n port 5))
|
||||||
|
(hash (get))
|
||||||
|
|
||||||
|
;; Now read from WRAPPED to make sure its current position is
|
||||||
|
;; correct.
|
||||||
|
(world (get-string-all wrapped)))
|
||||||
|
(list hello hash world))))
|
||||||
|
|
||||||
(test-end)
|
(test-end)
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue