diff --git a/tests/helper.scm b/tests/helper.scm index 8f983833..d32a66dd 100644 --- a/tests/helper.scm +++ b/tests/helper.scm @@ -48,6 +48,7 @@ (define helper-var-last-display-msg '()) (define helper-var-last-display-direction 0) (define helper-var-display-newline #f) +(define helper-var-recv-buf "") (define helper-init-vars (lambda () @@ -71,7 +72,7 @@ (set! t (timer-start t)) (do ((abort #f)) (abort) - (if (sock-select-read sock 10) + (if (or (not (string-null? helper-var-recv-buf)) (sock-select-read sock 10)) (begin (let ((msg (recv-function sock))) (if (predicate-one-true? predicate-list msg) diff --git a/tests/pkth.scm b/tests/pkth.scm index 555c6633..ab3472d9 100644 --- a/tests/pkth.scm +++ b/tests/pkth.scm @@ -188,6 +188,20 @@ (define pkth-minimum-message-length 8) (define pkth-maximum-message-length 268) +;;; Receive buf length +(define pkth-buf-length #xffff) + +;;; Game info constants +(define pkth-raise-interval-mode-on-hand 1) +(define pkth-raise-interval-mode-on-minute 2) + +(define pkth-raise-mode-double-blinds 1) +(define pkth-raise-mode-manual-blinds-order 2) + +(define pkth-end-raise-mode-double-blinds 1) +(define pkth-end-raise-mode-raise 2) +(define pkth-end-raise-mode-keep-last-blind 3) + ;;; ;;; Header constructors ;;; @@ -219,6 +233,34 @@ (uint8->bytes mE) (uint8->bytes mF)))) +(define pkth-create-game-info + (lambda (max-num-players raise-interval-mode raise-small-blind-interval raise-mode + end-raise-mode proposed-gui-speed player-action-timeout + first-small-blind end-raise-small-blind-value start-money manual-blind-slots) + (append + (uint16->bytes max-num-players) + (uint16->bytes raise-interval-mode) + (uint16->bytes raise-small-blind-interval) + (uint16->bytes raise-mode) + (uint16->bytes end-raise-mode) + (uint16->bytes (length manual-blind-slots)) + (uint16->bytes proposed-gui-speed) + (uint16->bytes player-action-timeout) + (uint32->bytes first-small-blind) + (uint32->bytes end-raise-small-blind-value) + (uint32->bytes start-money) + manual-blind-slots))) + +(define pkth-create-player-info + (lambda (player-id player-flags player-name avatar-md5) + (append + (uint32->bytes player-id) + (uint16->bytes player-flags) + (uint16->bytes (string-length player-name)) + (uint32->bytes 0) + avatar-md5 + (append-padding (string->bytes player-name))))) + (define pkth-create-init-ex (lambda (version-major version-minor privacy-flags avatar-md5 password player-name) (pkth-create-packet @@ -273,6 +315,49 @@ session-id player-id))) +(define pkth-create-create-game + (lambda (game-info game-name game-password) + (pkth-create-packet + pkth-type-create-game + (list + (uint16->bytes (string-length game-password)) + (uint16->bytes (string-length game-name)) + game-info + (append-padding (string->bytes game-password)) + (append-padding (string->bytes game-name)))))) + +(define pkth-create-join-game + (lambda (game-id game-password) + (pkth-create-packet + pkth-type-join-game + (list + (uint32->bytes game-id) + (uint16->bytes (string-length game-password)) + (uint16->bytes 0) + (append-padding (string->bytes game-password)))))) + +(define pkth-create-leave-current-game + (lambda () + (pkth-create-packet + pkth-type-leave-current-game + (list + (uint32->bytes 0))))) + +(define pkth-create-start-event + (lambda (start-flags) + (pkth-create-packet + pkth-type-start-event + (list + (uint16->bytes start-flags) + (uint16->bytes 0))))) + +(define pkth-create-start-event-ack + (lambda () + (pkth-create-packet + pkth-type-start-event-ack + (list + (uint32->bytes 0))))) + #! (pkth-create-init-ack #x66666666 #x88888888) !# @@ -575,29 +660,13 @@ ;;; 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) + (set! helper-var-recv-buf "") (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 @@ -616,29 +685,31 @@ (let ((ret 0)) (do ((abort #f)) (abort) - (let ((buflen (string-length pkth-recv-buf))) + (let ((buflen (string-length helper-var-recv-buf))) (if (>= buflen pkth-header-length-common) (begin - (let ((packetlen (pkth-get-length (string->bytes pkth-recv-buf)))) + (let ((packetlen (pkth-get-length (string->bytes helper-var-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)) + (let ((packet (string-copy (substring helper-var-recv-buf 0 packetlen)))) + (set! helper-var-recv-buf (string-drop helper-var-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)))))))) + (msg-display ret helper-direction-recv) + ))))))) (if (not abort) - (let ((buf (make-string pkth-maximum-message-length))) + (let ((buf (make-string pkth-buf-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! helper-var-recv-buf "") (set! abort #t) (set! ret #f)) (begin - (set! pkth-recv-buf (string-append pkth-recv-buf tmpbuf))))))))) + (set! helper-var-recv-buf (string-append helper-var-recv-buf tmpbuf)) + ))))))) ret))) #! diff --git a/tests/pkth_tests.scm b/tests/pkth_tests.scm index 70e8138f..09cc7b9e 100644 --- a/tests/pkth_tests.scm +++ b/tests/pkth_tests.scm @@ -41,8 +41,8 @@ (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 + (dotimes (n 1024) + (pkth-send-message-nolog sock (pkth-create-packet pkth-type-init @@ -50,15 +50,66 @@ (uint16->bytes pkth-version-major) (uint16->bytes pkth-version-minor) (uint16->bytes (string-length "")) - (uint16->bytes (string-length "test")) + (uint16->bytes (string-length "client1")) (uint16->bytes 0) (uint16->bytes 0) (append-padding (string->bytes "")) - (append-padding (string->bytes "test")) + (append-padding (string->bytes "client1")) (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)) + (sock-close sock) + )) +(set! pkth-test-list (test-register pkth-test-list "PKTH: Init with too large packets" pkth-test-init-packet-too-large)) + +(define (pkth-test-init) + (dotimes (n 1024) + (let ((sock (pkth-connect))) + (pkth-send-message sock (pkth-create-init '() "" (number->string n))) + (display "Waiting for Init-Ack...\n") + (wait-for-message sock pkth-recv-message (list pkth-is-type-init-ack?) '() 5000) + (sock-close sock)))) + +(set! pkth-test-list (test-register pkth-test-list "PKTH: Init" pkth-test-init)) + +(define (pkth-test-create-destroy-game) + (let ((sock (pkth-connect))) + (pkth-send-message sock (pkth-create-init '() "" "client1")) + (display "Waiting for Init-Ack...\n") + (wait-for-message sock pkth-recv-message (list pkth-is-type-init-ack?) '() 5000) + (display "Creating and destroying loads of games...\n") + (dotimes (n 256) + (pkth-send-message sock + (pkth-create-create-game + (pkth-create-game-info + 7 + pkth-raise-interval-mode-on-hand + 4 + pkth-raise-mode-double-blinds + pkth-end-raise-mode-double-blinds + 11 + 20 ; player action timeout + 40 ; first small blind + 0 ; end raise small blind + 2000 ; start money + '() ; manual blinds + ) + "test game" + "test password" + )) + (display "Waiting for Game List New / Join Game Ack / Game List Player Joined...\n") + (wait-for-message sock pkth-recv-message (list pkth-is-type-game-list-new? pkth-is-type-join-game-ack? pkth-is-type-game-list-player-joined?) (list pkth-is-type-statistics-changed?) 5000) + (wait-for-message sock pkth-recv-message (list pkth-is-type-game-list-new? pkth-is-type-join-game-ack? pkth-is-type-game-list-player-joined?) (list pkth-is-type-statistics-changed?) 5000) + (wait-for-message sock pkth-recv-message (list pkth-is-type-game-list-new? pkth-is-type-join-game-ack? pkth-is-type-game-list-player-joined?) (list pkth-is-type-statistics-changed?) 5000) + (pkth-send-message sock (pkth-create-leave-current-game)) + (display "Waiting for Game List Player Left...\n") + (wait-for-message sock pkth-recv-message (list pkth-is-type-game-list-player-left?) (list pkth-is-type-statistics-changed?) 5000) + (display "Waiting for Removed From Game...\n") + (wait-for-message sock pkth-recv-message (list pkth-is-type-removed-from-game?) (list pkth-is-type-statistics-changed?) 5000) + (display "Waiting for Game List Update...\n") + (wait-for-message sock pkth-recv-message (list pkth-is-type-game-list-update?) (list pkth-is-type-statistics-changed?) 5000) + ) + (sock-close sock) + )) +(set! pkth-test-list (test-register pkth-test-list "PKTH Test 2: Creating and destroying games" pkth-test-create-destroy-game)) (test-run-all pkth-test-list) -(pkth-close) +