[gnunet-scheme] branch master updated (1b75c50 -> a9dbb6e)

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a change to branch master
in repository gnunet-scheme.

    from 1b75c50  value-parser: Distinguish -0 from +0 as floating point number.
     new bdef145  Makefile.am: Register (gnu gnunet data-string).
     new 1bd999f  data-string: Raise exceptions in case of bogus input.
     new 60cabfe  data-string: Make string->data do less mutation.
     new 324a4fd  data-string: Remove some dead code in string->data.
     new 48ce465  data-string: Small simplification.
     new 9630d22  data-string: Simplify string->data more.
     new e5b3598  hat-let: Allow both _.
     new a9dbb6e  data-string: Do not select imports.

The 8 revisions listed above as "new" are entirely new to this
repository and will be described in separate emails.  The revisions
listed as "add" were already present in the repository and have only
been added to this reference.


Summary of changes:
 Makefile.am                   |   2 +
 gnu/gnunet/crypto.scm         |  10 ++--
 gnu/gnunet/data-string.scm    | 132 ++++++++++++++++++++++--------------------
 gnu/gnunet/hashcode-ascii.scm |   3 +-
 gnu/gnunet/utils/hat-let.scm  |  18 +++---
 tests/crypto.scm              |   1 -
 6 files changed, 89 insertions(+), 77 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 34a4c0a..3a643ea 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -49,6 +49,8 @@ modules = \
   gnu/gnunet/concurrency/repeated-condition.scm \
   gnu/gnunet/concurrency/lost-and-found.scm \
   \
+  gnu/gnunet/data-string.scm \
+  \
   gnu/gnunet/mq/envelope.scm \
   gnu/gnunet/mq/error-reporting.scm \
   gnu/gnunet/mq/handler.scm \
diff --git a/gnu/gnunet/crypto.scm b/gnu/gnunet/crypto.scm
index df6af3b..04d5b28 100644
--- a/gnu/gnunet/crypto.scm
+++ b/gnu/gnunet/crypto.scm
@@ -29,7 +29,7 @@
          (only (gnu gnunet crypto struct)
                /eddsa-public-key /ecdsa-public-key)
          (only (gnu gnunet data-string)
-               string->data)
+               string->data bogus-crockford-base32hex?)
          (only (gnu gnunet netstruct syntactic)
                sizeof)
          (only (gnu gnunet utils hat-let)
@@ -45,7 +45,7 @@
          (only (rnrs conditions)
                define-condition-type &violation)
          (only (rnrs exceptions)
-               raise))
+               raise guard))
   (begin
     ;; TODO: Extend bytevector-hash with offset + length.
     (define (hash-slice/bytevector algorithm slice)
@@ -99,8 +99,10 @@ fresh readable bytevector slice with the hash."
             (! key-length/characters (ceiling-quotient key-length/bits 5))
             (? (not (= key-length/characters (string-length string)))
                (raise-invalid-public-key-encoding)))
-           (or (string->data string key-length/bytes)
-               (raise-invalid-public-key-encoding))))
+           (guard (c ((bogus-crockford-base32hex? c)
+                      ;; TODO: maybe add c to &irritants
+                      (raise-invalid-public-key-encoding)))
+                  (string->data string key-length/bytes))))
 
     ;; TODO: find some test cases
     (define (string->eddsa-public-key string)
diff --git a/gnu/gnunet/data-string.scm b/gnu/gnunet/data-string.scm
index 8464d3d..041d382 100644
--- a/gnu/gnunet/data-string.scm
+++ b/gnu/gnunet/data-string.scm
@@ -23,13 +23,21 @@
 ;;     (The alternative encodings aren't generated by GNUnet anyway)
 ;;     TODO: perhaps reject alternate encodings (e.g. "00" and "01" both
 ;;     decode to 0 currently)
+;;
+;; Mini-changelog:
+;;   * (2 0): Instead of returning #false, raise an exception, in string->data.
 
-(library (gnu gnunet data-string (1 1))
-  (export data->string string->data)
+(library (gnu gnunet data-string (2 0))
+  (export data->string string->data
+         &bogus-crockford-base32hex
+         make-bogus-crockford-base32hex bogus-crockford-base32hex?)
   (import (rnrs base)
           (rnrs control)
+          (rnrs conditions)
+          (rnrs exceptions)
          (rnrs bytevectors)
-         (rnrs arithmetic bitwise))
+         (rnrs arithmetic bitwise)
+         (gnu gnunet utils hat-let))
 
   (define charset "0123456789ABCDEFGHJKMNPQRSTVWXYZ")
 
@@ -66,9 +74,19 @@ of the C implementation.
              (begin (assert (= 0 vbit))
                     (apply string (reverse accumulated))))))))
 
+  ;; TODO: appropriate supertype
+  ;; TODO: fields!
+  ;; TODO: &who
+  (define-condition-type &bogus-crockford-base32hex &condition
+    make-bogus-crockford-base32hex bogus-crockford-base32hex?)
+
+  (define (raise-bogus-crockford-base32hex)
+    (raise (make-bogus-crockford-base32hex)))
+
   (define (get-value ch)
     "Get the decoded value corresponding to a character according to Crockford
-Base32 encoding."
+Base32 encoding.  If @var{ch} does not correspond to anything, raise a
+@code{&bogus-crockford-base32hex} instead."
     (cond ((and (char<=? #\0 ch) (char<=? ch #\9))
           (- (char->integer ch) (char->integer #\0)))
          ((and (char<=? #\A ch) (char<=? ch #\H))
@@ -81,7 +99,7 @@ Base32 encoding."
           (- (char->integer ch) (char->integer #\P) -22))
          ((and (char<=? #\V ch) (char<=? ch #\Z))
           (- (char->integer ch) (char->integer #\V) -27))
-         (else #f)))
+         (else (raise-bogus-crockford-base32hex))))
 
   (define string->data
     (lambda (enc out-size)
@@ -90,65 +108,53 @@ Base32 encoding."
 This corresponds with the @code{GNUNET_STRINGS_string_to_data} function
 of the C implementation.
 
-Return the data as a bytevector on success, or return #f
-if result has the wrong encoding.
+Return the data as a bytevector on success, or raise a
+@code{&bogus-crockford-base32hex} if result has the wrong encoding.
 @var{out-size} must exactly match the size of the data before it was encoded.
 
 @var{enc} the encoding
 @var{out-size} size of output buffer"
-      (let ((rpos (string-length enc))
-           (bits #f)
-           (vbit #f)
-           (ret #f)
-           (shift #f)
-           (encoded-len (* 8 out-size))
-           (uout (make-bytevector out-size)))
-       (if (= 0 (string-length enc))
-           (if (= 0 out-size)
-               #vu8()
-               #f)
-           (begin
-             (if (< 0 (mod encoded-len 5))
-                 (begin ; padding!
-                   (set! vbit (mod encoded-len 5))
-                   (set! shift (- 5 vbit))
-                   (set! rpos (- rpos 1))
-                   (set! ret (get-value (string-ref enc rpos)))
-                   (set! bits (bitwise-arithmetic-shift-right ret shift)))
-                 (begin
-                   (set! vbit 5)
-                   (set! shift 0)
-                   (set! rpos (- rpos 1))
-                   (set! ret (get-value (string-ref enc rpos)))
-                   (set! bits ret)))
-             (cond ((not (= (/ (+ encoded-len shift) 5)
-                            (string-length enc)))
-                    #f)
-                   ((not ret)
-                    #f)
-                   (else
-                    (let loop ((wpos out-size))
-                      (if (> wpos 0)
-                          (begin
-                            (assert (not (= 0 rpos)))
-                            (set! rpos (- rpos 1))
-                            (set! ret (get-value (string-ref enc rpos)))
-                            (set! bits (bitwise-ior
-                                        (bitwise-arithmetic-shift-left
-                                         ret vbit)
-                                        bits))
-                            (and ret
-                                 (begin
-                                   (set! vbit (+ vbit 5))
-                                   (when (>= vbit 8)
-                                     (set! wpos (- wpos 1))
-                                     (bytevector-u8-set! uout wpos
-                                                         (bitwise-and bits
-                                                                      255))
-                                     (set! bits
-                                       (bitwise-arithmetic-shift-right bits 8))
-                                     (set! vbit (- vbit 8)))
-                                   (loop wpos))))
-                          (if (and (= 0 rpos) (= 0 vbit))
-                              uout
-                              #f)))))))))))
+      (let^ ((! rpos (string-length enc))
+            (! encoded-len (* 8 out-size))
+            (! uout (make-bytevector out-size))
+            (? (= 0 (string-length enc))
+               (if (= 0 out-size)
+                   #vu8()
+                   (raise-bogus-crockford-base32hex)))
+            ;; TODO: teach the compiler and optimiser about ceiling-remainder
+            (! vbit
+               (if (< 0 (mod encoded-len 5))
+                   ;; padding!
+                   (mod encoded-len 5)
+                   5))
+            (! shift (- 5 vbit))
+            (! rpos (- rpos 1))
+            (! bits (bitwise-arithmetic-shift-right
+                     (get-value (string-ref enc rpos))
+                     shift))
+            (? (not (= (/ (+ encoded-len shift) 5)
+                       (string-length enc)))
+               (raise-bogus-crockford-base32hex))
+            (/o/ loop
+                 (wpos out-size)
+                 (rpos rpos)
+                 (bits bits)
+                 (vbit vbit))
+            (? (<= wpos 0)
+               (if (and (= 0 rpos) (= 0 vbit))
+                   uout
+                   (raise-bogus-crockford-base32hex)))
+            (!! (not (= 0 rpos)))
+            (! rpos (- rpos 1))
+            (! ret (get-value (string-ref enc rpos)))
+            (! bits (bitwise-ior
+                     (bitwise-arithmetic-shift-left ret vbit)
+                     bits))
+            (! vbit (+ vbit 5))
+            (? (< vbit 8)
+               (loop wpos rpos bits vbit))
+            (! wpos (- wpos 1))
+            (_ (bytevector-u8-set! uout wpos (bitwise-and bits 255)))
+            (! bits (bitwise-arithmetic-shift-right bits 8))
+            (! vbit (- vbit 8)))
+           (loop wpos rpos bits vbit)))))
diff --git a/gnu/gnunet/hashcode-ascii.scm b/gnu/gnunet/hashcode-ascii.scm
index ca5c125..4ad98fb 100644
--- a/gnu/gnunet/hashcode-ascii.scm
+++ b/gnu/gnunet/hashcode-ascii.scm
@@ -48,5 +48,6 @@ characters.
 
 @var{ascii} the encoding
 Return @lisp{#f} in case of an encoding error."
-    (let ((bv (string->data ascii hashcode-u8-length)))
+    (let ((bv (guard (c ((bogus-crockford-base32hex? c) #false))
+                    (string->data ascii hashcode-u8-length))))
       (and bv (bv->hashcode bv)))))
diff --git a/gnu/gnunet/utils/hat-let.scm b/gnu/gnunet/utils/hat-let.scm
index df280a0..582d452 100644
--- a/gnu/gnunet/utils/hat-let.scm
+++ b/gnu/gnunet/utils/hat-let.scm
@@ -34,19 +34,17 @@
 ;;            usable.
 ;;   * (2 3): Allow dotted variable lists with <--.
 ;;   * (2 4): New: !^
+;;   * (2 5): Allow both RnRS _ and plain _.
 
-(library (gnu gnunet utils hat-let (2 4))
+(library (gnu gnunet utils hat-let (2 5))
   (export let^)
-  ;; Avoid letting users of (gnu gnunet utils hat-let)
-  ;; having to import _ from (rnrs base).
-  (import (only (rnrs base)
-               define-syntax syntax-rules let if begin
-               lambda assert call-with-values ...))
+  (import (except (rnrs base) _)
+         (rename (rnrs base) (_ rnrs:_)))
 
   ;; A generalisation of let*, and-let*, receive, begin,
   ;; and generalised let for avoiding nesting.
   (define-syntax let^
-    (syntax-rules (? ! !! _ <- <-- /o/)
+    (syntax-rules (? ! !! _ rnrs:_ <- <-- /o/)
       ((: () code ...)
        (let () code ...))
       ;; if x, then return @code{(begin esc esc* ...)}
@@ -76,11 +74,15 @@
        (begin
         (assert x)
         (let^ (etc ...) code ...)))
-      ;; Throw a result away
+      ;; Throw a result away.  Allow both RnRS _ and unbound _.
       ((: ((_ x) etc ...) code ...)
        (begin
         x
         (let^ (etc ...) code ...)))
+      ((: ((rnrs:_ x) etc ...) code ...)
+       (begin
+        x
+        (let^ (etc ...) code ...)))
       ;; Assign multiple values (from a thunk).
       ;; This is a historical mistake, use <--
       ;; instead (see mini changelog).
diff --git a/tests/crypto.scm b/tests/crypto.scm
index 26d6b5b..b355532 100644
--- a/tests/crypto.scm
+++ b/tests/crypto.scm
@@ -101,7 +101,6 @@
                    (string->eddsa-public-key "")
                    #false))
 
-(test-expect-fail 1) ; TODO
 (test-assert "string->eddsa-public-key, bogus character (invalid)"
             (guard (c ((invalid-public-key-encoding? c) #true))
                    (string->eddsa-public-key 
"@7SWVEMER2PPF11VTD737PQA2QAWVXA967EB6YFBHR5Z2J7AJ7E0")

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.