Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1897,68 +1897,76 @@ )) ;; not used, intended to indicate to run in calling process (define db:run-local-queries '()) ;; rollup-tests-pass-fail)) -(define (db:process-cached-writes db) - (let ((queries (make-hash-table)) - (data #f)) - (mutex-lock! *incoming-mutex*) - ;; data is a list of query packets (length data) 0) - ;; Process if we have data - (begin - (debug:print-info 7 "Writing cached data " data) - - ;; Prepare the needed sql statements - ;; - (for-each (lambda (request-item) - (let ((stmt-key (vector-ref request-item 0)) - (query (vector-ref request-item 1))) - (hash-table-set! queries stmt-key (sqlite3:prepare db query)))) - data) - - ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue - ;; and then are executed. - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (hed) - (let* ((params (vector-ref hed 2)) - (stmt-key (vector-ref hed 0)) - (stmt (hash-table-ref/default queries stmt-key #f))) - (if stmt - (apply sqlite3:execute stmt params) - (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params)))) - data))) - - ;; let all the waiting calls know all is done - (mutex-lock! *completed-mutex*) - (for-each (lambda (item) - (let ((qry-sig (cdb:packet-get-client-sig item))) - (debug:print-info 7 "Registering query " qry-sig " as done") - (hash-table-set! *completed-writes* qry-sig #t))) - data) - (mutex-unlock! *completed-mutex*) - - ;; Finalize the statements. Should this be done inside the mutex above? - ;; I think sqlite3 mutexes will keep the data safe - (for-each (lambda (stmt-key) - (sqlite3:finalize! (hash-table-ref queries stmt-key))) - (hash-table-keys queries)) - - ;; Do a little record keeping - (let ((cache-size (length data))) - (if (> cache-size *max-cache-size*) - (set! *max-cache-size* cache-size))) - #t) - #f))) +;; (define (db:process-cached-writes db) +;; (let ((queries (make-hash-table)) +;; (data #f)) +;; (mutex-lock! *incoming-mutex*) +;; ;; data is a list of query packets (length data) 0) +;; ;; Process if we have data +;; (begin +;; (debug:print-info 7 "Writing cached data " data) +;; +;; ;; Prepare the needed sql statements +;; ;; +;; (for-each (lambda (request-item) +;; (let ((stmt-key (vector-ref request-item 0)) +;; (query (vector-ref request-item 1))) +;; (hash-table-set! queries stmt-key (sqlite3:prepare db query)))) +;; data) +;; +;; ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue +;; ;; and then are executed. +;; (sqlite3:with-transaction +;; db +;; (lambda () +;; (for-each +;; (lambda (hed) +;; (let* ((params (vector-ref hed 2)) +;; (stmt-key (vector-ref hed 0)) +;; (stmt (hash-table-ref/default queries stmt-key #f))) +;; (if stmt +;; (apply sqlite3:execute stmt params) +;; (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params)))) +;; data))) +;; +;; ;; let all the waiting calls know all is done +;; (mutex-lock! *completed-mutex*) +;; (for-each (lambda (item) +;; (let ((qry-sig (cdb:packet-get-client-sig item))) +;; (debug:print-info 7 "Registering query " qry-sig " as done") +;; (hash-table-set! *completed-writes* qry-sig #t))) +;; data) +;; (mutex-unlock! *completed-mutex*) +;; +;; ;; Finalize the statements. Should this be done inside the mutex above? +;; ;; I think sqlite3 mutexes will keep the data safe +;; (for-each (lambda (stmt-key) +;; (sqlite3:finalize! (hash-table-ref queries stmt-key))) +;; (hash-table-keys queries)) +;; +;; ;; Do a little record keeping +;; (let ((cache-size (length data))) +;; (if (> cache-size *max-cache-size*) +;; (set! *max-cache-size* cache-size))) +;; #t) +;; #f))) + +(define (db:process-write db request-item) + (let ((stmt-key (vector-ref request-item 0)) + (query (vector-ref request-item 1)) + (params (vector-ref request-item 2)) + (queryh (sqlite3:prepare db query))) + (apply sqlite3:execute stmt params) + #f)) (define *db:process-queue-mutex* (make-mutex)) (define *number-of-writes* 0) (define *writes-total-delay* 0) @@ -2030,23 +2038,18 @@ ((member stmt-key db:special-queries) (let ((starttime (current-milliseconds))) (debug:print-info 9 "Handling special statement " stmt-key) (case stmt-key ((immediate) - ;; This is a read or mixed read-write query, must clear the cache - (case *transport-type* - ((http) - (mutex-lock! *db:process-queue-mutex*) - (db:process-cached-writes db) - (mutex-unlock! *db:process-queue-mutex*))) + (debug:print 0 "WARNING: Immediate calls are verboten now!") (let* ((proc (car params)) (remparams (cdr params)) ;; we are being handed a procedure so call it - ;; (debug:print-info 11 "Running (apply " proc " " remparams ")") (result (server:reply return-address qry-sig #t (apply proc remparams)))) - (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) - (set! *number-non-write-queries* (+ *number-non-write-queries* 1)) + (debug:print-info 11 "Ran (apply " proc " " remparams ")") + ;; (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime))) + ;; (set! *number-non-write-queries* (+ *number-non-write-queries* 1)) result)) ((login) (if (< (length params) 3) ;; should get toppath, version and signature (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params (let ((calling-path (car params)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -93,11 +93,18 @@ ;; http-transport:handle-directory) ;; simple-directory-handler) ;; Setup the web server and a /ctrl interface ;; (vhost-map `(((* any) . ,(lambda (continue) ;; open the db on the first call - (if (not db)(set! db *inmemdb*)) ;; (open-db))) + (let loop () + (if (not db) + (if (not (sqlite3:database? *inmemdb*)) + (begin + (debug:print 0 "WARNING: db not ready yet. Waiting for it to be ready") + (thread-sleep! 5) + (loop))) + (set! db *inmemdb*))) ;; (open-db))) (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ;; This is the /ctrl path where data is handed to the server and @@ -374,19 +381,19 @@ (let* ((th2 (make-thread (lambda () (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-"))) "Server run")) - (th3 (make-thread http-transport:keep-running "Keep running")) - (th1 (make-thread server:write-queue-handler "write queue"))) + (th3 (make-thread http-transport:keep-running "Keep running"))) +;; (th1 (make-thread server:write-queue-handler "write queue"))) ;; This is were we set up the database connections (set! *db* (open-db)) (set! *inmemdb* (open-in-mem-db)) (db:sync-to *db* *inmemdb*) (thread-start! th2) (thread-start! th3) - (thread-start! th1) + ;; (thread-start! th1) (set! *didsomething* #t) (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest"))) (exit))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -67,28 +67,28 @@ ;; We don't want to flush the queue if it was just flushed (define *server:last-write-flush* (current-milliseconds)) ;; Flush the queue every third of a second. Can we assume that setup-for-run ;; has already been done? -(define (server:write-queue-handler) - (if (setup-for-run) - (let ((db (open-db))) - (let loop () - (let ((last-write-flush-time #f)) - (mutex-lock! *incoming-mutex*) - (set! last-write-flush-time *server:last-write-flush*) - (mutex-unlock! *incoming-mutex*) - (if (> (- (current-milliseconds) last-write-flush-time) 10) - (begin - (mutex-lock! *db:process-queue-mutex*) - (db:process-cached-writes db) - (mutex-unlock! *db:process-queue-mutex*) - (thread-sleep! 0.005)))) - (loop))) - (begin - (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler") - (exit 1)))) +;; (define (server:write-queue-handler) +;; (if (setup-for-run) +;; (let ((db (open-db))) +;; (let loop () +;; (let ((last-write-flush-time #f)) +;; (mutex-lock! *incoming-mutex*) +;; (set! last-write-flush-time *server:last-write-flush*) +;; (mutex-unlock! *incoming-mutex*) +;; (if (> (- (current-milliseconds) last-write-flush-time) 10) +;; (begin +;; (mutex-lock! *db:process-queue-mutex*) +;; (db:process-cached-writes db) +;; (mutex-unlock! *db:process-queue-mutex*) +;; (thread-sleep! 0.005)))) +;; (loop))) +;; (begin +;; (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler") +;; (exit 1)))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;======================================================================