;; mzsocket: BSD/POSIX sockets library for PLT-scheme
;; testsuite
;;
;; (C) Copyright 2007,2008 Dimitris Vyzovitis <vyzo at media.mit.edu>
;;
;; mzsocket is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Lesser General Public License as published
;; by the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; mzsocket is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with mzsocket.  If not, see <http://www.gnu.org/licenses/>.

#lang scheme/base

(require "main.ss" srfi/78)
(provide run-tests)

(define (wait-idle)
  (sync (system-idle-evt)))

(define (make-junk len)
  (let ((buf (make-bytes len)))
    (do ((i 0 (add1 i)))
        ((= i len) buf)
      (bytes-set! buf i (random 255)))))

(define (bind-server sock where)
  (with-handlers*
      ((exn:fail:socket?
        (lambda (e)
          (if (eq? (exn:fail:socket-errno e) EADDRINUSE)
            #f
            (raise e)))))
    (socket-bind sock where)))

(define (socket-maker make-sock make-addr make-val)
  (lambda (lo hi)
    (let ((sock (make-sock)))
      (socket-setsockopt sock SOL_SOCKET SO_REUSEADDR #t)
      (let lp ((x lo))
        (if (< x hi)
          (if (bind-server sock (make-addr x))
            (make-val sock)
            (lp (add1 x)))
          (error 'socket-maker "can't bind"))))))

(define tcp-server-socket
  (socket-maker 
   socket
   (lambda (port) (inet4-address INADDR_LOOPBACK port))
   (lambda (sock) (socket-listen sock 1) sock)))

(define unix-server-socket
  (socket-maker
   (lambda () (socket PF_UNIX))
   (lambda (x) (string->path (format "/tmp/test-~a~a" x (random))))
   (lambda (sock) (socket-listen sock 1) sock)))

(define udp-server-socket
  (socket-maker
   (lambda () (socket PF_INET SOCK_DGRAM))
   (lambda (port) (inet4-address INADDR_ANY port))
   (lambda (sock) sock)))

(define (stream-server sock)
  (define buf (make-bytes 4096))
  (let-values (((cli cliaddr) (socket-accept sock)))
    (let lp ()
      (let ((ilen (socket-recv cli buf)))
        (if (> ilen 0)
          (begin
            (socket-send-all cli buf 0 ilen)
            (lp))
          (begin
            (socket-close cli)
            (stream-server sock)))))))


(define (stream-client srv pf len)
  (define-values (sbuf rbuf) (values (make-junk len) (make-bytes len)))
  (define sock (socket pf SOCK_STREAM))
  (socket-connect sock srv)
  (check (socket-send-all sock sbuf) => (bytes-length sbuf))
  (check (socket-recv-all sock rbuf) => (bytes-length rbuf))
  (check (equal? rbuf sbuf) => #t)
  (socket-close sock)
  (check (socket-closed? sock) => #t))

(define (dgram-server sock)
  (define buf (make-bytes 1500))
  (let lp ()
    (let-values (((ilen peer) (socket-recvfrom sock buf)))
      (check (socket-sendto sock peer buf 0 ilen) => ilen)
      (lp))))

(define (dgram-client srv len)
  (define-values (sbuf rbuf) (values (make-junk len) (make-bytes len)))
  (define sock (socket PF_INET SOCK_DGRAM))
  (check (socket-sendto sock srv sbuf) => (bytes-length sbuf))
  (let-values (((ilen peer) (socket-recvfrom sock rbuf)))
    (check ilen => (bytes-length rbuf))
    (check (inet-address=? peer srv) => #t)
    (check peer => srv)
    (check (equal? rbuf sbuf) => #t)))

(define (bcast-client bcast len)
  (define-values (sbuf rbuf) (values (make-junk len) (make-bytes len)))
  (define sock (socket PF_INET SOCK_DGRAM))
  (socket-setsockopt sock SOL_SOCKET SO_BROADCAST #t)
  (check (socket-sendto sock bcast sbuf) => (bytes-length sbuf))
  (let-values (((ilen peer) (socket-recvfrom sock rbuf)))
    (check ilen => (bytes-length rbuf))
    (check (equal? rbuf sbuf) => #t)))

(define (msg-server sock)
  (define data (make-bytes 1500))
  (define name (make-bytes 32))
  (let lp ()
    (let-values (((ilen nlen clen flags) (socket-recvmsg sock name data #f)))
      (check (socket-sendto sock (unpack-address name) data 0 ilen) => ilen)
      (lp))))

(define (msg-client srv len)
  (define-values (sbuf rbuf pbuf) 
    (values (make-junk len) (make-bytes len) (make-bytes 32)))
  (define sock (socket AF_INET SOCK_DGRAM))
  (check (socket-sendmsg sock (pack-address srv) sbuf #f)
         => (bytes-length sbuf))
  (let-values (((ilen nlen clen flags) (socket-recvmsg sock pbuf rbuf #f)))
    (check ilen => (bytes-length rbuf))
    (check (equal? rbuf sbuf) => #t)
    (check (inet-address=? (unpack-address pbuf) srv) => #t)
    (check (unpack-address pbuf) => srv)))

(define (test-tcp)
  (let* ((srvsock (tcp-server-socket 5000 5100))
         (srvthr (thread (lambda () (stream-server srvsock))))
         (srv (socket-getsockname srvsock)))
    (stream-client srv PF_INET 128)
    (stream-client srv PF_INET 16384)
    (kill-thread srvthr)))

(define (test-udp)
  (let* ((srvsock (udp-server-socket 5000 5100))
         (srvthr (thread (lambda () (dgram-server srvsock))))
         (srv (inet4-address 
               INADDR_LOOPBACK
               (inet-address-port (socket-getsockname srvsock)))))
    (wait-idle)
    (dgram-client srv 1024)
    (kill-thread srvthr)))

(define (test-bcast)
  (let* ((srvsock (udp-server-socket 5000 5100))
         (bcast (inet4-address 
                 INADDR_BROADCAST 
                 (inet-address-port (socket-getsockname srvsock)))))
    (socket-setsockopt srvsock SOL_SOCKET SO_BROADCAST #t)
    (let ((srvthr (thread (lambda () (dgram-server srvsock)))))
      (wait-idle)
      (bcast-client bcast 1024)
      (kill-thread srvthr))))

(define (test-msg)
  (let* ((srvsock (udp-server-socket 5000 5100))
         (srvthr (thread (lambda () (msg-server srvsock))))
         (srv (inet4-address 
               INADDR_LOOPBACK 
               (inet-address-port (socket-getsockname srvsock)))))
    (wait-idle)
    (msg-client srv 1024)
    (kill-thread srvthr)))

(define (test-unix)
  (let* ((srvsock (unix-server-socket 0 100))
         (srvthr (thread (lambda () (stream-server srvsock))))
         (srv (socket-getsockname srvsock)))
    (stream-client srv PF_UNIX 4096)
    (kill-thread srvthr)
    (delete-file srv)))
  
(define (run-suite tests)
  (for-each (lambda (test) 
              (printf "~n; test: ~a~n" (object-name test))
              (test)) 
    tests))
  
(define unix-suite 
  (list test-tcp test-udp test-bcast test-msg test-unix))
(define windows-suite 
  (list test-tcp test-udp test-bcast))
  
(define (run-tests)
  (case (system-type)
    ((windows) (run-suite windows-suite))
    (else (run-suite unix-suite)))
  (check-report))