Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1132,11 +1132,11 @@ (if (equal? query-sig (vector-ref myres 1)) (set! res (vector-ref myres 2)) (loop)))))) (timeout (lambda () (let loop ((n numretries)) - (thread-sleep! 20) + (thread-sleep! 60) (if (not res) (if (> numretries 0) (begin (debug:print 0 "WARNING: no reply to query " params ", trying resend") (debug:print-info 11 "re-sending message") @@ -1257,106 +1257,67 @@ ;; values to be applied ;; (define (db:process-queue pubsock indata) (open-run-close (lambda (db . junkparams) - (let ((queries (make-hash-table)) - (data (sort indata (lambda (a b) + (let* ((queries (make-hash-table)) + (data (sort indata (lambda (a b) (< (cdb:packet-get-qtime a)(cdb:packet-get-qtime b)))))) - (if (> (length data) 0) - (debug:print-info 4 "Writing cached data " data)) - - ;; prepare the needed statements, do each only once - (for-each (lambda (request-item) - (let ((stmt-key (cdb:packet-get-qtype request-item))) - (debug:print-info 11 "stmt-key=" stmt-key ", request-item=" request-item) - (if (not (hash-table-ref/default queries stmt-key #f)) - (let ((stmt (alist-ref stmt-key db:queries))) - (debug:print-info 11 "stmt-key=" stmt-key ", stmt=" stmt) - (if stmt - (hash-table-set! queries stmt-key (sqlite3:prepare db (car stmt))) - (if (procedure? stmt-key) - (hash-table-set! queries stmt-key #f) - (if (not (member stmt-key db:special-queries)) - (debug:print 0 "ERROR: Missing query spec for " stmt-key "!")))))))) - data) - - ;; outer loop to handle special queries that cannot be handled in the - ;; transaction. - (let outerloop ((special-qry #f) - (stmts data)) - (debug:print-info 11 "special-qry=" special-qry ", stmts=" stmts) - (if special-qry - - ;; handle a query that cannot be part of the grouped queries - (let* ((stmt-key (cdb:packet-get-qtype special-qry)) - (qry-sig (cdb:packet-get-query-sig special-qry)) - (return-address (cdb:packet-get-client-sig special-qry)) - (qry (hash-table-ref/default queries stmt-key #f)) - (params (cdb:packet-get-params special-qry))) - (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", qry=" qry ", params=" params) - (cond - ;; Special queries - ((string? qry) - (apply sqlite3:execute db qry params) - (server:reply pubsock return-address qry-sig #t #t)) - ;; ((and (not (null? params)) - ;; (procedure? (car params))) - ;; (let ((proc (car params)) - ;; (remparams (cdr params))) - ;; ;; we are being handed a procedure so call it - ;; (debug:print-info 11 "Running (apply " proc " " db " " remparams ")") - ;; (server:reply pubsock return-address (apply proc db remparams)))) - - (else - (case stmt-key - ((immediate) - (let ((proc (car params)) - (remparams (cdr params))) - ;; we are being handed a procedure so call it - (debug:print-info 11 "Running (apply " proc " " remparams ")") - (server:reply pubsock return-address qry-sig #t (apply proc remparams)))) - ((login) - (if (< (length params) 3) ;; should get toppath, version and signature - '(#f "login failed due to missing params") ;; missing params - (let ((calling-path (car params)) - (calling-vers (cadr params)) - (client-key (caddr params))) - (if (and (equal? calling-path *toppath*) - (equal? megatest-version calling-vers)) - (begin - (hash-table-set! *logged-in-clients* client-key (current-seconds)) - (server:reply pubsock return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... - (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))) - ((flush sync) - (server:reply pubsock return-address qry-sig #t (length data))) - ((set-verbosity) - (set! *verbosity* (car params)) - (server:reply pubsock return-address qry-sig #t '(#t *verbosity*))) - ((killserver) - (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") - (open-run-close tasks:server-deregister tasks:open-db - (cadr *server-info*) - pullport: (caddr *server-info*)) - (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) - (server:reply pubsock return-address qry-sig #t '(#t "exit process started"))) - (else - (debug:print 0 "ERROR: Unrecognised queued call " qry " " params) - (server:reply pubsock return-address qry-sig #f #t))))) - (if (not (null? stmts)) - (outerloop #f stmts))) - - ;; handle normal queries - (let ((rem (sqlite3:with-transaction - db - (lambda () - (debug:print-info 11 "flushing " stmts " to db") - (if (null? stmts) - stmts - (let innerloop ((hed (car stmts)) - (tal (cdr stmts))) - (let ((params (cdb:packet-get-params hed)) + (for-each + (lambda (special-qry) + (let* ((stmt-key (cdb:packet-get-qtype special-qry)) + (qry-sig (cdb:packet-get-query-sig special-qry)) + (return-address (cdb:packet-get-client-sig special-qry)) + (qry (hash-table-ref/default queries stmt-key #f)) + (params (cdb:packet-get-params special-qry))) + (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", qry=" qry ", params=" params) + (cond + ;; Special queries + ((string? qry) + (apply sqlite3:execute db qry params) + (server:reply pubsock return-address qry-sig #t #t)) + ;; ((and (not (null? params)) + ;; (procedure? (car params))) + ;; (let ((proc (car params)) + ;; (remparams (cdr params))) + ;; ;; we are being handed a procedure so call it + ;; (debug:print-info 11 "Running (apply " proc " " db " " remparams ")") + ;; (server:reply pubsock return-address (apply proc db remparams)))) + + (else + (case stmt-key + ((immediate) + (let ((proc (car params)) + (remparams (cdr params))) + ;; we are being handed a procedure so call it + (debug:print-info 11 "Running (apply " proc " " remparams ")") + (server:reply pubsock return-address qry-sig #t (apply proc remparams)))) + ((login) + (if (< (length params) 3) ;; should get toppath, version and signature + '(#f "login failed due to missing params") ;; missing params + (let ((calling-path (car params)) + (calling-vers (cadr params)) + (client-key (caddr params))) + (if (and (equal? calling-path *toppath*) + (equal? megatest-version calling-vers)) + (begin + (hash-table-set! *logged-in-clients* client-key (current-seconds)) + (server:reply pubsock return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ... + (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))) + ((flush sync) + (server:reply pubsock return-address qry-sig #t (length data))) + ((set-verbosity) + (set! *verbosity* (car params)) + (server:reply pubsock return-address qry-sig #t '(#t *verbosity*))) + ((killserver) + (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") + (open-run-close tasks:server-deregister tasks:open-db + (cadr *server-info*) + pullport: (caddr *server-info*)) + (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) + (server:reply pubsock return-address qry-sig #t '(#t "exit process started"))) + (let ((params (cdb:packet-get-params hed)) (return-address (cdb:packet-get-client-sig hed)) (qry-sig (cdb:packet-get-query-sig hed)) (stmt-key (cdb:packet-get-qtype hed))) (if (or (not (hash-table-ref/default queries stmt-key #f)) (member stmt-key db:special-queries)) @@ -1369,10 +1330,18 @@ (server:reply pubsock return-address qry-sig #t #t) (if (not (null? tal)) (innerloop (car tal)(cdr tal)) '())) )))))))) + + (else + (debug:print 0 "ERROR: Unrecognised queued call " qry " " params) + (server:reply pubsock return-address qry-sig #f #t)) + + + + (if (not (null? rem)) (outerloop (car rem)(cdr rem)))))) (for-each (lambda (stmt-key) (sqlite3:finalize! (hash-table-ref queries stmt-key))) (hash-table-keys queries))