Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -44,10 +44,11 @@ (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar +(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) ;; DATABASE (define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs ;; SERVER Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -255,13 +255,13 @@ (db (datashare:open-db configdat))) (if (> space-avail 10000) ;; dumb heuristic (begin (create-directory targ-path #t) (datastore:set-stored-path db id targ-path) - (print "Running command: rsync -av " source-path " " targ-path) + (print "Running command: rsync -av " source-path "/ " targ-path "/") (let ((th1 (make-thread (lambda () - (let ((pid (process-run "rsync" (list "-av" source-path targ-path)))) + (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/"))))) (process-wait pid) (datastore:set-copied db id "yes") (sqlite3:finalize! db))) "Data copy"))) (thread-start! th1)) @@ -340,11 +340,11 @@ ;; ;; #:y 'mouse ;; ) )))) (define (datashare:publish-view configdat) - (pp (hash-table->alist configdat)) + ;; (pp (hash-table->alist configdat)) (let* ((areas (configf:get-section configdat "areas")) (label-size "70x") (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x")) (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) @@ -397,11 +397,11 @@ (top (iup:show fd #:modal? "YES"))) (iup:attribute-set! source-tb "VALUE" (iup:attribute fd "VALUE")) (iup:destroy! fd)))))) (print "areas") - (pp areas) + ;; (pp areas) (fold (lambda (areadat num) ;; (print "Adding num=" num ", areadat=" areadat) (iup:attribute-set! areas-sel (conc num) (car areadat)) (+ 1 num)) 1 areas) @@ -465,11 +465,11 @@ (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datastore:pkg-get-datetime record)))) (iup:attribute-set! comment "TITLE" (datastore:pkg-get-comment record)) (iup:attribute-set! quality "TITLE" (datastore:pkg-get-quality record)) (iup:attribute-set! copy-link "TITLE" (datastore:pkg-get-store_type record)) )) - (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id) + ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id) )))) (tb2 (iup:treebox #:value 0 #:name "Installed" #:expand "YES" @@ -573,30 +573,52 @@ (iup:attribute-set! tabs "TABTITLE1" "Get") (iup:attribute-set! tabs "TABTITLE2" "Manage") ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") tabs))) (iup:main-loop)) + +;;====================================================================== +;; MISC +;;====================================================================== + +(define (datastore:find name paths) + (if (null? paths) + #f + (let loop ((hed (car paths)) + (tal (cdr paths))) + (if (file-exists? (conc hed "/" name)) + hed + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))) ;;====================================================================== ;; MAIN ;;====================================================================== -(define (datashare:load-config path) - (let* ((exename (pathname-file (car (argv)))) - (fname (conc path "/." exename ".config"))) +(define (datashare:load-config exe-dir exe-name) + (let* ((fname (conc exe-dir "/." exe-name ".config"))) (ini:property-separator-patt " * *") (ini:property-separator #\space) (if (file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t) (make-hash-table)))) +;; ease debugging by loading ~/.dashboardrc - remove from production! +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) - (configdat (datashare:load-config (pathname-directory prog)))) + (exe-name (pathname-file (car (argv)))) + (exe-dir (or (pathname-directory prog) + (datastore:find exe-name (string-split (get-environment-variable "PATH") ":")))) + (configdat (datashare:load-config exe-dir exe-name))) (cond ((eq? (length rema) 1) (case (string->symbol (car rema)) ((help -h -help --h --help) (print datashare:help)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -242,11 +242,11 @@ (maindb (dbr:dbstruct-get-main dbstruct)) (refdb (dbr:dbstruct-get-refdb dbstruct)) (olddb (dbr:dbstruct-get-olddb dbstruct)) ;; (runid (dbr:dbstruct-get-run-id dbstruct)) ) - (debug:print-info 0 "Syncing for run-id " run-id) + (debug:print-info 4 "Syncing for run-id: " run-id) (if (eq? run-id 0) ;; runid equal to 0 is main.db (if maindb (if (or (not (number? mtime)) (not (number? stime)) @@ -255,11 +255,14 @@ (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) num-synced) 0) (begin - (debug:print 0 "WARNING: call to sync main.db to megatest.db but main not initialized") + ;; this can occur when using local access (i.e. not in a server) + ;; need a flag to turn it off. + ;; + (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized") 0)) ;; any other runid is a run (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) @@ -270,11 +273,11 @@ 0)))) ;; close all opened run-id dbs (define (db:close-all dbstruct) ;; finalize main.db - (db:sync-touched dbstruct force-sync: #t) + (db:sync-touched dbstruct 0 force-sync: #t) (sqlite3:finalize! (db:get-db dbstruct #f)) (let* ((local (dbr:dbstruct-get-local dbstruct)) (rundb (dbr:dbstruct-get-rundb dbstruct))) (if local (for-each @@ -371,12 +374,12 @@ '("jobgroup" #f))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) (define (db:sync-tables tbls fromdb todb . slave-dbs) (cond - ((not fromdb) (debug:print 0 "ERROR: db:sync-tables called with fromdb missing") -1) - ((not todb) (debug:print 0 "ERROR: db:sync-tables called with todb missing") -2) + ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) ((not (sqlite3:database? fromdb)) (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? todb)) (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) (else Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -32,10 +32,29 @@ ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== +(define (rmt:write-frequency-over-limit? cmd run-id) + (or (member cmd api:read-only-queries) + (let* ((tmprec (hash-table-ref/default *write-frequency* run-id #f)) + (record (if tmprec tmprec + (let ((v (vector (current-seconds) 0))) + (hash-table-set! *write-frequency* run-id v) + v))) + (count (+ 1 (vector-ref record 1))) + (start (vector-ref record 0))) + (vector-set! record 1 count) + (if (and (> count 1) + (< (/ (- (current-seconds) start) + count) ;; seconds per count + 10)) + (begin + (debug:print-info 1 "db write rate too high, starting a server") + #t) + #f)))) ;; less than 10 seconds per count - start up a server + ;; cmd is a symbol ;; vars is a json string encoding the parameters for the call ;; (define (rmt:send-receive cmd rid params) (let* ((run-id (if rid rid 0)) @@ -45,12 +64,12 @@ ;; if read only query and server not already running ;; bypass starting the server. ;; ;; NB// can cache the answer for server running for 10 seconds ... ;; - (if (and (member cmd api:read-only-queries) - (not (open-run-close tasks:get-server tasks:open-db run-id))) + (if (and (not (rmt:write-frequency-over-limit? cmd run-id)) + (not (open-run-close tasks:server-running-or-starting? tasks:open-db run-id))) #f (let loop ((numtries 100)) (let ((res (client:setup run-id))) (if res (hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully) @@ -68,11 +87,11 @@ (db:string->obj res) (let ((new-connection-info (client:setup run-id))) (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.") (rmt:send-receive cmd run-id params)))) (begin - (debug:print-info 0 "no server and read-only query, bypassing normal channel") + (debug:print-info 4 "no server and read-only query, bypassing normal channel") (rmt:open-qry-close-locally cmd run-id params))))) (define (rmt:open-qry-close-locally cmd run-id params) (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct-local (make-dbr:dbstruct path: dbdir Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -265,10 +265,19 @@ ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ? "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers WHERE run_id=? AND state='running' ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id) res)) + +(define (tasks:server-running-or-starting? mdb run-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (id) + (set! res id)) + mdb + "SELECT id FROM servers WHERE run_id=? AND state in ('running','available');" run-id) + res)) (define (tasks:get-all-servers mdb) (let ((res '())) (sqlite3:for-each-row (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)