sco/pokerth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added first parts of server test code.

Browse Source
This commit is contained in:
lotodore
2007-10-03 22:14:31 +00:00
parent 1f97e26e49
commit 901fc1634d
6 changed files with 985 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
tests/common.scm
+280
View File
@@ -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))
tests/helper.scm
+101
View File
@@ -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))
!#
tests/pkth.scm
+285
View File
@@ -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))
!#
tests/sock.scm
+173
View File
@@ -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))))
!#
tests/test.scm
+87
View File
@@ -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)
!#
tests/timer.scm
+59
View File
@@ -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)))))