[gnunet-scheme] 136/324: mq: Verify message size during message injection.

[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 d43408138d119d9042c91b12824a485913cfeb53
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Tue Jun 15 17:19:18 2021 +0200

    mq: Verify message size during message injection.
    
    * gnu/packages/mq.scm
      (inject-message!): When the message doesn't have a header,
      raise a &missing-header-error.  When the size of message slice
      doesn't match the size in the message header, raise a
      &size-mismatch-error.  Document this behaviour.
      (&missing-header-error): New condition type.
      (&size-mismatch-error): New condition type.
---
 gnu/gnunet/mq.scm | 73 +++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 60 insertions(+), 13 deletions(-)

diff --git a/gnu/gnunet/mq.scm b/gnu/gnunet/mq.scm
index 5e1e291..94b13b7 100644
--- a/gnu/gnunet/mq.scm
+++ b/gnu/gnunet/mq.scm
@@ -34,12 +34,18 @@
          make-one-by-one-sender
          inject-message! send-message!
          message-queue-length
-         try-send-again!)
+         try-send-again!
+
+         &missing-header-error make-missing-header-error
+         missing-header-error? missing-header-error-received-size
+         &size-mismatch-error make-size-mismatch-error
+         size-mismatch-error? size-mismatch-error-expected-size
+         size-mismatch-error-received-size)
   (import (gnu gnunet mq handler)
          (gnu gnunet mq envelope)
          (gnu gnunet utils hat-let)
          (only (gnu gnunet utils bv-slice)
-               slice?)
+               slice-slice slice-length slice?)
          (only (gnu gnunet util struct)
                /:message-header)
          (only (gnu gnunet netstruct syntactic)
@@ -51,14 +57,14 @@
          (only (rnrs base)
                lambda assert let begin define
                procedure? eq? >= = <= < if quote
-               values and let*)
+               values and let* not)
          (only (rnrs control)
                when unless)
          (only (rnrs conditions)
-               define-condition-type &warning
+               define-condition-type &warning &error
                make-who-condition condition)
          (only (rnrs exceptions)
-               raise-continuable)
+               raise raise-continuable)
          (only (rnrs records syntactic) define-record-type)
          (only (srfi srfi-8) receive)
          (prefix (only (pfds queues)
@@ -155,24 +161,65 @@ with the message @var{message}. In case the message is 
malformed
 (according to the message handler), inject a @code{&malformed-message}
 error instead.
 
+(TODO). In case no appropriate message handler exists,
+inject a ??? instead.
+
+It is an error for @var{message} to be so small it doesn't have
+a @code{/:message-header}. Likewise, it is also an error for the
+size in the message header not to correspond to the size of the
+slice @var{message}.  In the first case, a @code{&missing-header-error}
+is raised.  In the second case, a @code{&size-mismatch-error} is raised.
+
+In both cases, a @code{&who} condition with as value @code{inject-message!}
+(a symbol) is included as well.
+
 This procedure is intended to be used by the implementation
 of message queues."
-      (let* ((header (slice-slice message 0 (sizeof /:message-header '(type))))
-            (handler (message-handler-for
-                      (message-queue-handlers mq)
-                      (read% /:message-header '(type) header))))
-       (if (verify-message? handler message)
+      (let^ ((! message-header-size (sizeof /:message-header '()))
+            (! message-size (slice-length message))
+            (? (< message-size message-header-size)
+               (raise (condition
+                       (make-missing-header-error message-size)
+                       (make-who-condition 'inject-message!))))
+            (! header
+               (slice-slice message 0 (sizeof /:message-header '())))
+            (! type (read% /:message-header '(type) header))
+            (! supposed-size (read% /:message-header '(size) header))
+            (? (not (= message-size supposed-size))
+               (raise (condition
+                       (make-size-mismatch-error supposed-size message-size)
+                       (make-who-condition 'inject-message!))))
+            ;; #f if does not exist
+            (! handler (message-handler-for
+                        (message-queue-handlers mq)
+                        (read% /:message-header '(type) header)))
+            (? (not handler)
+               ;; TODO: error handling
+               (inject-error! handler ???))
+            (? (not (verify-message? handler message))
+               ;; TODO: error handling
+               (inject-error! handler ???))) ; malformed message
            ;; TODO: maybe a good place to catch out-of-memory
            ;; and stack overflow errors ...
-           (handle-message! handler message)
-           ;; XXX
-           (inject-error! handler message))))
+           (handle-message! handler message)))
 
     (define (message-queue-length mq)
       "How many messages are currently in the message queue @var{mq}?"
       (pfds:queue-length
        (atomic-box-ref (message-queue-messages/box mq))))
 
+    ;; TODO: should this be a subtype of the not-yet-existing
+    ;; &malformed-message?
+    (define-condition-type &missing-header-error &error
+      make-missing-header-error missing-header-error?
+      (received-size missing-header-error-received-size))
+
+    ;; TODO: likewise
+    (define-condition-type &size-mismatch-error &error
+      make-size-mismatch-error size-mismatch-error?
+      (expected-size size-mismatch-error-expected-size)
+      (received-size size-mismatch-error-received-size))
+
     (define-condition-type &overly-full-queue-warning &warning
       make-overly-full-queue-warning overly-full-queue-warning?
       (current-length  overly-full-queue-length)

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