Megatest

run.scm at [848a55348a]
Login

File ulex/tests/run.scm artifact f59b10a27d part of check-in 848a55348a


(use test
     (prefix sqlite3 sqlite3:)
     posix
     ;; ulex-netutil rpc
     pkts
     mailbox
     hostinfo
     regex
     tcp6)

(include "ulex.scm")
;; (use (prefix ulex ulex:))
;; (if (file-exists? "ulex.scm")
;;     (load "ulex.scm")
;;     (load "../ulex.scm"))

(use trace)
(trace-call-sites #t)

(import ulex) ;; (import (prefix ulex ulex:))

(trace
 ;; find-or-setup-captain
 ;; get-all-captain-pkts
 ;; setup-as-captain
 ;; get-winning-pkt
 ;; ping
 ;; remove-captain-pkt
 ;; start-server-find-port
 ;; connect-server
 )

(test-begin "addresses")
(test #f #t (not (null? (get-all-ips))))
(test #f #t (string? (get-my-best-address)))
(test-end   "addresses")

;;======================================================================
;; Setup
;;======================================================================

(system "rm -rf testulexdb testpkts")
(create-directory "testulexdb" #t)
(create-directory "testpkts"   #t)

;;======================================================================
;; Captainship
;;======================================================================

(define *udat1* (make-udat))
(test #f #t (udat? (start-server-find-port *udat1* (+ 4242 (random 5000)))))

(test-begin "captainship")
(test #f #t (list? (get-all-captain-pkts  *udat1*)))
(test #f #t (udat? (let ((res (find-or-setup-captain *udat1*)))(print res) res)))
(test-end   "captainship")

;; ; (define *area* (make-area dbdir: "testulexdb" pktsdir: "testpkts"))
;; ; 
;; ; (define *port* #f)
;; ; 
;; ; ;;======================================================================
;; ; ;; Ulex-db
;; ; ;;======================================================================
;; ; 
;; ; (test-begin "ulex-db")
;; ; (test #f #t (equal? (area-dbdir *area*) "testulexdb"))
;; ; (test #f #t (thread? (thread-start! (make-thread (lambda ()(launch *area*)) "server"))))
;; ; (thread-sleep! 1)
;; ; (test #f 1  (update-known-servers *area*))
;; ; (test #f #t (list? (get-all-server-pkts *area*)))
;; ; (test #f (area-myaddr *area*) (cadr (ping *area* (area-myaddr *area*)(area-port *area*))))
;; ; 
;; ; (let loop ((count 10))
;; ;   (if (null? (get-all-server-pkts *area*))
;; ;       (if (> count 0)
;; ; 	  (begin
;; ; 	    (thread-sleep! 1)
;; ; 	    (print "waiting for server pkts")
;; ; 	    (loop (- count 1))))))
;; ; (test #f #t (let ((spkts (get-all-server-pkts *area*)))
;; ; 	      (and (list spkts) (> (length spkts) 0))))
;; ; (test #f #t (begin (register-batch
;; ; 		    *area*
;; ; 		    'dbwrite ;; this is the call type
;; ; 		    `((dbinitsql . ("CREATE TABLE IF NOT EXISTS messages (id INTEGER PRIMARY KEY, message TEXT, author TEXT, msg_time INTEGER);"))
;; ; 		      (savemsg   . "INSERT INTO messages (message,author) VALUES (?,?)")
;; ; 		      ;; (readmsg   . "SELECT * FROM messages WHERE author=?;")
;; ; 		      
;; ; 		      ))
;; ; 		   #t))
;; ; 
;; ; (test #f #t (calldat? (get-rentry *area* 'dbinitsql)))
;; ; (define cdat1 (get-rentry *area* 'dbinitsql))
;; ; (test #f #t (list? (get-best-server *area* "test.db" 'savemsg)))
;; ; (test #f #t (eq? 'dbwrite (calldat-ctype cdat1)))
;; ; (test #f #t (list? (get-rsql *area* 'dbinitsql)))
;; ; (test #f #t  (dbdat? (open-db *area* "test.db")))
;; ; 
;; ; (test #f #t (dbdat? (let ((dbh (get-dbh *area* "test.db")))
;; ; 		      (save-dbh *area* "test.db" dbh)
;; ; 		      dbh)))
;; ; (test #f #t (dbdat? (let ((dbh (get-dbh *area* "test.db")))
;; ; 		      dbh)))
;; ; 
;; ; ;(test #f '(#t "db write submitted" #t)  (call *area* "test.db" 'savemsg '("Test message!" "matt")))
;; ; (test #f #t  (call *area* "test.db" 'savemsg '("Test message!" "matt")))
;; ; ;;(thread-sleep! 15);; server needs time to process the request (it is non-blocking)
;; ; ;; (test #f #t (shutdown *area*))
;; ; ;; (test #f 0 (calc-server-score *area* "test.db"  (area-pktid *area*)))
;; ; 
;; ; (test #f #t (list? (get-best-server *area* "test.db" (area-pktid *area*))))
;; ; (define *best-server* (car (get-best-server *area* "test.db" (area-pktid *area*))))
;; ; (pp *best-server*)
;; ; (define *server-pkt*  (hash-table-ref/default (area-hosts *area*) (area-pktid *area*) #f))
;; ; (define *server-ip*   (alist-ref 'ipaddr *server-pkt*))
;; ; (define *server-port* (any->number (alist-ref 'port *server-pkt*)))
;; ; (test #f #t (list? (ping      *area* *server-ip* *server-port*)))
;; ; 
;; ; (test #f #t (process-db-queries *area* "test.db"))
;; ; (test #f #f (process-db-queries *area* "junk.db"))
;; ; ;; (test #f #t (cadr (full-ping *area* *server-pkt*)))
;; ; 
;; ; 
;; ; (test-end "ulex-db")
;; ; 
;; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ; 
;; ; (test-begin "faux-mtdb")
;; ; ;; pre-clean
;; ; 
;; ; #;(for-each (lambda (dir)
;; ;             (if (directory-exists? dir)
;; ;                 (system (conc "/bin/rm -rf ./"dir)))
;; ;             (system (conc "/bin/mkdir -p ./"dir))
;; ;             )
;; ;           '("faux-mtdb" "faux-mtdb-pkts"))
;; ; 
;; ; 
;; ; (let* ((area     *area*) ;; (make-area dbdir: "faux-mtdb" pktsdir: "faux-mtdb-pkts"))
;; ;        (specfile "tests/mt-spec.sexpr")
;; ;        (dbname   "faux-mt.db"))
;; ;   ;; (launch area)
;; ;   (initialize-area-calls-from-specfile area specfile)
;; ;   (let* ((target-name "a/b/c/d")
;; ;          (insert-result (call area dbname 'new-target (list target-name)))
;; ;          (test-target-id (caar (call area dbname 'target-name->target-id (list target-name))))
;; ;          (test-target-name (caar (call area dbname 'target-id->target-name (list 1)))))
;; ;     (test #f #t insert-result)
;; ;     (test #f 1 test-target-id )
;; ;     (test #f target-name test-target-name )
;; ;     )
;; ;   (test #f #t (list? (get-best-server *area* "test.db" 'savemsg)))
;; ;   (thread-sleep! 5)
;; ;   (test #f #t (begin (shutdown area) #t)))
;; ;   
;; ; (test #f #t (process-db-queries *area* "test.db"))
;; ; (test #f #f (process-db-queries *area* "junk.db"))
;; ; 
;; ; ;; thought experiment - read cursors
;; ; ;; (let* ((cursor (call area dbname 'get-target-names '())))
;; ; ;;   (let loop ((row (cursor)))
;; ; ;;     (cond
;; ; ;;      ((not row) #t)
;; ;   ;;      (else
;; ; ;;       (print "ROW IS "row)
;; ; ;;       (loop (cursor))))))
;; ; 
;; ;   
;; ; (test-end "faux-mtdb")
;; ; 
;; ; ;;======================================================================
;; ; ;; Portlogger tests
;; ; ;;======================================================================
;; ; 
;; ; ;; (test-begin "portlogger")
;; ; ;; 
;; ; ;; (test #f #f (begin (pl-open-run-close (lambda (db b)(pl-get-prev-used-port db)) *area*) #f))
;; ; ;; (test #f #f (pl-open-run-close (lambda (db b)(pl-get-port-state db 1234567)) *area*))
;; ; ;; (test #f #f (number? (pl-open-run-close (lambda (db b)(pl-take-port db 123456)) *area*)))
;; ; ;; (test #f #t (number? (let ((port (pl-open-run-close pl-find-port *area*)))
;; ; ;; 		       (set! *port* port)
;; ; ;; 		       port)))
;; ; ;; (test #f 1 (pl-open-run-close pl-release-port *port*))
;; ; ;; (test #f "released" (pl-open-run-close
;; ; ;; 		     (lambda (db)
;; ; ;; 		       (sqlite3:first-result db "select state from ports where port=?" *port*))))
;; ; ;; 
;; ; ;; (test-end "portlogger")
;; ;