DELETED emergency-patches/emergency-patch-1.scm Index: emergency-patches/emergency-patch-1.scm ================================================================== --- emergency-patches/emergency-patch-1.scm +++ /dev/null @@ -1,203 +0,0 @@ - - -;; These are called by the server on recipt of /api calls -;; - keep it simple, only return the actual result of the call, i.e. no meta info here -;; -;; - returns #( flag result ) -;; -(define (api:execute-requests dbstruct dat) - (handle-exceptions - exn - (let ((call-chain (get-call-chain))) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat) - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens - (cond - ((not (vector? dat)) ;; it is an error to not receive a vector - (vector #f (vector #f "remote must be called with a vector"))) - ((> *api-process-request-count* 20) ;; 20) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") - (set! *server-overloaded* #t) - (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! - (else - (let* ((cmd-in (vector-ref dat 0)) - (cmd (if (symbol? cmd-in) - cmd-in - (string->symbol cmd-in))) - (params (vector-ref dat 1)) - (start-t (current-milliseconds)) - (readonly-mode (dbr:dbstruct-read-only dbstruct)) - (readonly-command (member cmd api:read-only-queries)) - (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) - (res - (if writecmd-in-readonly-mode - (conc "attempt to run write command "cmd" on a read-only database") - (case cmd - ;;=============================================== - ;; READ/WRITE QUERIES - ;;=============================================== - - ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl - - ;; SERVERS - ((start-server) (apply server:kind-run params)) - ((kill-server) (set! *server-run* #f)) - - ;; TESTS - - ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) - ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. - ((test-set-state-status-by-id) - - ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) - (db:set-state-status-and-roll-up-items - dbstruct - (list-ref params 0) ; run-id - (list-ref params 1) ; test-name - #f ; item-path - (list-ref params 2) ; state - (list-ref params 3) ; status - (list-ref params 4) ; comment - )) - - ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) - ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) - ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) - ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) - ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) - - ;; RUNS - ((register-run) (apply db:register-run dbstruct params)) - ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) - ((delete-run) (apply db:delete-run dbstruct params)) - ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) - ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) - ((update-run-stats) (apply db:update-run-stats dbstruct params)) - ((set-var) (apply db:set-var dbstruct params)) - ((del-var) (apply db:del-var dbstruct params)) - - ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - - ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) - - ;; MISC - ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) - ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) - - ;; TESTMETA - ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) - ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) - ((get-tests-tags) (db:get-tests-tags dbstruct)) - - ;; TASKS - ((tasks-add) (apply tasks:add dbstruct params)) - ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) - ((tasks-get-last) (apply tasks:get-last dbstruct params)) - - ;; NO SYNC DB - ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) - ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) - ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) - - ;; ARCHIVES - ;; ((archive-get-allocations) - ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) - ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) - - ;;====================================================================== - ;; READ ONLY QUERIES - ;;====================================================================== - - ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys dbstruct)) - ((get-key-vals) (apply db:get-key-vals dbstruct params)) - ((get-target) (apply db:get-target dbstruct params)) - ((get-targets) (db:get-targets dbstruct)) - - ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) - - ;; TESTS - ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) - ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) - ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) - ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) - ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) - ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) - - ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((get-num-runs) (apply db:get-num-runs dbstruct params)) - ((get-all-run-ids) (db:get-all-run-ids dbstruct)) - ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) - ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) - ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) - ((get-var) (apply db:get-var dbstruct params)) - ((get-run-stats) (apply db:get-run-stats dbstruct params)) - - ;; STEPS - ((get-steps-data) (apply db:get-steps-data dbstruct params)) - ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) - - ;; TEST DATA - ((read-test-data) (apply db:read-test-data dbstruct params)) - ((read-test-data*) (apply db:read-test-data* dbstruct params)) - - ;; MISC - ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) - ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) - ((login) (apply db:login dbstruct params)) - ((general-call) (let ((stmtname (car params)) - (run-id (cadr params)) - (realparams (cddr params))) - (db:general-call dbstruct stmtname realparams))) - ((sdb-qry) (apply sdb:qry params)) - ((ping) (current-process-id)) - ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - - ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) - - ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) - (else - (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) - (conc "ERROR: BAD api call " cmd)))))) - - ;; save all stats - (let ((delta-t (- (current-milliseconds) - start-t))) - (hash-table-set! *db-api-call-time* cmd - (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) - (if writecmd-in-readonly-mode - (vector #f res) - (vector #t res))))))) DELETED emergency-patches/emergency-patch-2.scm Index: emergency-patches/emergency-patch-2.scm ================================================================== --- emergency-patches/emergency-patch-2.scm +++ /dev/null @@ -1,311 +0,0 @@ -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - -(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) - (let* ((loadavg (common:get-cpu-load remote-host)) - (first (car loadavg)) - (next (cadr loadavg)) - (adjload (* maxload numcpus)) - (loadjmp (- first next))) - (cond - ((and (> first adjload) - (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg "")) - (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) - ((and (> loadjmp numcpus) - (> count 0)) - (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) - (thread-sleep! waitdelay) - (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) - -(define (common:wait-for-homehost-load maxload msg) - (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. - #f - (common:get-homehost))) - (hh (if hh-dat (car hh-dat) #f)) - (numcpus (common:get-num-cpus hh))) - (common:wait-for-normalized-load maxload msg: msg remote-host: hh))) - -;; wait for normalized cpu load to drop below maxload -;; -(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f)) - (let ((num-cpus (common:get-num-cpus remote-host))) - (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) - -;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) -(define (runs:process-expanded-tests runsdat testdat) - ;; unroll the contents of runsdat and testdat (due to ongoing refactoring). - (let* ((hed (runs:testdat-hed testdat)) - (tal (runs:testdat-tal testdat)) - (reg (runs:testdat-reg testdat)) - (reruns (runs:testdat-reruns testdat)) - (test-name (runs:testdat-test-name testdat)) - (item-path (runs:testdat-item-path testdat)) - (jobgroup (runs:testdat-jobgroup testdat)) - (waitons (runs:testdat-waitons testdat)) - (item-path (runs:testdat-item-path testdat)) - (testmode (runs:testdat-testmode testdat)) - (newtal (runs:testdat-newtal testdat)) - (itemmaps (runs:testdat-itemmaps testdat)) - (test-record (runs:testdat-test-record testdat)) - (prereqs-not-met (runs:testdat-prereqs-not-met testdat)) - - (reglen (runs:dat-reglen runsdat)) - (regfull (runs:dat-regfull runsdat)) - (runname (runs:dat-runname runsdat)) - (max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat)) - (run-id (runs:dat-run-id runsdat)) - (test-patts (runs:dat-test-patts runsdat)) - (required-tests (runs:dat-required-tests runsdat)) - (test-registry (runs:dat-test-registry runsdat)) - (registry-mutex (runs:dat-registry-mutex runsdat)) - (flags (runs:dat-flags runsdat)) - (keyvals (runs:dat-keyvals runsdat)) - (run-info (runs:dat-run-info runsdat)) - (all-tests-registry (runs:dat-all-tests-registry runsdat)) - (run-limits-info (runs:dat-can-run-more-tests runsdat)) - ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (have-resources (car run-limits-info)) - (num-running (list-ref run-limits-info 1)) - (num-running-in-jobgroup(list-ref run-limits-info 2)) - (max-concurrent-jobs (list-ref run-limits-info 3)) - (job-group-limit (list-ref run-limits-info 4)) - ;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) - ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - (fails (if (list? prereqs-not-met) - (runs:calc-fails prereqs-not-met) - (begin - (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) - '()))) - (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! - (not (equal? x hed))) - (runs:calc-not-completed prereqs-not-met))) - (loop-list (list hed tal reg reruns)) - ;; configure the load runner - (numcpus (common:get-num-cpus #f)) - (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0"))) ;; use a non-number string to disable - (maxhomehostload (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "1.2"))) ;; use a non-number string to disable - (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) - (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" - (string-intersperse - (map (lambda (t) - (if (vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t)) - (conc " WARNING: t is not a vector=" t ))) - prereqs-not-met) - ", ") ") fails: " fails - "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) - - - - (if (and (not (null? prereqs-not-met)) - (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) - - ;; Don't know at this time if the test have been launched at some time in the past - ;; i.e. is this a re-launch? - (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info) - - (cond - - ;; Check item path against item-patts, - ;; - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) - (if (or (not (null? tal))(not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) - #f)) - - ;; Register tests - ;; - ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) - (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" ) - ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs - (let register-loop ((numtries 15)) - (rmt:register-test run-id test-name item-path) - (if (rmt:get-test-id run-id test-name item-path) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) - (if (> numtries 0) - (begin - (thread-sleep! 0.5) - (register-loop (- numtries 1))) - (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path))))) - (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) - (begin - (rmt:register-test run-id test-name "") - (if (rmt:get-test-id run-id test-name "") - (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - (if (and (null? tal)(null? reg)) - (list hed tal (append reg (list hed)) reruns) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - ;; NB// Here we are building reg as we register tests - ;; if regfull we must pop the front item off reg - (if regfull - (append (cdr reg) (list hed)) - (append reg (list hed))) - reruns))) - - ;; At this point hed test registration must be completed. - ;; - ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) - 'start) - (debug:print-info 0 *default-log-port* "Waiting on test registration(s): " - (string-intersperse - (filter (lambda (x) - (eq? (hash-table-ref/default test-registry x #f) 'start)) - (hash-table-keys test-registry)) - ", ")) - (thread-sleep! 0.051) - (list hed tal reg reruns)) - - ;; If no resources are available just kill time and loop again - ;; - ((not have-resources) ;; simply try again after waiting a second - (if (runs:lownoise "no resources" 60) - (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) - ;; Have gone back and forth on this but db starvation is an issue. - ;; wait one second before looking again to run jobs. - (thread-sleep! 1) - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (list (car newtal)(cdr newtal) reg reruns)) - - ;; This is the final stage, everything is in place so launch the test - ;; - ((and have-resources - (or (null? prereqs-not-met) - (and (member 'toplevel testmode) ;; 'toplevel) - (null? non-completed) - (not (member 'exclusive testmode))))) - ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) - ;; we are going to reset all the counters for test retries by setting a new hash table - ;; this means they will increment only when nothing can be run - (set! *max-tries-hash* (make-hash-table)) - ;; well, first lets see if cpu load throttling is enabled. If so wait around until the - ;; average cpu load is under the threshold before continuing - (if maxload ;; only gate if maxload is specified - (common:wait-for-cpuload maxload numcpus waitdelay)) - (if maxhomehostload - (common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload))) - - (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) - (runs:incremental-print-results run-id) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (if (or (not (null? tal))(not (null? reg))) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns) - #f)) - - ;; must be we have unmet prerequisites - ;; - (else - (debug:print 4 *default-log-port* "FAILS: " fails) - ;; If one or more of the prereqs-not-met are FAIL then we can issue - ;; a message and drop hed from the items to be processed. - ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) - (if (and (not (null? prereqs-not-met)) - (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse - (runs:mixed-list-testname-and-testrec->list-of-strings - prereqs-not-met) ", "))) - (if (or (null? fails) - (member 'toplevel testmode)) - (begin - ;; couldn't run, take a breather - (if (runs:lownoise "Waiting for more work to do..." 60) - (debug:print-info 0 *default-log-port* "Waiting for more work to do...")) - (thread-sleep! 1) - (list (car newtal)(cdr newtal) reg reruns)) - ;; the waiton is FAIL so no point in trying to run hed ever again - (if (or (not (null? reg))(not (null? tal))) - (if (vector? hed) - (begin - (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path - " from the launch list as it has prerequistes that are FAIL") - (let ((test-id (rmt:get-test-id run-id hed ""))) - (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - ;; This next is for the items - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) - (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed) - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? - )) - (let ((nth-try (hash-table-ref/default test-registry hed 0))) - (cond - ((member "RUNNING" (map db:test-get-state prereqs-not-met)) - (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) - (thread-sleep! 4) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)) - ((or (not nth-try) - (and (number? nth-try) - (< nth-try 10))) - (hash-table-set! test-registry hed (if (number? nth-try) - (+ nth-try 1) - 0)) - (if (runs:lownoise (conc "not removing test " hed) 60) - (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) - ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) - ;; (list hed tal reg reruns) - ;; (list (car newtal)(cdr newtal) reg reruns) - ;; (hash-table-set! test-registry hed 'removed) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)) - ((symbol? nth-try) - (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW - (if (null? tal) - #f ;; yes, really - (list (car tal)(cdr tal) reg reruns)) - (begin - (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) - (hash-table-set! test-registry hed 0) - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns)))) - (else - (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) - (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) - ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) - (hash-table-set! test-registry hed 'removed) - (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) - ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. - (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL - (list (if (null? tal)(car newtal)(car tal)) - tal - reg - reruns))))) - ;; can't drop this - maybe running? Just keep trying - (let ((runable-tests (runs:runable-tests prereqs-not-met))) - (if (null? runable-tests) - #f ;; I think we are truly done here - (list (runs:queue-next-hed newtal reg reglen regfull) - (runs:queue-next-tal newtal reg reglen regfull) - (runs:queue-next-reg newtal reg reglen regfull) - reruns))))))))) DELETED emergency-patches/emergency-patch-3.scm Index: emergency-patches/emergency-patch-3.scm ================================================================== --- emergency-patches/emergency-patch-3.scm +++ /dev/null @@ -1,81 +0,0 @@ - ;; To build patch: - ;;;;;;;;;;;;;;;;;;;;;;;;; - ;; ldd /p/foundry/env/pkgs/megatest/1.64/19/bin/.11/mtest - ;; linux-vdso.so.1 => (0x00002aaaaaaab000) - ;; libchicken.so.7 => /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0//lib/libchicken.so.7 (0x00002aaaaaaad000) - ;; libm.so.6 => /lib64/libm.so.6 (0x00002aaaab0a6000) - ;; libdl.so.2 => /lib64/libdl.so.2 (0x00002aaaab31f000) - ;; libc.so.6 => /lib64/libc.so.6 (0x00002aaaab523000) - ;; /lib64/ld-linux-x86-64.so.2 (0x0000555555554000) - ;; - ;; /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0/bin/csc -s emergency-patch-3.scm - ;; - - - ;; to test patch: - ;;;;;;;;;;;;;;;;;;;;;;;;; - ;; in .megatestrc, add: - ;; (if (and (> megatest-version 1.64) - ;; (< megatest-version 1.6421)) - ;; (begin - ;; (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-1.so") - ;; (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-2.so"))) - ;; - - - ;; to productize patch: - ;;;;;;;;;;;;;;;;;;;;;;;;; - ;; -(use directory-utils regex) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - -;; Given a run id start a server process ### NOTE ### > file 2>&1 -;; if the run-id is zero and the target-host is set -;; try running on that host -;; incidental: rotate logs in logs/ dir. -;; -(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area - (let* ((curr-host (get-host-name)) - ;; (attempt-in-progress (server:start-attempted? areapath)) - ;; (dot-server-url (server:check-if-running areapath)) - (curr-ip (server:get-best-guess-address curr-host)) - (curr-pid (current-process-id)) - (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) - (target-host (car homehost)) - (testsuite (common:get-testsuite-name)) - (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log")) - (cmdln (conc (common:get-megatest-exe) - " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") - " -daemonize " - "") - ;; " -log " logfile - " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &"))))) - (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")) - (load-limit (configf:lookup-number *configdat* "server" "load-limit" default: 0.9))) - ;; we want the remote server to start in *toppath* so push there - (push-directory areapath) - (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") - (thread-start! log-rotate) - - ;; host.domain.tld match host? - (if (and target-host - ;; look at target host, is it host.domain.tld or ip address and does it - ;; match current ip or hostname - (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) - (not (equal? curr-ip target-host))) - (begin - (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) - (setenv "TARGETHOST" target-host))) - - (setenv "TARGETHOST_LOGF" logfile) - (common:wait-for-normalized-load load-limit " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever - (system (conc "nbfake " cmdln)) - (unsetenv "TARGETHOST_LOGF") - (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) - (thread-join! log-rotate) - (pop-directory))) DELETED iupexamples/graph.scm Index: iupexamples/graph.scm ================================================================== --- iupexamples/graph.scm +++ /dev/null @@ -1,62 +0,0 @@ -(use iup) -(import iup-pplot) - - - -(define (tl) - (let* ((lastx 0) - (lastsample 2) - (plt (pplot - #:title "MyTitle" - #:marginbottom "65" - #:marginleft "65" - #:axs_xlabel "Score" - #:axs_ylabel "Count" - #:legendshow "YES" - ;; #:axs_xmin "0" - ;; #:axs_ymin "0" - #:axs_yautomin "YES" - #:axs_xautomin "YES" - #:axs_xautotick "YES" - #:axs_yautotick "YES" - #:ds_showvalues "YES" - #:size "200x200" - )) - (plt1 (call-with-pplot - plt - (lambda (x) - (pplot-add! plt 10 100) - (pplot-add! plt 20 120) - (pplot-add! plt 30 200)) - #:x-string #f - )) - (plt2 (call-with-pplot - plt - (lambda (x) - (pplot-add! plt 10 180) - (pplot-add! plt 20 125) - (pplot-add! plt 30 100)) - #:x-string #f - )) - (dlg (dialog - (vbox - plt - (hbox - ;; (button "Redraw" size: "50x" action: (lambda (obj) - ;; (redraw plt))) - (button "Quit" size: "50x" action: (lambda (obj) - (exit))) - (button "AddPoint" size: "50x" action: (lambda (obj) - (set! lastx (+ lastx 10)) - (set! lastsample (+ lastsample 1)) - ;; (attribute-set! plt 'current 0) - (print "lastx: " lastx " lastsample: " lastsample) - (pplot-add! plt lastx (random 300) lastsample 1) - (attribute-set! plt "REDRAW" "1")))))))) - (set! lastx 30) - (attribute-set! plt 'ds_mode "LINE") - ;; (attribute-set! plt 'ds_legend "Yada") - (show dlg) - (main-loop))) - -(tl) DELETED iupexamples/iupwidgetinfo.scm Index: iupexamples/iupwidgetinfo.scm ================================================================== --- iupexamples/iupwidgetinfo.scm +++ /dev/null @@ -1,191 +0,0 @@ -#! /usr/bin/env csi - -(require-library srfi-4 iup) -(import srfi-4 iup iup-pplot iup-glcanvas) - -(define (popup dlg . args) - (apply show dlg #:modal? 'yes args) - (destroy! dlg)) - -(define (properties ih) - (popup (element-properties-dialog ih)) - 'default) - -(define dlg - (dialog - (vbox - (hbox ; headline - (fill) - (frame (label " Inspect control and dialog classes " - fontsize: 15)) - (fill) - margin: '0x0) - - (label "") - (label "Dialogs" fontsize: 12) - (hbox - (button "dialog" - action: (lambda (self) (properties (dialog (vbox))))) - (button "color-dialog" - action: (lambda (self) (properties (color-dialog)))) - (button "file-dialog" - action: (lambda (self) (properties (file-dialog)))) - (button "font-dialog" - action: (lambda (self) (properties (font-dialog)))) - (button "message-dialog" - action: (lambda (self) (properties (message-dialog)))) - (fill) - margin: '0x0) - (hbox - (button "layout-dialog" - action: (lambda (self) (properties (layout-dialog)))) - (button "element-properties-dialog" - action: (lambda (self) - (properties - (element-properties-dialog (create 'user))))) - (fill) - margin: '0x0) - - (label "") - (label "Composition widgets" fontsize: 12) - (hbox - (button "fill" - action: (lambda (self) (properties (fill)))) - (button "hbox" - action: (lambda (self) (properties (hbox)))) - (button "vbox" - action: (lambda (self) (properties (vbox)))) - (button "zbox" - action: (lambda (self) (properties (zbox)))) - (button "radio" - action: (lambda (self) (properties (radio (vbox))))) - (button "normalizer" - action: (lambda (self) (properties (normalizer)))) - (button "cbox" - action: (lambda (self) (properties (cbox)))) - (button "sbox" - action: (lambda (self) (properties (sbox (vbox))))) - (button "split" - action: (lambda (self) (properties (split (vbox) (vbox))))) - (fill) - margin: '0x0) - - (label "") - (label "Standard widgets" fontsize: 12) - (hbox - (button "button" - action: (lambda (self) (properties (button)))) - (button "canvas" - action: (lambda (self) (properties (canvas)))) - (button "frame" - action: (lambda (self) (properties (frame)))) - (button "label" - action: (lambda (self) (properties (label)))) - (button "listbox" - action: (lambda (self) (properties (listbox)))) - (button "progress-bar" - action: (lambda (self) (properties (progress-bar)))) - (button "spin" - action: (lambda (self) (properties (spin)))) - (fill) - margin: '0x0) - (hbox - (button "tabs" - action: (lambda (self) (properties (tabs)))) - (button "textbox" - action: (lambda (self) (properties (textbox)))) - (button "toggle" - action: (lambda (self) (properties (toggle)))) - (button "treebox" - action: (lambda (self) (properties (treebox)))) - (button "valuator" - action: (lambda (self) (properties (valuator "")))) - (fill) - margin: '0x0) - - (label "") - (label "Additional widgets" fontsize: 12) - (hbox - (button "cells" - action: (lambda (self) (properties (cells)))) - (button "color-bar" - action: (lambda (self) (properties (color-bar)))) - (button "color-browser" - action: (lambda (self) (properties (color-browser)))) - (button "dial" - action: (lambda (self) (properties (dial "")))) - (button "matrix" - action: (lambda (self) (properties (matrix)))) - (fill) - margin: '0x0) - (hbox - (button "pplot" - action: (lambda (self) (properties (pplot)))) - (button "glcanvas" - action: (lambda (self) (properties (glcanvas)))) - (button "web-browser" - action: (lambda (self) (properties (web-browser)))) - (fill) - margin: '0x0) - - (label "") - (label "Menu widgets" fontsize: 12) - (hbox - (button "menu" - action: (lambda (self) (properties (menu)))) - (button "menu-item" - action: (lambda (self) (properties (menu-item)))) - (button "menu-separator" - action: (lambda (self) (properties (menu-separator)))) - (fill) - margin: '0x0) - - (label "") - (label "Images" fontsize: 12) - (hbox - (button "image/palette" - action: (lambda (self) - (properties - (image/palette 1 1 (u8vector->blob (u8vector 0)))))) - (button "image/rgb" - action: (lambda (self) - (properties - (image/rgb 1 1 (u8vector->blob (u8vector 0)))))) - (button "image/rgba" - action: (lambda (self) - (properties - (image/rgba 1 1 (u8vector->blob (u8vector 0)))))) - (button "image/file" - action: (lambda (self) - (properties - ;; same attributes as image/palette - (image/palette 1 1 (u8vector->blob (u8vector 0)))))) - ;; needs a file in current directory - ;(image/file "chicken.ico")))) ; ok - ;(image/file "chicken.png")))) ; doesn't work - (fill) - margin: '0x0) - - (label "") - (label "Other widgets" fontsize: 12) - (hbox - (button "clipboard" - action: (lambda (self) (properties (clipboard)))) - (button "timer" - action: (lambda (self) (properties (timer)))) - (button "spinbox" - action: (lambda (self) (properties (spinbox (vbox))))) - (fill) - margin: '0x0) - - (fill) - (button "E&xit" - expand: 'horizontal - action: (lambda (self) 'close)) - ) - margin: '15x15 - title: "Iup inspector")) - -(show dlg) -(main-loop) -(exit 0) DELETED iupexamples/tree.scm Index: iupexamples/tree.scm ================================================================== --- iupexamples/tree.scm +++ /dev/null @@ -1,145 +0,0 @@ - -(use test) -(require-library iup) -(import (prefix iup iup:)) - -(define t #f) - -(define tree-dialog - (iup:dialog - #:title "Tree Test" - (let ((t1 (iup:treebox - #:selection_cb (lambda (obj id state) - (print "selection_db with id=" id " state=" state) - (print "USERDATA: " (iup:attribute obj "USERDATA")) - (print "SPECIALDATA: " (iup:attribute obj "SPECIALDATA")) - (print "Depth: " (iup:attribute obj "DEPTH")) - )))) - (set! t t1) - t1))) - -(iup:show tree-dialog) - -(map (lambda (elname el) - (print "Adding " elname " with value " el) - (iup:attribute-set! t elname el) - (iup:attribute-set! t "USERDATA" el)) - '("VALUE" "NAME" "ADDLEAF" "ADDBRANCH1" "ADDLEAF2" "VALUE") - '("0" "Figures" "Other" "triangle" "equilateral" "4") - ) -(map (lambda (attr) - (print attr " is " (iup:attribute t attr))) - '("KIND1" "PARENT2" "STATE1")) - -(define (tree-find-node obj path) - ;; start at the base of the tree - (if (null? path) - #f ;; or 0 ???? - (let loop ((hed (car path)) - (tal (cdr path)) - (depth 0) - (nodenum 0)) - ;; nodes in iup tree are 100% sequential so iterate over nodenum - (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes - (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) - (node-title (iup:attribute obj (conc "TITLE" nodenum)))) - ;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title) - (if (and (equal? depth node-depth) - (equal? hed node-title)) ;; yep, this is the one! - (if (null? tal) ;; end of the line - nodenum - (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) - ;; this is the case where we found part of the hierarchy but not - ;; all of it, i.e. the node-depth went from deep to less deep - (if (> depth node-depth) ;; (+ 1 node-depth)) - #f - (loop hed tal depth (+ nodenum 1))))) - #f)))) - -;; top is the top node name zeroeth node VALUE=0 -(define (tree-add-node obj top nodelst) - (if (not (iup:attribute obj "TITLE0")) - (iup:attribute-set! obj "ADDBRANCH0" top)) - (cond - ((not (string=? top (iup:attribute obj "TITLE0"))) - (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) - ((null? nodelst)) - (else - (let loop ((hed (car nodelst)) - (tal (cdr nodelst)) - (depth 1) - (pathl (list top))) - ;; Because the tree dialog changes node numbers when - ;; nodes are added or removed we must look up nodes - ;; each and every time. 0 is the top node so default - ;; to that. - (let* ((newpath (append pathl (list hed))) - (parentnode (tree-find-node obj pathl)) - (nodenum (tree-find-node obj newpath))) - ;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl) - ;; Add the branch under lastnode if not found - (if (not nodenum) - (begin - (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) - (if (null? tal) - #t - ;; reset to top - (loop (car nodelst)(cdr nodelst) 1 (list top)))) - (if (null? tal) ;; if null here then this path has already been added - #t - ;; (if nodenum - (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;; (if nodenum nodenum lastnode))))))) - ;; (loop hed tal depth pathl lastnode))))))) - -(define (tree-node->path obj nodenum) - ;; (print "\ncurrnode nodenum depth node-depth node-title path") - (let loop ((currnode 0) - (depth 0) - (path '())) - (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode))) - (node-title (iup:attribute obj (conc "TITLE" currnode)))) - ;; (display (conc "\n "currnode " " nodenum " " depth " " node-depth " " node-title " " path)) - (if (> currnode nodenum) - path - (if (not node-depth) ;; #f if we are out of nodes - '() - (let ((ndepth (string->number node-depth))) - (if (eq? ndepth depth) - ;; This next is the match condition depth == node-depth - (if (eq? currnode nodenum) - (begin - ;; (display " ") - (append path (list node-title))) - (loop (+ currnode 1) - (+ depth 1) - (append path (list node-title)))) - ;; didn't match, reset to base path and keep looking - ;; due to more iup odditys we don't reset to base - (begin - ;; (display " ") - (loop (+ 1 currnode) - 2 - (append (take path ndepth)(list node-title))))))))))) - -(test #f 0 (tree-find-node t '("Figures"))) -(test #f 1 (tree-find-node t '("Figures" "Other"))) -(test #f #f (tree-find-node t '("Figures" "Other" "equilateral"))) -(test #f 3 (tree-find-node t '("Figures" "triangle" "equilateral"))) -(test #f #t (tree-add-node t "Figures" '())) -(test #f #t (tree-add-node t "Figures" '("a" "b" "c"))) -(test #f 3 (tree-find-node t '("Figures" "a" "b" "c"))) -(test #f #t (tree-add-node t "Figures" '("d" "b" "c"))) -(test #f 3 (tree-find-node t '("Figures" "d" "b" "c"))) -(test #f 6 (tree-find-node t '("Figures" "a" "b" "c"))) -(test #f #t (tree-add-node t "Figures" '("a" "e" "c"))) -(test #f 6 (tree-find-node t '("Figures" "a" "e" "c"))) - -(test #f '("Figures") (tree-node->path t 0)) -(test #f '("Figures" "d") (tree-node->path t 1)) -(test #f '("Figures" "d" "b" "c") (tree-node->path t 3)) -(test #f '("Figures" "a") (tree-node->path t 4)) -(test #f '("Figures" "a" "b" "c") (tree-node->path t 8)) -(test #f '() (tree-node->path t 40)) - -(iup:main-loop) - DELETED loadwatch/Makefile Index: loadwatch/Makefile ================================================================== --- loadwatch/Makefile +++ /dev/null @@ -1,11 +0,0 @@ - -all : launch-many queuefeeder queuefeeder-server - -launch-many : launch-many.scm - csc launch-many.scm - -queuefeeder : queuefeeder.scm - csc queuefeeder.scm - -queuefeeder-server : queuefeeder-server.scm - csc queuefeeder-server.scm DELETED loadwatch/bjob-count.sh Index: loadwatch/bjob-count.sh ================================================================== --- loadwatch/bjob-count.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/bash - -bqueues | grep normal |awk '{print $8}' DELETED loadwatch/launch-many.scm Index: loadwatch/launch-many.scm ================================================================== --- loadwatch/launch-many.scm +++ /dev/null @@ -1,9 +0,0 @@ -(use posix) - -(let loop ((count 0)) - (if (> count 500000) - (print "DONE") - (let ((cmd (conc "./queuefeeder xena:22022 bsub ./testopenlava.sh " count " " (random 30)))) - (print "Running: " cmd) - (system cmd) - (loop (+ count 1))))) DELETED loadwatch/loadwatch.scm Index: loadwatch/loadwatch.scm ================================================================== --- loadwatch/loadwatch.scm +++ /dev/null @@ -1,86 +0,0 @@ -(use regex srfi-69) - -(define-record processdat - %cpu - virt - res - %mem - count - ) - -(define (pp-processdat dat) - (print "(processdat" - " %cpu=" (processdat-%cpu dat) - " virt=" (processdat-virt dat) - " res=" (processdat-res dat) - " %mem=" (processdat-%mem dat) - " count=" (processdat-count dat))) - - -(define nrex (regexp "^(\\d+[\\d\\.]*)([mkgMKG])$")) - -(define (get-number numstr) - (let ((n (string->number numstr))) - (if n - n - (let ((nmatch (string-match nrex numstr))) - (if nmatch - (* (string->number (cadr nmatch)) - (case (string->symbol (caddr nmatch)) - ((k) 1024) - ((m) 1048576) - ((g) 1073741824) - (else - (print "ERROR: Unrecognised unit: " (caddr nmatch) ", extracted for " numstr) - 1))) - #f))))) - - -(define (snagload) - (let ((dat (make-hash-table)) ;; user => hash-of-processdat - (hdr (regexp "^\\s+PID")) - (rx (regexp "\\s+")) - (wht (regexp "^\\s+")) - ) - (with-input-from-pipe - "top -n 1 -b" - (lambda () - (let loop ((inl (read-line)) - (inbod #f)) - (if (eof-object? inl) - dat - (if (not inbod) - (if (string-search hdr inl) - (loop (read-line) #t) - (loop (read-line) #f)) - (let* ((lparts (map (lambda (x) - (let ((num (get-number x))) - (if num num x))) - (string-split-fields rx (string-substitute wht "" inl) #:infix)))) - (if (> (length lparts) 10) - (let* ((user (list-ref lparts 1)) - (virt (list-ref lparts 4)) - (res (list-ref lparts 5)) - (%cpu (list-ref lparts 8)) - (%mem (list-ref lparts 9)) - (time (list-ref lparts 10)) - (pname (list-ref lparts 11)) - (udat (or (hash-table-ref/default dat user #f) - (let ((u (make-hash-table))) - (hash-table-set! dat user u) - u))) - (pdat (or (hash-table-ref/default udat pname #f) - (let ((p (make-processdat 0 0 0 0 0))) - (hash-table-set! udat pname p) - p)))) - (print "User: " user ", pname: " pname ", virt: " virt ", res: " res ", %cpu: " %cpu ", %mem: " %mem) - (processdat-%cpu-set! pdat (+ (processdat-%cpu pdat) %cpu)) - (processdat-%mem-set! pdat (+ (processdat-%mem pdat) %mem)) - (processdat-virt-set! pdat (+ (processdat-virt pdat) virt)) - (processdat-res-set! pdat (+ (processdat-res pdat) res)) - (processdat-count-set! pdat (+ (processdat-count pdat) 1)) - (loop (read-line) inbod)) - dat))))))))) - -(define x (snagload)) -;; (processdat-%cpu (hash-table-ref (hash-table-ref x "matt") "evolution-calen")) DELETED loadwatch/queuefeeder-server.scm Index: loadwatch/queuefeeder-server.scm ================================================================== --- loadwatch/queuefeeder-server.scm +++ /dev/null @@ -1,185 +0,0 @@ -;;====================================================================== -;; Copyright 2015-2015, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. -;;====================================================================== - -;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue -;; to prevent slamming the queue - -;;====================================================================== -;; Methodology -;; -;; Connect to the server, the server delays the appropriate time (if -;; any) and then launch the task. -;; - -(use nanomsg posix regex) - -;; (use trace) -;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close ) - -(define port 22022) - -;; get needed stuff from commandline -;; -(define queuelen #f) -(define cmd '()) ;; cmd is run to give a count of the queue length => returns number in queue - -(define usage "Usage: queuefeeder-server port target_queue_length command - where command is a script or program that gives an integer on stdout of current queue length") - -(let ((args (argv))) - (if (> (length args) 3) - (begin - (set! port (cadr args)) - (set! queuelen (string->number (caddr args))) - (set! cmd (cadddr args))) ;; no params supported - (begin - (print usage) - (exit)))) - -(if (not queuelen) - (begin - (print "queuelen must be a number") - (print usage) - (exit))) - -(print "Running queue feeder with port=" port ", command=" cmd) - -(define rep (nn-socket 'rep)) - -(print "connecting, got: " (nn-bind rep (conc "tcp://" "*" ":" port))) - -(define *current-delay* 0) -(define (exp-droop-calc x targ) - (cond - ((> (- x targ) 1) 136) ;; top off at 136 seconds - (else - (let ((res (* 50 (exp (- x targ))))) - (cond - ((and (> res 0)(< res 0.01)) 0.01) - ((> res 45) 45) ;; cap at 45 seconds - (else res)))))) - -;; x input value (current number in the queue) -;; targ is the desired queue length -;; -(define (piecewise-droop-calc x targ) - (let ((top 50)) - (cond - ((> (- x targ) 0) - top) ;; top off at top seconds - ((> x (- targ top)) - (+ (* 1 (- x (- targ top))) - (/ (- top targ) targ))) - (else (let ((res (/ x targ))) - (if (< res 0.01) - 0.01 - res)))))) - -(define (server soc) - (print "server starting") - (let loop ((msg-in (nn-recv soc)) - (count 0)) - (if (eq? 0 (modulo count 1000)) - (print "server received: " msg-in ", count=" count)) - (cond - ((equal? msg-in "quit") - (nn-send soc "Ok, quitting")) - ((and (>= (string-length msg-in) 4) - (equal? (substring msg-in 0 4) "ping")) - (nn-send soc (conc (current-process-id))) - (loop (nn-recv soc)(+ count 1))) - (else - (mutex-lock! *current-delay-mutex*) - (let ((current-delay *current-delay*)) - (mutex-unlock! *current-delay-mutex*) - ;; (thread-sleep! current-delay) - (nn-send soc (conc current-delay " hello " msg-in " you waited " current-delay " seconds")) - (loop (nn-recv soc)(if (> count 20000000) - 0 - (+ count 1)))))))) - -(define (ping-self host port #!key (return-socket #t)) - ;; send a random number along with pid and check that we get it back - (let* ((req (nn-socket 'req)) - (key "ping") - (success #f) - (keepwaiting #t) - (ping (make-thread - (lambda () - (print "ping: sending string \"" key "\", expecting " (current-process-id)) - (nn-send req key) - (let ((result (nn-recv req))) - (if (equal? (conc (current-process-id)) result) - (begin - (print "ping, success: received \"" result "\"") - (set! success #t)) - (begin - (print "ping, failed: received key \"" result "\"") - (set! keepwaiting #f) - (set! success #f))))) - "ping")) - (timeout (make-thread (lambda () - (let loop ((count 0)) - (thread-sleep! 1) - (print "still waiting after " count " seconds...") - (if (and keepwaiting (< count 10)) - (loop (+ count 1)))) - (if keepwaiting - (begin - (print "timeout waiting for ping") - (thread-terminate! ping)))) - "timeout"))) - (nn-connect req (conc "tcp://" host ":" port)) - (handle-exceptions - exn - (begin - (print-call-chain) - (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) - (print "ping failed to connect to " host ":" port)) - (thread-start! timeout) - (thread-start! ping) - (thread-join! ping) - (if success (thread-terminate! timeout))) - (if return-socket - (if success req #f) - (begin - (nn-close req) - success)))) - -(define *current-delay-mutex* (make-mutex)) - -;; update the *current-delay* value every minute or QUEUE_CHK_DELAY seconds -(thread-start! (make-thread (lambda () - (let ((delay-time (string->number (or (get-environment-variable "QUEUE_CHK_DELAY") "30")))) - (let loop () - (with-input-from-pipe - cmd ;;; my query to get queue length - (lambda () - (let* ((val (read)) - (droop-val (if (number? val)(piecewise-droop-calc val queuelen) #f))) - ;; val is number of jobs in queue. Use a linear droop of val/40 - (mutex-lock! *current-delay-mutex*) - (set! *current-delay* (or droop-val 30)) ;; (/ (or droop-val 100) 50)) - (mutex-unlock! *current-delay-mutex*) - (print "droop-val=" droop-val) - (thread-sleep! delay-time)))) - (loop)))))) - -(let ((server-thread (make-thread (lambda ()(server rep)) "server"))) - (thread-start! server-thread) - (if (ping-self (get-host-name) port) - (begin - (thread-join! server-thread) - (nn-close rep)) - (print "ping failed"))) - -(exit) DELETED loadwatch/queuefeeder.scm Index: loadwatch/queuefeeder.scm ================================================================== --- loadwatch/queuefeeder.scm +++ /dev/null @@ -1,96 +0,0 @@ -;;====================================================================== -;; Copyright 2015-2015, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. -;;====================================================================== - -;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue -;; to prevent slamming the queue - -;;====================================================================== -;; Methodology -;; -;; Connect to the server, the server delays the appropriate time (if -;; any) and then launch the task. -;; -(use nanomsg posix regex message-digest md5) - -(define req (nn-socket 'req)) - -;; get needed stuff from commandline -;; -(define hostport #f) -(define cmd '()) - -(let ((args (argv))) - (if (> (length args) 2) - (begin - (set! hostport (cadr args)) - (set! cmd (cddr args))) - (begin - (print "Usage: queuefeeder host:port command params ....") - (exit)))) - -(nn-connect req (conc "tcp://" hostport)) ;; xena:22022") - -(define (client-send-receive soc msg) - (nn-send soc msg) - (nn-recv soc)) - -;; Generate a unique signature for this client location -;; -(define (make-signature) - (message-digest-string (md5-primitive) - (with-output-to-string - (lambda () - (write (current-directory)))))) - -;; (define ((talk-to-server soc)) -;; (let loop ((cnt 200000)) -;; (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6)))) -;; ;; (print "Sending " name) -;; ;; (print -;; (client-send-receive req name) ;; ) -;; (if (> cnt 0)(loop (- cnt 1))))) -;; (print (client-send-receive req "quit")) -;; (nn-close req) -;; (exit)) -;; - -(define (get-delay signature) - (let* ((full-msg (client-send-receive req (conc (current-user-name) "@" (get-host-name) ":" signature)))) - (print "Got " full-msg) - (let* ((reply-msg (string-match "^([\\d\\.]+)\\s+(.*)$" full-msg)) - (delay-time (if (> (length reply-msg) 2) - (string->number (cadr reply-msg)) - 1)) ;; fall back to one sec delay - (msg (if (> (length reply-msg) 2) - (caddr reply-msg) - full-msg))) - (values delay-time msg)))) - - -(let ((signature (make-signature))) - - (thread-start! (lambda () - (thread-sleep! 60) - (print "Give up on waiting for the server") - ;; (nn-close req) - ;; (exit) - )) - (thread-join! (thread-start! (lambda () - (let-values - (((delay-time msg)(get-delay signature))) - (print "INFO: sleeping " delay-time " seconds per request of queuefeeder server") - (thread-sleep! delay-time) - (print "INFO: done waiting, now executing requested task."))))) - (nn-close req)) - -(process-execute (car cmd) (cdr cmd)) - - DELETED loadwatch/testopenlava.sh Index: loadwatch/testopenlava.sh ================================================================== --- loadwatch/testopenlava.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/bash - -job_order=$1 -job_length=$2 - -echo "START: $job_order" > $job_order.log -sleep $job_length -echo "END: $job_order" >> $job_order.log - DELETED rpctest/rpctest-continuous-client.scm Index: rpctest/rpctest-continuous-client.scm ================================================================== --- rpctest/rpctest-continuous-client.scm +++ /dev/null @@ -1,138 +0,0 @@ -;;;; rpc-demo.scm -;;;; Simple database server / client - -;;; start server thusly: ./rpctest server test.db -;;; you will need to init test.db: -;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);" - -(require-extension (srfi 18) extras tcp rpc sql-de-lite) - -;;; Common things - -(define total-queries 0) -(define start-time (current-seconds)) - -(define operation (string->symbol (car (command-line-arguments)))) -(define param (cadr (command-line-arguments))) -(print "Operation: " operation ", param: " param) - -;; have a pool of db's to pick from -(define *dbpool* '()) -(define *pool-mutex* (make-mutex)) - -(define (get-db) - (mutex-lock! *pool-mutex*) - (if (null? *dbpool*) - (begin - (mutex-unlock! *pool-mutex*) - (let ((db (open-database param))) - (set-busy-handler! db (busy-timeout 10000)) - (exec (sql db "PRAGMA synchronous=0;")) - db)) - (let ((res (car *dbpool*))) - (set! *dbpool* (cdr *dbpool*)) - (mutex-unlock! *pool-mutex*) - res))) - -(define (return-db db) - (mutex-lock! *pool-mutex*) - (set! *dbpool* (cons db *dbpool* )) - (let ((res (length *dbpool*))) - (mutex-unlock! *pool-mutex*) - res)) - -(define rpc:listener - (if (eq? operation 'server) - (tcp-listen (rpc:default-server-port)) - (tcp-listen 0))) - -;; Start server thread -(define rpc:server - (make-thread - (cute (rpc:make-server rpc:listener) "rpc:server") ;; NOTE: see equivalent code below - 'rpc:server)) - -;; This is what the code would look like without cute -;; (define rpc:server -;; (make-thread -;; (lambda () -;; ((rpc:make-server rpc:listener) "rpc:server")) -;; 'rpc:server)) - -(thread-start! rpc:server) - -;;; Server side - -(define (server) - (rpc:publish-procedure! - 'change-response-port - (lambda (port) - (rpc:default-server-port port)) - #f) - ;;(let ((db (get-db))(open-database param))) - ;; (set-finalizer! db finalize!) - (rpc:publish-procedure! - 'query - (lambda (sqlstmt callback) - (set! total-queries (+ total-queries 1)) - (print "Executing query '" sqlstmt "' ...") - (let ((db (get-db))) - (query (for-each-row - callback) - (sql db sqlstmt)) - (print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute") - (print "num dbs: " (return-db db)) - ))) - (thread-join! rpc:server)) - -;;; Client side - -(define (callback1 . columns) - (let loop ((c columns) (i 0)) - (unless (null? c) - (printf "~a=~s " i (car c)) - (loop (cdr c) (+ i 1)))) - (newline)) - -(define callback2-results '()) - -(define (callback2 . columns) - (set! callback2-results (cons columns callback2-results))) - -(define (client param) - ((rpc:procedure 'change-response-port "localhost") - (tcp-listener-port rpc:listener)) - ((rpc:procedure 'query "localhost") param callback1) - (rpc:publish-procedure! 'callback2 callback2) - ((rpc:procedure 'query "localhost") param callback2) - (pp callback2-results) - (rpc:close-all-connections!) - ;; (rpc:close-connection! "localhost" (rpc:default-server-port)) - ) - -(define (run-query param) - ((rpc:procedure 'query "localhost") param callback1) - ((rpc:procedure 'query "localhost") param callback2) - callback2-results) - -(define (continuous-client #!key (duration 600)) ;; default - run for 10 minutes - ((rpc:procedure 'change-response-port "localhost") - (tcp-listener-port rpc:listener)) - (rpc:publish-procedure! 'callback2 callback2) - (let loop () - (if (< (- (current-seconds) start-time) duration) - (begin - (run-query (conc "INSERT INTO foo (var,val) VALUES (" (random 1000) "," (random 1000) ");")) - (let ((numrows (caaar (run-query "SELECT COUNT(id) FROM foo;")))) - (if (and (number? numrows) - (> numrows 300)) - (print (run-query (conc "DELETE FROM foo WHERE var > " (random 1000) ";"))))) - (loop)))) - (rpc:close-all-connections!)) - -;;; Run it - -(if (eq? operation 'server) - (server) - (continuous-client)) - DELETED rpctest/rpctest.scm Index: rpctest/rpctest.scm ================================================================== --- rpctest/rpctest.scm +++ /dev/null @@ -1,109 +0,0 @@ -;;;; rpc-demo.scm -;;;; Simple database server / client - -;;; start server thusly: ./rpctest server test.db -;;; you will need to init test.db: -;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);" - -(require-extension (srfi 18) extras tcp rpc sql-de-lite) - -;;; Common things - -(define total-queries 0) -(define start-time (current-seconds)) - -(define operation (string->symbol (car (command-line-arguments)))) -(define param (cadr (command-line-arguments))) -(print "Operation: " operation ", param: " param) - -;; have a pool of db's to pick from -(define *dbpool* '()) -(define *pool-mutex* (make-mutex)) - -(define (get-db) - (mutex-lock! *pool-mutex*) - (if (null? *dbpool*) - (begin - (mutex-unlock! *pool-mutex*) - (let ((db (open-database param))) - (set-busy-handler! db (busy-timeout 10000)) - (exec (sql db "PRAGMA synchronous=0;")) - db)) - (let ((res (car *dbpool*))) - (set! *dbpool* (cdr *dbpool*)) - (mutex-unlock! *pool-mutex*) - res))) - -(define (return-db db) - (mutex-lock! *pool-mutex*) - (set! *dbpool* (cons db *dbpool* )) - (let ((res (length *dbpool*))) - (mutex-unlock! *pool-mutex*) - res)) - -(define rpc:listener - (if (eq? operation 'server) - (tcp-listen (rpc:default-server-port)) - (tcp-listen 0))) - -;; Start server thread -(define rpc:server - (make-thread - (cute (rpc:make-server rpc:listener) "rpc:server") - 'rpc:server)) - -(thread-start! rpc:server) - -;;; Server side - -(define (server) - (rpc:publish-procedure! - 'change-response-port - (lambda (port) - (rpc:default-server-port port)) - #f) - ;;(let ((db (get-db))(open-database param))) - ;; (set-finalizer! db finalize!) - (rpc:publish-procedure! - 'query - (lambda (sqlstmt callback) - (set! total-queries (+ total-queries 1)) - (print "Executing query '" sqlstmt "' ...") - (let ((db (get-db))) - (query (for-each-row - callback) - (sql db sqlstmt)) - (print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute") - (print "num dbs: " (return-db db)) - ))) - (thread-join! rpc:server)) - -;;; Client side - -(define (callback1 . columns) - (let loop ((c columns) (i 0)) - (unless (null? c) - (printf "~a=~s " i (car c)) - (loop (cdr c) (+ i 1)))) - (newline)) - -(define callback2-results '()) - -(define (callback2 . columns) - (set! callback2-results (cons columns callback2-results))) - -(define (client) - ((rpc:procedure 'change-response-port "localhost") - (tcp-listener-port rpc:listener)) - ((rpc:procedure 'query "localhost") param callback1) - (rpc:publish-procedure! 'callback2 callback2) - ((rpc:procedure 'query "localhost") param callback2) - (pp callback2-results) - (rpc:close-connection! "localhost" (rpc:default-server-port))) - -;;; Run it - -(if (eq? operation 'server) - (server) - (client)) - DELETED rpctest/run-client.sh Index: rpctest/run-client.sh ================================================================== --- rpctest/run-client.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/bash - - -while ./rpctest client "insert into foo (var,val) values ($RANDOM,$RANDOM);";do - numrows=$(./rpctest client "select count(id) from foo;") # |wc -l) - deletefrom=$RANDOM - echo "numrows=$numrows, deletefrom=$deletefrom" - if [[ $numrows -gt 300 ]];then - echo "numrows=$numrows, deletefrom=$deletefrom" - ./rpctest client "delete from foo where var > $deletefrom;" - fi -done DELETED spreadsheet/basic/Configurations2/accelerator/current.xml Index: spreadsheet/basic/Configurations2/accelerator/current.xml ================================================================== --- spreadsheet/basic/Configurations2/accelerator/current.xml +++ /dev/null DELETED spreadsheet/basic/META-INF/manifest.xml Index: spreadsheet/basic/META-INF/manifest.xml ================================================================== --- spreadsheet/basic/META-INF/manifest.xml +++ /dev/null @@ -1,22 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - DELETED spreadsheet/basic/Thumbnails/thumbnail.png Index: spreadsheet/basic/Thumbnails/thumbnail.png ================================================================== --- spreadsheet/basic/Thumbnails/thumbnail.png +++ /dev/null cannot compute difference between binary files DELETED spreadsheet/basic/content.xml Index: spreadsheet/basic/content.xml ================================================================== --- spreadsheet/basic/content.xml +++ /dev/null @@ -1,132 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - -Row 1,A - - -Row 1,B - - - - -Row 2,A - - -Row 2,B - - - - - - - -this is sheet one - - - - - - - - -Row 1,A - - -Row 1,B - - - - -Row 2,A - - -Row 2,B - - - - - - - -this is sheet two - - - - - - - - -1 - - -2 - - - - -2 - - -4 - - - - -3 - - -6 - - - - -4 - - -8 - - - - -5 - - -10 - - - - -6 - - -12 - - - - - - DELETED spreadsheet/basic/content.xml~ Index: spreadsheet/basic/content.xml~ ================================================================== --- spreadsheet/basic/content.xml~ +++ /dev/null @@ -1,2 +0,0 @@ - -Row 1,ARow 1,BRow 2,ARow 2,Bthis is sheet oneRow 1,ARow 1,BRow 2,ARow 2,Bthis is sheet two12243648510612 DELETED spreadsheet/basic/meta.xml Index: spreadsheet/basic/meta.xml ================================================================== --- spreadsheet/basic/meta.xml +++ /dev/null @@ -1,2 +0,0 @@ - -Matt Welland2011-09-06T20:46:232011-09-06T22:05:47Matt WellandPT1H19M25S2LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301 DELETED spreadsheet/basic/mimetype Index: spreadsheet/basic/mimetype ================================================================== --- spreadsheet/basic/mimetype +++ /dev/null @@ -1,1 +0,0 @@ -application/vnd.oasis.opendocument.spreadsheet DELETED spreadsheet/basic/settings.xml Index: spreadsheet/basic/settings.xml ================================================================== --- spreadsheet/basic/settings.xml +++ /dev/null @@ -1,2 +0,0 @@ - -0045161799view100000020000010060true04000020000010060true15000020000010060trueSheet3270010060falsetruetruetrue12632256truetruetruetruefalsefalse1270127011truefalsetrue3falsetruetruetrue12701270false1truetrue1true12632256falsefalsetrue0truetruetruefalsetrue DELETED spreadsheet/basic/styles.xml Index: spreadsheet/basic/styles.xml ================================================================== --- spreadsheet/basic/styles.xml +++ /dev/null @@ -1,2 +0,0 @@ - -$-$???Page 1??? (???)09/06/2011, 22:05:47Page 1 / 99 DELETED testhttp/example-client.scm Index: testhttp/example-client.scm ================================================================== --- testhttp/example-client.scm +++ /dev/null @@ -1,6 +0,0 @@ -(use regex http-client) - -(print (with-input-from-request "http://localhost:8083/?foo=1" #f - (lambda () - (let ((match (string-search (regexp "(.*)<.body>") (caddr (string-split (read-string) "\n"))))) - (cadr match))))) DELETED testhttp/example-server.scm Index: testhttp/example-server.scm ================================================================== --- testhttp/example-server.scm +++ /dev/null @@ -1,26 +0,0 @@ -(use spiffy awful) - -(tcp-buffer-size 2048) -(enable-sxml #t) - -(define (hello-world) - (define-page (main-page-path) - (lambda () - (with-request-variables (foo) - foo)))) - -(define (start-server #!key (portnum 8080)) - (handle-exceptions - exn - (begin - (print-error-message exn) - (if (< portnum 9000) - (begin - (print "WARNING: failed to start on portnum: " portnum ", trying next port") - (sleep 1) - (start-server portnum: (+ portnum 1))) - (print "ERROR: Tried and tried but could not start the server"))) - (print "INFO: Trying to start server on portnum: " portnum) - (awful-start hello-world port: portnum))) - -(start-server) DELETED testhttp/mockupclient.scm Index: testhttp/mockupclient.scm ================================================================== --- testhttp/mockupclient.scm +++ /dev/null @@ -1,35 +0,0 @@ -(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!!") DELETED testhttp/mockupclientlib.scm Index: testhttp/mockupclientlib.scm ================================================================== --- testhttp/mockupclientlib.scm +++ /dev/null @@ -1,33 +0,0 @@ -(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))) - DELETED testhttp/mockupserver.scm Index: testhttp/mockupserver.scm ================================================================== --- testhttp/mockupserver.scm +++ /dev/null @@ -1,140 +0,0 @@ -;; 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 -(tcp-buffer-size 2048) -(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)) DELETED testhttp/testclient.scm Index: testhttp/testclient.scm ================================================================== --- testhttp/testclient.scm +++ /dev/null @@ -1,8 +0,0 @@ -(use http-client) - -(with-input-from-request "http://localhost:12345/hey" - ;; #f - ;; msg - (list (cons 'dat "Testing eh")) - read-string) - DELETED testhttp/testserver.scm Index: testhttp/testserver.scm ================================================================== --- testhttp/testserver.scm +++ /dev/null @@ -1,16 +0,0 @@ -(use spiffy uri-common intarweb spiffy-request-vars) - -(root-path "/var/www") - -(vhost-map `(((* any) . ,(lambda (continue) - (let (($ (request-vars source: 'both))) - (print ($ 'dat)) - (if (equal? (uri-path (request-uri (current-request))) - '(/ "hey")) - (send-response body: "hey there!\n" - headers: '((content-type text/plain))) - (continue))))))) - -(start-server port: 12345) - - DELETED testnanomsg/basic-req-rep.scm Index: testnanomsg/basic-req-rep.scm ================================================================== --- testnanomsg/basic-req-rep.scm +++ /dev/null @@ -1,3 +0,0 @@ -(use nanomsg srfi-18 sqlite3 numbers) - -(define resp (nn-socket 'rep)) DELETED testnanomsg/mockupclient.scm Index: testnanomsg/mockupclient.scm ================================================================== --- testnanomsg/mockupclient.scm +++ /dev/null @@ -1,42 +0,0 @@ -(use zmq posix numbers) - -(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)) - -;; first ping the server to ensure we have a connection -(if (server-ping cname 5) - (print "SUCCESS: Client " cname " connected to server") - (begin - (print "ERROR: Client " cname " failed ping of server, exiting") - (exit))) - -(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!!") DELETED testnanomsg/mockupclientlib.scm Index: testnanomsg/mockupclientlib.scm ================================================================== --- testnanomsg/mockupclientlib.scm +++ /dev/null @@ -1,58 +0,0 @@ -(define reqs (nn-socket 'req)) - -(connect-socket reqs "tcp://localhost:6563") - -(thread-sleep! 0.2) - -(define (server-ping cname timeout) - (let ((msg (conc cname ":ping:" timeout)) - (maxtime (+ (current-seconds) timeout))) - (print "pinging server from " cname " with timeout " timeout) - (let loop ((res #f)) - (if (< maxtime (current-seconds)) - #f ;; failed to ping - (if (equal? res "Got ping") - #t - (begin - (print "Ping received from server " res) - (send-message push msg) - (thread-sleep! 0.1) - (loop (receive-message sub non-blocking: #t)))))))) - -(define (dbaccess cname cmd var val #!key (numtries 20)) - (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var))) - (res #f) - (mtx1 (make-mutex)) - (do-access (lambda () - (let ((tmpres #f)) - (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! tmpres (receive-message* sub)) - (mutex-lock! mtx1) - (set! res tmpres) - (mutex-unlock! mtx1)))) - (th1 (make-thread do-access "do access")) - (th2 (make-thread (lambda () - (let ((result #f)) - (mutex-lock! mtx1) - (set! result res) - (mutex-unlock! mtx1) - (thread-sleep! 5) - (if (not result) - (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) - (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts")) - res)) - DELETED testnanomsg/mockupserver.scm Index: testnanomsg/mockupserver.scm ================================================================== --- testnanomsg/mockupserver.scm +++ /dev/null @@ -1,146 +0,0 @@ -;; 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 nanomsg srfi-18 sqlite3 numbers) - -(define resp (nn-socket 'rep)) -(define cname "server") -(define total-db-accesses 0) -(define start-time (current-seconds)) - -(nn-bind resp "tcp://*:6563") - -(thread-sleep! 0.2) - -(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))) - -;; SERVER THREAD -(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 - ;; (print "Server received message: " indat) - (count-client db cname) - (case clcmd - ((ping) - (print "Got ping from " cname) - (send-message pub cname send-more: #t) - (send-message pub "Got ping") - (loop queuelst)) - ((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") - -;; SYNC THREAD -;; 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")) - -(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)) DELETED testnanomsg/pipeline.scm Index: testnanomsg/pipeline.scm ================================================================== --- testnanomsg/pipeline.scm +++ /dev/null @@ -1,25 +0,0 @@ -;; watch nanomsg's pipeline load-balancer in action. -(use nanomsg) - -(define push (nn-socket 'push)) -(define pull1 (nn-socket 'pull)) -(define pull2 (nn-socket 'pull)) - -(nn-bind push "inproc://test") -(nn-connect pull1 "inproc://test") -(nn-connect pull2 "inproc://test") - -(nn-send push "a") -(nn-send push "b") -(nn-send push "c") -(nn-send push "d") - -(define ((th sock)) - (print (current-thread) ": " (nn-recv sock)) - (print (current-thread) ": " (nn-recv sock)) - (print (current-thread) " is done")) - -(thread-start! (th pull1)) -(thread-start! (th pull2)) - -(thread-sleep! 1) DELETED testnanomsg/req-rep-client.scm Index: testnanomsg/req-rep-client.scm ================================================================== --- testnanomsg/req-rep-client.scm +++ /dev/null @@ -1,31 +0,0 @@ -;; watch nanomsg's pipeline load-balancer in action. -(use nanomsg posix regex) - -(define req (nn-socket 'req)) - -(nn-connect req "tcp://localhost:22022") - -;; (with-output-to-string (lambda ()(serialize obj))) -(define (client-send-receive soc msg) - (nn-send soc msg) - (nn-recv soc)) - -(define ((talk-to-server soc)) - (let loop ((cnt 200000)) - (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6)))) - ;; (print "Sending " name) - ;; (print - (client-send-receive req name) ;; ) - (if (> cnt 0)(loop (- cnt 1))))) - (print (client-send-receive req "quit")) - (nn-close req) - (exit)) - -;; (thread-start! (lambda () -;; (thread-sleep! 20) -;; (print "Give up on waiting for the server") -;; (nn-close req) -;; (exit))) - -(thread-join! (thread-start! (talk-to-server req))) - DELETED testnanomsg/req-rep-server.scm Index: testnanomsg/req-rep-server.scm ================================================================== --- testnanomsg/req-rep-server.scm +++ /dev/null @@ -1,94 +0,0 @@ -;; watch nanomsg's pipeline load-balancer in action. -(use nanomsg posix regex) - -;; (use trace) -;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close ) - -(define port 22022) -(define host "127.0.0.1") - -(define rep (nn-socket 'rep)) - -(print "connecting, got: " (nn-bind rep (conc "tcp://" "*" ":" port))) - -(define (server soc) - (print "server starting") - (let loop ((msg-in (nn-recv soc)) - (count 0)) - (if (eq? 0 (modulo count 1000)) - (print "server received: " msg-in ", count=" count)) - (cond - ((equal? msg-in "quit") - (nn-send soc "Ok, quitting")) - ((and (>= (string-length msg-in) 4) - (equal? (substring msg-in 0 4) "ping")) - (nn-send soc (conc (current-process-id))) - (loop (nn-recv soc)(+ count 1))) - ;;((and (>= (string-length msg-in) - (else - (let ((this-task (/ (random 10) 200.0)) - (start-time (current-milliseconds))) - ;; (thread-sleep! this-task) - (nn-send soc (conc "hello " msg-in " this task took " this-task " seconds to complete")) - ;; (print "Actual send-receive time: " (- (current-milliseconds) start-time)); - (loop (nn-recv soc)(+ count 1))))))) - -(define (ping-self host port #!key (return-socket #t)) - ;; send a random number along with pid and check that we get it back - (let* ((req (nn-socket 'req)) - (key "ping") - (success #f) - (keepwaiting #t) - (ping (make-thread - (lambda () - (print "ping: sending string \"" key "\", expecting " (current-process-id)) - (nn-send req key) - (let ((result (nn-recv req))) - (if (equal? (conc (current-process-id)) result) - (begin - (print "ping, success: received \"" result "\"") - (set! success #t)) - (begin - (print "ping, failed: received key \"" result "\"") - (set! keepwaiting #f) - (set! success #f))))) - "ping")) - (timeout (make-thread (lambda () - (let loop ((count 0)) - (thread-sleep! 1) - (print "still waiting after count seconds...") - (if (and keepwaiting (< count 10)) - (loop (+ count 1)))) - (if keepwaiting - (begin - (print "timeout waiting for ping") - (thread-terminate! ping)))) - "timeout"))) - (nn-connect req (conc "tcp://" host ":" port)) - (handle-exceptions - exn - (begin - (print-call-chain) - (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (print "exn=" (condition->list exn)) - (print "ping failed to connect to " host ":" port)) - (thread-start! timeout) - (thread-start! ping) - (thread-join! ping) - (if success (thread-terminate! timeout))) - (if return-socket - (if success req #f) - (begin - (nn-close req) - success)))) - -(let ((server-thread (make-thread (lambda ()(server rep)) "server"))) - (thread-start! server-thread) - ;; (thread-sleep! 1) - (if (ping-self host port) - (begin - (thread-join! server-thread) - (nn-close rep)) - (print "ping failed"))) - -(exit) DELETED testnanomsg/req-rep.scm Index: testnanomsg/req-rep.scm ================================================================== --- testnanomsg/req-rep.scm +++ /dev/null @@ -1,33 +0,0 @@ -;; watch nanomsg's pipeline load-balancer in action. -(use nanomsg) - -;; client -(define req (nn-socket 'req)) -(nn-connect req "inproc://test") - -(define (client-send-receive soc msg) - (nn-send soc msg) - (nn-recv soc)) - -;; server -(define rep (nn-socket 'rep)) -(nn-bind rep "inproc://test") - -(define ((server soc)) - (let loop ((msg-in (nn-recv soc))) - (if (not (equal? msg-in "quit")) - (begin - (nn-send soc (conc "hello " msg-in)) - (loop (nn-recv soc)))))) - -(thread-start! (server rep)) - -;; client -(print (client-send-receive req "Matt")) -(print (client-send-receive req "Tom")) - -;; (client-send-receive req "quit") - -(nn-close req) ;; client -(nn-close rep) ;; server -(exit) DELETED testrpc/client.scm Index: testrpc/client.scm ================================================================== --- testrpc/client.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;;; client.scm -(use rpc posix) - -(define call (rpc:procedure 'foo "localhost")) - -(do ((i 10 (sub1 i))) - ((zero? i)) - (print "-> " (call (random 100)))) DELETED testrpc/server.scm Index: testrpc/server.scm ================================================================== --- testrpc/server.scm +++ /dev/null @@ -1,15 +0,0 @@ -;;;; server.scm -(use rpc) - -(rpc:publish-procedure! - 'foo - (lambda (x) - (print "foo: " x) - #f)) - -(rpc:publish-procedure! - 'fini - (lambda () (print "fini") (thread-start! (lambda () (thread-sleep! 3) (print "terminate") (exit))) #f)) - -((rpc:make-server (tcp-listen (rpc:default-server-port))) #t) - DELETED testzmq/hwclient.scm Index: testzmq/hwclient.scm ================================================================== --- testzmq/hwclient.scm +++ /dev/null @@ -1,16 +0,0 @@ -(use zmq posix srfi-18) - -(define s (make-socket 'req)) -(connect-socket s "tcp://*:5563") - -(define myname (cadr (argv))) - -(print "Start client...") - -(do ((i 0 (+ i 1))) - ((>= i 1000)) - (print "sending message #" i) - (send-message s (conc "Hello from " myname)) - (print "sent \"Hello\", looking for a reply") - (printf "Received reply ~a [~a]\n" - i (receive-message s))) DELETED testzmq/hwserver.scm Index: testzmq/hwserver.scm ================================================================== --- testzmq/hwserver.scm +++ /dev/null @@ -1,28 +0,0 @@ -(use zmq srfi-18 posix) - -(define th1 (make-thread - (lambda () - (let ((s (make-socket 'rep))) - (bind-socket s "tcp://*:5563") - (print "Start server...") - (let loop () - (let* ((msg (receive-message s)) - (name (caddr (string-split msg " "))) - (resp (conc "World " name))) - (print "Received request: [" msg "]") - (thread-sleep! 0.0001) - (print "Sending response \"" resp "\"") - (send-message s resp) - (loop))))))) -(define th2 (make-thread - (lambda () - (let loop ((count 0)) - (print "count is " count) - (thread-sleep! 0.1) - (if (< count 10000) - (loop (+ count 1))))))) - -(thread-start! th1) -(thread-start! th2) - -(thread-join! th1) DELETED testzmq/hwtest.sh Index: testzmq/hwtest.sh ================================================================== --- testzmq/hwtest.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/bin/bash - -echo Compiling hwclient and hwserver -csc hwclient.scm -csc hwserver.scm - -./hwserver > hwserver.log & - -sleep 1 -for x in a b c d e f g h i j k l m n o p q r s t u v w x y z;do -./hwclient $x & -done - -# killall -v hwserver hwclient DELETED testzmq/mockupclient.scm Index: testzmq/mockupclient.scm ================================================================== --- testzmq/mockupclient.scm +++ /dev/null @@ -1,42 +0,0 @@ -(use zmq posix numbers) - -(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)) - -;; first ping the server to ensure we have a connection -(if (server-ping cname 5) - (print "SUCCESS: Client " cname " connected to server") - (begin - (print "ERROR: Client " cname " failed ping of server, exiting") - (exit))) - -(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!!") DELETED testzmq/mockupclientlib.scm Index: testzmq/mockupclientlib.scm ================================================================== --- testzmq/mockupclientlib.scm +++ /dev/null @@ -1,63 +0,0 @@ -(define sub (make-socket 'sub)) -(define push (make-socket 'push)) -(socket-option-set! sub 'subscribe cname) -(socket-option-set! sub 'hwm 1000) -(socket-option-set! push 'hwm 1000) - -(connect-socket sub "tcp://localhost:6563") -(connect-socket push "tcp://localhost:6564") - -(thread-sleep! 0.2) - -(define (server-ping cname timeout) - (let ((msg (conc cname ":ping:" timeout)) - (maxtime (+ (current-seconds) timeout))) - (print "pinging server from " cname " with timeout " timeout) - (let loop ((res #f)) - (if (< maxtime (current-seconds)) - #f ;; failed to ping - (if (equal? res "Got ping") - #t - (begin - (print "Ping received from server " res) - (send-message push msg) - (thread-sleep! 0.1) - (loop (receive-message sub non-blocking: #t)))))))) - -(define (dbaccess cname cmd var val #!key (numtries 20)) - (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var))) - (res #f) - (mtx1 (make-mutex)) - (do-access (lambda () - (let ((tmpres #f)) - (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! tmpres (receive-message* sub)) - (mutex-lock! mtx1) - (set! res tmpres) - (mutex-unlock! mtx1)))) - (th1 (make-thread do-access "do access")) - (th2 (make-thread (lambda () - (let ((result #f)) - (mutex-lock! mtx1) - (set! result res) - (mutex-unlock! mtx1) - (thread-sleep! 5) - (if (not result) - (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) - (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts")) - res)) - DELETED testzmq/mockupserver.scm Index: testzmq/mockupserver.scm ================================================================== --- testzmq/mockupserver.scm +++ /dev/null @@ -1,151 +0,0 @@ -;; 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 zmq srfi-18 sqlite3 numbers) - -(define pub (make-socket 'pub)) -(define pull (make-socket 'pull)) -(define cname "server") -(define total-db-accesses 0) -(define start-time (current-seconds)) - -(socket-option-set! pub 'hwm 1000) -(socket-option-set! pull 'hwm 1000) - -(bind-socket pub "tcp://*:6563") -(bind-socket pull "tcp://*:6564") - -(thread-sleep! 0.2) - -(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))) - -;; SERVER THREAD -(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 - ;; (print "Server received message: " indat) - (count-client db cname) - (case clcmd - ((ping) - (print "Got ping from " cname) - (send-message pub cname send-more: #t) - (send-message pub "Got ping") - (loop queuelst)) - ((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") - -;; SYNC THREAD -;; 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")) - -(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)) DELETED testzmq/random.scm Index: testzmq/random.scm ================================================================== --- testzmq/random.scm +++ /dev/null @@ -1,8 +0,0 @@ -(use posix numbers) -(randomize (inexact->exact (current-seconds))) - -(define low (string->number (cadr (argv)))) -(define hi (string->number (caddr (argv)))) - -(print (+ low (random (- hi low)))) - DELETED testzmq/testmockup.sh Index: testzmq/testmockup.sh ================================================================== --- testzmq/testmockup.sh +++ /dev/null @@ -1,41 +0,0 @@ -#!/bin/bash - -rm -f mockup.db - -echo Compiling mockupserver.scm and mockupclient.scm - -# Clean up first -killall mockupserver mockupclient -v - -csc random.scm -csc mockupserver.scm -csc mockupclient.scm - -echo Starting server -./mockupserver & - -sleep 1 - -rm -f mockupclients.log - -echo Starting clients -for i in a b c d e f g h i j k l m n o p q s t u v w x y z; - do - for k in a b; - do - for j in 0 1 2 3 4 5 6 7 8 9; - do - waittime=`./random 0 60` - runtime=`./random 5 120` - echo "Starting client $i$k$j with waittime $waittime and runtime $runtime" - (sleep $waittime;./mockupclient $i$k$j $runtime) & - # >> mockupclients.log & - done - done -done - -wait -echo testmockup.sh script done -# echo "Waiting for 5 seconds then killing all mockupserver and mockupclient processes" -# sleep 30 -# killall -v mockupserver mockupclient