[gnunet-scheme] 28/324: Define library for structures

[gnunet]

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

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

commit 7b31c4aa642ec74ed6cdf95ac061499e4ef14dc7
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Wed Nov 18 22:00:41 2020 +0100

    Define library for structures
---
 README.org                     |  13 +++
 gnu/gnunet/utils/netstruct.scm | 230 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 243 insertions(+)

diff --git a/README.org b/README.org
index 95c03de..b1bc83a 100644
--- a/README.org
+++ b/README.org
@@ -6,11 +6,24 @@
 # without any warranty.
 
 * scheme-GNUnet: a partial Scheme port of GNUnet
+  TODO: ask upstream of use of name is acceptable
+  TODO: more bindings, less duplication
+  TODO: document directory & meta data format
 * Purposes
   + for use by Guix and disarchive
   + bit-for-bit reproducibility in directory creation
 * Modules
   + gnu/gnunet/directory.scm: directory construction
+* Wishlist
+  + Schemification
+
+    Many procedures are less-or-more directly transcribed
+    from the imperative C source code. Less is preferred over
+    more.
+  + Less copying bytevectors around
+
+    Bytevectors are often duplicated to preserve safety in presence of
+    buggy / insecure / hostile code in a sandbox.
 * License
   See the LICENSES directory for license text,
   and each file with source code for the license and copyright text.
diff --git a/gnu/gnunet/utils/netstruct.scm b/gnu/gnunet/utils/netstruct.scm
new file mode 100644
index 0000000..b7ca44b
--- /dev/null
+++ b/gnu/gnunet/utils/netstruct.scm
@@ -0,0 +1,230 @@
+;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
+;;   Copyright (C) 2020 Maxime Devos <maxime.devos@student.kuleuven.be>
+;;
+;;   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
+;;
+;;   As a special exception to the GNU Affero General Public License,
+;;   the file may be relicensed under any license used for
+;;   most source code of GNUnet 0.13.1, or later versions, as published by
+;;   GNUnet e.V.
+
+;; Author: Maxime Devos
+;; Source: gnu/gnunet/utils/netstruct.scm
+;; Brief: C-like structures as syntactical sugar
+;; TODO: guile-bytestructures is more standard
+;; TODO: testing
+
+(library (gnu gnunet utils netstruct)
+  (export u8vector u8
+         u16/big u32/big u64/big
+         u16/little u32/little u64/little
+         structure/packed
+         sizeof offset select read% set!%)
+  (import (rnrs base)
+         (srfi srfi-26)
+         (gnu gnunet utils bv-slice))
+
+  ;; Methods (not all might be available)
+  ;;  :sizeof (): size of structure
+  ;;  :sizeof (x ...): sizeof of field x (& repeat) in structure
+  ;;  :offset (x ...): offset of field x (& repeat) in structure
+  ;;  :select (x ...):
+  ;;    select field x in structure, repeat for ... (function between slices)
+  ;;  :reader (x ...):
+  ;;    select field x (& repeat), and parse the found value
+  ;;    (only for very simple values usually)
+  ;;  :setter (x ...):
+  ;;    select field x (& repeat), and mutate the found value
+  ;;
+  ;; The use of sizeof, offset, select, read & write is preferred
+
+  (define (slice-length-verifying-id length)
+    (lambda (slice)
+      (assert (= (slice-length slice) length))
+      slice))
+  (define (verify-index i length)
+    (assert (and (integer? i)
+                (exact? i)
+                (<= 0 i)
+                (< i length))))
+  (define (reader-also-check-length length reader)
+    (lambda (slice)
+      (assert (= (slice-length slice) length))
+      (reader slice)))
+  (define (setter-also-check-length length setter)
+    (lambda (slice x)
+      (assert (= (slice-length slice) length))
+      (setter slice x)))
+  (define-syntax standard-select
+    (syntax-rules ()
+      ((_ % indices)
+       (let ((stot (% :sizeof ()))
+            (offset (% :offset indices))
+            (size (% :sizeof indices)))
+       (lambda (slice)
+        (assert (= stot (slice-length slice)))
+        (slice-slice slice offset size))))))
+  (define-syntax u8vector
+    (syntax-rules ()
+      ((_ length)
+       (syntax-rules (:sizeof :offset :select :reader :setter)
+        ((% :sizeof ()) length)
+        ((% :sizeof (i))
+         (begin (verify-index i length)
+                1))
+        ((% :offset ()) 0)
+        ((% :offset (i))
+         (begin (verify-index i length)
+                i))
+        ((% :select indices)
+         (let-syntax ((%-self (u8vector length)))
+           (standard-select %-self indices)))
+        ((% :reader indices)
+         (let-syntax ((self (u8vector length)))
+           (let ((s (self :select indices))
+                 (r (u8 :reader ())))
+             (lambda (slice)
+               (r (s slice))))))
+        ((% :setter indices)
+         (let-syntax ((self (u8vector length)))
+           (let ((se (self :select indices))
+                 (ss (u8 :setter indices)))
+             (lambda (slice v)
+               (ss (se slice) v)))))))))
+
+  (define-syntax unsigned-N-bytes
+    (syntax-rules ()
+      ((_ length slice-ref slice-set!)
+       (syntax-rules (:sizeof :offset :select :reader :setter)
+        ((% :sizeof ()) length)
+        ((% :offset ()) 0)
+        ((% :select ()) (slice-verifying-id length))
+        ((% :reader ())
+         (reader-also-check-length length (cute slice-ref <> 0)))
+        ((% :setter ())
+         (setter-also-check-length length (cute slice-set! <> 0 <>)))))))
+
+  (define-syntax define-unsigned-N-bytes
+    (syntax-rules ()
+      ((_ ((length slice-ref slice-set!)
+          (name-big name-little)) ...)
+       (begin
+        (begin
+          (define-syntax name-big
+            (unsigned-N-bytes
+             length
+             (cute slice-u8-ref <> <> (endianness big))
+             (cute slice-u8-set! <> <> (endianness big) <>)))
+          (define-syntax name-little
+            (unsigned-N-bytes
+             length
+             (cute slice-u8-ref <> <> (endianness little))
+             (cute slice-u8-set! <> <> (endianness little) <>))))
+        ...))))
+
+  (define-syntax u8  (unsigned-N-bytes 1 slice-u8-ref slice-u8-set!))
+  (define-unsigned-N-bytes
+    ((2 slice-u16-ref slice-u16-set!) (u16/big u16/little))
+    ((4 slice-u32-ref slice-u64-set!) (u32/big u32/little))
+    ((8 slice-u32-ref slice-u64-set!) (u64/big u64/little)))
+
+  (define-syntax structure/packed
+    (syntax-rules ::: ()
+      ((_)
+       (syntax-rules (:sizeof :offset :select)
+        ((% :sizeof ()) 0)
+        ((% :offset ()) 0)
+        ((% :select ()) (slice-verifying-id 0))))
+      ((_ (field-name field-type) (field-name* field-type*) :::)
+       (syntax-rules (:sizeof :offset :select
+                     :reader-for-field :setter-for-field
+                     :reader :setter
+                     field-name field-name* :::)
+        ((% :sizeof ())
+         (+ (field-type :sizeof ())
+            (field-type* :sizeof ())
+            :::))
+        ((% :sizeof (field-name etc ...))
+         (field-type :sizeof (etc ...)))
+        ((% :sizeof (field-name* etc ...))
+         (field-type* :sizeof (etc ...)))
+        :::
+        ((% :offset ()) 0)
+        ((% :offset (field-name etc ...))
+         (field-type :offset (etc ...)))
+        ((% :offset (other-field-name etc ...))
+         (+ (field-type :sizeof ())
+            (let-syntax ((tail
+                          (structure/packed
+                           (field-name* field-type*) :::)))
+              (tail :offset (other-field-name etc ...)))))
+        ((% :select indices)
+         (let-syntax ((%-self (structure/packed
+                               (field-name field-type)
+                               (field-name* field-type*) :::)))
+           (standard-select %-self indices)))
+        ((% :reader-for-field field-name rest)
+         (field-type :reader rest))
+        ((% :reader-for-field field-name* rest)
+         (field-type* :reader rest))
+        :::
+        ((% :setter-for-field field-name rest)
+         (field-type :setter rest))
+        ((% :setter-for-field field-name* rest)
+         (field-type* :setter rest))
+        :::
+        ((% :reader (any-field-name . rest))
+         (let-syntax ((self
+                       (structure/packed
+                        (field-name field-type)
+                        (field-name* field-type*)
+                        :::)))
+           (let ((fs (self :select (any-field-name)))
+                 (fr (self :reader-for-field any-field-name rest)))
+             (lambda (slice)
+               (fr (fs slice))))))
+        ((% :setter (any-field-name . rest))
+         (let-syntax ((self
+                       (structure/packed
+                        (field-name field-type)
+                        (field-name* field-type*)
+                        :::)))
+           (let ((fsel (self :select (any-field-name)))
+                 (fset (self :setter-for-field any-field-name rest)))
+             (lambda (slice x)
+               (fset (fsel slice) x)))))))))
+
+  (define-syntax syntax-method
+    (syntax-rules ()
+      ((_ () method)
+       (syntax-rules ()
+        ((_ struct arg)
+         (struct method arg))))
+      ((_ (()) method)
+       (syntax-rules ()
+        ((_ struct arg arg*)
+         ((struct method arg) arg*))))
+      ((_ (() ()) method)
+       (syntax-rules ()
+        ((_ struct arg arg* arg**)
+         ((struct method arg) arg* arg**))))))
+
+  (define-syntax sizeof (syntax-method () :sizeof))
+  (define-syntax offset (syntax-method () :offset))
+  (define-syntax select (syntax-method (()) :select))
+  (define-syntax read% (syntax-method (()) :reader))
+  (define-syntax set%! (syntax-method (() ()) :setter)))
+

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