[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet-scheme] branch master updated (44061e6 -> 86e6038)
|
From: |
gnunet |
|
Subject: |
[gnunet-scheme] branch master updated (44061e6 -> 86e6038) |
|
Date: |
Thu, 02 Feb 2023 18:49:02 +0100 |
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 44061e6 Define 'construct' macro for making bytevector slices.
new ceb8a22 fs/struct: Add missing field 'signature' of
/:msg:fs:response-loc-signature.
new 46ddc3b bv-slice: Add procedure for comparing slices.
new 6cc094b tests/util: Ignore location of slices.
new 656f435 records: New API for record types, specialised to bytevector
slices.
new 78f26c5 hashcode: Define equality procedures.
new 3cb4d00 doc/typeclasses: Document cisw types.
new ab3795c doc/cadet: Simplify cadet address documentation with a
reference to cisw.
new 86e6038 utils/records: Raise &missing-capabilities exceptions.
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 | 1 +
NEWS | 3 +-
doc/bytevector-slices.tm | 14 +++
doc/cadet.tm | 27 ++---
doc/scheme-gnunet.tm | 2 +-
doc/typeclasses.tm | 36 +++++++
gnu/gnunet/cadet/client.scm | 39 ++++----
gnu/gnunet/fs/struct.scm | 4 +-
gnu/gnunet/fs/uri.scm | 81 +++++++--------
gnu/gnunet/hashcode.scm | 70 ++++++-------
gnu/gnunet/utils/bv-slice.scm | 21 +++-
gnu/gnunet/utils/records.scm | 223 ++++++++++++++++++++++++++++++++++++++++++
tests/bv-slice.scm | 80 ++++++++++++++-
tests/utils.scm | 19 +++-
14 files changed, 501 insertions(+), 119 deletions(-)
create mode 100644 gnu/gnunet/utils/records.scm
diff --git a/Makefile.am b/Makefile.am
index 1c9fbe3..a0437f4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -68,6 +68,7 @@ modules = \
gnu/gnunet/utils/cut-syntax.scm \
gnu/gnunet/utils/netstruct.scm \
gnu/gnunet/utils/platform-enum.scm \
+ gnu/gnunet/utils/records.scm \
gnu/gnunet/utils/tokeniser.scm \
\
gnu/gnunet/block.scm \
diff --git a/NEWS b/NEWS
index 550d859..37234f0 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,5 @@
# -*- mode: org; coding: utf-8 -*-
-# Copyright (C) 2021,2022 GNUnet e.V.
+# Copyright (C) 2021--2023 GNUnet e.V.
# SPDX-License-Identifier: FSFAP
# Copying and distribution of this file, with or without modification,
# are permitted in any medium without royalty provided the copyright
@@ -16,6 +16,7 @@
read%, select% and 'set%', less tedious when the type and slice remains
the same. Also, by using the new macros, the code base should now be a
bit more readible.
+ - New 'slice-contents-equal?' procedure.
** Bugfixes
- A potential (but unverified) bug with automatic collection is fixed --
previously, if DHT garbage was found multiple times within a single
diff --git a/doc/bytevector-slices.tm b/doc/bytevector-slices.tm
index 5b1019f..3274ece 100644
--- a/doc/bytevector-slices.tm
+++ b/doc/bytevector-slices.tm
@@ -132,6 +132,20 @@
</explain|Return <scm|#true> if the slice <var|slice> is writable,
<scm|#false> otherwise.>
+ <\explain>
+ <scm|(slice-contents-equal? <var|this>
+ <var|that>)><index|slice-contents-equal?>
+ <|explain>
+ Return <scm|#true> if the two readable bytevector slices <var|this> and
+ <var|that> have the same contents, i.e., they have the same length and
+ the same octet at each index. If one of the slices is not readable, a
+ <scm|&missing-capabilities> exception is raised, with the
+ \<#2018\>what\<#2019\> field set to the name of the argument as a symbol.
+ If both slices are not readable, it is unspecified whether
+ \<#2018\>what\<#2019\> is \<#2018\>this\<#2019\> or
+ \<#2018\>that\<#2019\>.
+ </explain>
+
<section|Reading / modifying bytevector slices>
To read the value at a (byte) index in the slice, the procedures
diff --git a/doc/cadet.tm b/doc/cadet.tm
index 6d7eaa3..e42985b 100644
--- a/doc/cadet.tm
+++ b/doc/cadet.tm
@@ -52,24 +52,29 @@
To contact a peer over CADET, the remote peer must have an <dfn|open
port><index|port> and the local peer needs to contact this port. The remote
peer\Uport identifier pair is called a <dfn|CADET address><index|CADET
- address> in Scheme-GNUnet. A <dfn|CADET address> can be made with the
- <scm|make-cadet-address> procedure:
+ address> in Scheme-GNUnet. A <dfn|CADET address> is represented by the
+ <acronym|cisw> (<reference|cisw>) type cadet-address:
<\explain>
- <scm|(make-cadet-address <var|peer> <var|port>)>
+ <scm|(make-cadet-address <var|peer> <var|port>)><index|make-cadeet-address>
+
+ <scm|(make-cadet-address/share <var|peer>
+ <var|port>)><index|make-cadet-address/share>
<|explain>
Make a CADET address for the peer <var|peer> (a readable bytevector slice
containing a <scm|/peer-identity>) at the port <var|port> (a readable
- bytevector slice containing a <scm|/hashcode:512>). The slices <var|peer>
- and <var|port> are copied, so future changes to them do not have any
- impact on the CADET address.
-
- The predicate for CADET addresses is <scm|cadet-address?>. The peer and
- port can be extracted with the accessors <scm|cadet-address-peer> and
- <scm|cadet-address-port>. CADET addresses can be compared with
- <scm|equal?>.
+ bytevector slice containing a <scm|/hashcode:512>), subject to the
+ <acronym|cisw> restrictions.
</explain>
+ <\explain>
+ <scm|cadet-address-peer><index|cadet-address-peer>,
+ <scm|cadet-address-port><index|cadet-address-port>,
+ <scm|cadet-address=?><index|cadet-address=?>,
+ <scm|cadet-address?><index|cadet-address?>
+ </explain|Standard <acronym|cisw> procedures. CADET addresses cannot be
+ compared with <scm|equal?>.>
+
Guile has a generic interface for network addresses, see (guile)Network
Socket Address. If BSD socket integration is activated (see <todo|todo>),
this interface is extended to support CADET addresses. In particular,
diff --git a/doc/scheme-gnunet.tm b/doc/scheme-gnunet.tm
index 9816852..c791f65 100644
--- a/doc/scheme-gnunet.tm
+++ b/doc/scheme-gnunet.tm
@@ -7,7 +7,7 @@
manual>|<doc-author|<author-data|<author-name|Maxime
Devos>|<author-email|maximedevos@telenet.be>>>>
- Copyright \<#A9\> 2012-2016, 2021, 2022 GNUnet e.V.
+ Copyright \<#A9\> 2012-2016, 2021\U2023 GNUnet e.V.
Permission is granted to copy, distribute and/or modify this document under
the terms of the GNU Free Documentation License, Version 1.3 or any later
diff --git a/doc/typeclasses.tm b/doc/typeclasses.tm
index 1f92061..f0430cf 100644
--- a/doc/typeclasses.tm
+++ b/doc/typeclasses.tm
@@ -39,6 +39,42 @@
<\todo>
todo
</todo>
+
+ <section|Cooperative immutable slice wrappers (<acronym|cisw>)
+ <index|cisw><index|cooperative immutable slice wrapper>><label|cisw>
+
+ Records in Scheme-GNUnet often contain bytevector slices. When constructing
+ such a record, it would be inefficient to copy the whole bytevector slice.
+ As such, constructors of such record types typically don't do that, then.
+ At the same time, it usually is expected that the record is fully
+ immutable, and hence that the contents of the slices it contains don't
+ change over time. However, sometimes the slices do change over time so a
+ copy needs to made even if it is somewhat inefficient.
+
+ Therefore, these record types have two constructors: a constructor
+ conventionally named <scm|type-name/share> that does not make a copy and
+ requires that the slices are unmodified as long as the constructed object
+ remains in use, and a constructor conventionally named <scm|type-name> that
+ does make a copy and does not impose such requirements.
+
+ Sometimes, you receive a record that is only valid for a limited duration,
+ because afterwards the slices will be modified. To extend the duration, it
+ then is required to make a <em|copy> of the record that contains a copy of
+ the bytevector slices, and use the copy instead of the original. Procedures
+ for making such copies are conventionally named <scm|copy-type-name>, can
+ be called as <scm|(copy-type-name <var|original-record>)> and return the
+ copy.
+
+ These kind of record types are called <acronym|cisw> in Scheme-GNUnet. You
+ can contribute to Scheme-GNUnet by finding a better acronym.
+
+ As the records are immutable, field accessors for slices will always return
+ a read-only bytevector slice, even if a read-write bytevector slice was
+ passed to the constructor and even if the copying constructor was used.
+
+ Because bytevector slices cannot be compared with <scm|equal?>, the same
+ holds for <acronym|cisw> types. Instead, <acronym|cisw> types define their
+ own equality procedures, conventionally named <scm|type-name=?>.
</body>
<\initial>
diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index 7306cb4..970c75a 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -1,6 +1,6 @@
;#!r6rs
;; This file is part of Scheme-GNUnet.
-;; Copyright © 2022 GNUnet e.V.
+;; Copyright © 2022--2023 GNUnet e.V.
;;
;; Scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
@@ -80,19 +80,19 @@
sizeof %sizeof read% r% s% define-analyser analyse
construct =>! =>slice!)
(only (gnu gnunet utils bv-slice)
- make-slice/read-write slice-copy/read-only slice-length
- slice-copy! slice-slice)
+ slice-copy/read-only slice-length
+ slice-copy! slice-slice slice-contents-equal?)
(only (gnu gnunet utils hat-let)
let^)
(only (rnrs base)
- begin define lambda assert quote cons apply values
- case else = define-syntax + expt - let and >
- not if < append list)
+ begin define lambda assert apply values
+ = + expt - let and > not if < list quote)
(only (rnrs control)
when)
(only (pfds bbtrees)
bbtree-set make-bbtree bbtree-ref)
(only (rnrs records syntactic) define-record-type)
+ (only (gnu gnunet utils records) define-record-type*)
(only (ice-9 control) let/ec)
(only (ice-9 match) match)
(only (guile) define* error)
@@ -370,20 +370,25 @@
rest message-queue (loop:terminal-condition loop)
(cut k/reconnect! channel-number->channel-map)))))
- (define-record-type (<cadet-address> make-cadet-address cadet-address?)
- (fields (immutable peer cadet-address-peer)
- (immutable port cadet-address-port))
- (protocol (lambda (%make)
- "Make a CADET address for contacting the peer @var{peer}
+ (define-record-type* (<cadet-address> cadet-address?)
+ #:constructor (make-cadet-address
+ "Make a CADET address for contacting the peer @var{peer}
(a readable bytevector slice containing a @code{/peer-identity}) at port
@var{port} (a readable bytevector slice containing a @code{/hashcode:512}).
The slices @var{peer} and @var{port} are copied, so future changes to them
-do not have any impact on the cadet address."
- (lambda (peer port)
- (assert (= (sizeof /peer-identity '()) (slice-length peer)))
- (assert (= (sizeof /hashcode:512 '()) (slice-length port)))
- (%make (slice-copy/read-only peer)
- (slice-copy/read-only port))))))
+do not have any impact on the cadet address.")
+ #:field (peer #:getter cadet-address-peer
+ #:predicate (lambda (peer)
+ (= (sizeof /peer-identity '())
+ (slice-length peer)))
+ #:preprocess slice-copy/read-only
+ #:equality slice-contents-equal?)
+ #:field (query #:getter cadet-address-port
+ #:predicate (lambda (port)
+ (= (sizeof /hashcode:512 '())
+ (slice-length port)))
+ #:preprocess slice-copy/read-only
+ #:equality slice-contents-equal?))
(define* (construct-local-channel-create cadet-address channel-number
#:optional (options 0))
diff --git a/gnu/gnunet/fs/struct.scm b/gnu/gnunet/fs/struct.scm
index c63c866..12e9874 100644
--- a/gnu/gnunet/fs/struct.scm
+++ b/gnu/gnunet/fs/struct.scm
@@ -31,7 +31,7 @@
/:msg:fs:put!)
(import (only (rnrs base) define begin * quote)
(only (gnu gnunet crypto struct)
- /peer-identity)
+ /eddsa-signature /peer-identity)
(only (gnu gnunet hashcode struct)
/hashcode:512)
(only (gnu gnunet util struct)
@@ -80,6 +80,8 @@
(synopsis "Expiration time of this signature.")
(documentation "Expiration time that was actually used (rounded!).
IIUC, not necessarily the time that was requested."))
+ (field (signature /eddsa-signature)
+ (synopsis "The requested signature"))
(field (peer /peer-identity)
(synopsis "Identity of the peer sharing the file.")
(documentation "On a typical setup, this is the identity of the
diff --git a/gnu/gnunet/fs/uri.scm b/gnu/gnunet/fs/uri.scm
index 88cdb56..8e0200d 100644
--- a/gnu/gnunet/fs/uri.scm
+++ b/gnu/gnunet/fs/uri.scm
@@ -1,6 +1,6 @@
;#!r6rs
;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;; Copyright (C) 2003--2014, 2020, 2022 GNUnet e.V.
+;; Copyright (C) 2003--2014, 2020, 2022--2023 GNUnet e.V.
;;
;; GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
@@ -84,7 +84,6 @@
chk-uri? make-chk-uri chk-uri-file-length chk-uri-chk
chk-uri-parse)
(import (rnrs base)
- (rnrs records syntactic)
(gnu gnunet hashcode)
(gnu gnunet hashcode-ascii)
(only (gnu gnunet fs struct) /content-hash-key)
@@ -92,59 +91,55 @@
(only (guile) make-regexp regexp-exec)
(only (ice-9 regex) match:substring)
(only (srfi srfi-2) and-let*)
- (only (gnu gnunet netstruct syntactic)
- define-analyser s%))
+ (only (gnu gnunet netstruct syntactic) s%)
+ (only (gnu gnunet utils records)
+ define-record-type*))
;; Size of the individual blocks used for file-sharing.
;; TODO: what is the proper place to define this constant
#;(define DBLOCK_SIZE (* 32 1024))
;; Content hash key
- (define-record-type (<content-hash-key> %make-content-hash-key
- content-hash-key?)
- (fields ;; Hash of the original content, used for encryption.
- ;; Of type <hashcode:512>.
- (immutable key content-hash-key-key)
- ;; Hash of the encrypted content, used for querying.
- ;; Of type <hashcode:512>
- (immutable query content-hash-key-query)))
-
- (define (make-content-hash-key key query)
- "Construct a <content-hash-key>"
- (assert (hashcode:512? key))
- (assert (hashcode:512? query))
- (%make-content-hash-key key query))
-
- (define-analyser make-content-hash-key/share /content-hash-key
- "Construct a <content-hash-key> corresponding to the
+ (define-record-type* (<content-hash-key> content-hash-key?)
+ #:constructor (make-content-hash-key "Construct a <content-hash-key>")
+ #:network-structure /content-hash-key
+ #:analyse (make-content-hash-key/share
+ "Construct a <content-hash-key> corresponding to the
@code{/content-hash-key} slice. The slice may not be modified
-while the content hash key is in use."
- (make-content-hash-key
- (make-hashcode:512/share (s% key))
- (make-hashcode:512/share (s% query))))
+while the content hash key is in use.")
+ ;; Hash of the original content, used for encryption.
+ #:field (key #:getter content-hash-key-key
+ #:predicate hashcode:512?
+ #:analyse make-hashcode:512/share
+ #:network-structure-select (s% key))
+ ;; Hash of the encrypted content, used for querying.
+ #:field (query #:getter content-hash-key-query
+ #:predicate hashcode:512?
+ #:analyse make-hashcode:512/share
+ #:network-structure-select (s% query)))
;; Information needed to retrieve a file (content-hash-key
;; plus file size)
- (define-record-type (<chk-uri> %make-chk-uri chk-uri?)
- (fields ;; Total size of the file referred to in bytes.
- (immutable file-length chk-uri-file-length)
- ;; Query and key of the top GNUNET_EC_IBlock.
- ;; Of type <content-hash-key>.
- (immutable chk chk-uri-chk)))
+ (define-record-type* (<chk-uri> chk-uri?)
+ #:constructor (make-chk-uri "Make a chk-URI")
+ ;; Total size of the file referred to in bytes.
+ #:field (file-length #:getter chk-uri-file-length
+ #:predicate
+ (lambda (n)
+ (and (exact? file-length)
+ (integer? file-length)
+ (<= 0 file-length)
+ (< file-length file-length-limit)))
+ #:equality =)
+ ;; Query and key of the top GNUNET_EC_IBlock.
+ ;; Of type <content-hash-key>.
+ #:field (chk #:getter chk-uri-chk
+ #:predicate content-hash-key?))
;; TODO: is this limitation on file size
;; merely a limit of the implementation?
(define file-length-limit (expt 2 64))
- (define (make-chk-uri file-length chk)
- "Make a chk-URI"
- (assert (and (exact? file-length)
- (integer? file-length)))
- (assert (and (<= 0 file-length)
- (< file-length file-length-limit)))
- (assert (content-hash-key? chk))
- (%make-chk-uri file-length chk))
-
;; TODO: location URIs, ksk URIs?
;; Why does GNUnet have location URIs?
@@ -163,7 +158,7 @@ error."
(query-hashcode (ascii->hashcode query-match))
(size (string->number size-match 10))
(size-ok (< size file-length-limit)))
- (%make-chk-uri size
- (%make-content-hash-key key-hashcode
- query-hashcode)))))))
+ (make-chk-uri size
+ (make-content-hash-key key-hashcode
+ query-hashcode)))))))
diff --git a/gnu/gnunet/hashcode.scm b/gnu/gnunet/hashcode.scm
index 2137755..ec21cd5 100644
--- a/gnu/gnunet/hashcode.scm
+++ b/gnu/gnunet/hashcode.scm
@@ -1,6 +1,6 @@
;#!r6rs
;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;; Copyright (C) 2006--2020, 2022 GNUnet e.V.
+;; Copyright (C) 2006--2020, 2022--2023 GNUnet e.V.
;;
;; GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
@@ -23,13 +23,17 @@
(export hashcode:512-bit-length hashcode:512-u8-length
hashcode:256-bit-length hashcode:256-u8-length
hashcode:512? hashcode:256?
+ hashcode:512=? hashcode:256=?
make-hashcode:512/share make-hashcode:512
make-hashcode:256/share make-hashcode:256
hashcode:512->slice hashcode:256->slice
copy-hashcode:512 copy-hashcode:256)
(import (rnrs base)
(gnu gnunet utils bv-slice)
- (rnrs records syntactic))
+ (only (gnu gnunet hashcode struct)
+ /hashcode:512 /hashcode:256)
+ (only (gnu gnunet utils records)
+ define-record-type*))
(define hashcode:512-bit-length 512)
(define hashcode:256-bit-length 256)
@@ -38,51 +42,37 @@
;; A 512-bit hashcode. These are the default length for GNUnet,
;; using SHA-512.
- (define-record-type (<hashcode:512> make-hashcode:512/share hashcode:512?)
- (fields (immutable slice hashcode:512->slice))
- (opaque #t)
- (sealed #t)
- (protocol
- (lambda (%make)
- (lambda (slice)
- "Make a hashcode, containing @var{slice} (a readable
+ (define-record-type* (<hashcode:512> hashcode:512?)
+ #:equality hashcode:512=?
+ #:network-structure /hashcode:512
+ #:read-only-slice-wrapper #true
+ #:unwrap hashcode:512->slice
+ #:constructor (make-hashcode:512/share
+ "Make a hashcode, containing @var{slice} (a readable
@code{/hashcode:512} bytevector slice). @var{slice} may not be mutated
-while the constructed hashcode is in use."
- (assert (= (slice-length slice) hashcode:512-u8-length))
- (%make (slice/read-only slice))))))
-
- (define (make-hashcode:512 slice)
- "Make a hashcode, containing @var{slice} (a readable @code{/hashcode:512}
-bytevector slice). @var{slice} may not be mutated while the constructed
-hashcode is in use."
- (make-hashcode:512/share (slice-copy/read-only slice)))
-
- (define (copy-hashcode:512 hashcode:512)
- "Make a copy of the hashcode:512 @var{hashcode:512}. This can be useful if
+while the constructed hashcode is in use.")
+ #:constructor/copy make-hashcode:512
+ #:copy (copy-hashcode:512
+ "Make a copy of the hashcode:512 @var{hashcode:512}. This can be
useful if
the slice used during the construction of @var{hashcode:512} is potentially
-going to be mutated while a hashcode will still be in use."
- (make-hashcode:512 (hashcode:512->slice hashcode:512)))
+going to be mutated while a hashcode will still be in use."))
;; A 256-bit hashcode. Used under special conditions, like when space
;; is critical and security is not impacted by it.
- (define-record-type (<hashcode:256> make-hashcode:256/share hashcode:256?)
- (fields (immutable slice hashcode:256->slice))
- (opaque #t)
- (sealed #t)
- (protocol
- (lambda (%make)
- (lambda (slice)
- "Make a short hashcode, containing @var{slice} (a readable
+ (define-record-type* (<hashcode:256> hashcode:256?)
+ #:equality hashcode:256=?
+ #:network-structure /hashcode:256
+ #:read-only-slice-wrapper #true
+ #:unwrap hashcode:256->slice
+ #:constructor (make-hashcode:256/share
+ "Make a short hashcode, containing @var{slice} (a readable
@code{/hashcode:256} bytevector slice). @var{slice} may not be mutated
-while the constructed short hashcode is in use."
- (assert (= (slice-length slice) hashcode:256-u8-length))
- (%make (slice/read-only slice))))))
-
- (define (copy-hashcode:256 hashcode:256)
- "Make a copy of the hashcode:256 @var{hashcode:256}. This can be useful if
+while the constructed short hashcode is in use.")
+ #:constructor/copy make-hashcode:256
+ #:copy (copy-hashcode:256
+ "Make a copy of the hashcode:256 @var{hashcode:256}. This can be
useful if
the slice used during the construction of @var{hashcode:256} is potentially
-going to be mutated while a hashcode will still be in use."
- (make-hashcode:256 (hashcode:256->slice hashcode:256)))
+going to be mutated while a hashcode will still be in use."))
(define (bv->hashcode:512 bv)
"Read a hashcode from a bytevector (deprecated)."
diff --git a/gnu/gnunet/utils/bv-slice.scm b/gnu/gnunet/utils/bv-slice.scm
index 72ab94d..edbcf41 100644
--- a/gnu/gnunet/utils/bv-slice.scm
+++ b/gnu/gnunet/utils/bv-slice.scm
@@ -1,6 +1,6 @@
;#!r6rs
;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;; Copyright (C) 2020, 2021, 2022 GNUnet e.V.
+;; Copyright (C) 2020--2023 GNUnet e.V.
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
@@ -58,6 +58,7 @@
slice-ieee-double-ref
slice-ieee-double-set!
;; Large operations
+ slice-contents-equal?
slice-copy!
slice-zero!
slice-copy/bytevector
@@ -320,6 +321,24 @@ If not, raise an appropriate @code{&missing-capabilities}."
;; ‘Large’ operations.
+ (define (slice-contents-equal? this that)
+ "Check if the readable bytevector slices @var{this} and @var{that}
+have the same contents. I.e., the lengths are the same and for all
+valid index, the octets at that index are equal.
+
+The current implementation, as a side-effect, does allocations.
+This is a bug."
+ (verify-slice-readable 'this this)
+ (verify-slice-readable 'that that)
+ ;; fast paths
+ (or (eq? this that)
+ (and (eq? (slice-bv this) (slice-bv that))
+ (= (slice-offset this) (slice-offset that))
+ (= (slice-length this) (slice-length that)))
+ ;; slow path (TODO: replace this with a 'memcmp' equivalent
+ ;; once Guile supports that).
+ (equal? (slice-copy/bytevector this) (slice-copy/bytevector that))))
+
(define (slice-zero! slice)
"Zero out the writable slice @var{slice}."
(verify-slice-writable 'slice slice)
diff --git a/gnu/gnunet/utils/records.scm b/gnu/gnunet/utils/records.scm
new file mode 100644
index 0000000..becf263
--- /dev/null
+++ b/gnu/gnunet/utils/records.scm
@@ -0,0 +1,223 @@
+;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
+;; Copyright (C) 2023 GNUnet e.V.
+;;
+;; Scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; Scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+(define-library (gnu gnunet utils records)
+ (export define-record-type*)
+ ;; keyword? cannot be used from (srfi srfi-88) because that sets
+ ;; a reader option.
+ (import (only (guile) define* keyword? error define-values pk)
+ (only (ice-9 match) match)
+ (only (rnrs base)
+ begin define lambda define-syntax cons quasiquote quote unquote
+ unquote-splicing apply reverse append null? eq? and not if
+ string? values map assert car cdr cadr cddr let or pair?)
+ (only (rnrs control) when unless)
+ (only (rnrs syntax-case)
+ syntax quasisyntax unsyntax unsyntax-splicing syntax-case
+ syntax->datum identifier? generate-temporaries)
+ (only (rnrs records syntactic) define-record-type)
+ (only (srfi srfi-1) assoc)
+ ;; in generated code
+ (only (rnrs base) =)
+ (only (gnu gnunet netstruct syntactic)
+ define-analyser sizeof)
+ (only (gnu gnunet utils bv-slice)
+ slice? slice-readable? slice-length
+ slice-contents-equal? slice/read-only
+ slice-copy/read-only))
+ (begin
+ (define unset (cons #false #false))
+
+ (define* (process fields^ <type> type?
+ #:key
+ (constructor unset)
+ (constructor/copy unset)
+ (read-only-slice-wrapper #false)
+ (equality unset)
+ (analyse unset)
+ (copy unset)
+ (unwrap unset)
+ (network-structure unset))
+ (define fields*
+ (match (syntax->datum read-only-slice-wrapper)
+ (#true
+ (unless (null? fields^)
+ (error "fields may not be manually defined when
#:read-only-slice-wrapper is #true"))
+ (when (eq? network-structure unset)
+ (error "when #:read-only-slice-wrapper is set, #:network-structure
must be defined"))
+ (when (eq? unwrap unset)
+ (error "when #:read-only-slice-wrapper is set, #:unwrap must be
defined"))
+ `((,#'slice
+ (#:getter . ,unwrap)
+ ;; Readability is checked by 'preprocess', to get a nice
+ ;; '&missing-capabilities' exception.
+ (#:predicate . ,#`(lambda (s)
+ (and (slice? s)
+ (= (slice-length s)
+ (sizeof #,network-structure '())))))
+ (#:preprocess . ,#'slice/read-only)
+ (#:equality . ,#'slice-contents-equal?))))
+ (#false fields^)))
+ (when (and (not (eq? unwrap unset))
+ (eq? read-only-slice-wrapper unset))
+ (error "#:unwrap can only be used in combination with
#:read-only-slice-wrapper #true"))
+ ;; s: unset, or syntax of the form '(identifier "docstring")',
+ ;; or syntax of the form 'identifier'.
+ ;;
+ ;; Return types: (unset | identifier), syntax
+ (define (maybe-identifier-maybe-with-docstring s)
+ (if (eq? s unset)
+ (values unset #false)
+ (syntax-case s ()
+ ((id docstring)
+ (and (identifier? #'id) (string? (syntax->datum #'docstring)))
+ (values #'id #'docstring))
+ (id
+ (identifier? #'id)
+ (values #'id #false)))))
+ (define-values (constructor** constructor-docstring)
+ (maybe-identifier-maybe-with-docstring constructor))
+ (define constructor*
+ (if (eq? constructor** unset)
+ ;; define-record-type always requires a constructor
+ (car (generate-temporaries '(stuff)))
+ constructor**))
+ (define-values (equality* equality-docstring)
+ (maybe-identifier-maybe-with-docstring equality))
+ (define-values (analyse* analyse-docstring)
+ (maybe-identifier-maybe-with-docstring analyse))
+ (define-values (copy* copy-docstring)
+ ;; The generated code for 'constructor/copy*' expects
+ ;; a 'copy' procedure to exist.
+ (if (and (eq? copy unset) (not (eq? constructor/copy unset)))
+ (car (generate-temporaries '(copy)))
+ (maybe-identifier-maybe-with-docstring copy)))
+ (define-values (constructor/copy* constructor/copy-docstring)
+ (maybe-identifier-maybe-with-docstring constructor/copy))
+ (define (field-name field) ; -> identifier
+ (car field))
+ (define (field-verify field)
+ (if (field-set field #:predicate)
+ #`(assert (#,(field-ref field #:predicate) #,(field-name field)))
+ #'#true)) ; exact value doesn't matter
+ (define (field-compare field this that)
+ (define g (field-ref field #:getter)) ; always defined
+ #`(#,(field-ref field #:equality) ; sometimes undefined
+ (#,g #,this)
+ (#,g #,that)))
+ (define (field->analyse-fragment field)
+ ;; TODO: #:network-structure-read, e.g. for when it's just a number?
+ #`(#,(field-ref field #:analyse) ; sometimes undefined
+ #,(field-ref field #:network-structure-select))) ; sometimes
undefined
+ (define (field-clause field)
+ #`(immutable #,(field-name field)
+ #,(field-ref field #:getter)))
+ ;; TODO bail out if unrecognised field settings
+ (define (field-preprocess field)
+ (if (field-set field #:preprocess)
+ #`(#,(field-ref field #:preprocess) #,(field-name field))
+ (field-name field)))
+ #`(begin
+ (define-record-type (#,<type> #,constructor* #,type?)
+ (fields #,@(map field-clause fields*))
+ (protocol
+ (lambda (%make)
+ (lambda #,(map field-name fields*)
+ #,constructor-docstring
+ #,@(map field-verify fields*)
+ (%make #,@(map field-preprocess fields*)))))
+ (sealed #true)
+ (opaque #true))
+ #,@(if (eq? equality* unset)
+ #'()
+ #`((define (#,equality* this that)
+ #,equality-docstring
+ (and #,@(map (lambda (f) (field-compare f #'this #'that))
fields*)))))
+ #,@(if (eq? analyse* unset)
+ #'()
+ #`((define-analyser #,analyse* #,network-structure
+ #,analyse-docstring
+ (#,constructor*
+ #,@(map field->analyse-fragment fields*)))))
+ #,@(if (eq? copy* unset)
+ #'()
+ ;; Note: support for read-only-slice-wrapper = unset can be
+ ;; implemented if needed with some work.
+ (begin
+ (assert (eq? #true (syntax->datum read-only-slice-wrapper)))
+ #`((define (#,copy* slice)
+ (#,constructor*
+ (slice-copy/read-only
+ (#,(field-ref (car fields*) #:getter) slice)))))))
+ #,@(if (eq? constructor/copy* unset)
+ #'()
+ ;; Note: likewise.
+ (begin
+ (assert (eq? #true (syntax->datum read-only-slice-wrapper)))
+ #`((define (#,constructor/copy* object)
+ #,constructor/copy-docstring
+ (#,copy* (#,constructor* object))))))))
+
+ (define (field-ref field keyword)
+ (match (assoc keyword (cdr field))
+ ((key . value) value)
+ (_ (pk 'field-ref field keyword)
+ (error "missing keyword in field"))))
+
+ (define (field-set field keyword)
+ (pair? (assoc keyword (cdr field))))
+
+ (define (decompose-field-syntax stuff)
+ (define (decompose-field-syntax-stuff* rest accumulated)
+ (syntax-case rest ()
+ ;; Assuming no duplicates, the order of the keyword arguments
+ ;; doesn't matter, so no reversal needed here.
+ (() accumulated)
+ ((keyword value . rest*)
+ (keyword? (syntax->datum #'keyword))
+ (decompose-field-syntax-stuff*
+ #'rest*
+ `((,(syntax->datum #'keyword) . ,#'value) ,@accumulated)))))
+ (syntax-case stuff ()
+ ((name . rest)
+ (cons #'name (decompose-field-syntax-stuff* #'rest '())))))
+
+ (define (decompose-syntax s accumulated-fields accumulated-arguments k .
k*)
+ (syntax-case s ()
+ ;; order of keyword arguments doesn't matter, so no reversal there.
+ ;; (it is assumed there are no duplicates)
+ (() (apply k (reverse accumulated-fields)
+ (append k* accumulated-arguments)))
+ ((#:field stuff . rest)
+ (apply decompose-syntax
+ #'rest
+ (cons (decompose-field-syntax #'stuff) accumulated-fields)
+ accumulated-arguments
+ k k*))
+ ((keyword value . rest) ; not #:field
+ (keyword? (syntax->datum #'keyword))
+ (apply decompose-syntax
+ #'rest
+ accumulated-fields
+ `(,(syntax->datum #'keyword) ,#'value ,@accumulated-arguments)
+ k k*))))
+
+ (define-syntax define-record-type*
+ (lambda (s)
+ (syntax-case s ()
+ ((_ (<type> type?) . stuff)
+ (decompose-syntax #'stuff '() '() process #'<type> #'type?)))))))
diff --git a/tests/bv-slice.scm b/tests/bv-slice.scm
index 043f6af..a48f7e3 100644
--- a/tests/bv-slice.scm
+++ b/tests/bv-slice.scm
@@ -1,5 +1,5 @@
;; This file is part of scheme-GNUnet.
-;; Copyright (C) 2021, 2022 GNUnet e.V.
+;; Copyright (C) 2021--2023 GNUnet e.V.
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
@@ -39,6 +39,84 @@
(missing-capabilities-required c))))
code)))
+(test-missing-caps
+ "first argument of slice-contents-equal? must be readable"
+ 'this
+ CAP_WRITE
+ CAP_READ
+ (slice-contents-equal? (slice/write-only (make-slice/read-write 9))
+ (make-slice/read-write 9)))
+
+(test-missing-caps
+ "second argument of slice-contents-equal? must be readable"
+ 'that
+ CAP_WRITE
+ CAP_READ
+ (slice-contents-equal? (make-slice/read-write 9)
+ (slice/write-only (make-slice/read-write 9))))
+
+(define (make-a-bv n)
+ (define bv (make-bytevector n))
+ (let loop ((i 0))
+ (when (< 0 i n)
+ (bytevector-u8-set! bv i (random 256))))
+ bv)
+
+(test-assert "slice-contents-equal? is reflexive"
+ (let ((s (make-slice/read-write 10)))
+ (slice-contents-equal? s s)))
+
+(test-assert "slice-contents-equal? is reflexive (read-only)"
+ (let ((s (slice/read-only (make-slice/read-write 10))))
+ (slice-contents-equal? s s)))
+
+(test-assert "slice-contents-equal? #true backed by same bytevector but
different offset"
+ (let* ((s (bv-slice/read-only #vu8(0 1 2 3
+ 0 1 2 3)))
+ (s1 (slice/read-only s 0 4))
+ (s2 (slice/read-only s 4 4)))
+ (and (slice-contents-equal? s1 s2)
+ (slice-contents-equal? s2 s1))))
+
+(test-assert "slice-contents-equal? #false backed by same bytevector but
different offset"
+ (let* ((bv (bv-slice/read-only #vu8(0 1 2 3
+ 0 1 2 4)))
+ (s1 (slice/read-only bv 0 4))
+ (s2 (slice/read-only bv 4 4)))
+ (and (not (slice-contents-equal? s1 s2))
+ (not (slice-contents-equal? s2 s1)))))
+
+(test-assert "slice-contents-equal? #false backed by same bytevector but
different length"
+ (let* ((s (bv-slice/read-only #vu8(0 1 2 3 4)))
+ (s1 (slice/read-only s 0 4))
+ (s2 (slice/read-only s 0 5)))
+ (and (not (slice-contents-equal? s1 s2))
+ (not (slice-contents-equal? s2 s1)))))
+
+(test-assert "slice-contents-equal? #false, same offset and length"
+ (let ((s1 (bv-slice/read-only #vu8(0 1 2 3)))
+ (s2 (bv-slice/read-only #vu8(10 11 12 13))))
+ (and (not (slice-contents-equal? s1 s2))
+ (not (slice-contents-equal? s2 s1)))))
+
+(test-assert
+ "copies are slice-contents-equal?"
+ (let* ((bv (make-a-bv 10))
+ (s (bv-slice/read-write bv)))
+ (slice-contents-equal? s (slice-copy/read-write s))))
+
+(test-assert
+ "copies are slice-contents-equal? (read-only)"
+ (let* ((bv (make-a-bv 10))
+ (s (bv-slice/read-write bv)))
+ (slice-contents-equal? (slice/read-only s) (slice-copy/read-only s))))
+
+(test-assert
+ "copies are slice-contents-equal? (one offset)"
+ (let* ((bv (make-a-bv 10))
+ (s (bv-slice/read-write bv 1)))
+ (slice-contents-equal? s (slice-copy/read-only s))))
+
(test-missing-caps
"destination of slice-copy! must be writable"
'to
diff --git a/tests/utils.scm b/tests/utils.scm
index 09524af..2affc7f 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
;; This file is part of scheme-GNUnet.
-;; Copyright © 2021, 2022 GNUnet e.V.
+;; Copyright © 2021--2023 GNUnet e.V.
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
@@ -36,7 +36,7 @@
(hash->configuration hash-key key=? set-value!)
#:autoload (gnu gnunet mq error-reporting) (error-reporter)
#:autoload (gnu gnunet utils bv-slice)
- (slice-readable? slice-writable?)
+ (slice? slice-readable? slice-writable? slice-contents-equal?)
#:export (conservative-gc? calls-in-tail-position?
call-with-services
call-with-services/fibers
@@ -434,6 +434,19 @@ connection port as seen by the server and can e.g. write
to the port or close it
;; TODO export
(define make-property (@@ (quickcheck property) make-property))
+;; TODO: eliminate 'normalise' by passing equality procedures.
+(define (equal/ignore-location? this that)
+ (cond ((pair? this)
+ (and (pair? that)
+ (equal/ignore-location? (car this) (car that))
+ (equal/ignore-location? (cdr this) (cdr that))))
+ ((slice? this)
+ (and (slice? that)
+ (eq? (slice-readable? this) (slice-readable? that))
+ (eq? (slice-writable? this) (slice-writable? that))
+ (slice-contents-equal? this that)))
+ (#t (equal? this that))))
+
(define (round-trip-property analyse construct normalise names gen/arbs)
(make-property
names gen/arbs
@@ -443,7 +456,7 @@ connection port as seen by the server and can e.g. write to
the port or close it
(! analysed (normalise analysed)))
(and (slice-readable? constructed)
(slice-writable? constructed)
- (equal? expected analysed))))))
+ (equal/ignore-location? expected analysed))))))
;; This test construct network messages by generating @var{name} ...
;; with the quickcheck arbitraries @var{$arbitrary} ...
--
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.
- [gnunet-scheme] branch master updated (44061e6 -> 86e6038),
gnunet <=
- [gnunet-scheme] 01/08: fs/struct: Add missing field 'signature' of /:msg:fs:response-loc-signature., gnunet, 2023/02/02
- [gnunet-scheme] 06/08: doc/typeclasses: Document cisw types., gnunet, 2023/02/02
- [gnunet-scheme] 07/08: doc/cadet: Simplify cadet address documentation with a reference to cisw., gnunet, 2023/02/02
- [gnunet-scheme] 08/08: utils/records: Raise &missing-capabilities exceptions., gnunet, 2023/02/02
- [gnunet-scheme] 05/08: hashcode: Define equality procedures., gnunet, 2023/02/02
- [gnunet-scheme] 04/08: records: New API for record types, specialised to bytevector slices., gnunet, 2023/02/02
- [gnunet-scheme] 02/08: bv-slice: Add procedure for comparing slices., gnunet, 2023/02/02
- [gnunet-scheme] 03/08: tests/util: Ignore location of slices., gnunet, 2023/02/02