From 901fc1634d5a0d866ba3073ada979dceb62bb62e Mon Sep 17 00:00:00 2001 From: lotodore Date: Wed, 3 Oct 2007 22:14:31 +0000 Subject: [PATCH] Added first parts of server test code. --- tests/common.scm | 280 ++++++++++++++++++++++++++++++++++++++++++++++ tests/helper.scm | 101 +++++++++++++++++ tests/pkth.scm | 285 +++++++++++++++++++++++++++++++++++++++++++++++ tests/sock.scm | 173 ++++++++++++++++++++++++++++ tests/test.scm | 87 +++++++++++++++ tests/timer.scm | 59 ++++++++++ 6 files changed, 985 insertions(+) create mode 100644 tests/common.scm create mode 100644 tests/helper.scm create mode 100644 tests/pkth.scm create mode 100644 tests/sock.scm create mode 100644 tests/test.scm create mode 100644 tests/timer.scm diff --git a/tests/common.scm b/tests/common.scm new file mode 100644 index 00000000..c4594495 --- /dev/null +++ b/tests/common.scm @@ -0,0 +1,280 @@ +;;; +;;; Copyright (C) 2004, 2005 M. Tuexen tuexen@fh-muenster.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. + +;;; $Id: common.scm,v 1.4 2006/01/18 01:00:30 tuexen Exp $ + +;;; Load the SCTP API needed. +(use-modules (net sctp)) + +;;; Just have a convenient way of simple looping. +(use-modules (ice-9 syncase)) +(define-syntax dotimes + (syntax-rules () + ((_ (var n res) . body) + (do ((limit n) + (var 0 (+ var 1))) + ((>= var limit) res) + . body)) + ((_ (var n) . body) + (do ((limit n) + (var 0 (+ var 1))) + ((>= var limit)) + . body)))) + +;;; The following functions implement modulo arithmetic. +(define 2^8 (expt 2 8)) +(define 2^16 (expt 2 16)) +(define 2^24 (expt 2 24)) +(define 2^32 (expt 2 32)) + +(define 2^8-1 (1- 2^8)) +(define 2^16-1 (1- 2^16)) +(define 2^24-1 (1- 2^24)) +(define 2^32-1 (1- 2^32)) + +(define (+mod2^8 x y) + (modulo (+ x y) 2^8)) +(define (-mod2^8 x y) + (modulo (- x y) 2^8)) +(define (*mod2^8 x y) + (modulo (* x y) 2^8)) + +(define (+mod2^16 x y) + (modulo (+ x y) 2^16)) +(define (-mod2^16 x y) + (modulo (- x y) 2^16)) +(define (*mod2^16 x y) + (modulo (* x y) 2^16)) + +(define (+mod2^24 x y) + (modulo (+ x y) 2^24)) +(define (-mod2^24 x y) + (modulo (- x y) 2^24)) +(define (*mod2^24 x y) + (modulo (* x y) 2^24)) + +(define (+mod2^32 x y) + (modulo (+ x y) 2^32)) +(define (-mod2^32 x y) + (modulo (- x y) 2^32)) +(define (*mod2^32 x y) + (modulo (* x y) 2^32)) + +;;; The following functions convert unsigned integers into +;;; a list of bytes in network byte order. + +(define (uint8->bytes n) + (if (and (exact? n) (integer? n) (<= 0 n 2^8-1)) + (list n) + (error "Argument not a uint8" n))) + +;;;(uint8->bytes 1) +;;;(uint8->bytes -1) +;;;(uint8->bytes 2^8) +;;;(uint8->bytes 2.0) + +(define (uint16->bytes n) + (if (and (exact? n) (integer? n) (<= 0 n 2^16-1)) + (list (quotient n 2^8) + (remainder n 2^8)) + (error "Argument not a uint16" n))) + +;;;(uint16->bytes 1) +;;;(uint16->bytes 2^8) +;;;(uint16->bytes 2^16) +;;;(uint16->bytes 2^16-1) + +(define (uint24->bytes n) + (if (and (exact? n) (integer? n) (<= 0 n 2^24-1)) + (list (quotient n 2^16) + (quotient (remainder n 2^16) 2^8) + (remainder n 2^8)) + (error "Argument not a uint24", n))) + +;;;(uint24->bytes 1) +;;;(uint24->bytes 2^8) +;;;(uint24->bytes 2^16) +;;;(uint24->bytes 2^24-1) + +(define (uint32->bytes n) + (if (and (exact? n) (integer? n) (<= 0 n 2^32-1)) + (list (quotient n 2^24) + (quotient (remainder n 2^24) 2^16) + (quotient (remainder n 2^16) 2^8) + (remainder n 2^8)) + (error "Argument not a uint32", n))) + +;;;(uint32->bytes 1) +;;;(uint32->bytes 2^8) +;;;(uint32->bytes 2^16) +;;;(uint32->bytes 2^24) +;;;(uint32->bytes 2^32-1) + +(define uint8->big-endian-bytes uint8->bytes) +(define uint16->big-endian-bytes uint16->bytes) +(define uint24->big-endian-bytes uint24->bytes) +(define uint32->big-endian-bytes uint32->bytes) + +(define (uint8->little-endian-bytes n) + (reverse (uint8->bytes n))) + +(define (uint16->little-endian-bytes n) + (reverse (uint16->bytes n))) + +(define (uint24->little-endian-bytes n) + (reverse (uint24->bytes n))) + +(define (uint32->little-endian-bytes n) + (reverse (uint32->bytes n))) + +;;;(uint32->little-endian-bytes 1024) + + +;;; The following functions converts the first bytes of the argument +;;; to an unsigned integer in host byte order. + +(define (bytes->uint8 l) + (car l)) + +;;;(bytes->uint8 (uint8->bytes 56)) + +(define (bytes->uint16 l) + (+ (* 2^8 (car l)) + (cadr l))) + +;;;(bytes->uint16 (uint16->bytes 12345)) + +(define (bytes->uint24 l) + (+ (* 2^16 (car l)) + (* 2^8 (cadr l)) + (caddr l))) + +;;;(bytes->uint24 (uint24->bytes 12345567)) + +(define (bytes->uint32 l) + (+ (* 2^24 (car l)) + (* 2^16 (cadr l)) + (* 2^8 (caddr l)) + (cadddr l))) + +;;;(bytes->uint32 (uint32->bytes 2^32-1)) + +(define (list-head l n) + (list-head-1 l n (list))) + +(define (list-head-1 l n r) + (if (<= n 0) + (reverse r) + (list-head-1 (cdr l) (- n 1) (cons (car l) r)))) +;;; (list-head (list 1 2 3) 4) + +(define big-endian-bytes->uint8 bytes->uint8) +(define big-endian-bytes->uint16 bytes->uint16) +(define big-endian-bytes->uint24 bytes->uint24) +(define big-endian-bytes->uint32 bytes->uint32) + +(define (little-endian-bytes->uint8 l) + (bytes->uint8 (reverse (list-head l 1)))) + +(define (little-endian-bytes->uint16 l) + (bytes->uint16 (reverse (list-head l 2)))) + +(define (little-endian-bytes->uint24 l) + (bytes->uint24 (reverse (list-head l 3)))) + +(define (little-endian-bytes->uint32 l) + (bytes->uint32 (reverse (list-head l 4)))) +;;;(little-endian-bytes->uint32 (uint32->little-endian-bytes 123456)) + +;;; This function generates a list of bytes representing a string. + +(define (string->bytes s) + (map char->integer (string->list s))) + +;;;(string->bytes "Hello") + +;;; Convert a list of bytes to a string which can be used by the send call + +(define (bytes->string l) + (list->string (map integer->char l))) + +;;; (bytes->string '(65 65 65 0 65)) + +;;; This function generates a list of random bytes of a given length + +(define (random-bytes n) + (random-bytes-1 n (list))) + +;;; This is the tail-recursive version + +(define (random-bytes-1 n l) + (if (<= n 0) + l + (random-bytes-1 (- n 1) (cons (random 2^8) l)))) + +;;; (random-bytes 10000) + +(define (zero-bytes n) + (zero-bytes-1 n (list))) + +(define (zero-bytes-1 n l) + (if (<= n 0) + l + (zero-bytes-1 (- n 1) (cons 0 l)))) + +;;;(length (zero-bytes 3400)) +;;;(zero-bytes 0) + +(define (remove pred lst) + (if (null? lst) + (list) + (if (pred (car lst)) + (remove pred (cdr lst)) + (cons (car lst) (remove pred (cdr lst)))))) +;;; (remove positive? (list 1 -32 3 -9)) +;;; (remove positive? (list -9)) +;;; (remove positive? (list 1 2 3)) + +(define (filter pred lst) + (if (null? lst) + (list) + (if (pred (car lst)) + (cons (car lst) (filter pred (cdr lst))) + (filter pred (cdr lst))))) +;;; (filter positive? (list 1 -32 3 -9)) +;;; (filter positive? (list -9)) +;;; (filter positive? (list 1 2 3)) + + diff --git a/tests/helper.scm b/tests/helper.scm new file mode 100644 index 00000000..de40377d --- /dev/null +++ b/tests/helper.scm @@ -0,0 +1,101 @@ +;;; +;;; 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. + +;;; Test functions +(load "test.scm") +;;; Software timer +(load "timer.scm") + +(define predicate? + (lambda (pred data) + (apply pred (list data)))) + +(define predicate-one-true? + (lambda (predicate-list data) + (let ((data-list (make-list (length predicate-list) data))) + (primitive-eval (append '(or) (map predicate? predicate-list data-list)))))) + +(define wait-for-message + (lambda (socket recv-function predicate-list ignore-predicate-list timeout-msec) + (let ((t (timer-create timeout-msec)) (ret #f)) + (set! t (timer-start t)) + (do ((abort #f)) + (abort) + (if (sock-select-read socket 10) + (begin + (let ((msg (recv-function socket))) + (if (predicate-one-true? predicate-list msg) + (begin + (set! abort #t) + (test-assert (not (predicate-one-true? ignore-predicate-list msg)) "Invalid message received.") + (set! ret #t)))))) + (if (timer-expired? t) + (set! abort #t))) + ret))) + +#! +(define recv-message + (lambda (socket) + (let ((buffer (make-string 256))) + (let ((ret (sock-recv! socket buffer))) + (let ((n (car ret))) + (string->bytes (substring buffer 0 n))))))) + +(define msg-test? + (lambda (msg) + #t)) + +(let ((sock (car (sock-accept (sock-bind-listen (sock-create-tcp AF_INET) "127.0.0.1" 6002 5))))) + (let ((ret (wait-for-message sock recv-message (list msg-test?) '() 10000))) + (sleep 1) + (sock-close sock) + ret)) +!# + +;;; +;;; Padding helper functions +;;; + +(define calc-num-padding-bytes + (lambda (size) + (remainder (- 4 (remainder size 4)) 4))) + +(define append-padding + (lambda (data) + (append data (zero-bytes (calc-num-padding-bytes (length data)))))) + +#! +(append-padding (list 1 2 3 4 5)) +!# diff --git a/tests/pkth.scm b/tests/pkth.scm new file mode 100644 index 00000000..d3b88b4d --- /dev/null +++ b/tests/pkth.scm @@ -0,0 +1,285 @@ +;;; +;;; 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. + +;;; Version 1.0.0 + +;;; Socket functions +(load "sock.scm") +;;; Helper functions +(load "helper.scm") + +;;; SCTP Payload Protocol Identifier for PKTH +(define pkth-ppid 0) + +;;; SCTP Port for PKTH +(define pkth-port 7234) + +;;; PKTH protocol version +(define pkth-version-major 2) +(define pkth-version-minor 0) + +(define pkth-type-init #x0001) +(define pkth-type-init-ack #x0002) +(define pkth-type-game-list-new #x0003) +(define pkth-type-game-list-update #x0004) +(define pkth-type-game-list-player-joined #x0005) +(define pkth-type-game-list-player-left #x0006) +(define pkth-type-retrieve-player-info #x0007) +(define pkth-type-player-info #x0008) +(define pkth-type-create-game #x0009) +(define pkth-type-join-game #x000A) +(define pkth-type-join-game-ack #x000B) +(define pkth-type-join-game-failed #x000C) +(define pkth-type-player-joined #x000D) +(define pkth-type-player-left #x000E) +(define pkth-type-game-admin-changed #x000F) +(define pkth-type-kick-player #x0010) +(define pkth-type-leave-current-game #x0011) +(define pkth-type-start-event #x0012) +(define pkth-type-game-start #x0013) +(define pkth-type-hand-start #x0014) +(define pkth-type-players-turn #x0015) +(define pkth-type-players-action #x0016) +(define pkth-type-players-action-done #x0017) +(define pkth-type-players-action-rejected #x0018) +(define pkth-type-deal-flop-cards #x0019) +(define pkth-type-deal-turn-card #x001A) +(define pkth-type-deal-river-card #x001B) +(define pkth-type-all-in-show-cards #x001C) +(define pkth-type-end-of-hand-show-cards #x001D) +(define pkth-type-end-of-hand-hide-cards #x001E) +(define pkth-type-end-of-game #x001F) + +(define pkth-type-removed-from-game #x0100) + +(define pkth-type-send-chat-text #x0200) +(define pkth-type-chat-text #x0201) + +(define pkth-type-error #x0400) + +(define pkth-game-flag-password-protected #x01) + +(define pkth-player-flag-human #x01) +(define pkth-player-flag-has-avatar #x02) + +(define pkth-start-flag-fill-with-cpu-players #x01) + +(define pkth-privacy-flag-show-avatar #x01) + +;;; Reasons why join game failed. +(define pkth-join-failed-game-full #x0001) +(define pkth-join-failed-game-already-running #x0002) +(define pkth-join-failed-invalid-password #x0003) +(define pkth-join-failed-other-reason #xFFFF) + +;;; Reasons for being removed from a game. +(define pkth-removed-on-request #x0000) +(define pkth-removed-game-full #x0001) +(define pkth-removed-game-already-running #x0002) +(define pkth-removed-kicked #x0003) +(define pkth-removed-other-reason #xFFFF) + +;;; Internal error codes. +(define pkth-err-reserved #x0000) +(define pkth-err-init-version-not-supported #x0001) +(define pkth-err-init-server-full #x0002) +(define pkth-err-init-invalid-password #x0004) +(define pkth-err-init-player-name-in-use #x0005) +(define pkth-err-init-invalid-player-name #x0006) +(define pkth-err-general-invalid-packet #xFF01) +(define pkth-err-general-invalid-state #xFF02) +(define pkth-err-general-player-kicked #xFF03) +(define pkth-err-other #xFFFF) + +;;; Constant for reserved +(define pkth-reserved 0) + +;;; Header lengths +(define pkth-header-length-common 4) + +;;; Common header value lengths +(define pkth-length-type 2) +(define pkth-length-msg-length 2) + +;;; Value lengths +(define pkth-length-version 2) +(define pkth-length-string-length 2) +(define pkth-length-flags 2) +(define pkth-length-reserved 2) +(define pkth-length-player-id 4) +(define pkth-length-session-id 4) +(define pkth-length-md5 16) +(define pkth-length-blind-value 2) + +;;; Value offsets common header +(define pkth-offset-type 0) +(define pkth-offset-msg-length (+ pkth-offset-type pkth-length-type)) +(define pkth-offset-data (+ pkth-offset-msg-length pkth-length-msg-length)) + +;;; Value offsets pkth-type-init +(define pkth-init-offset-version-major pkth-offset-data) +(define pkth-init-offset-version-minor (+ pkth-init-offset-version-major pkth-length-version)) +(define pkth-init-offset-password-length (+ pkth-init-offset-version-minor pkth-length-version)) +(define pkth-init-offset-player-name-length (+ pkth-init-offset-password-length pkth-length-string-length)) +(define pkth-init-offset-privacy-flags (+ pkth-init-offset-player-name-length pkth-length-string-length)) +(define pkth-init-offset-reserved (+ pkth-init-offset-privacy-flags pkth-length-flags)) +(define pkth-init-offset-avatar-md5 (+ pkth-init-offset-reserved pkth-length-reserved)) +(define pkth-init-offset-password (+ pkth-init-offset-avatar-md5 pkth-length-md5)) + +;;; Value offsets pkth-type-init-ack +(define pkth-init-ack-offset-session-id pkth-offset-data) +(define pkth-init-ack-offset-player-id (+ pkth-init-ack-offset-session-id pkth-length-session-id)) + +;;; Minimum/maximum packet length +(define pkth-minimum-message-length 8) +(define pkth-maximum-message-length 264) + +;;; +;;; Header constructors +;;; + +(define (pkth-create-packet type data) + (append + (uint16->bytes type) + (uint16->bytes (+ pkth-header-length-common (apply + (map length data)))) + (apply append data))) + +(define (pkth-create-md5 m0 m1 m2 m3 m4 m5 m6 m7 m8 m9 mA mB mC mD mE mF) + (append + (uint8->bytes m0) + (uint8->bytes m1) + (uint8->bytes m2) + (uint8->bytes m3) + (uint8->bytes m4) + (uint8->bytes m5) + (uint8->bytes m6) + (uint8->bytes m7) + (uint8->bytes m8) + (uint8->bytes m9) + (uint8->bytes mA) + (uint8->bytes mB) + (uint8->bytes mC) + (uint8->bytes mD) + (uint8->bytes mE) + (uint8->bytes mF))) + +(define (pkth-create-init-ex version-major version-minor privacy-flags avatar-md5 password player-name) + (pkth-create-packet + pkth-type-init + (list + (uint16->bytes version-major) + (uint16->bytes version-minor) + (uint16->bytes (string-length password)) + (uint16->bytes (string-length player-name)) + (uint16->bytes privacy-flags) + (uint16->bytes 0) + avatar-md5 + (append-padding (string->bytes password)) + (append-padding (string->bytes player-name))))) + +(define (pkth-create-init privacy-flags avatar-md5 password player-name) + (pkth-create-init-ex pkth-version-major pkth-version-minor privacy-flags avatar-md5 password player-name)) + +#! +(pkth-create-init + pkth-privacy-flag-show-avatar + (pkth-create-md5 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16) + "" + "hallo") +!# + +(define (pkth-create-init-ack session-id player-id) + (pkth-create-packet + pkth-type-init-ack + (list + (uint32->bytes session-id) + (uint32->bytes player-id)))) + +#! +(pkth-create-init-ack #x6666 #x8888) +!# + +(define pkth-assert-minimal-length + (lambda (message) + (test-assert (>= (length message) pkth-minimum-message-length) "PKTH message is too small (no common header)!"))) + +#! +(pkth-assert-minimal-length '(1 2 3 4)) +(pkth-assert-minimal-length '(1 2 3 4 5 6)) +!# + +(define pkth-assert-length + (lambda (ls len) + (test-assert (>= (length ls) len) "PKTH message is too small!"))) + +#! +(pkth-assert-length '(1 2 3 4 5 6 7 8) 16) +(pkth-assert-length '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16) 16) +!# + +;;; +;;; Packet getter functions +;;; + +(define pkth-get-type + (lambda (message) + (pkth-assert-minimal-length message) + (bytes->uint16 (list-head (list-tail message pkth-offset-type) pkth-length-type)))) + +(define pkth-get-length + (lambda (message) + (pkth-assert-minimal-length message) + (bytes->uint16 (list-head (list-tail message pkth-offset-msg-length) pkth-length-msg-length)))) + +(define pkth-get-data + (lambda (message) + (pkth-assert-minimal-length message) + (list-tail message pkth-offset-data))) + +;;; pkth-type-init + +#! +(let ((sock (sock-connect (sock-create-tcp AF_INET) "127.0.0.1" pkth-port))) + (sock-send + sock + (bytes->string + (pkth-create-init + pkth-privacy-flag-show-avatar + (pkth-create-md5 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16) + "" + "hallo"))) + (sleep 1) + (sock-close sock)) +!# diff --git a/tests/sock.scm b/tests/sock.scm new file mode 100644 index 00000000..44df4386 --- /dev/null +++ b/tests/sock.scm @@ -0,0 +1,173 @@ +;;; +;;; 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. + +(load "common.scm") + +(define sock-create-tcp + (lambda (af) + (let ((s (socket af SOCK_STREAM 0))) + (cons s af)))) + +(define sock-create-udp + (lambda (af) + (let ((s (socket af SOCK_DGRAM 0))) + (cons s af)))) + +(define sock-create-sctp + (lambda (af) + (let ((s (socket af SOCK_STREAM IPPROTO_SCTP))) + (cons s af)))) + +(define sock-create-sctp-1toM + (lambda (af) + (let ((s (socket af SOCK_DGRAM IPPROTO_SCTP))) + (cons s af)))) + +(define sock-close + (lambda (sock) + (let ((s (car sock))) + (close s)))) + +(define sock-select-read + (lambda (sock timeout-msec) + (let ((s (car sock))) + (= + (vector-length (car (select (vector s) (vector) (vector) (quotient timeout-msec 1000) (* 1000 (modulo timeout-msec 1000))))) + 1)))) + +#! +(sock-close (sock-create-sctp AF_INET)) +(sock-close (sock-create-sctp AF_INET6)) +!# + + (define ipv4-resolve + (lambda (name) + (inet-ntop AF_INET (car (vector-ref (gethostbyname name) 4))))) + +(define sock-bind + (lambda (sock local-addr local-port) + (let ((af (cdr sock))) + (setsockopt (car sock) SOL_SOCKET SO_REUSEADDR 1) + (bind (car sock) af (inet-pton af local-addr) local-port) + sock))) + +#! +(sock-close (sock-bind (sock-create-udp AF_INET) "127.0.0.1" 5555)) +(sock-close (sock-bind (sock-create-udp AF_INET6) "::1" 5555)) +(sock-close (sock-bind (sock-create-tcp AF_INET) "127.0.0.1" 5555)) +(sock-close (sock-bind (sock-create-tcp AF_INET6) "::1" 5555)) +(sock-close (sock-bind (sock-create-sctp AF_INET) "127.0.0.1" 5555)) +(sock-close (sock-bind (sock-create-sctp AF_INET6) "::1" 5555)) +!# + +(define sock-bind-listen + (lambda (sock local-addr local-port queuesize) + (sock-bind sock local-addr local-port) + (listen (car sock) queuesize) + sock)) + +#! +(sock-close (sock-bind-listen (sock-create-sctp AF_INET) "127.0.0.1" 5555 5)) +(sock-close (sock-bind-listen (sock-create-sctp AF_INET6) "::1" 5555 5)) +!# + +(define sock-accept + (lambda (sock) + (let ((clientinfo (accept (car sock)))) + (let ((sender (cdr clientinfo))) + (cons (cons (car clientinfo) (cdr sock)) (cons (inet-ntop (cdr sock) (sockaddr:addr sender)) (sockaddr:port sender))))))) + + #! +(sock-accept (sock-bind-listen (sock-create-tcp AF_INET) "127.0.0.1" 5555 5)) +(sock-accept (sock-bind-listen (sock-create-tcp AF_INET6) "::1" 5555 5)) +!# + +(define sock-connect + (lambda (sock remote-addr remote-port) + (let ((af (cdr sock))) + (connect (car sock) af (inet-pton af remote-addr) remote-port) + sock))) + + #! +(sock-close (sock-connect (sock-create-tcp AF_INET) (ipv4-resolve "www.google.de") 80)) +!# + +(define sock-send + (lambda (sock buf) + (send (car sock) buf))) + +(define sock-send-sctp + (lambda (sock stream ppid buf) + (if (= (cdr sock) AF_INET6) + (sctp-sendmsg (car sock) buf (htonl ppid) stream 0 0 AF_INET6 (inet-pton AF_INET6 "::0") 0) + (sctp-sendmsg (car sock) buf (htonl ppid) stream 0 0 AF_INET INADDR_ANY 0) + ))) + +(define sock-recv-sctp! + (lambda (sock buf) + (let ((ret (sctp-recvmsg! (car sock) buf))) + (let ((info (list-ref ret 3))) ; Return number of bytes and PPID + (cons (car ret) (ntohl (list-ref info 2))))))) + + #! +(sock-send (car (sock-accept (sock-bind-listen (sock-create-tcp AF_INET) "127.0.0.1" 5555 5))) "Hallo") +!# + +(define sock-sendto + (lambda (sock buf remote-addr remote-port) + (let ((af (cdr sock))) + (sendto (car sock) buf af (inet-pton af remote-addr) remote-port)))) + +(define sock-recvfrom! + (lambda (sock buf) + (let ((ret (recvfrom! (car sock) buf))) + (let ((sender (cdr ret))) + (cons (car ret) (cons (inet-ntop (cdr sock) (sockaddr:addr sender)) (sockaddr:port sender))))))) + +(define sock-recv! + (lambda (sock buf) + (let ((ret (recv! (car sock) buf))) + (cons ret (cons "" 0))))) + +#! +(let ((server (sock-bind (sock-create-udp AF_INET) "0.0.0.0" 4440))) + (let ((client (sock-connect (sock-create-udp AF_INET) (ipv4-resolve "localhost") 4440))) + (sock-send client "Test\0") + (let ((recv-buf (make-string 10))) + (sock-recv! server recv-buf) + (display recv-buf) + (sock-close server) + (sock-close client)))) +!# diff --git a/tests/test.scm b/tests/test.scm new file mode 100644 index 00000000..2f35e314 --- /dev/null +++ b/tests/test.scm @@ -0,0 +1,87 @@ +;;; +;;; 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. + +;;; +;;; Basic check functions +;;; + +(define test-get-next-test-num + (lambda (test-list) + (+ (length test-list) 1))) + +;;; Simple test registration +(define test-register + (lambda (test-list name function) + (append test-list (list (cons (cons (test-get-next-test-num test-list) name) function))))) + +(define test-assert + (lambda (predicate errortext) + (if (not predicate) + (begin + (display (string-append "Assertion failed: " errortext "\n")) + (throw 'badex))))) + +#! +(test-assert #f "Test") +(test-assert #t "Test") +!# + +(define test-get-string + (lambda (data) + (string-append "Test " (number->string (car (car data))) ": \"" (cdr (car data)) "\""))) + +(define test-run-single + (lambda (data) + (display (string-append "Running " (test-get-string data) "...\n")) + (catch 'badex + (lambda () + ((cdr data)) ; call test + (display "PASSED\n")) + (lambda (key) + (display "FAILED\n"))))) + +(define test-run-all + (lambda (test-list) + (display "\nTest Run: All Tests\n") + (map test-run-single test-list) + (display "\nDone.\n"))) + +#! +(define test-func + (lambda () + (test-assert #f "False should be true!"))) +(test-register "Test" test-func) +(test-run-all) +!# diff --git a/tests/timer.scm b/tests/timer.scm new file mode 100644 index 00000000..6c6fcb3c --- /dev/null +++ b/tests/timer.scm @@ -0,0 +1,59 @@ +;;; +;;; 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. + +;;; +;;; Software timer +;;; + +(define timer-create + (lambda (timeout-msec) + (cons timeout-msec 0))) + +(define timer-gettimeout + (lambda (timer) + (car timer))) + +(define timer-getcurtime + (lambda () + (let ((time (gettimeofday))) + (+ (* (car time) 1000) (quotient (cdr time) 1000))))) + +(define timer-start + (lambda (timer) + (cons (timer-gettimeout timer) (timer-getcurtime)))) + +(define timer-expired? + (lambda (timer) + (>= (timer-getcurtime) (+ (car timer) (cdr timer)))))