;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2020, 2021 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
	  wrap-reader-setter
	  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-ref <> 0 (endianness big))
	      (cute slice-set! <> 0 (endianness big) <>)))
	   (define-syntax name-little
	     (unsigned-N-bytes
	      length
	      (cute slice-ref <> 0 (endianness little))
	      (cute slice-set! <> 0 (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-u32-set!) (u32/big u32/little))
    ((8 slice-u64-ref slice-u64-set!) (u64/big u64/little)))

  ;; FIXME ideally field names would be symbols,
  ;; not strings, but I can't get this to work
  ;; with symbols.
  (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)
	 ((% :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 wrap-reader-setter
    (syntax-rules ()
      ((_ internal internal->wrap wrap->internal)
       (syntax-rules (:sizeof :offset :reader :setter)
	 ((% :sizeof rest)
	  (internal :sizeof rest))
	 ((% :offset ())
	  (internal :offset ()))
	 ((% :reader ())
	  (let ((internal-reader (internal :reader ()))
		(internal->wrap/expanded internal->wrap))
	    (lambda (slice)
	      (internal->wrap (internal-reader slice)))))
	 ((% :setter ())
	  (let ((internal-setter (internal :setter ()))
		(wrap->internal/expanded wrap->internal))
	    (lambda (slice wrapped)
	      (internal-setter slice (wrap->internal wrapped)))))))))

  (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)))