More work on network tests.

tests/helper.scm

@@ -37,6 +37,25 @@
 (load "test.scm")
 ;;; Software timer
 (load "timer.scm")
+(define m2pa-var-forward-seq                #xFFFFFF)
+
+;;; Helper constants
+
+(define helper-direction-recv               1)
+(define helper-direction-send               2)
+
+;;; Helper variables
+
+(define helper-var-last-display-msg         '())
+(define helper-var-last-display-direction   0)
+(define helper-var-display-newline          #f)
+
+(define helper-init-vars
+  (lambda ()
+    (set! helper-var-last-display-msg '())
+    (set! helper-var-last-display-direction 0)
+    (set! helper-var-display-newline #f)
+    ))
 
 (define predicate?
   (lambda (pred data)
@@ -94,6 +113,25 @@
     ret))
 !#
 
+(define msg-display
+ (lambda (message direction)
+   (if (and (equal? message helper-var-last-display-msg) (= direction helper-var-last-display-direction))
+       (begin
+         (display ".")
+         (set! helper-var-display-newline #t))
+       (begin
+         (if helper-var-display-newline
+             (begin
+               (display "\n")
+               (set! helper-var-display-newline #f)))
+         (if (= direction helper-direction-recv)
+             (display "<-")
+             (display "->"))
+         (set! helper-var-last-display-msg (list-copy message))
+         (set! helper-var-last-display-direction direction)
+         (display message)
+         (display "\n")))))
+ 
 ;;;
 ;;; Padding helper functions
 ;;;

tests/pkth.scm

@@ -39,11 +39,13 @@
 (load "sock.scm")
 ;;; Helper functions
 (load "helper.scm")
+;;; Network configuration
+(load "pkth_config.scm")
 
 ;;; SCTP Payload Protocol Identifier for PKTH
 (define pkth-ppid                               0)
 
-;;; SCTP Port for PKTH
+;;; TCP/SCTP Port for PKTH
 (define pkth-port                               7234)
 
 ;;; PKTH protocol version
@@ -152,6 +154,7 @@
 
 ;;; Value lengths
 (define pkth-length-version                     2)
+(define pkth-length-revision                    2)
 (define pkth-length-string-length               2)
 (define pkth-length-flags                       2)
 (define pkth-length-reserved                    2)
@@ -178,7 +181,7 @@
 ;;; Value offsets pkth-type-init-ack
 (define pkth-init-ack-offset-game-version       pkth-offset-data)
 (define pkth-init-ack-offset-beta-revision      (+ pkth-init-ack-offset-game-version pkth-length-version))
-(define pkth-init-ack-offset-session-id         (+ pkth-init-ack-offset-beta-revision pkth-length-version))
+(define pkth-init-ack-offset-session-id         (+ pkth-init-ack-offset-beta-revision pkth-length-revision))
 (define pkth-init-ack-offset-player-id          (+ pkth-init-ack-offset-session-id pkth-length-session-id))
 
 ;;; Minimum/maximum packet length
@@ -348,7 +351,6 @@
   (lambda (message)
     (pkth-assert-minimal-length message)
     (let ((type (bytes->uint16 (list-head (list-tail message pkth-offset-type) pkth-length-type))))
-      (test-assert (pkth-is-valid-type? type))
       type)))
 
 (define pkth-get-length
@@ -361,6 +363,28 @@
     (pkth-assert-minimal-length message)
     (list-tail message pkth-offset-data)))
 
+;;; init-ack
+
+(define pkth-get-init-ack-game-version
+  (lambda (message)
+    (pkth-assert-length message (+ pkth-header-length-common pkth-length-version))
+    (bytes->uint16 (list-head (pkth-get-data message) pkth-length-version))))
+
+(define pkth-get-init-ack-beta-revision
+  (lambda (message)
+    (pkth-assert-length message (+ pkth-header-length-common pkth-init-ack-offset-beta-revision pkth-length-revision))
+    (bytes->uint16 (list-head (list-tail (pkth-get-data message) pkth-init-ack-offset-beta-revision) pkth-length-revision))))
+
+(define pkth-get-init-ack-session-id
+  (lambda (message)
+    (pkth-assert-length message (+ pkth-header-length-common pkth-init-ack-offset-session-id pkth-length-session-id))
+    (bytes->uint32 (list-head (list-tail (pkth-get-data message) pkth-init-ack-offset-session-id) pkth-length-session-id))))
+
+(define pkth-get-init-ack-player-id
+  (lambda (message)
+    (pkth-assert-length message (+ pkth-header-length-common pkth-init-ack-offset-player-id pkth-length-player-id))
+    (bytes->uint32 (list-head (list-tail (pkth-get-data message) pkth-init-ack-offset-player-id) pkth-length-player-id))))
+
 ;;;
 ;;; Type check functions
 ;;;
@@ -547,15 +571,85 @@
 
 ;;; pkth-type-init
 
+;;;
+;;; I/O functions
+;;;
+
+;;; Close helper
+(define pkth-has-sock #f)
+(define pkth-sock 0)
+(define pkth-recv-buf "")
+
+(define pkth-close
+  (lambda ()
+    (if pkth-has-sock
+        (begin
+          (sock-close pkth-sock)
+          (set! pkth-has-sock #f)
+          (set! pkth-recv-buf "")))))
+
+;;; Connect to server according to config.
+(define pkth-connect
+  (lambda ()
+    (pkth-close)
+    (helper-init-vars)
+    (let ((sock (sock-create-tcp PKTH_CONF_CONNECT_ADDR_FAMILY)))
+      (sock-bind sock PKTH_CONF_CONNECT_LOCAL_ADDR PKTH_CONF_CONNECT_LOCAL_PORT)
+      (sock-connect sock PKTH_CONF_CONNECT_REMOTE_ADDR PKTH_CONF_CONNECT_REMOTE_PORT)
+      (set! pkth-sock sock)
+      (set! pkth-has-sock #t)
+      sock)))
+
+(define pkth-send-message-nolog
+  (lambda (socket message)
+    (sock-send socket (bytes->string message))))
+
+(define pkth-send-message
+  (lambda (socket message)
+    (msg-display message helper-direction-send)
+    (pkth-send-message-nolog socket message)))
+
+; The recv function for PKTH is somewhat more complicated, because
+; TCP has to be supported. We have to check for message boundaries.
+(define pkth-recv-message
+  (lambda (socket)
+    (let ((ret 0))
+      (do ((abort #f))
+          (abort)
+          (let ((buflen (string-length pkth-recv-buf)))
+            (if (>= buflen pkth-header-length-common)
+                (begin
+                  (let ((packetlen (pkth-get-length (string->bytes pkth-recv-buf))))
+                    (if (<= packetlen buflen)
+                        (begin
+                          (set! abort #t)
+                          (let ((packet (string-copy (substring pkth-recv-buf 0 packetlen))))
+                            (set! pkth-recv-buf (string-drop pkth-recv-buf packetlen))
+                            (set! ret (string->bytes packet))
+                            (test-assert (pkth-is-valid-type? (pkth-get-type ret)) "Invalid PKTH message type.")
+                            (msg-display ret helper-direction-recv))))))))
+          (if (not abort)
+              (let ((buf (make-string pkth-maximum-message-length)))
+                (let ((recvret (sock-recv! socket buf)))
+                  (let ((tmpbuf (substring buf 0 (car recvret))))
+                    (if (string-null? tmpbuf) ; Abort if connection closed.
+                        (begin
+                          (set! pkth-recv-buf "")
+                          (set! abort #t)
+                          (set! ret #f))
+                        (begin
+                          (set! pkth-recv-buf (string-append pkth-recv-buf tmpbuf)))))))))
+      ret)))
+
 #!
-(let ((sock (sock-connect (sock-create-tcp AF_INET) "127.0.0.1" pkth-port)))
+(let ((sock (pkth-connect)))
-  (sock-send
+  (pkth-send-message
    sock
-   (bytes->string
+   (pkth-create-init
-    (pkth-create-init
+    (pkth-create-md5 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
-     (pkth-create-md5 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
+    ""
-     ""
+    "hallo"))
-     "hallo")))
+  (pkth-recv-message sock)
   (sleep 1)
-  (sock-close sock))
+  (pkth-close))
 !#

tests/pkth_config.scm

@@ -0,0 +1,40 @@
+;;; 
+;;; Copyright (C) 2007 Lothar May l-may@gmx.de
+;;; 
+;;; All rights reserved.
+;;; 
+;;; Redistribution and use in source and binary forms, with or
+;;; without modification, are permitted provided that the
+;;; following conditions are met:
+;;; 1. Redistributions of source code must retain the above
+;;;    copyright notice, this list of conditions and the
+;;;    following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the
+;;;    above copyright notice, this list of conditions and
+;;;    the following disclaimer in the documentation and/or
+;;;    other materials provided with the distribution.
+;;; 3. Neither the name of the project nor the names of
+;;;    its contributors may be used to endorse or promote
+;;;    products derived from this software without specific
+;;;    prior written permission.
+;;;  
+;;; THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS
+;;; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,
+;;; BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;;; DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS
+;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
+;;; IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY
+;;; OF SUCH DAMAGE.
+
+(define PKTH_CONF_CONNECT_LOCAL_ADDR "192.168.1.5")
+(define PKTH_CONF_CONNECT_LOCAL_PORT 0)
+(define PKTH_CONF_CONNECT_REMOTE_ADDR "192.168.1.4")
+(define PKTH_CONF_CONNECT_REMOTE_PORT 7234)
+(define PKTH_CONF_CONNECT_ADDR_FAMILY AF_INET)

tests/pkth_tests.scm

@@ -0,0 +1,64 @@
+;;; 
+;;; Copyright (C) 2007 Lothar May l-may@gmx.de
+;;; 
+;;; All rights reserved.
+;;; 
+;;; Redistribution and use in source and binary forms, with or
+;;; without modification, are permitted provided that the
+;;; following conditions are met:
+;;; 1. Redistributions of source code must retain the above
+;;;    copyright notice, this list of conditions and the
+;;;    following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the
+;;;    above copyright notice, this list of conditions and
+;;;    the following disclaimer in the documentation and/or
+;;;    other materials provided with the distribution.
+;;; 3. Neither the name of the project nor the names of
+;;;    its contributors may be used to endorse or promote
+;;;    products derived from this software without specific
+;;;    prior written permission.
+;;;  
+;;; THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS
+;;; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,
+;;; BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;;; DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS
+;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
+;;; IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY
+;;; OF SUCH DAMAGE.
+
+;;; PKTH functions
+(load "pkth.scm")
+
+(define pkth-test-list '())
+
+(define (pkth-test-init-packet-too-large)
+  (let ((sock (pkth-connect)))
+    (display "Sending loads of large init packets...\n")
+    (dotimes (n 2048)
+             (pkth-send-message
+              sock
+              (pkth-create-packet
+               pkth-type-init
+               (list
+                (uint16->bytes pkth-version-major)
+                (uint16->bytes pkth-version-minor)
+                (uint16->bytes (string-length ""))
+                (uint16->bytes (string-length "test"))
+                (uint16->bytes 0)
+                (uint16->bytes 0)
+                (append-padding (string->bytes ""))
+                (append-padding (string->bytes "test"))
+                (make-list 1024 0)))))
+    (display "Done.\n")
+  ))
+(set! pkth-test-list (test-register pkth-test-list "PKTH Test 1 Init with too large packets" pkth-test-init-packet-too-large))
+
+(test-run-all pkth-test-list)
+(pkth-close)