“纯” SHA256的方案实施（R5RS）？ [英] A "pure" scheme implementation (R5RS) of SHA256?

问题描述

我可以在Scheme中使用SHA256，使用外部库（Java，C或系统相关）或者使用特定的Scheme实现（如Chicken eg），但是我想知道是否存在纯粹方案实现。 b $ b

解决方案

我今天写了一个实现。唉，R5RS既没有字节向量也没有二进制I / O，所以它使用R7RS API来实现字节向量和二进制I / O。应该很容易将这些API连接到Scheme实现的本地API（例如，我实际上在Racket和Guile上测试了我的实现）。

几个注释： p>

• 该代码假定区分大小写。这是R7RS的默认设置，但不是R5RS，所以如果您使用的是R5RS实现，请注意。


• 它需要SRFIs 1 ， 26 ， 43 和< a href =http://srfi.schemers.org/srfi-60/srfi-60.html =nofollow> 60 。 我强调优雅和速度上的清晰度。实际上，代码很慢。


• 与我的配置文件相反，我只是在 Apache License 2.0 （除了 CC BY-SA 3.0 ），而不是CC0或类似于公有领域的任何东西。
  

不管怎样，这里都是（也可以作为要点）：

  ;;;辅助定义，以避免使用巨大的常量表。 
 
（定义素数80'（2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 
 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 
 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 
 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 
 337 347 349 353 359 367 373 379 383 389 397 401 409））
 
（定义（sqrt x）
（fold（lambda（_ y）（/（+（/ xy）y）2）） 4（iota 7）））
 
（define（cbrt x）
（fold（lambda（_y）（/（+（/ xyy）yy）3））4 ）））
 $ b $（定义（压缩x比例基数）
（按位和（floor（* x（算术转换1比例）））
（ - 移位1个碱基）1）））
 
 ;;;实际的初始化和常量值。 
 $ b $（define sha1-init'（＃x67452301＃xefcdab89＃x98badcfe＃x10325476＃xc3d2e1f0））
（define sha2-init（map（lambda（x）（frac（sqrt x）64 （sha-init-8））
（定义sha256-init（map（切割算法） （转换<> -32）sha512-init））
（定义sha224-init（映射（剪切压缩<> 0 32）sha384-init））
 
 sha1-const（map（lambda（x）（frac（sqrt x）30 32））'（2 3 5 10）））
（define sha512-const（map（lambda（x）（frac（cbrt x ）64）64））素数80））
（定义sha256-const（映射（切换算术移位<> -32）（取sha512-const 64）））
 
 ;; ;压缩和驱动程序功能使用的实用程序功能。 
 $ b $（define（u32 +。xs）（bitwise-and（apply + xs）#xffffffff））
（define（u64 +。xs）（bitwise-and（apply + xs）#xffffffffffffffff ））
（按位和xy）（bitwise-and xz） （定义（bytevector-be-ref bv base n）
（let loop（（res 0）（i 0））
（if（（loop（+ （bytevector-u8-ref bv（+ base i）））
（+ i 1））
 res）））
（bytevector-u64-ref bv i）
（bytevector-be-ref bv（算术移位i 3）8））
（bytevector-u32-ref bv i）
（bytevector-be-ref bv算术转换i 2）4））
 
（define（bytevector-be-set！bv base n val）
（let loop（（in）（val val））
（当（正数？i）
（bytevector-u8-set！bv（+ base i -1）（按位和数值255））
（循环（ -  i 1） val-8）））））
 
（define（md-pad！bv offset count counter-size）
（define b锁定大小（bytevector-length bv））
（除非（负数？ （（i（+ offset 1）））
（当（（bytevector-u8-set！bv offset＃x80））
 
（bytevector-u8-set！bv i 0）
（loop（+ i 1））））
（when count 
（bytevector-be-set！bv（ - 块大小计数器大小）计数器大小
（算术移位计数3））））
 
（define（散列状态 - >字节向量hs trunc字长）
（定义结果（make-bytevector（* trunc word-size）））
（for-each（lambda（hi）
（bytevector-be-set！result i word-size h）） 
 hs（iota trunc 0 word size））
结果）
 
 ;;;压缩功能。 
 
（define（sha2-compress KΣ0Σ1σ0σ1mod + getter hs）
（define W（vector-> list（apply vector-unfold 
（lambda（_ abcdefghijklmnop ）
（values abcdefghijklmnop 
（mod + a（σ0b）j（σ1o））））
（length K）
（list-tabulate 16 getter））））
（定义（循环kwabcdefgh）
（if（null？k）
（map mod + hs（list abcdefgh））
（let（（T1（mod + h（Σ1e）（ （如果efg）（car k）（car w）））
（T2（mod +（Σ0a）（bitwise-majority abc））））
（cdr k）（cdr w） （mod + T1 T2）abc（mod + d T1）efg）））
（apply loop KW hs））
 
（define（sha512-compress bv hs）
 （旋转xy）（旋转位字段x（ -  y）0 64））
（define（shr xy）（arithmetic-shift x（ -  y）））
 （sha2-compress sha512-const 
（lambda（x）（bitwise-xor（rotr x 28）（rotr x 34）（rotr x 39）））
（lambda（x）（bitwise-xor （rotr x 14）（rotr x 18）（rotr x 41）））
（lambda（x）（bitwise-xor（rotr x 1）（rotr x 8）（shr x 7））） b（lambda（x）（bitwise-xor（rotr x 19）（rotr x 61）（shr x 6）））
 u64 +（cut bytevector -u64-ref bv<>）hs））
 $ b $ define（sha256-compress bv hs）
（define（rotr xy）（rotate-bit-field x（-y）0 32））
（define（shr xy） （算术移位x（y）））
（sha2-compress sha256-const 
（lambda（x）（bitwise-xor（rotr x 2）（rotr x 13）（rotr x 22） ））
（lambda（x）（bitwise-xor（rotr x 7）（rotr x 11）（rotr x 25））） （rotr x 18）（shr x 3）））
（lambda（x）（bitwise-xor（rotr x 17）（rotr x 19）（shr x 10）））
 u32 +（cut bytevector - （定义（sha1-compress bv hs））
（define（getter x）（bytevector-u32-ref bv x））
 
 b $ b（define（rotl xy）（rotate-bit-field xy 0 32））
（define W（vector-> list（apply vector-unfold 
（lambda（_abcdefghijklmnop）
（values（abcdefghijklmnop 
（rotl（bitwise-xor acin）1）））
 80 
（list-tabulate 16 getter））））
（define（outer fkwabcde） 
（if（null？ （b）（cc）（dd）（ee））
（地图u32 + hs （（t（u）+（t））（（t） + i 1）（cdr w）T a（rotl b 30）cd））
（outer（cdr f）（cdr k）wabcde）））））
（apply outer（list bitwise-if bitwise-xor按位多数按位xor）
 sha1-const W hs））
 
 ;;; Merkle-Damgård驱动程序功能。 
 
（define（md-loop init compress block-size trunc word-size counter-size in）
（define leftover（ -  block-size counter-size））
定义bv（make-byte vector block size））
（define pad！（cut md-pad！bv< （cut hash-state-> bytevector<> trunc word-size））
 
（let loop（（count 0）（hs init））
（define read-size read-bytevector！bv in））
（cond（（eof-object？read-size）
（pad！0 count）
（hs-> bv（compress bv hs）） ）
（（读取大小块大小）
（循环（+计数读取大小）（compress bv hs）））
（（ $（pad！read-size（+ count read-size））
（hs-> bv（compress bv hs）））
（else 
（pad！read-size＃ f）
（让（（pen（compress bv hs）））
（pad！-1（+ count read-size））
（hs-> bv） ）））））） 
 
 ;;; SHA-512 / t的东西。 
 $ b $（定义sha512 / t-init（map（cut bitwise-xor<>＃xa5a5a5a5a5a5a5a5a5）sha512-init））
（define（make-sha512 / t-init t） 
（define key（string-> utf8（string-appendSHA-512 /（number-> string t））））
（define size（bytevector-length key））
 $（bv（make-bytevector 128））
（bytevector-copy！bv 0 key）
（md-pad！bv size size 16）
（sha512-compress bv sha512 / t-init））
 
（define（make-sha512 / tt）
（定义init（make-sha512 / t-init t））
（定义字（零？（bitwise-and t 63））
（cut md-loop init sha512-compress 128 words 8 16>）
（ lambda（in）
（bytevector-copy 
（md-loop init sha512-compress 128（ceiling words）8 16 in）
 0（arithmetic-shift t -3））））） 
 
 ;;;公共入口点。 
 
（define sha1（cut md-loop sha1-init sha1-compress 64 5 4 8<>））
（define sha224（cut md-loop sha224-init sha256-compress （定义sha256（cut md-loop sha256-init sha256-compress 64 8 4 8>））
（定义sha384（cut md-loop （定义sha512（cut md-loop sha512-init sha512-compress 128 8 8 16>））
（define （定义sha512 / 224（make-sha512 / t 224））
  

我在FIPS 180-4中实现了所有的算法，但是可以去掉任何不需要的东西。

---

如前所述，我在Racket上测试了这一点;我添加到Racket API的定义如下：

  #lang racket 
（require（only-in srfi / 1 iota）
（仅用于srfi / 26 cut）
（仅用于srfi / 43 vector-unfold）
（仅用于srfi / 60按位 - 如果旋转位字段长度] 
（重新命名为球拍/基础[build-list list-tabulate] 
 [bytes-copy！bytevector-copy！] 
 [byte-length bytevector-length] 
 [byte-ref bytevector-u8-ref] 
 [bytes-set！bytevector-u8-set！] 
 [foldl fold] 
 [make-bytes make-bytevector] 
 $ b [string-> bytes / utf-8 string-> utf8] 
 [subbytes bytevector-copy]））
  

这里是Guile的定义（需要2.0.11或更高版本）：

$ p $ （use-modules（srfi srfi-1）（srfi （srfi srfi-43）（srfi srfi-60）
（rnrs字节向量）（冰-9二进制端口））

（define *（bytevector-copy bv＃ ：可选（开始0）（结束（bytevector-length bv）））
（定义副本（make-bytevector（ - 结束开始）））
（bytevector-copy！复制0 bv开始结束）
复制）
（define *（bytevector-copy！to at from＃：可选（开始0）
（结束（bytevector-length from）））
$（（@（rnrs bytevectors）bytevector-copy！）从开始到（ - 结束开始））
（定义*（read-bytevector！bv＃：optional（port（current-input-port） ）（开始0）
（end（bytevector-length bv）））
（get-bytevector-n！port bv start（ - end start）））


对于您选择的实现应该很容易做出类似的事情。

---

我也有一个函数将输出打印为十六进制字符串，以便与各种命令行SHA-1和SHA-2实用程序进行比较（例如 sha1sum ， sha256sum ， sha512sum 等）：

 （define（hex bv）
（define out（open-output-string））
（do（（i 0（+ i 1 ）））
（（> = i（bytevector-length ）（b））（get-output-string out））
（let-values（（（qr）（truncate /（bytevector-u8-ref bv i）16）））
（display（number- > string q 16）out）
（display（number-> string r 16）out））））
  

I can use SHA256 in Scheme using external libraries (Java, C or system dependent) or using a specific Scheme implementation (like Chicken e.g.), but I wonder if there is a "pure" scheme implementation.

解决方案

I wrote an implementation today. Alas, R5RS has neither bytevectors nor binary I/O, so this uses the R7RS APIs for bytevectors and binary I/O. It should be easy to bridge those APIs to your Scheme implementation's native APIs (for example, I actually tested my implementation on Racket and Guile).

A few notes:

• This code assumes case-sensitivity. This is the default for R7RS, but not R5RS, so if you're using an R5RS implementation, beware.
• It requires SRFIs 1, 26, 43, and 60.
• I emphasise elegance and clarity over speed. In fact, the code is quite slow.
• Contrary to what my profile says, I'm only licensing this code under the Apache Licence 2.0 (in addition to the standard Stack Overflow licence of CC BY-SA 3.0), and not under CC0 or anything resembling public domain.

Anyway, without further ado, here it is (also available as a Gist):

;;; Auxiliary definitions to avoid having to use giant tables of constants.

(define primes80 '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73
                   79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157
                   163 167 173 179 181 191 193 197 199 211 223 227 229 233 239
                   241 251 257 263 269 271 277 281 283 293 307 311 313 317 331
                   337 347 349 353 359 367 373 379 383 389 397 401 409))

(define (sqrt x)
  (fold (lambda (_ y) (/ (+ (/ x y) y) 2)) 4 (iota 7)))

(define (cbrt x)
  (fold (lambda (_ y) (/ (+ (/ x y y) y y) 3)) 4 (iota 8)))

(define (frac x scale base)
  (bitwise-and (floor (* x (arithmetic-shift 1 scale)))
               (- (arithmetic-shift 1 base) 1)))

;;; The actual initialisation and constant values.

(define sha1-init '(#x67452301 #xefcdab89 #x98badcfe #x10325476 #xc3d2e1f0))
(define sha2-init (map (lambda (x) (frac (sqrt x) 64 64)) (take primes80 16)))
(define-values (sha512-init sha384-init) (split-at sha2-init 8))
(define sha256-init (map (cut arithmetic-shift <> -32) sha512-init))
(define sha224-init (map (cut frac <> 0 32) sha384-init))

(define sha1-const (map (lambda (x) (frac (sqrt x) 30 32)) '(2 3 5 10)))
(define sha512-const (map (lambda (x) (frac (cbrt x) 64 64)) primes80))
(define sha256-const (map (cut arithmetic-shift <> -32) (take sha512-const 64)))

;;; Utility functions used by the compression and driver functions.

(define (u32+ . xs) (bitwise-and (apply + xs) #xffffffff))
(define (u64+ . xs) (bitwise-and (apply + xs) #xffffffffffffffff))
(define (bitwise-majority x y z)
  (bitwise-xor (bitwise-and x y) (bitwise-and x z) (bitwise-and y z)))

(define (bytevector-be-ref bv base n)
  (let loop ((res 0) (i 0))
    (if (< i n)
        (loop (+ (arithmetic-shift res 8) (bytevector-u8-ref bv (+ base i)))
              (+ i 1))
        res)))
(define (bytevector-u64-ref bv i)
  (bytevector-be-ref bv (arithmetic-shift i 3) 8))
(define (bytevector-u32-ref bv i)
  (bytevector-be-ref bv (arithmetic-shift i 2) 4))

(define (bytevector-be-set! bv base n val)
  (let loop ((i n) (val val))
    (when (positive? i)
      (bytevector-u8-set! bv (+ base i -1) (bitwise-and val 255))
      (loop (- i 1) (arithmetic-shift val -8)))))

(define (md-pad! bv offset count counter-size)
  (define block-size (bytevector-length bv))
  (unless (negative? offset)
    (bytevector-u8-set! bv offset #x80))
  (let loop ((i (+ offset 1)))
    (when (< i block-size)
      (bytevector-u8-set! bv i 0)
      (loop (+ i 1))))
  (when count
    (bytevector-be-set! bv (- block-size counter-size) counter-size
                        (arithmetic-shift count 3))))

(define (hash-state->bytevector hs trunc word-size)
  (define result (make-bytevector (* trunc word-size)))
  (for-each (lambda (h i)
              (bytevector-be-set! result i word-size h))
            hs (iota trunc 0 word-size))
  result)

;;; The compression functions.

(define (sha2-compress K Σ0 Σ1 σ0 σ1 mod+ getter hs)
  (define W (vector->list (apply vector-unfold
                                 (lambda (_ a b c d e f g h i j k l m n o p)
                                   (values a b c d e f g h i j k l m n o p
                                           (mod+ a (σ0 b) j (σ1 o))))
                                 (length K)
                                 (list-tabulate 16 getter))))
  (define (loop k w a b c d e f g h)
    (if (null? k)
        (map mod+ hs (list a b c d e f g h))
        (let ((T1 (mod+ h (Σ1 e) (bitwise-if e f g) (car k) (car w)))
              (T2 (mod+ (Σ0 a) (bitwise-majority a b c))))
          (loop (cdr k) (cdr w) (mod+ T1 T2) a b c (mod+ d T1) e f g))))
  (apply loop K W hs))

(define (sha512-compress bv hs)
  (define (rotr x y) (rotate-bit-field x (- y) 0 64))
  (define (shr x y) (arithmetic-shift x (- y)))
  (sha2-compress sha512-const
                 (lambda (x) (bitwise-xor (rotr x 28) (rotr x 34) (rotr x 39)))
                 (lambda (x) (bitwise-xor (rotr x 14) (rotr x 18) (rotr x 41)))
                 (lambda (x) (bitwise-xor (rotr x 1) (rotr x 8) (shr x 7)))
                 (lambda (x) (bitwise-xor (rotr x 19) (rotr x 61) (shr x 6)))
                 u64+ (cut bytevector-u64-ref bv <>) hs))

(define (sha256-compress bv hs)
  (define (rotr x y) (rotate-bit-field x (- y) 0 32))
  (define (shr x y) (arithmetic-shift x (- y)))
  (sha2-compress sha256-const
                 (lambda (x) (bitwise-xor (rotr x 2) (rotr x 13) (rotr x 22)))
                 (lambda (x) (bitwise-xor (rotr x 6) (rotr x 11) (rotr x 25)))
                 (lambda (x) (bitwise-xor (rotr x 7) (rotr x 18) (shr x 3)))
                 (lambda (x) (bitwise-xor (rotr x 17) (rotr x 19) (shr x 10)))
                 u32+ (cut bytevector-u32-ref bv <>) hs))

(define (sha1-compress bv hs)
  (define (getter x) (bytevector-u32-ref bv x))
  (define (rotl x y) (rotate-bit-field x y 0 32))
  (define W (vector->list (apply vector-unfold
                                 (lambda (_ a b c d e f g h i j k l m n o p)
                                   (values a b c d e f g h i j k l m n o p
                                           (rotl (bitwise-xor a c i n) 1)))
                                 80
                                 (list-tabulate 16 getter))))
  (define (outer f k w a b c d e)
    (if (null? k)
        (map u32+ hs (list a b c d e))
        (let inner ((i 0) (w w) (a a) (b b) (c c) (d d) (e e))
          (if (< i 20)
              (let ((T (u32+ (rotl a 5) ((car f) b c d) e (car k) (car w))))
                (inner (+ i 1) (cdr w) T a (rotl b 30) c d))
              (outer (cdr f) (cdr k) w a b c d e)))))
  (apply outer (list bitwise-if bitwise-xor bitwise-majority bitwise-xor)
               sha1-const W hs))

;;; The Merkle-Damgård "driver" function.

(define (md-loop init compress block-size trunc word-size counter-size in)
  (define leftover (- block-size counter-size))
  (define bv (make-bytevector block-size))
  (define pad! (cut md-pad! bv <> <> counter-size))
  (define hs->bv (cut hash-state->bytevector <> trunc word-size))

  (let loop ((count 0) (hs init))
    (define read-size (read-bytevector! bv in))
    (cond ((eof-object? read-size)
           (pad! 0 count)
           (hs->bv (compress bv hs)))
          ((= read-size block-size)
           (loop (+ count read-size) (compress bv hs)))
          ((< read-size leftover)
           (pad! read-size (+ count read-size))
           (hs->bv (compress bv hs)))
          (else
           (pad! read-size #f)
           (let ((pen (compress bv hs)))
             (pad! -1 (+ count read-size))
             (hs->bv (compress bv pen)))))))

;;; SHA-512/t stuff.

(define sha512/t-init (map (cut bitwise-xor <> #xa5a5a5a5a5a5a5a5) sha512-init))
(define (make-sha512/t-init t)
  (define key (string->utf8 (string-append "SHA-512/" (number->string t))))
  (define size (bytevector-length key))
  (define bv (make-bytevector 128))
  (bytevector-copy! bv 0 key)
  (md-pad! bv size size 16)
  (sha512-compress bv sha512/t-init))

(define (make-sha512/t t)
  (define init (make-sha512/t-init t))
  (define words (arithmetic-shift t -6))
  (if (zero? (bitwise-and t 63))
      (cut md-loop init sha512-compress 128 words 8 16 <>)
      (lambda (in)
        (bytevector-copy
         (md-loop init sha512-compress 128 (ceiling words) 8 16 in)
         0 (arithmetic-shift t -3)))))

;;; Public entry points.

(define sha1 (cut md-loop sha1-init sha1-compress 64 5 4 8 <>))
(define sha224 (cut md-loop sha224-init sha256-compress 64 7 4 8 <>))
(define sha256 (cut md-loop sha256-init sha256-compress 64 8 4 8 <>))
(define sha384 (cut md-loop sha384-init sha512-compress 128 6 8 16 <>))
(define sha512 (cut md-loop sha512-init sha512-compress 128 8 8 16 <>))
(define sha512/256 (make-sha512/t 256))
(define sha512/224 (make-sha512/t 224))

I implemented all the algorithms in FIPS 180-4, but you can strip out whatever you don't need.

---

As mentioned before, I tested this on Racket; the definitions I added to bridge to Racket's APIs are as follows:

#lang racket
(require (only-in srfi/1 iota)
         (only-in srfi/26 cut)
         (only-in srfi/43 vector-unfold)
         (only-in srfi/60 bitwise-if rotate-bit-field)
         (rename-in racket/base [build-list list-tabulate]
                                [bytes-copy! bytevector-copy!]
                                [bytes-length bytevector-length]
                                [bytes-ref bytevector-u8-ref]
                                [bytes-set! bytevector-u8-set!]
                                [foldl fold]
                                [make-bytes make-bytevector]
                                [read-bytes! read-bytevector!]
                                [string->bytes/utf-8 string->utf8]
                                [subbytes bytevector-copy]))

And here are the definitions for Guile (requires version 2.0.11 or above):

(use-modules (srfi srfi-1) (srfi srfi-26) (srfi srfi-43) (srfi srfi-60)
             (rnrs bytevectors) (ice-9 binary-ports))

(define* (bytevector-copy bv #:optional (start 0) (end (bytevector-length bv)))
  (define copy (make-bytevector (- end start)))
  (bytevector-copy! copy 0 bv start end)
  copy)
(define* (bytevector-copy! to at from #:optional (start 0)
                                                 (end (bytevector-length from)))
  ((@ (rnrs bytevectors) bytevector-copy!) from start to at (- end start)))
(define* (read-bytevector! bv #:optional (port (current-input-port)) (start 0)
                                         (end (bytevector-length bv)))
  (get-bytevector-n! port bv start (- end start)))

It should be easy to make something similar for your chosen implementation.

---

I also have a function that prints out the output as a hex string, for ready comparison with various command-line SHA-1 and SHA-2 utilities (e.g., sha1sum, sha256sum, sha512sum, etc.):

(define (hex bv)
  (define out (open-output-string))
  (do ((i 0 (+ i 1)))
      ((>= i (bytevector-length bv)) (get-output-string out))
    (let-values (((q r) (truncate/ (bytevector-u8-ref bv i) 16)))
      (display (number->string q 16) out)
      (display (number->string r 16) out))))

这篇关于“纯” SHA256的方案实施（R5RS）？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！