path: root/gnu/gnunet/netstruct/procedural.scm

;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2020, 2021 Maxime Devos <maximedevos@telenet.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

(define-library (gnu gnunet netstruct procedural)
  (export ;; XXX move elsewhere
   <documentable> make-documentable documentable?
   documentation synopsis properties

   netstruct? part sizeof offsetof select read% set%!
   <netstruct:struct> <netstruct:array> <netstruct:primitive>
   make-netstructure make-netarray make-netprimitive
   netstructure? netarray? netprimitive?

   <field> make-field field? field-name field-type
   netarray-type netarray-length

   &structure-violation
   &out-of-bounds &no-such-field &unreadable &unwritable
   &bad-slice-length

   make-structure-violation make-out-of-bounds make-no-such-field
   make-bad-slice-length make-unreadable make-unwritable

   structure-violation? out-of-bounds? no-such-field?
   bad-slice-length? unreadable? unwritable?

   bad-slice-length-expected bad-slice-length-found

   u8 u16/big u32/big u64/big
   u16/little u32/little u64/little
   ieee-double/big ieee-double/little

   u8vector

   ;; internal
   %out-of-bounds/cond %select-length-cond)
  (import (rnrs base)
	  (rnrs records syntactic)
	  (only (rnrs exceptions) raise)
	  (only (rnrs bytevectors) endianness)
	  (rnrs control)
	  (rnrs conditions)
	  (srfi srfi-26)
	  (only (srfi srfi-43) vector-any)
	  (only (guile) eval-when)
	  (ice-9 optargs)
	  (gnu gnunet utils bv-slice))
  (begin
    ;; TODO maybe include structure & field name
    (define-condition-type &structure-violation &violation
      make-structure-violation structure-violation?)
    (define-condition-type &out-of-bounds &structure-violation
      make-out-of-bounds out-of-bounds?)
    (define-condition-type &no-such-field &structure-violation
      make-no-such-field no-such-field?)
    (define-condition-type &bad-slice-length &structure-violation
      make-bad-slice-length bad-slice-length?
      (expected bad-slice-length-expected)
      (found    bad-slice-length-found))
    (define-condition-type &unreadable &violation
      make-unreadable unreadable?)
    (define-condition-type &unwritable &violation
      make-unwritable unwritable?)

    ;; TODO also use for enumerations and optionally include line numbers
    (define-record-type (<documentable> make-documentable documentable?)
      (fields (immutable documentation documentation)
	      (immutable synopsis synopsis)
	      (immutable properties properties))
      (sealed #f)
      (opaque #t)
      (protocol (lambda (%make)
		  (lambda* (#:key
			    (documentation #f)
			    (synopsis #f)
			    (properties '())
			    #:allow-other-keys)
		  "A synopsis and documentation string can be specified
with @var{synopsis} and @var{documentation} (two strings).
@var{properties} can be arbitrary (but usually is an association list)
and is an empty list by default.  Other keyword arguments are ignored."
		  (when synopsis
		    (assert (string? synopsis)))
		  (when documentation
		    (assert (string? documentation)))
		  ;; TODO somehow make properties read-only
		  ;; (disallow set-car!, set-cdr!)
		  (%make synopsis documentation properties)))))

    (define-record-type (<netstruct/vtable> make-netstruct-vtable netstruct-vtable?)
      (fields (immutable offset   ~offset)
	      (immutable part     ~part)
	      (immutable reader   ~reader)
	      (immutable setter   ~set))
      (sealed #f)
      (opaque #t)
      (protocol (lambda (%make)
		  (lambda* (#:key offset part reader setter)
		    "Make a network structure vtable.  The following
methods can be defined:

@table @var
@item offset two-argument procedure, accepts a network structure and a field
  name and returns the byte offset of the field.
@item part two-argument procedure, accepts a network structure and a field name
  and returns the network structure of the field.
@item reader one-argument procedure, accepts a network structure and returns
 a procedure accepting a slice.
@item setter one-argument procedure, accepts a network structure and returns
 a procedure accepting a slice and a value."
		    (for-each
		     (lambda (p)
		       (when p
			 (assert (procedure? p))))
		     (list offset part reader setter))
		    (%make offset part reader setter)))))

    (define (exact-natural? size)
      (and (integer? size)
	   (exact? size)
	   (<= 0 size)))

    (define-record-type (<netstruct> %make-netstruct netstruct?)
      (fields (immutable size %size)
	      (immutable vtable netstruct-vtable))
      (sealed #f)
      (opaque #t)
      (parent <documentable>)
      (protocol (lambda (%make)
		  (lambda (size vtable . r)
		    "Create a network structure.

The size in bytes is specified by @var{size}, a positive and exact integer."
		    (assert (exact-natural? size))
		    (assert (netstruct-vtable? vtable))
		    ((apply %make r) size vtable)))))

    (define (sizeof ns fields)
      "What is the size of the field @var{fields} of the network structure
@var{ns} in bytes?"
      (%size (part ns fields)))

    (define (no-fields who)
      (raise (condition (make-no-such-field)
			(make-who-condition who)
			(make-message-condition
			 "structure does not have any fields"))))

    (define (no-such-field who)
      (raise (condition (make-no-such-field)
			(make-who-condition who)
			(make-message-condition
			 "structure does not have that field"))))

    (define (offsetof ns fields)
      "What is the offset of the field @var{fields} in the network structure
@var{ns} in bytes?"
      (let loop ((off 0) (ns ns) (fields fields))
	(assert (netstruct? ns))
	(if (null? fields)
	    off
	    (let* ((field (car fields))
		   (fields* (cdr fields))
		   (v (netstruct-vtable ns))
		   (~part (~part v))
		   (~offset (~offset v)))
	      (unless (and ~part ~offset)
		(no-fields 'offsetof))
	      (loop (+ off (~offset ns field))
		    (~part ns field)
		    fields*)))))

    (define (part ns fields)
      "What is the network structure of the field @var{fields} in the
network structure @var{ns}? @var{fields} is a list structure
like @code{(some-field an-array-index other-field)}."
      (assert (netstruct? ns))
      (if (null? fields)
	  ns
	  (let ((field (car fields))
		(fields* (cdr fields))
		(~part (~part (netstruct-vtable ns))))
	    (unless ~part (no-fields 'part))
	    (part (~part ns field) fields*))))

    (define (%select-length-cond expected-length found-length)
      (condition (make-bad-slice-length expected-length found-length)
		 (make-message-condition
		  "length of bytevector slice is incorrect")
		 (make-who-condition 'select)))

    (define (select ns fields slice)
      "Select the field @var{fields} of the network structure
@var{ns} in the bytevector slice @var{ns}.  If the length
of the slice @var{slice} is inappropriate, raise an appropriate
exception instead."
      (let ((expected-length (sizeof ns '()))
	    (found-length    (slice-length slice)))
	(unless (= found-length expected-length)
	  (raise (%select-length-cond expected-length found-length)))
	(slice-slice slice (offsetof ns fields) (sizeof ns fields))))

    (define (read% ns fields slice)
      "Read the field @var{fields} of the network structure @var{ns}
from the bytevector slice @var{slice}."
      (let* ((relevant (select ns fields slice))
	     (part (part ns fields))
	     (~reader (~reader (netstruct-vtable part))))
	(unless ~reader
	  (raise (condition
		  (make-unreadable)
		  (make-who-condition 'read%)
		  (make-message-condition "field cannot be read"))))
	((~reader part) relevant)))

    (define (set%! ns fields slice value)
      "Write @var{value} to the field @var{field} of the network
structure @var{ns} in the bytevector slice @var{ns}."
      (let* ((relevant (select ns fields slice))
	     (part (part ns fields))
	     (~set (~set (netstruct-vtable part))))
	(unless ~set
	  (raise (condition
		  (make-unwritable)
		  (make-who-condition 'set%!)
		  (make-message-condition "field cannot be set"))))
	((~set part) relevant value)))

    (define-record-type (<field> make-field field?)
      (fields (immutable name field-name)
	      (immutable type field-type))
      (parent <documentable>)
      (protocol (lambda (%make)
		  (lambda (name type . rest)
		    "Construct a field with some name
@var{name} (a symbol) and type @var{type} (a network structure).
@var{rest} is interpreted the constructor of @code{<documentable>}."
		    (assert (symbol? name))
		    (assert (netstruct? type))
		    ((apply %make rest) name type))))
      (sealed #f)
      (opaque #t))

    (define (compute-size fields)
      (assert (vector? fields))
      (let loop ((i 0) (size 0))
	(if (>= i (vector-length fields))
	    size
	    (let* ((field (vector-ref fields i))
		   (field-size (%size (field-type field))))
	      (loop (+ i 1)
		    (+ size field-size))))))

    ;; FIXME somehow make the fields vector immutable
    ;; TODO check for duplicates
    (define-record-type (<netstruct:struct> make-netstructure netstructure?)
      (fields (immutable fieldsv %netstruct-fields))
      (parent <netstruct>)
      (protocol (lambda (%make)
		  (lambda (fieldsv . rest)
		    "Contruct a network struct with fields
@var{fieldsv}, a vector of field objects."
		    ((apply %make (compute-size fieldsv) vtable/struct rest)
		     fieldsv))))
      (opaque #t)
      (sealed #f))

    (define vtable/struct
      (let ()
	(define (offsetof ns field)
	  (let* ((vec (%netstruct-fields ns))
		 (vlen (vector-length vec)))
	    (let loop ((i 0) (off 0))
	      (unless (< i vlen)
		(no-such-field 'offsetof))
	      (let* ((field-found (vector-ref vec i))
		     (field-size (%size (field-type field-found))))
		(if (eq? (field-name field-found) field)
		    off
		    (loop (+ i 1)
			  (+ off field-size)))))))

	(define (part ns field)
	  (let* ((vec (%netstruct-fields ns)))
	    (or (vector-any (lambda (f)
			      (and (eq? (field-name f) field)
				   (field-type f)))
			    vec)
		(no-such-field 'part))))
	(make-netstruct-vtable
	 #:offset offsetof
	 #:part part)))

    (define-record-type (<netstruct:array> make-netarray netarray?)
      (fields (immutable type netarray-type)
	      (immutable length netarray-length))
      (parent <netstruct>)
      (protocol (lambda (%make)
		  (lambda (type length . rest)
		    "Construct a network array of length @var{length}
and type @var{type} (a network structure)."
		    (assert (netstruct? type))
		    (assert (exact-natural? length))
		    ((apply %make (* length (%size type)) vtable/array rest)
		     type length))))
      (opaque #t)
      (sealed #f))

    ;; Used from (gnu gnunet netstruct syntactic)
    (define (%out-of-bounds/cond who)
      (condition (make-out-of-bounds)
		 (make-who-condition who)
		 (make-message-condition
		  "index is out of bounds")))

    (define (out-of-bounds who)
      (raise (%out-of-bounds/cond who)))

    (define vtable/array
      (let ()
	(define (offsetof ns field)
	  (assert (exact-natural? field))
	  (if (> field (netarray-length ns))
	      (out-of-bounds 'offsetof))
	  (* field (%size (netarray-type ns))))
	(define (part ns field)
	  (assert (exact-natural? field))
	  (if (> field (netarray-length ns))
	      (out-of-bounds 'part))
	  (netarray-type ns))
	(make-netstruct-vtable
	 #:offset offsetof
	 #:part part)))

    (define-record-type (<netstruct:primitive> make-netprimitive netprimitive?)
      (fields (immutable reader primitive-reader)
	      (immutable setter primitive-setter))
      (parent <netstruct>)
      (protocol (lambda (%make)
		  (lambda (size reader setter . rest)
		    "Construct a network structure of size @var{size}
in bytes that can be read with @var{reader} and modified with @var{setter}.

The reader @var{read} is a one-argument procedure accepting a bytevector slice
of length of size @var{size}.  The writer @var{setter} is a two-argument procedure
accepting a bytevector slice and a value."
		    (assert (procedure? reader))
		    (assert (procedure? setter))
		    (assert (exact-natural? size))
		    ((apply %make size vtable/primitive rest) reader setter))))
      (opaque #t)
      (sealed #f))

    (define vtable/primitive
      (make-netstruct-vtable
       #:reader primitive-reader
       #:setter primitive-setter))

    (define (unsigned-N-bytes length slice-ref slice-set! . rest)
      (apply make-netprimitive length slice-ref slice-set! rest))

    ;; Not used at run-time, only when expanding,
    ;; so this doesn't need to end up in the .go.
    (eval-when (expand)
      (define-syntax define-unsigned-N-bytes
	(syntax-rules ()
	  ((_ (length slice-ref slice-set!)
	      (name-big name-little))
	   (begin
	     (define name-big
	       (unsigned-N-bytes
		length
		(cute slice-ref <> 0 (endianness big))
		(cute slice-set! <> 0 <> (endianness big))
		#:properties '((endianness . big)
			       (integer-type . unsigned))))
	     (define name-little
	       (unsigned-N-bytes
		length
		(cute slice-ref <> 0 (endianness little))
		(cute slice-set! <> 0 <> (endianness little))
		#:properties '((endianness . little)
			       (integer-type . unsigned))))))))
      (define-syntax define-unsigned-N-bytes*
	(syntax-rules ()
	  ((_ ((length slice-ref slice-set!)
	       (name-big name-little)) ...)
	   (begin
	     (define-unsigned-N-bytes
	       (length slice-ref slice-set!) (name-big name-little))
	     ...)))))

    (define u8 (make-netprimitive 1
				  (cut slice-u8-ref <> 0)
				  (cut slice-u8-set! <> 0 <>)
				  #:properties '((integer-type . unsigned))))

    (define-unsigned-N-bytes*
      ((2 slice-u16-ref slice-u16-set!) (u16/big u16/little))
      ((4 slice-u32-ref slice-u32-set!) (u32/big u32/little))
      ((8 slice-u64-ref slice-u64-set!) (u64/big u64/little))
      ((8 slice-ieee-double-ref slice-ieee-double-set!)
       (ieee-double/big ieee-double/little)))

    (define (u8vector n)
      "Return a network structure representing an array of bytes,
of length @var{n}."
      (make-netarray u8 n))))