Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -54,11 +54,11 @@ ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; (define (client:setup run-id #!key (remaining-tries 100) (failed-connects 0)) - (debug:print-info 0 "client:setup remaining-tries=" remaining-tries) + (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) (if (<= remaining-tries 0) (begin (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) (exit 1)) (let ((host-info (hash-table-ref/default *runremote* run-id #f))) @@ -67,37 +67,37 @@ (port (http-transport:server-dat-get-port host-info)) (start-res (http-transport:client-connect iface port)) (ping-res (rmt:login-no-auto-client-setup start-res run-id))) (if ping-res ;; sucessful login? (begin - (debug:print-info 0 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries) + (debug:print-info 2 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries) ;; Why add the close-connections here? ;; (http-transport:close-connections run-id) (hash-table-set! *runremote* run-id start-res) start-res) ;; return the server info ;; have host info but no ping. shutdown the current connection and try again (begin ;; login failed - (debug:print-info 0 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info) + (debug:print-info 1 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info) (http-transport:close-connections run-id) (hash-table-delete! *runremote* run-id) (if (< remaining-tries 8) (thread-sleep! 5) (thread-sleep! 1)) (client:setup run-id remaining-tries: (- remaining-tries 1))))) ;; YUK: rename server-dat here (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id))) - (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-dat (let* ((iface (tasks:hostinfo-get-interface server-dat)) (port (tasks:hostinfo-get-port server-dat)) (start-res (http-transport:client-connect iface port)) (ping-res (rmt:login-no-auto-client-setup start-res run-id))) (if (and start-res ping-res) (begin (hash-table-set! *runremote* run-id start-res) - (debug:print-info 0 "connected to " (http-transport:server-dat-make-url start-res)) + (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) (http-transport:close-connections run-id) (hash-table-delete! *runremote* run-id) Index: datashare-testing/.datashare.config ================================================================== --- datashare-testing/.datashare.config +++ datashare-testing/.datashare.config @@ -1,19 +1,22 @@ # Read in the users vars first (so the offical data cannot be overridden [include datastore.config] -[storagegroups] -1 eng /tmp/datastore/eng +[storage] +1 /tmp/datastore/eng [areas] -synthesis asic/synthesis -verilog asic/verilog -oalibs custom/oalibs +synthesis asic/synthesis +verilog asic/verilog +customlibs custom/oalibs [target] basepath #{getenv BASEPATH} [quality] 0 untested 1 lightly tested 2 tested 3 full QA + +[database] +location /tmp/datastore Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -62,51 +62,128 @@ (for-each (lambda (qry) (sqlite3:execute db qry)) (list "CREATE TABLE pkgs - (id INTEGER PRIMARY KEY, - area TEXT, - key TEXT, - iteration INTEGER, - submitter TEXT, - datetime TEXT, - storegrp TEXT, - datavol INTEGER, - quality TEXT, - disk_id INTEGER, - comment TEXT);" + (id INTEGER PRIMARY KEY, + area TEXT, + version_name TEXT, + store_type TEXT DEFAULT 'copy', + copied INTEGER DEFAULT 0, + source_path TEXT, + iteration INTEGER DEFAULT 0, + submitter TEXT, + datetime TIMESTAMP DEFAULT (strftime('%s','now')), + storegrp TEXT, + datavol INTEGER, + quality TEXT, + disk_id INTEGER, + comment TEXT);" "CREATE TABLE refs (id INTEGER PRIMARY KEY, pkg_id INTEGER, destlink TEXT);" "CREATE TABLE disks (id INTEGER PRIMARY KEY, storegrp TEXT, path TEXT);"))) + +(define (datashare:register-data db area version-name store-type submitter quality source-path comment) + (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;")) + (next-iteration 0)) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row + (lambda (iteration) + (if (and (number? iteration) + (>= iteration next-iteration)) + (set! next-iteration (+ iteration 1)))) + iter-qry area version-name) + ;; now store the data + (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) + VALUES (?,?,?,?,?,?,?,?);" + area version-name next-iteration store-type submitter source-path quality comment))) + (sqlite3:finalize! iter-qry) + next-iteration)) + +(define (datashare:get-pkg-record db area version-name iteration) + #f) ;; Create the sqlite db -(define (datashare:open-db path) - (if (and path - (directory? path) - (file-read-access? path)) - (let* ((dbpath (conc path "/datashare.db")) - (writeable (file-write-access? dbpath)) - (dbexists (file-exists? dbpath)) - (handler (make-busy-timeout 136000))) - (handle-exceptions - exn - (begin - (debug:print 2 "ERROR: problem accessing db " dbpath - ((condition-property-accessor 'exn 'message) exn)) - (exit)) - (set! db (sqlite3:open-database dbpath))) - (if *db-write-access* (sqlite3:set-busy-handler! db handler)) - (if (not dbexists) - (begin - (datashare:initialize-db db))) - db))) +(define (datashare:open-db configdat) + (let ((path (configf:lookup configdat "database" "location"))) + (if (and path + (directory? path) + (file-read-access? path)) + (let* ((dbpath (conc path "/datashare.db")) + (writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath)) + (handler (make-busy-timeout 136000))) + (handle-exceptions + exn + (begin + (debug:print 2 "ERROR: problem accessing db " dbpath + ((condition-property-accessor 'exn 'message) exn)) + (exit)) + (set! db (sqlite3:open-database dbpath))) + (if *db-write-access* (sqlite3:set-busy-handler! db handler)) + (if (not dbexists) + (begin + (datashare:initialize-db db))) + db) + (print "ERROR: invalid path for storing database: " path)))) + +(define (open-run-close-exception-handling proc idb . params) + (handle-exceptions + exn + (let ((sleep-time (random 30)) + (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + (case err-status + ((busy) + (thread-sleep! sleep-time)) + (else + (print "EXCEPTION: database overloaded or unreadable.") + (print " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (print " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (print-call-chain) + (thread-sleep! sleep-time) + (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) + (apply open-run-close-exception-handling proc idb params)) + (apply open-run-close-no-exception-handling proc idb params))) + +(define (open-run-close-no-exception-handling proc idb . params) + ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (print "ERROR: cannot open-run-close with #f anymore")) + ((procedure? idb) (idb)) + (else (print "ERROR: cannot open-run-close with #f anymore")))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! dbstruct)) + ;; (print "open-run-close-no-exception-handling END" ) + res)) + +(define open-run-close open-run-close-no-exception-handling) + +;;====================================================================== +;; DATA IMPORT/EXPORT +;;====================================================================== + +(define (datashare:import-data source-path dest-path area version iteration) + (let ((targ-path (conc dest-path "/" area "/" version "/" iteration))) + (create-directory targ-path #t) + (process-run "rsync" (list "-av" source-path targ-path)) + #t)) ;; #t on success + +(define (datastore:get-best-storage configdat) + (let ((store-areas (configf:get-section configdat "storage"))) + (print "store-areas:") + (pp store-areas) + (cadar store-areas))) ;;====================================================================== ;; GUI ;;====================================================================== @@ -134,24 +211,39 @@ (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")) + (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" )) + (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x")) + ;; (iteration (iup:textbox #:expand "YES" #:size "20x")) ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x")) (comment-tb (iup:textbox #:expand "YES" #:multiline "YES")) + (import-type "copy") (source-tb (iup:textbox #:expand "HORIZONTAL" #:value (or (configf:lookup configdat "target" "basepath") ""))) (publish (lambda (publish-type) - (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0)) - (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED"))) - (area-path (cadr area-dat)) - (area-name (car area-dat)) - (version (iup:attribute version-tb "VALUE")) - (comment (iup:attribute comment-tb "VALUE")) - (spath (iup:attribute source-tb "VALUE"))) - (print "Publish: type=" publish-type ", area-name=" area-name ", spath=" spath ", area-path=" area-path )))) + (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0)) + (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED"))) + (area-path (cadr area-dat)) + (area-name (car area-dat)) + (version (iup:attribute version-tb "VALUE")) + (comment (iup:attribute comment-tb "VALUE")) + (spath (iup:attribute source-tb "VALUE")) + (submitter (current-user-name)) + (quality 2) + (db (datashare:open-db configdat)) + (iteration (datashare:register-data db area-name version import-type submitter quality spath comment)) + (dest-store (datastore:get-best-storage configdat))) + (if iteration + (if (equal? "copy" import-type) + (datashare:import-data spath dest-store area-name version iteration)) + (print "ERROR: Failed to get an iteration number")) + (sqlite3:finalize! db)))) + ;; (print "Publish: type=" publish-type ", area-name=" area-name ", spath=" spath ", area-path=" area-path )))) (copy (iup:button "Copy and Publish" #:expand "HORIZONTAL" #:action (lambda (obj) (publish 'copy)))) (link (iup:button "Link and Publish" @@ -218,11 +310,12 @@ ;;====================================================================== ;; MAIN ;;====================================================================== (define (datashare:load-config path) - (let ((fname (conc path "/.datashare.config"))) + (let* ((exename (pathname-file (car (argv)))) + (fname (conc path "/." exename ".config"))) (ini:property-separator-patt " * *") (ini:property-separator #\space) (if (file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t)