path: root/gnu/gnunet/util/cmsg.scm

;#!r6rs
;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2021 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
;;   by the Free Software Foundation, either version 3 of the License,
;;   or (at your option) any later version.
;;
;;   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

;; Accessing ancillary data from Scheme.

;; * Analysis: bytes -> ancillary messages
;;
;; The basic procedure is @code{split-ancillary},
;; which analyses the first ancillary message.
;; Also defined is:
;;
;; + count-ancillaries
;; + control->ancillary-vector
;; + control->ancillary-list
;; + ancillary:protocol
;; + ancillary:type
;; + ancillary:data
;;
;; * Construction: ancillary messages -> bytes
;;
;; + control-size: determine the length of the bytevector
;;   to allocate for use in sendmsg(2).
;; + write-ancillary->control!: copy an ancillary message to a slice
;; + write-ancillaries->control!: likewise, for multiple ancillaries
;; + write-ancillary-vector->control!: likewise with different calling
;;   convention.
;; + ancillaries->bytevector: likewise, and make a fresh bytevector for it.
;; + ancillary-vector->bytevector: likewise, with a different calling
;;   convention.
;;
;; * TODO: basic analysis of sock_extended_err & others
(define-module (gnu gnunet util cmsg)
  #:export (;; Data types
	    <ancillary>
	    make-ancillary
	    ancillary?
	    ancillary:protocol
	    ancillary:type
	    ancillary:data
	    ;; Conditions
	    &control-data-too-small
	    make-control-data-too-small
	    control-data-too-small?
	    control-data-too-small:written
	    control-data-too-small:bytes-written
	    ;; bytes --> ancillaries
	    split-ancillary
	    count-ancillaries
	    control->ancillary-vector
	    control->ancillary-list
	    ;; ancillaries --> bytes
	    control-size
	    write-ancillary->control!
	    write-ancillary-vector->control!
	    write-ancillaries->control!
	    ancillary-vector->bytevector
	    ancillaries->bytevector
	    ;; Required by tests
	    cmsghdr:size align-len cmsghdr)
  #:use-module (rnrs records syntactic)
  #:use-module (rnrs conditions)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs exceptions)
  #:use-module (bytestructures guile)
  #:use-module ((rnrs base) #:select (assert))
  #:use-module (srfi srfi-8)
  #:use-module (srfi srfi-26)
  #:use-module (gnu gnunet utils bv-slice))

;; XXX system specific -- but size_t according to POSIX
(define socklen_t size_t)

(define cmsghdr
  (bs:struct
   `((len ,socklen_t) ; length of data + this header
     (level ,int)
     (type ,int))))

(define cmsghdr:size (bytestructure-descriptor-size cmsghdr))

;; This is something glibc does
(define align-len
  (let ((s (bytestructure-descriptor-size size_t)))
    (lambda (len)
      (logand (+ len s -1)
	      (lognot (- s 1))))))

(assert (= cmsghdr:size (align-len cmsghdr:size)))

(define-syntax-rule (case-values exp
				 case ...)
  (call-with-values (lambda () exp)
    (case-lambda case ...)))

(define-record-type (<ancillary> make-ancillary ancillary?)
  (fields (immutable protocol ancillary:protocol)
	  (immutable type ancillary:type)
	  (immutable data ancillary:data))
  (sealed #t)
  (opaque #t)
  (protocol
   (lambda (%make)
     (lambda (protocol type data)
       "Construct an ancillary message, originating from
the protocol @var{protocol}, having a protocol-specific type
@var{type} and data @var{data} (a readable bytevector slice).
The numeric values of @var{protocol} and @var{type} and
system-dependent."
       ;; TODO verify bounds of protocol and type
       (assert (and (exact-integer? protocol)
		    (exact-integer? type)
		    (slice-readable? data)))
       (%make protocol type data)))))


;; Analysis of control data

(define (split-ancillary control-slice)
  "Split off the first ancillary datum from @var{control-slice},
returning the protocol, the type, the bytevector slice of the data
and the rest.  If there are no ancillaries anymore, return nothing
instead.  If a fancy data type for ancillaries is desired, see
@code{make-ancillary}.  If the ancillary didn't fit in
@var{control-slice} (i.e., it was truncated), this is counted as
‘no ancillaries’."
  (assert (slice-readable? control-slice))
  (if (< (slice-length control-slice) cmsghdr:size)
      (values)
      (receive (len level type)
	  (let ((bv (slice-bv control-slice))
		(of (slice-offset control-slice)))
	    (let-syntax ((ref (syntax-rules ()
				((_ field)
				 (bytestructure-ref* bv of cmsghdr 'field)))))
	      (values (ref len)
		      (ref level)
		      (ref type))))
	;; according to glibc, the first can happen somehow
	(if (or (< len cmsghdr:size)
		(< (slice-length control-slice) len))
	    (values)
	    (let ((aligned-len (align-len len)))
	      (values level type
		      (slice-slice control-slice cmsghdr:size
				   (- len cmsghdr:size))
		      (slice-slice control-slice
				   (min (slice-length control-slice)
					aligned-len))))))))

(define (count-ancillaries control-slice)
  "Count the number of ancillary messages in @var{control-slice}.
Ignore the last ancillary if it was truncated."
  (let loop ((n 0) (control-slice control-slice))
    (case-values (split-ancillary control-slice)
		 (() n)
		 ((x y z rest)
		  (loop (+ 1 n) rest)))))

(define (control->ancillary-vector control-slice)
  "Make a vector of ancillary messages for each
ancillary message in @var{control-slice} (in the same order).
Ignore the last ancillary if it was truncated."
  (let* ((n (count-ancillaries control-slice))
	 (v (make-vector n)))
    (let loop ((i 0) (control-slice control-slice))
      (if (< i n)
	  (receive (protocol type data rest)
	      (split-ancillary control-slice)
	    (vector-set! v i (make-ancillary protocol type data))
	    (loop (+ 1 i) rest))
	  v))))

(define (control->ancillary-list control-slice)
  "Make a list of ancillary messages for each
ancillary message in @var{control-slice} (in the same order).
Ignore the last ancillary if it was truncated."
  (let loop ((control-slice control-slice))
    (case-values (split-ancillary control-slice)
		 (() '())
		 ((protocol type data rest)
		  (cons (make-ancillary protocol type data)
			(loop rest))))))


;; Constructing control data
(define (control-size . data-sizes)
  (define control-size-acc
    (case-lambda
      ((n) n)
      ((n data-size . data-sizes)
       (apply control-size-acc (+ n (align-len (+ cmsghdr:size data-size)))
	      data-sizes))))
  (apply control-size-acc 0 data-sizes))

(define (write-ancillary->control! control-slice ancillary)
  "Write the ancillary message @var{ancillary} to the control
data @var{control-slice} (a writable bytevector slice).

Return the number written/the length of the ancillary message
on success (that is, there was sufficient space in
@var{control-slice}), and zero values otherwise."
  (assert (slice-writable? control-slice))
  (assert (ancillary? ancillary))
  (let ((required-space
	 (+ cmsghdr:size
	    (align-len (slice-length (ancillary:data ancillary))))))
    (if (< (slice-length control-slice) required-space)
	(values)
	(let ((bv (slice-bv control-slice))
	      (of (slice-offset control-slice))
	      (length
	       (+ cmsghdr:size (slice-length (ancillary:data ancillary)))))
	  (let-syntax ((set (syntax-rules ()
			      ((_ field val)
			       (bytestructure-set!* bv of cmsghdr 'field val)))))
	    (set len length)
	    (set level (ancillary:protocol ancillary))
	    (set type (ancillary:type ancillary))
	    (slice-copy! (ancillary:data ancillary)
			 (slice/write-only
			  control-slice cmsghdr:size
			  (slice-length
			   (ancillary:data ancillary))))
	    (slice-zero!
	     (slice-slice control-slice length (- required-space length))))
	  required-space))))

(define-condition-type &control-data-too-small &error
  %make-control-data-too-small control-data-too-small?
  (written control-data-too-small:written) ; ancillaries written
  ;; total size of ancillaries written, including padding
  (bytes-written  control-data-too-small:bytes-written))

(define (make-control-data-too-small written bytes-written)
  (assert (and (exact-integer? written)
	       (exact-integer? bytes-written)
	       (<= 0 written)
	       (<= 0 bytes-written)))
  (%make-control-data-too-small written bytes-written))

(define (write-ancillary-vector->control! control-slice a)
  "Write the ancillary messages in the vector @var{a} to the
control data @var{control-slice} (a writable bytevector slice)
and return the number of bytes written (including padding).

In case @var{control-slice} is too small, a @code{&control-data-too-small}
error is raised.

Even if such a condition is raised, this procedure will still
write as many ancillary messages as fit in @var{control-slice},
setting the @var{written} field to the number of ancillary
messages written and @var{bytes-written} to the number of bytes
these control messages occupy."
  (define (too-small ancillaries-written bytes-written)
    (raise (condition
	    (make-control-data-too-small ancillaries-written bytes-written)
	    (make-who-condition 'write-ancillary-vector->control!))))
  (assert (and (slice-writable? control-slice) (vector? a)))
  (let loop ((i 0) (bytes-written 0) (control-slice control-slice))
    (if (< i (vector-length a))
	(let ((x (vector-ref a i)))
	  (assert (ancillary? x))
	  (case-values (write-ancillary->control! control-slice x)
		       (() (too-small i bytes-written))
		       ((n)
			(loop (+ i 1) (+ bytes-written n)
			      (slice-slice control-slice n)))))
	bytes-written)))

(define (write-ancillaries->control! control-slice . a)
  (write-ancillary-vector->control! control-slice
				    (list->vector a)))

(define (ancillary-vector->bytevector a)
  "Make a fresh bytevector consisting of the ancillary messages in
the vector @var{a}."
  ;; TODO performance: the lucid calculation of the required bytevector
  ;; size could be done less lucid (reduce allocations, single pass).
  (let* ((size (apply + (map (compose
			      (cute + cmsghdr:size <>)
			      align-len
			      slice-length
			      ancillary:data)
			     (vector->list a))))
	 (bv (make-bytevector size))
	 ;; should not result in &control-data-too-small
	 (written (write-ancillary-vector->control!
		   (bv-slice/write-only bv)
		   a)))
    (assert (= size written))
    bv))

(define (ancillaries->bytevector . a)
  "Make a fresh bytevector consisting of the ancillary messages
@var{a}."
  (ancillary-vector->bytevector (list->vector a)))