Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -17,11 +17,11 @@ DEPLOYHELPERS=$(addprefix $(DEPLOYTARG)/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') all : mtest dboard mtest: $(OFILES) megatest.o - csc $(CSCOPTS) $(OFILES) megatest.o -o mtest + csc -heap-size 1m $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) csc $(OFILES) $(GOFILES) -o dboard $(DEPLOYTARG)/megatest : $(OFILES) megatest.o ADDED testhttp/mockupclient.scm Index: testhttp/mockupclient.scm ================================================================== --- /dev/null +++ testhttp/mockupclient.scm @@ -0,0 +1,35 @@ +(use posix) + +(define cname "Bob") +(define runtime 10) +(let ((args (argv))) + (if (< (length args) 3) + (begin + (print "Usage: mockupclient clientname runtime") + (exit)) + (begin + (set! cname (cadr args)) + (set! runtime (string->number (caddr args)))))) + +;; (define start-delay (/ (random 100) 9)) +;; (define runtime (+ 1 (/ (random 200) 2))) + +(print "Starting client " cname " with runtime " runtime) + +(include "mockupclientlib.scm") + +(set! endtime (+ (current-seconds) runtime)) + +(let loop () + (let ((x (random 15)) + (varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4)))) + (case x + ;; ((1)(dbaccess cname 'sync "nodat" #f)) + ((2 3 4 5)(dbaccess cname 'set varname (random 999))) + ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f))) + (else + (thread-sleep! 0.011))) + (if (< (current-seconds) endtime) + (loop)))) + +(print "Client " cname " all done!!") ADDED testhttp/mockupclientlib.scm Index: testhttp/mockupclientlib.scm ================================================================== --- /dev/null +++ testhttp/mockupclientlib.scm @@ -0,0 +1,33 @@ +(define sub (make-socket 'sub)) +(define push (make-socket 'push)) +(socket-option-set! sub 'subscribe cname) +(connect-socket sub "tcp://localhost:5563") +(connect-socket push "tcp://localhost:5564") + +(define (dbaccess cname cmd var val #!key (numtries 1)) + (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var))) + (res #f) + (do-access (lambda () + (print "Sending msg: " msg) + (send-message push msg) + (print "Message " msg " sent") + (print "Client " cname " waiting for response to " msg) + (print "Client " cname " received address " (receive-message* sub)) + (set! res (receive-message* sub))))) + (let ((th1 (make-thread do-access "do access")) + (th2 (make-thread (lambda () + (thread-sleep! 5) + (if (not res) + (if (> numtries 0) + (begin + (print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries) + (dbaccess cname cmd var val numtries: (- numtries 1))) + (begin + (print "ERROR: dbaccess timed out. Exiting") + (exit))))) + "timeout thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res))) + ADDED testhttp/mockupserver.scm Index: testhttp/mockupserver.scm ================================================================== --- /dev/null +++ testhttp/mockupserver.scm @@ -0,0 +1,139 @@ +;; pub/sub with envelope address +;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon +;; as a client disconnects. Also a remaining client may receive tons of +;; messages afterward. + +(use srfi-18 sqlite3 spiffy) + +(define cname "server") +(define total-db-accesses 0) +(define start-time (current-seconds)) + +;; setup the server here +(server-port 5563) + +(define (open-db) + (let* ((dbpath "mockup.db") + (dbexists (file-exists? dbpath)) + (db (open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (handler (make-busy-timeout 10))) + (set-busy-handler! db handler) + (if (not dbexists) + (for-each + (lambda (stmt) + (execute db stmt)) + (list + "PRAGMA SYNCHRONOUS=0;" + "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);" + "CREATE TABLE vars (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));"))) + db)) + +(define cid-cache (make-hash-table)) + +(define (get-client-id db cname) + (let ((cid (hash-table-ref/default cid-cache cname #f))) + (if cid + cid + (begin + (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname) + (for-each-row + (lambda (id) + (set! cid id)) + db + "SELECT id FROM clients WHERE name=?;" cname) + (hash-table-set! cid-cache cname cid) + (set! total-db-accesses (+ total-db-accesses 2)) + cid)))) + +(define (count-client db cname) + (let ((cid (get-client-id db cname))) + (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid) + (set! total-db-accesses (+ total-db-accesses 1)) + )) + +(define db (open-db)) +;; (define queuelst '()) +;; (define mx1 (make-mutex)) + +(define max-queue-len 0) + +(define (process-queue queuelst) + (let ((queuelen (length queuelst))) + (if (> queuelen max-queue-len) + (set! max-queue-len queuelen)) + (for-each + (lambda (item) + (let ((cname (vector-ref item 1)) + (clcmd (vector-ref item 2)) + (cdata (vector-ref item 3))) + (send-message pub cname send-more: #t) + (send-message pub (case clcmd + ((sync) + (conc queuelen)) + ((set) + (set! total-db-accesses (+ total-db-accesses 1)) + (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata)) + "ok") + ((get) + (set! total-db-accesses (+ total-db-accesses 1)) + (let ((res "noval")) + (for-each-row + (lambda (val) + (set! res val)) + db + "SELECT val FROM vars WHERE var=?;" cdata) + res)) + (else (conc "unk cmd: " clcmd)))))) + queuelst))) + +(define th1 (make-thread + (lambda () + (let ((last-run 0)) ;; current-seconds when run last + (let loop ((queuelst '())) + (let* ((indat (receive-message* pull)) + (parts (string-split indat ":")) + (cname (car parts)) ;; client name + (clcmd (string->symbol (cadr parts))) ;; client cmd + (cdata (caddr parts)) ;; client data + (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue + (count-client db cname) + (case clcmd + ((sync) ;; just process the queue + (print "Got sync from " cname) + (process-queue (cons svect queuelst)) + (loop '())) + ((get) + (process-queue (cons svect queuelst)) + (loop '())) + (else + (loop (cons svect queuelst)))))))) + "server thread")) + +(include "mockupclientlib.scm") + +;; ;; send a sync to the pull port +;; (define th2 (make-thread +;; (lambda () +;; (let ((last-action-time (current-seconds))) +;; (let loop () +;; (thread-sleep! 5) +;; (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f))) +;; (last-action-delta #f)) +;; (if (> queuelen 1)(set! last-action-time (current-seconds))) +;; (set! last-action-delta (- (current-seconds) last-action-time)) +;; (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta) +;; (if (< last-action-delta 60) +;; (loop) +;; (print "Server exiting, 25 seconds since last access")))))) +;; "sync thread")) + +(handle-not-found + + +(thread-start! th1) +(thread-start! th2) +(thread-join! th2) + +(let* ((run-time (- (current-seconds) start-time)) + (queries/second (/ total-db-accesses run-time))) + (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len)) Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -79,11 +79,11 @@ make PLATFORM=linux PREFIX=$PREFIX install cd $BUILDHOME fi # Some eggs are quoted since they are reserved to Bash -for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do +for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 spiffy http-client; do if ! [[ -e $PREFIX/lib/chicken/6/$f.so ]];then chicken-install $PROX $f # chicken-install -deploy -prefix $DEPLOYTARG $PROX $f else echo Skipping install of egg $f as it is already installed