Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -10,11 +10,11 @@ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm \ client.scm synchash.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm rpc-transport.scm \ - portlogger.scm archive.scm env.scm + portlogger.scm archive.scm env.scm diff-report.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -50,13 +50,13 @@ ((zmq) (zmq:client-connect iface port)) (else (rpc:client-connect iface port)))) (define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) (case (server:get-transport) - ((rpc) (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) + ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) - (else (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) + (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; ;; There are two scenarios. @@ -67,11 +67,11 @@ ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; -(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)) +(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) (server:start-and-wait areapath) (if (<= remaining-tries 0) (begin (debug:print-error 0 *default-log-port* "failed to start or connect to server") @@ -78,33 +78,36 @@ (exit 1)) ;; ;; Alternatively here, we can get the list of candidate servers and work our way ;; through them searching for a good one. ;; - (let* ((server-dat (server:get-first-best areapath))) + (let* ((server-dat (server:get-first-best areapath)) + (runremote (or area-dat *runremote*))) (if (not server-dat) ;; no server found (client:setup-http areapath remaining-tries: (- remaining-tries 1)) (let ((host (cadr server-dat)) (port (caddr server-dat))) (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if (not *runremote*)(set! *runremote* (make-remote))) + (if (and (not area-dat) + (not *runremote*)) + (set! *runremote* (make-remote))) (if (and host port) (let* ((start-res (case *transport-type* ((http)(http-transport:client-connect host port)))) (ping-res (case *transport-type* ((http)(rmt:login-no-auto-client-setup start-res))))) (if (and start-res ping-res) (begin - (remote-conndat-set! *runremote* start-res) ;; (hash-table-set! *runremote* run-id start-res) + (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) (case *transport-type* - ((http)(http-transport:close-connections run-id))) - (remote-conndat-set! *runremote* #f) ;; (hash-table-delete! *runremote* run-id) + ((http)(http-transport:close-connections))) + (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) (thread-sleep! 1) (client:setup-http areapath remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered (server:kind-run areapath) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -590,11 +590,11 @@ (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))) - (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) + (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) (let* ((dbstruct (db:setup)) (mtdb (dbr:dbstruct-mtdb dbstruct)) (mtpath (db:dbdat-get-path mtdb))) (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") @@ -750,11 +750,11 @@ #t)) ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) (define (common:get-runconfig-targets #!key (configf #f)) (let ((targs (sort (map car (hash-table->alist - (or configf + (or configf ;; NOTE: There is no value in using runconfig:read here. (read-config (conc *toppath* "/runconfigs.config") #f #t) (make-hash-table)))) string (length bundle) 2)(caddr bundle) #f))) + (hash-table-set! ht section (config:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) + vars))) + (hash-table-keys ht)))) + ht) + ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) +;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections ;; -(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '())) +(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '())(apply-wildcards #t)) (debug:print-info 5 *default-log-port* "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) (debug:print 9 *default-log-port* "START: " path) (if (and (not (port? path)) (not (file-exists? path))) ;; for case where we are handed a port (begin @@ -201,18 +227,27 @@ (open-input-file path) path)) ;; we can be handed a port (res (if (not ht)(make-hash-table) ht)) (metapath (if (or (debug:debug-mode 9) keep-filenames) - path #f))) + path #f)) + (process-wildcards (lambda (res curr-section-name) + (if (and apply-wildcards + (or (string-contains curr-section-name "%") ;; wildcard + (string-match "/.*/" curr-section-name))) ;; regex + (begin + (configf:apply-wildcards res curr-section-name) + (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) (begin + ;; process last section for wildcards + (process-wildcards res curr-section-name) (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. (close-input-port inp)) (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht (debug:print 9 *default-log-port* "END: " path) res) @@ -265,10 +300,13 @@ (let ((patt (car dat)) (proc (cdr dat))) (if (string-match patt curr-section-name) (proc curr-section-name section-name res path)))) post-section-procs) + ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards + ;; NOTE: we are processing the curr-section-name, NOT section-name. + (process-wildcards res curr-section-name) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) ;; if we have the sections list then force all settings into "" and delete it later? (if (or (not sections) (member section-name sections)) section-name "") ;; stick everything into "" Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -463,11 +463,11 @@ keydat) "/")) (item-path (db:test-get-item-path testdat)) ;; this next block was added to fix a bug where variables were ;; needed. Revisit this. - (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) + (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read (if (file-exists? runconfigf) (handle-exceptions exn #f ;; do nothing, just keep on trucking .... (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -1,28 +1,17 @@ -;; #!/bin/bash - -;; #;; rmt:get-tests-for-run - - -;; #;; (let* ((dbstruct (db:get-db - - -;; #;; (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - -;; #;; (rmt:get-test-info-by-id run-id test-id) -;; #;; (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - -;; megatest -repl << EOF - -;; TODO:dashboard not on homehost message exit - + +(declare (unit diff-report)) +(declare (uses common)) +(declare (uses rmt)) + +(include "common_records.scm") (use matchable) +(use fmt) (use ducttape-lib) (define css "") -(use matchable) -(define (tests-mindat->hash tests-mindat) +(define (diff:tests-mindat->hash tests-mindat) (let* ((res (make-hash-table))) (for-each (lambda (item) (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) (value (list-ref item 2))) @@ -31,11 +20,11 @@ res)) ;; return 1 if status1 is better ;; return 0 if status1 and 2 are equally good ;; return -1 if status2 is better -(define (status-compare3 status1 status2) +(define (diff:status-compare3 status1 status2) (let* ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f)) (mem1 (member status1 status-goodness-ranking)) (mem2 (member status2 status-goodness-ranking)) ) @@ -46,13 +35,13 @@ ((= (length mem1) (length mem2)) 0) ((> (length mem1) (length mem2)) 1) (else -1)))) -(define (xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f)) - (let* ((src-hash (tests-mindat->hash src-tests-mindat)) - (dest-hash (tests-mindat->hash dest-tests-mindat)) +(define (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f) (consistent-fail-not-clean #f)) + (let* ((src-hash (diff:tests-mindat->hash src-tests-mindat)) + (dest-hash (diff:tests-mindat->hash dest-tests-mindat)) (all-keys (reverse (sort (delete-duplicates (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) @@ -68,16 +57,16 @@ (map ;; TODO: rename xor to delta globally in dcommon and dashboard (lambda (key) (let* ((test-name (car key)) (item-path (cdr key)) - (dest-value (hash-table-ref/default dest-hash key (list #f #f #f))) ;; (list test-id state status) + (dest-value (hash-table-ref/default dest-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status) (dest-test-id (list-ref dest-value 0)) (dest-state (list-ref dest-value 1)) (dest-status (list-ref dest-value 2)) - (src-value (hash-table-ref/default src-hash key (list #f #f #f))) ;; (list test-id state status) + (src-value (hash-table-ref/default src-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status) (src-test-id (list-ref src-value 0)) (src-state (list-ref src-value 1)) (src-status (list-ref src-value 2)) (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete @@ -88,34 +77,36 @@ (not (member dest-status incomplete-statuses)))) (src-complete (and src-value src-state src-status (equal? src-state "COMPLETED") (not (member src-status incomplete-statuses)))) - (status-compare-result (status-compare3 src-status dest-status)) + (status-compare-result (diff:status-compare3 src-status dest-status)) (xor-new-item (cond ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) ;; neither complete -> bad ;; src !complete, dest complete -> better ((and (not dest-complete) (not src-complete)) (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE") src-value dest-value) ((not dest-complete) - (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE") src-value dest-value) + (list src-test-id "NOT-IN-DEST" "DEST-INCOMPLETE") src-value dest-value) ((not src-complete) - (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE") src-value dest-value) + (list dest-test-id "NOT-IN-SRC" "SRC-INCOMPLETE") src-value dest-value) ((and (equal? src-state dest-state) (equal? src-status dest-status)) - (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) src-value dest-value)) + (if (and consistent-fail-not-clean (not (member dest-status '("PASS" "SKIP" "WAIVED" "WARN")))) + (list dest-test-id (conc "BOTH-BAD") (conc "CLEAN-" dest-status) src-value dest-value) + (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) src-value dest-value))) ;; better or worse: pass > warn > waived > skip > fail > abort ;; pass > warn > waived > skip > fail > abort ((= 1 status-compare-result) ;; src is better, dest is worse - (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status) src-value dest-value)) + (list dest-test-id "WORSE" (conc src-status "->" dest-status) src-value dest-value)) (else - (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status) src-value dest-value))))) + (list dest-test-id "BETTER" (conc src-status "->" dest-status) src-value dest-value))))) (list test-name item-path xor-new-item))) all-keys))) (if hide-clean (filter @@ -125,24 +116,37 @@ "CLEAN" (list-ref (list-ref item 2) 1)))) res) res)))) -(define (run-name->run-id runname) - (if (number? runname) - runname - (let* ((qry-res (rmt:get-runs runname 1 0 '()))) +(define (diff:run-name->run-id run-name) + (if (number? run-name) + run-name + (let* ((qry-res (rmt:get-runs run-name 1 0 '()))) (if (eq? 2 (vector-length qry-res)) (vector-ref (car (vector-ref qry-res 1)) 1) #f)))) -(define (run-name->tests-mindat runname) - (let* ((run-id (run-name->run-id runname)) - (testpatt "%/%") -;; (states '("COMPLETED" "INCOMPLETE")) - ;; (statuses '("PASS" "FAIL" "ABORT" "SKIP")) - (states '()) +(define (diff:target+run-name->run-id target run-name) + (let* ((keys (rmt:get-keys)) + (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) + (if (not (eq? (length keys) (length keys))) + (begin + (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) + #f) + (let* ((target-map (zip keys target-parts)) + (qry-res (rmt:get-runs run-name 1 0 target-map))) + + (if (eq? 2 (vector-length qry-res)) + (let ((first-ent (vector-ref qry-res 1))) + (if (> (length first-ent) 0) + (vector-ref (car first-ent) 1) + #f)) + #f))))) + +(define (diff:run-id->tests-mindat run-id #!key (testpatt "%/%")) + (let* ((states '()) (statuses '()) (offset #f) (limit #f) (not-in #t) (sort-by #f) @@ -173,46 +177,120 @@ qryvals last-update mode)))) -(define (diff-runs run1 run2) - (let* ((src-tests-mindat (run-name->tests-mindat run1)) - (dest-tests-mindat (run-name->tests-mindat run2))) - (xor-tests-mindat src-tests-mindat dest-tests-mindat)));; #!key (hide-c +(define (diff:diff-runs src-run-id dest-run-id) + (let* ((src-tests-mindat (diff:run-id->tests-mindat src-run-id)) + (dest-tests-mindat (diff:run-id->tests-mindat dest-run-id))) + (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat consistent-fail-not-clean: #t))) -(define (rundiff-find-by-state run-diff state) +(define (diff:rundiff-find-by-state run-diff state) (filter (lambda (x) (equal? (list-ref (caddr x) 1) state)) run-diff)) +(define (diff:rundiff-clean-breakdown run-diff) + (map + (lambda (run-diff-item) + (match run-diff-item + ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) + (list test-name item-path "CLEAN" src-status)) + (else ""))) + (diff:rundiff-find-by-state run-diff "CLEAN"))) + +(define (diff:summarize-run-diff run-diff) -(define (summarize-run-diff run-diff) - (let* ((diff-states (list "CLEAN" "DIRTY-BETTER" "DIRTY-WORSE" "BOTH-BAD" "DIFF-MISSING" "DIFF-NEW" ))) + (let* ((diff-states (list "CLEAN" "BETTER" "WORSE" "BOTH-BAD" "NOT-IN-DEST" "NOT-IN-SRC" ))) (map (lambda (state) (list state - (length (rundiff-find-by-state run-diff state)))) + (length (diff:rundiff-find-by-state run-diff state)))) diff-states))) -(define (stml->string in-stml) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Presentation code below, business logic above ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (diff:stml->string in-stml) (with-output-to-string (lambda () (s:output-new (current-output-port) in-stml)))) -(define (test-state-status->diff-report-cell state status) - (s:td status)) - -(define (diff-state-status->diff-report-cell state status) - (s:td state 'bgcolor "#33ff33")) - -(define (run-diff->diff-report src-runname dest-runname run-diff) - (let* ((test-count (length run-diff)) +(define (diff:state-status->bgcolor state status) + (match (list state status) + (("CLEAN" _) "#88ff88") + (("BETTER" _) "#33ff33") + (("WORSE" _) "#ff3333") + (("BOTH-BAD" _) "#ff3333") + ((_ "WARN") "#ffff88") + ((_ "FAIL") "#ff8888") + ((_ "ABORT") "#ff0000") + ((_ "PASS") "#88ff88") + ((_ "SKIP") "#ffff00") + (else "#ffffff"))) + +(define (diff:test-state-status->diff-report-cell state status) + (s:td 'bgcolor (diff:state-status->bgcolor state status) status)) + +(define (diff:diff-state-status->diff-report-cell state status) + (s:td state 'bgcolor (diff:state-status->bgcolor state status))) + + +(define (diff:megatest-html-logo) + + "
+___  ___                 _            _
+|  \\/  | ___  __ _  __ _| |_ ___  ___| |_
+| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __|
+| |  | |  __/ (_| | (_| | ||  __/\\__ \\ |_
+|_|  |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__|
+             |___/
+
") + +(define (diff:megatest-html-diff-logo) + "
+___  ___                 _            _
+|  \\/  | ___  __ _  __ _| |_ ___  ___| |_  |  _ \\(_)/ _|/ _|
+| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __| | | | | | |_| |_
+| |  | |  __/ (_| | (_| | ||  __/\\__ \\ |_  | |_| | |  _|  _|
+|_|  |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__| |____/|_|_| |_|
+             |___/
+
") + + +(define (diff:run-id->target+run-name+starttime run-id) + (let* ((target (rmt:get-target run-id)) + (runinfo (rmt:get-run-info run-id)) ; vector of header (list) and result (vector) + (info-hash (alist->hash-table + (map (lambda (x) (cons (car x) (cadr x))) ; make it a useful hash + (zip (vector-ref runinfo 0) (vector->list (vector-ref runinfo 1)))))) + (run-name (hash-table-ref/default info-hash "runname" "N/A")) + (start-time (hash-table-ref/default info-hash "event_time" 0))) + (list target run-name start-time))) + +(define (diff:deliver-diff-report src-run-id dest-run-id + #!key + (html-output-file #f) + (email-subject-prefix "[MEGATEST DIFF]") + (email-recipients-list '()) ) + (let* ((src-info (diff:run-id->target+run-name+starttime src-run-id)) + (src-target (car src-info)) + (src-run-name (cadr src-info)) + (src-start (conc (seconds->string (caddr src-info)) " " (local-timezone-abbreviation))) + (dest-info (diff:run-id->target+run-name+starttime dest-run-id)) + (dest-target (car dest-info)) + (dest-run-name (cadr dest-info)) + (dest-start (conc (seconds->string (caddr dest-info)) " " (local-timezone-abbreviation))) + + + (run-diff (diff:diff-runs src-run-id dest-run-id )) + (test-count (length run-diff)) (summary-table (apply s:table 'cellspacing "0" 'border "1" (s:tr (s:th "Diff type") (s:th "% share") @@ -219,61 +297,112 @@ (s:th "Count")) (map (lambda (state-count) (s:tr - (s:td (car state-count)) - (s:td (* 100 (/ (cadr state-count) test-count))) - (s:td (cadr state-count)))) - (summarize-run-diff run-diff)))) + (diff:diff-state-status->diff-report-cell (car state-count) #f) + (s:td 'align "right" (fmt #f + (decimal-align 3 + (fix 2 + (num/fit 6 + (* 100 (/ (cadr state-count) test-count))))))) + (s:td 'align "right" (cadr state-count)))) + (diff:summarize-run-diff run-diff)))) + (meta-table + (s:table 'cellspacing "0" 'border "1" + + (s:tr + (s:td 'colspan "2" + (s:table 'cellspacing "0" 'border "1" + (s:tr + (s:th 'align "LEFT" "") (s:th "SOURCE RUN") (s:th "DESTINATION RUN")) + (s:tr + (s:th 'align "LEFT" "Started") (s:td src-start) (s:td dest-start)) + (s:tr + (s:th 'align "LEFT" "TARGET") (s:td src-target) (s:td dest-target)) + (s:tr + (s:th 'align "LEFT" "RUN NAME") (s:td src-run-name) (s:td dest-run-name))))))) + (main-table (apply s:table 'cellspacing "0" 'border "1" (s:tr (s:th "Test name") (s:th "Item Path") - (s:th (conc "Source=" src-runname)) - (s:th (conc "Dest=" dest-runname)) + (s:th (conc "SOURCE")) + (s:th (conc "DEST")) (s:th "Diff")) (map (lambda (run-diff-item) (match run-diff-item ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) (s:tr (s:td test-name) (s:td item-path) - (test-state-status->diff-report-cell src-state src-status) - (test-state-status->diff-report-cell dest-state dest-status) - (diff-state-status->diff-report-cell diff-state diff-status))) + (diff:test-state-status->diff-report-cell src-state src-status) + (diff:test-state-status->diff-report-cell dest-state dest-status) + (diff:diff-state-status->diff-report-cell diff-state diff-status))) (else ""))) (filter (lambda (run-diff-item) (match run-diff-item ((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status))) (not (equal? diff-state "CLEAN"))) (else #f))) - run-diff))))) - (stml->string (s:body - summary-table - main-table)))) - - - - - - -(let* ((src-runname "all57") - (dest-runname "all60") - (to "bjbarcla") - (subj (conc "[MEGATEST DIFF] "src-runname" vs. "dest-runname)) - (run-diff (diff-runs src-runname dest-runname)) - (diff-summary (summarize-run-diff run-diff)) - (html-report (run-diff->diff-report src-runname dest-runname run-diff))) - ;;(pretty-print run-diff) - ;;(pretty-print diff-summary) - - (sendmail to subj html-report use_html: #t) - ;;(print html-report) - ) - - -;; (match de -;; ((test-name test-path ( test-id "BOTH-BAD" test-status)) test-path) -;; (else #f)) + run-diff)))) + (email-subject (conc email-subject-prefix " " src-target "/" src-run-name" vs. "dest-target"/"dest-run-name)) + (html-body (diff:stml->string (s:body + (diff:megatest-html-diff-logo) + (s:h2 "Summary") + (s:table 'border "0" + (s:tr + (s:td "Diff calculated at") + (s:td (conc (seconds->string) " " (local-timezone-abbreviation)))) + (s:tr + (s:td "MT_RUN_AREA_HOME" ) (s:td *toppath*)) + (s:tr 'valign "TOP" + (s:td summary-table) + (s:td meta-table))) + (s:h2 "Diffs + consistently failing tests") + main-table))) + + ) + (if html-output-file + (with-output-to-file html-output-file (lambda () (print html-body)))) + (when (and email-recipients-list (> (length email-recipients-list) 0)) + (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t)) + html-body)) + + + + + +;; (let* ((src-run-name "all57") +;; (dest-run-name "all60") +;; (src-run-id (diff:run-name->run-id src-run-name)) +;; (dest-run-id (diff:run-name->run-id dest-run-name)) +;; (to-list (list "bjbarcla"))) +;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html") +;; ) + +(define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw) + (let* (;;(src-target "nope%") + ;;(src-runname "all57") + ;;(dest-target "%") + ;;(dest-runname "all60") + (src-run-id (diff:target+run-name->run-id src-target src-runname)) + (dest-run-id (diff:target+run-name->run-id dest-target dest-runname)) + ;(html-file "/tmp/bjbarcla/zippy.html") + (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f)) + ) + + (cond + ((not src-run-id) + (print "No match for source target/runname="src-target"/"src-runname) + (print "Cannot proceed.") + #f) + ((not dest-run-id) + (print "No match for source target/runname="dest-target"/"dest-runname) + (print "Cannot proceed.") + #f) + (else + (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file))))) + + Index: docs/api.html ================================================================== --- docs/api.html +++ docs/api.html @@ -1,1024 +1,1024 @@ - - - - - -Megatest Web App API Specificiation - - - - - + +
+
+
+

Megatest Web App

+
    +
  1. +

    +See runs +

    +
    2. +
  2. +

    +Manage jobs +

    +
    3. +
  3. +

    +Debug +

    +
    4. +
+
+
+
+

Example Abstract

+
+

The Megatest Web App aims to make as much of the power of the dashboard available to the web based user.

+
+
+
+

1. Common

+
+

This is an example endpoint. You will need to use your own cgi server to serve out your megatest runs.

+

Endpoint: http://kiatoa.com/cgi-bin/megatest

+
+

1.1. Error format response

+

All API errors are returned in the following format:

+
+
+

{ "error" : "Error message" }

+
+
+
+

1.2. Get List of Runs

+

URL: <base>/runs

+

Method: GET

+

Filter Params: target, testpatt, offset, limit

+

Megatest Cmd: megatest -start-dir <path to megatest area> -list-runs % -target % -dumpmode json -fields runs:runname,id+tests:state,status:id

+

Response:

+
+
+

[ + { + "run_id" : "1", + "name" : "runname1", + "target" : "target1", + "tests" : + [ + "test": + [ + {"id": 1, "name":test1, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS#"} + {"id": 2, "name":test2, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test2", "final_logf": "megatest-rollup-test2.html", "status": "PASS"} + {"id": 3, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + }, + { + "run_id" : "2", + "name" : "runname2", + "target" : "target2", + "tests" : + [ + "test: + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + } +]

+
+
+
+

1.3. Trigger a new Run

+

URL: <base>/runs

+

Method: POST

+

Megatest Cmd: megatest -runtests % -target <target> :runname <run_name> -run

+

Request Params:

+
+
+

{"target": "target_value", "runname" : "runname", "test_pattern": "optional test pattern"}

+
+

Response:

+

If Error

+
+
+

{ "error" : "Error message" }

+
+

If Success returns the results of the run

+
+
+

[ + { + "run_id" : "2", + "name" : "runname2", + "target" : "target2", + "tests" : + [ + "test: + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + } +]

+
+
+
+

1.4. Get perticular Run

+

URL: <base>/runs/:id

+

Method: GET

+

Filter Params: testpatt

+

Megatest Cmd: megatest -start-dir <path to megatest area> -list-runs <runname> -target % -dumpmode json -fields runs:runname,id+tests:state,status:id

+

Response:

+
+
+

[ + { + "run_id" : "2", + "name" : "runname2", + "target" : "target2", + "tests" : + [ + "test": + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + } +]

+
+
+
+

1.5. Re-execute a run

+

URL: <base>/runs/:id

+

Method: PUT/PATCH

+

Request Params: {"testpatt" : "pattern"}

+

Response:

+
+
+

[ + { + "run_id" : "2", + "name" : "runname2", + "target" : "target2", + "tests" : + [ + "test": + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] + ] + } +]

+
+
+
+

1.6. Get List of tests within a run

+

URL: <base>/runs/:id/tests

+

Method: GET

+

Megatest Cmd: megatest -start-dir <path to megatest area> -list-runs <runname> -target % -dumpmode json -fields runs:runname,id+tests:state,status:id

+

Response:

+
+
+

[ + "tests" : + [ + {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"} + {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"} + {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"} + ] +]

+
+
+
+

1.7. Re-execute a test within a run

+

URL: <base>/runs/:id/tests/:id

+

Method: PUT/PATCH

+

Response:

+
+
+

{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}

+
+
+
+

1.8. Get perticular test that belongs to a Runs

+

URL: <base>/runs/:id/tests/:id

+

Method: GET

+

Megatest Cmd: megatest -start-dir <path to megatest area> -list-runs <runname> -target % -testpattern <pattern> -dumpmode json -fields runs:runname,id+tests:state,status:id

+

Response:

+
+
+

{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}

+
+
+
+
+
+

2. Notes

+
+

Misc …

+
    +
  1. +

    +blah +

    +
    2. +
  2. +

    +baz +

    +
    3. +
+
+
+
+
+ + + Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -42,15 +42,36 @@ A a b c B d e f ------------------------- Then the config file would effectively appear to contain an items section -exactly like the output from the script. This is extremely useful when -dynamically creating items, itemstables and other config structures. You can -see the expansion of the call by looking in the cached files (look in your -linktree for megatest.config and runconfigs.config cache files and in your -test run areas for the expanded and cached testconfig). +exactly like the output from the script. This is useful when dynamically +creating items, itemstables and other config structures. You can see the +expansion of the call by looking in the cached files (look in your linktree +for megatest.config and runconfigs.config cache files and in your test run +areas for the expanded and cached testconfig). + +Wildcards and regexes in Targets + +------------------------- +[a/2/b] +VAR1 VAL1 + +[a/%/b] +VAR1 VAL2 +------------------------- + +Will result in: + +------------------------- +[a/2/b] +VAR1 VAL2 +------------------------- + +Can use either wildcard of "%" or a regular expression: + +[/abc.*def/] Disk Space Checks ^^^^^^^^^^^^^^^^^ Some parameters you can put in the [setup] section of megatest.config: Index: ducttape/Makefile ================================================================== --- ducttape/Makefile +++ ducttape/Makefile @@ -1,7 +1,5 @@ -SHELL=/bin/tcsh -f - help: @echo "" @echo "make targets:" @echo "=============" @echo "install - build and install general_lib egg as icfadm" @@ -20,11 +18,11 @@ test: chicken-install -no-install csc test_ducttape.scm ./test_ducttape - if (-e foo) rm -f foo + rm -f foo test_example: @csc test_example.scm @./test_example @rm test_example ADDED ducttape/README Index: ducttape/README ================================================================== --- /dev/null +++ ducttape/README @@ -0,0 +1,8 @@ +This directory holds the "ducttape" chicken scheme egg used by megatest. + +Run "make test" to ensure this egg works on your system. + +Run "make install" as your admin user with chicken on your $PATH to install this egg. + + + Index: ducttape/ducttape-lib.scm ================================================================== --- ducttape/ducttape-lib.scm +++ ducttape/ducttape-lib.scm @@ -18,11 +18,11 @@ ; launch-repl keyword-skim skim-cmdline-opts-noarg-by-regex skim-cmdline-opts-withargs-by-regex concat-lists - process-command-line + ducttape-process-command-line ducttape-append-logfile ducttape-activate-logfile isys do-or-die counter-maker @@ -46,11 +46,14 @@ current-isodate ) (import scheme chicken extras ports data-structures ) - (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339 scsh-process directory-utils uuid-lib filepath srfi-19 ) ; linenoise + (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339) + ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process* + (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise + (include "mimetypes.scm") ; provides ext->mimetype (include "workweekdate.scm") (define ducttape-lib-version 1.00) (define (toplevel-command sym proc) (lambda () #f)) ;;;; utility procedures @@ -182,23 +185,10 @@ (if (equal? 0 exit-code) stdout-str (begin (ierr (conc "Command > " command " " "< failed with " exit-code " because: \n" stderr-str) ) (if nodie #f (exit exit-code)))))) - - - - - ;; this is broken. one day i will fix it and thus understand run/collecting... don't use isys-broken. - (define (isys-broken command-list) - - (let-values ( ( (rv outport errport) (run/collecting (1 2) ("ls" "-l") ) ) ) - (print "rv is " rv) - (print "op is " outport) - (print "ep is " errport) - (values rv (port->string outport) (port->string errport)))) - ;; runs-ok: evaluate expression while suppressing exceptions. ; on caught exception, returns #f ; otherwise, returns expression value @@ -341,23 +331,19 @@ (begin (ducttape-log-file logfile) (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t))) - ;; immediately activate logfile (will be noop if logfile disabled) - (ducttape-activate-logfile) ;; log exit code - (define (set-exit-handler) + (define (set-ducttape-log-exit-handler) (let ((orig-exit-handler (exit-handler))) (exit-handler (lambda (exitcode) (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t) (orig-exit-handler exitcode))))) - (set-exit-handler) - - ;; TODO: hook exception handler so we can log exception before we sign off. + (define (idbg first-message . rest-args) (let* ((debug-level-threshold (if (> (length rest-args) 0) (car rest-args) 1)) (message-list @@ -495,11 +481,13 @@ (from_addr "admin") cc_addr bcc_addr more-headers use_html - (attach-files-list '())) + (attach-files-list '()) + (images-with-content-id-alist '()) + ) (define (sendmail-proc sendmail-port) (define (wl line-str) (write-line line-str sendmail-port)) @@ -531,10 +519,11 @@ (wl "") (boundary) (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\"")) (wl "") ) + (define (email-text-body) (body-boundary) (wl "Content-Type: text/plain; charset=ISO-8859-1") (wl "Content-Disposition: inline") @@ -551,12 +540,12 @@ (wl "Content-Type: text/html; charset=ISO-8859-1") (wl "Content-Disposition: inline") (wl "") (wl body) (body-boundary)) - - (define (attach-file file) + + (define (attach-file file #!key (content-id #f)) (let* ((filename (filepath:take-file-name file)) (ext-with-dot (filepath:take-extension file)) (ext (string-take-right @@ -565,24 +554,32 @@ (mimetype (ext->mimetype ext)) (uuencode-command (conc "uuencode " file " " filename))) (boundary) (wl (conc "Content-Type: " mimetype "; name=\"" filename "\"")) (wl "Content-Transfer-Encoding: uuencode") + (if content-id + (wl (conc "Content-Id: " content-id))) (wl (conc "Content-Disposition: attachment; filename=\"" filename "\"")) (wl "") (do-or-die uuencode-command foreach-stdout: (lambda (line) (wl line))))) + + (define (embed-image file+content-id) + (let ((file (car file+content-id)) + (content-id (cdr file+content-id))) + (attach-file file content-id: content-id))) ;; send the email (email-mime-header) (if use_html (email-html-body) (email-text-body)) (for-each attach-file attach-files-list) + (for-each embed-image images-with-content-id-alist) (boundary) (close-output-port sendmail-port))) (do-or-die "/usr/sbin/sendmail -t" stdin-proc: sendmail-proc)) @@ -604,71 +601,10 @@ (if (file-execute-access? candidate) candidate (loop next-rest))))))) - - - ;; (define (launch-repl ) - ;; (use linenoise) - ;; (current-input-port (make-linenoise-port)) - - ;; (let ((histfile (conc (or (get-environment-variable "HOME") ".") "/." (script-name) "-hist"))) - - ;; (set-history-length! 30000) - - ;; (load-history-from-file histfile) - - ;; (let loop ((l (linenoise "> "))) - ;; (cond ((equal? l "bye") - ;; (save-history-to-file histfile) - ;; "Bye!") - ;; ((eof-object? l) - ;; (save-history-to-file histfile) - ;; (exit)) - ;; (else - ;; (display l) - ;; (handle-exceptions exn - ;; ;;(print-call-chain (current-error-port)) - ;; (let ((message ((condition-property-accessor 'exn 'message) exn))) - ;; (print "exn> " message ) - ;; ;;(pp (condition->list exn)) - ;; ;;(exit) - ;; ;;(display "Went wrong") - ;; (newline)) - ;; (print (eval l))))) - ;; (newline) - ;; (history-add l) - ;; (loop (linenoise "> "))))) - - ;; (define (launch-repl2 ) - ;; (use readline) - ;; (use apropos) - ;; (use trace) - ;; ;(import csi) - ;; (current-input-port (make-readline-port (conc (script-name) "> ") "... ")) - ;; ; (install-history-file #f (conc (or (get-environment-variable "HOME") ".") "/." (script-name) "_history")) - ;; (parse-and-bind "set editing-mode emacs") - ;; (install-history-file) - ;; (let loop ((foo #f)) - - ;; (let ((expr (read))) - ;; (cond - ;; ((eof-object? expr) (exit)) - ;; (else - ;; (handle-exceptions exn - ;; ;;(print-call-chain (current-error-port)) - ;; (let ((message ((condition-property-accessor 'exn 'message) exn))) - ;; (print "exn> " message ) - ;; ;;(pp (condition->list exn)) - ;; ;;(exit) - ;; ;;(display "Went wrong") - ;; (newline)) - ;; (print (eval expr)))))) - ;; (loop #f)) - ;; ) - ;;;; process command line options ;; get command line switches (have no subsequent arg; eg. [-foo]) ;; assumes these are switches without arguments ;; will return list of matches @@ -728,11 +664,13 @@ ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile) ;; - reset parameters; reset DUCTTAPE_* env vars to match user specified intent ;; - mutate (command-line-arguments) parameter to subtract these recognized and handled switches ;; * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas. Use (command-line-arguments) - (define (process-command-line) + ;; WARNING: this defines command line arguments that may clash with your program. Only call this if you + ;; are sure they can coexist. + (define (ducttape-process-command-line) ;; --quiet (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet"))) (if (not (null? quiet-opts)) (begin @@ -792,10 +730,18 @@ (if (not (null? debugpat-opts)) (begin (ducttape-debug-regex-filter (string-join debugpat-opts "|")) (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) + + ;;; following code commented out; side effects not wanted on startup + ;; immediately activate logfile (will be noop if logfile disabled) + ;;(ducttape-activate-logfile) + ;;(set-ducttape-log-exit-handler) + + ;; TODO: hook exception handler so we can log exception before we sign off. + ;; handle command line immediately; - (process-command-line) + ;;(process-command-line) ) ; end module Index: ducttape/test_ducttape.scm ================================================================== --- ducttape/test_ducttape.scm +++ ducttape/test_ducttape.scm @@ -7,34 +7,34 @@ (set! systype (do-or-die (if (file-exists? "/bin/uname") "/bin/uname" "/usr/bin/uname"))) ;(trace skim-cmdline-opts-withargs-by-regex) ;(trace keyword-skim) ;(trace re-match?) (define (reset-ducttape) - (unsetenv "ducttape_DEBUG_LEVEL") + (unsetenv "DUCTTAPE_DEBUG_LEVEL") (ducttape-debug-level #f) - (unsetenv "ducttape_DEBUG_PATTERN") + (unsetenv "DUCTTAPE_DEBUG_PATTERN") (ducttape-debug-regex-filter ".") - (unsetenv "ducttape_LOG_FILE") + (unsetenv "DUCTTAPE_LOG_FILE") (ducttape-log-file #f) - (unsetenv "ducttape_SILENT_MODE") + (unsetenv "DUCTTAPE_SILENT_MODE") (ducttape-silent-mode #f) - (unsetenv "ducttape_QUIET_MODE") + (unsetenv "DUCTTAPE_QUIET_MODE") (ducttape-quiet-mode #f) - (unsetenv "ducttape_COLOR_MODE") + (unsetenv "DUCTTAPE_COLOR_MODE") (ducttape-color-mode #f) ) (define (reset-ducttape-with-cmdline-list cmdline-list) (reset-ducttape) (command-line-arguments cmdline-list) - (process-command-line) + (ducttape-process-command-line) ) (define (direct-iputs-test) (ducttape-color-mode #f) @@ -112,10 +112,12 @@ (test-assert "mktemp: temp file created" (file-exists? tmpfile)) (if (file-exists? tmpfile) (delete-file tmpfile)) ))) + + (define (test-systemstuff) (test-group "system commands" @@ -335,11 +337,19 @@ (test-misc) (test-wwdate) ) ; end main() (main) -(sendmail "brandon.j.barclay@intel.com" "6hello subject" "test body") +(sendmail "brandon.j.barclay@intel.com" "6hello subject" "test body" ) + +;(let* ((image-file "/nfs/site/home/bjbarcla/megatest-logo.png") +; (cid "mtlogo") +; (image-alist (list (cons image-file cid))) +; (body (conc "Hello world
\"test
bye!"))) + +; (sendmail "brandon.j.barclay@intel.com" "7hello subject" body use_html: #t images-with-content-id-alist: image-alist) +; (print "sent image mail")) ;(sendmail "bjbarcla" "2hello subject html" "test body

hello

italics" use_html: #t) ;(sendmail "bb" "4hello attach subject html" "

hmm

" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) ) ;(launch-repl) (test-exit) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -202,19 +202,20 @@ (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; Send "cmd" with json payload "params" to serverdat and receive result ;; -(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) +(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)(area-dat #f)) (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) (res (vector #f "uninitialized")) (success #t) - (sparams (db:obj->string params transport: 'http))) + (sparams (db:obj->string params transport: 'http)) + (runremote (or area-dat *runremote*))) (debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") ;; set up the http-client here (max-retry-attempts 1) ;; consider all requests indempotent (retry-request? (lambda (request) @@ -233,12 +234,12 @@ exn (begin (set! success #f) (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (if *runremote* - (remote-conndat-set! *runremote* #f)) + (if runremote + (remote-conndat-set! runremote #f)) ;; Killing associated server to allow clean retry.") ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? (mutex-unlock! *http-mutex*) ;;; (signal (make-composite-condition ;;; (make-property-condition 'commfail 'message "failed to connect to server"))) @@ -283,13 +284,14 @@ 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))) ;; careful closing of connections stored in *runremote* ;; -(define (http-transport:close-connections run-id) - (let* ((server-dat (if *runremote* - (remote-conndat *runremote*) +(define (http-transport:close-connections #!key (area-dat #f)) + (let* ((runremote (or area-dat *runremote*)) + (server-dat (if runremote + (remote-conndat runremote) #f))) ;; (hash-table-ref/default *runremote* run-id #f))) (if (vector? server-dat) (let ((api-dat (http-transport:server-dat-get-api-uri server-dat))) (close-connection! api-dat) #t) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -773,11 +773,11 @@ given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME")) (first-rundat (let ((toppath (if toppath toppath (car first-pass)))) - (read-config ;; (conc toppath "/runconfigs.config") + (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now. (conc (if (string? toppath) toppath (get-environment-variable "MT_RUN_AREA_HOME")) "/runconfigs.config") *runconfigdat* #t @@ -806,11 +806,11 @@ pathenvvar: "MT_RUN_AREA_HOME")) (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals) - (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t + (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... sections: sections)))) (if cancreate (configf:write-alist runconfigdat rccachef)) (set! *runconfigdat* runconfigdat) (if cancreate (configf:write-alist *configdat* mtcachef)) (if cancreate (set! *configstatus* 'fulldata)))) @@ -824,11 +824,11 @@ environ-patt: "env-override" given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") pathenvvar: "MT_RUN_AREA_HOME"))) (if cfgdat (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))) - (rdat (read-config (conc toppath + (rdat (read-config (conc toppath ;; convert this to use runconfig:read! "/runconfigs.config") *runconfigdat* #t sections: sections))) (set! *configinfo* cfgdat) (set! *configdat* (car cfgdat)) (set! *runconfigdat* rdat) (set! *toppath* toppath) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6306) +(define megatest-version 1.6307) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -43,10 +43,11 @@ (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) +(declare (uses diff-report)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -175,10 +176,18 @@ -archive cmd : archive runs specified by selectors to one of disks specified in the [archive-disks] section. cmd: keep-html, restore, save, save-remove -generate-html : create a simple html tree for browsing your runs +Diff report + -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname + and either -diff-email or -diff-html) + -src-target + -src-runname + -diff-email : comma separated list of email addresses to send diff report + -diff-html : path to html file to generate + Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile if it contains forward slashes the path will be converted @@ -267,10 +276,15 @@ "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" "-source-db" + + "-src-target" + "-src-runname" + "-diff-email" + "-diff-html" ) (list "-h" "-help" "--help" "-manual" "-version" "-force" @@ -326,11 +340,13 @@ "-sync-to-megatest.db" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only - ) + + "-diff-rep" + ) args:arg-hash 0)) ;; Add args that use remargs here ;; @@ -353,15 +369,28 @@ (define *watchdog* (make-thread common:watchdog "Watchdog thread")) (if (not (args:get-arg "-server")) (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog +;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions +(define (open-logfile logpath) + (condition-case + (let* ((log-dir (or (pathname-directory logpath) "."))) + (if (not (directory-exists? log-dir)) + (system (conc "mkdir -p " log-dir))) + (open-output-file logpath)) + (exn () + (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath) + (define *didsomething* #t) + (exit 1)))) + + (if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) - (oup (open-output-file logf))) + (oup (open-logfile logf))) (if (not (args:get-arg "-log")) (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log (debug:print-info 0 *default-log-port* "Sending log output to " logf) (set! *default-log-port* oup))) @@ -811,11 +840,12 @@ (setenv "MT_RUN_AREA_HOME" *toppath*) (if key-vals (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals)) - (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) (file-write-access? rundir)) (begin (configf:write-alist data cfgf) @@ -833,16 +863,17 @@ ((and (args:get-arg "-section") (args:get-arg "-var")) (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")) (configf:lookup data "default" (args:get-arg "-var"))))) (if val (print val)))) - ((not (args:get-arg "-dumpmode")) + ((or (not (args:get-arg "-dumpmode")) + (string=? (args:get-arg "-dumpmode") "ini")) + (configf:config->ini data)) + ((string=? (args:get-arg "-dumpmode") "sexp") (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) - ((string=? (args:get-arg "-dumpmode") "ini") - (configf:config->ini data)) (else (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) @@ -1839,10 +1870,30 @@ ;;====================================================================== ;; fakeout readline (include "readline-fix.scm") + +(when (args:get-arg "-diff-rep") + (when (and + (not (args:get-arg "-diff-html")) + (not (args:get-arg "-diff-email"))) + (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep") + (set! *didsomething* 1) + (exit 1)) + + (let* ((toppath (launch:setup))) + (do-diff-report + (args:get-arg "-src-target") + (args:get-arg "-src-runname") + (args:get-arg "-target") + (args:get-arg "-runname") + (args:get-arg "-diff-html") + (args:get-arg "-diff-email")) + (set! *didsomething* #t) + (exit 0))) + (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) (dbstruct (if (and toppath @@ -1954,11 +2005,11 @@ (set! *didsomething* #t))) (if (args:get-arg "-generate-html") (let* ((toppath (launch:setup))) (if (tests:create-html-tree #f) - (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/runs-index.html") + (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html") (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -31,12 +31,13 @@ ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; -(define (rmt:get-connection-info areapath) ;; TODO: push areapath down. - (let ((cinfo (remote-conndat *runremote*)) +(define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. + (let* ((runremote (or area-dat *runremote*)) + (cinfo (remote-conndat runremote)) (run-id 0)) (if cinfo cinfo (if (server:check-if-running areapath) (client:setup areapath) @@ -44,130 +45,131 @@ (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; -(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected +(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected ;; do all the prep locked under the rmt-mutex (mutex-lock! *rmt-mutex*) - ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in *runremote* + ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds. ;; 3. do the query, if on homehost use local access ;; - (let* ((start-time (current-seconds))) ;; snapshot time so all use cases get same value + (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value + (runremote (or area-dat *runremote*))) (cond ;; give up if more than 15 attempts ((> attemptnum 15) (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.") (exit 1)) ;; reset the connection if it has been unused too long - ((and *runremote* - (remote-conndat *runremote*) - (let ((expire-time (+ (- start-time (remote-server-timeout *runremote*))(random 30)))) ;; add 30 seconds of noise so that not all running tests expire at the same time causing a storm of server starts - (< (http-transport:server-dat-get-last-access (remote-conndat *runremote*)) expire-time))) + ((and runremote + (remote-conndat runremote) + (let ((expire-time (+ (- start-time (remote-server-timeout runremote))(random 30)))) ;; add 30 seconds of noise so that not all running tests expire at the same time causing a storm of server starts + (< (http-transport:server-dat-get-last-access (remote-conndat runremote)) expire-time))) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8") - (remote-conndat-set! *runremote* #f) + (remote-conndat-set! runremote #f) (mutex-unlock! *rmt-mutex*) (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; ensure we have a record for our connection for given area - ((not *runremote*) + ((not runremote) (set! *runremote* (make-remote)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 1") (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; ensure we have a homehost record - ((not (pair? (remote-hh-dat *runremote*))) ;; not on homehost + ((not (pair? (remote-hh-dat runremote))) ;; not on homehost (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little - (remote-hh-dat-set! *runremote* (common:get-homehost)) + (remote-hh-dat-set! runremote (common:get-homehost)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2") (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; on homehost and this is a read - ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + ((and (cdr (remote-hh-dat runremote)) ;; on homehost (member cmd api:read-only-queries)) ;; this is a read (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 3") (rmt:open-qry-close-locally cmd 0 params)) ;; on homehost and this is a write, we already have a server, but server has died - ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + ((and (cdr (remote-hh-dat runremote)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write - (remote-server-url *runremote*) ;; have a server + (remote-server-url runremote) ;; have a server (not (server:check-if-running *toppath*))) ;; server has died. (set! *runremote* (make-remote)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; on homehost and this is a write, we already have a server - ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + ((and (cdr (remote-hh-dat runremote)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write - (remote-server-url *runremote*)) ;; have a server + (remote-server-url runremote)) ;; have a server (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4") (rmt:open-qry-close-locally cmd 0 params)) ;; on homehost, no server contact made and this is a write, passively start a server - ((and (cdr (remote-hh-dat *runremote*)) ; new - (not (remote-server-url *runremote*)) + ((and (cdr (remote-hh-dat runremote)) ; new + (not (remote-server-url runremote)) (not (member cmd api:read-only-queries))) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5") (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call (if server-url - (remote-server-url-set! *runremote* server-url) ;; the string can be consumed by the client setup if needed + (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed (server:kind-run *toppath*))) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1") (rmt:open-qry-close-locally cmd 0 params)) - ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost - (not (remote-conndat *runremote*))) ;; and no connection - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*)) + ((and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost + (not (remote-conndat runremote))) ;; and no connection + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote)) (mutex-unlock! *rmt-mutex*) (server:start-and-wait *toppath*) - (remote-conndat-set! *runremote* (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http + (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as ;; all set up if get this far, dispatch the query - ((cdr (remote-hh-dat *runremote*)) ;; we are on homehost + ((cdr (remote-hh-dat runremote)) ;; we are on homehost (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 7") (rmt:open-qry-close-locally cmd (if rid rid 0) params)) ;; not on homehost, do server query (else (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") (mutex-lock! *rmt-mutex*) - (let* ((conninfo (remote-conndat *runremote*)) - (dat (case (remote-transport *runremote*) + (let* ((conninfo (remote-conndat runremote)) + (dat (case (remote-transport runremote) ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away (http-transport:client-api-send-receive 0 conninfo cmd params) ((commfail)(vector #f "communications fail")) ((exn)(vector #f "other fail" (print-call-chain))))) (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported") + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported") (exit)))) (success (if (vector? dat) (vector-ref dat 0) #f)) (res (if (vector? dat) (vector-ref dat 1) #f))) (if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time ;; (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " *runremote* = "*runremote*) + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = "runremote) (if success - (case (remote-transport *runremote*) + (case (remote-transport runremote) ((http) (mutex-unlock! *rmt-mutex*) res) (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown") + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " is unknown") (mutex-unlock! *rmt-mutex*) (exit 1))) (begin (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) - (remote-conndat-set! *runremote* #f) - (remote-server-url-set! *runremote* #f) + (remote-conndat-set! runremote #f) + (remote-server-url-set! runremote #f) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1") (mutex-unlock! *rmt-mutex*) (server:start-and-wait *toppath*) (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))))))))) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -8,10 +8,15 @@ (declare (unit runconfig)) (declare (uses common)) (include "common_records.scm") +(define (runconfig:read fname target environ-patt) + (let ((ht (make-hash-table))) + (hash-table-set! ht target '()) + (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) + ;; NB// to process a runconfig ensure to use environ-patt with target! ;; (define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) (let* ((keys (map car keyvals)) (thekey (if keyvals @@ -21,11 +26,11 @@ (begin (debug:print-error 0 *default-log-port* "setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target|default) - (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey))) + (confdat (runconfig:read fname thekey environ-patt)) (whatfound (make-hash-table)) (finaldat (make-hash-table)) (sections (list "default" thekey))) (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code (debug:print 4 *default-log-port* "Using key=\"" thekey "\"") DELETED sample-sauth-paths.scm Index: sample-sauth-paths.scm ================================================================== --- sample-sauth-paths.scm +++ /dev/null @@ -1,4 +0,0 @@ -(define *db-path* "/path/to/db") -(define *exe-path* "/path/to/store/suids") -(define *exe-src* "/path/to/spublish/and/sretrieve/executables") -(define *sauth-path* "/path/to/production/sauthorize/exe") DELETED sauth-common.scm Index: sauth-common.scm ================================================================== --- sauth-common.scm +++ /dev/null @@ -1,263 +0,0 @@ - -;; Create the sqlite db -(define (sauthorize:db-do proc) - (if (or (not *db-path*) - (not (file-exists? *db-path*))) - (begin - (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!") - (exit 1))) - (if (and *db-path* - (directory? *db-path*) - (file-read-access? *db-path*)) - (let* ((dbpath (conc *db-path* "/sauthorize.db")) - (writeable (file-write-access? dbpath)) - (dbexists (file-exists? dbpath))) - (handle-exceptions - exn - (begin - (debug:print 2 "ERROR: problem accessing db " dbpath - ((condition-property-accessor 'exn 'message) exn)) - (exit 1)) - ; (print "calling proc " proc "db path " dbpath ) - (call-with-database - dbpath - (lambda (db) - ;(print 0 "calling proc " proc " on db " db) - (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout - (if (not dbexists)(sauthorize:initialize-db db)) - (proc db))))) - (print 0 "ERROR: invalid path for storing database: " *db-path*))) - -;;execute a query -(define (sauthorize:db-qry db qry) - (exec (sql db qry))) - - -(define (sauthorize:do-as-calling-user proc) - (let ((eid (current-effective-user-id)) - (cid (current-user-id))) - (if (not (eq? eid cid)) ;; running suid - (set! (current-effective-user-id) cid)) - ;(print 0 "cid " cid " eid:" eid) - (proc) - (if (not (eq? eid cid)) - (set! (current-effective-user-id) eid)))) - - -(define (run-cmd cmd arg-list) - ; (print (current-effective-user-id)) - ;(handle-exceptions -; exn -; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert)) - (let ((pid (process-run cmd arg-list))) - (process-wait pid)) -) -;) - - -(define (regster-log inl usr-id area-id cmd) - (sauth-common:shell-do-as-adm - (lambda () - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )"))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; Check user types -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - -;;check if a user is an admin -(define (is-admin username) - (let* ((admin #f)) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'"))))) - (if (not (null? data-row)) - (let ((col (car data-row))) - (if (equal? col "yes") - (set! admin #t))))))) -admin)) - - -;;check if a user is an read-admin -(define (is-read-admin username) - (let* ((admin #f)) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'"))))) - (if (not (null? data-row)) - (let ((col (car data-row))) - (if (equal? col "read-admin") - (set! admin #t))))))) -admin)) - - -;;check if user has specifc role for a area -(define (is-user role username area) - (let* ((has-access #f)) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'"))))) - (if (not (null? data-row)) - (begin - (let* ((access-type (car data-row)) - (exdate (cadr data-row))) - (if (not (null? exdate)) - (begin - (let ((valid (is-access-valid exdate))) - ;(print valid) - (if (and (equal? access-type role) - (equal? valid #t)) - (set! has-access #t)))) - (print "Access expired")))))))) - ;(print has-access) -has-access)) - -(define (is-access-valid exp-str) - (let* ((ret-val #f ) - (date-parts (string-split exp-str "/")) - (yr (string->number (car date-parts))) - (month (string->number(car (cdr date-parts)))) - (day (string->number(caddr date-parts))) - (exp-date (make-date 0 0 0 0 day month yr ))) - ;(print exp-date) - ;(print (current-date)) - (if (> (date-compare exp-date (current-date)) 0) - (set! ret-val #t)) - ;(print ret-val) - ret-val)) - - -;check if area exists -(define (area-exists area) - (let* ((area-defined #f)) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'"))))) - (if (not (null? data-row)) - (set! area-defined #t))))) -area-defined)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; Get Record from database -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;gets area id by code -(define (get-area area) - (let* ((area-defined '())) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'"))))) - (set! area-defined data-row)))) -area-defined)) - -;get id of users table by user name -(define (get-user user) - (let* ((user-defined '())) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'"))))) - (set! user-defined data-row)))) -user-defined)) - -;get permissions id by userid and area id -(define (get-perm userid areaid) - (let* ((user-defined '())) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid))))) - (set! user-defined data-row)))) - -user-defined)) - -(define (get-restrictions base-path usr) -(let* ((user-defined '())) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'"))))) - ;(print data-row) - (set! user-defined data-row)))) - ; (print user-defined) - (if (null? user-defined) - "" - (car user-defined)))) - - -(define (get-obj-by-path path) - (let* ((obj '())) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'"))))) - (set! obj data-row)))) -obj)) - -(define (get-obj-by-code code ) - (let* ((obj '())) - (sauthorize:db-do (lambda (db) - (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'"))))) - (set! obj data-row)))) -;(print obj) -obj)) - - - -;; function to validate the users input for target path and resolve the path -;; TODO: Check for restriction in subpath -(define (sauth-common:resolve-path new current allowed-sheets) - (let* ((target-path (append current (string-split new "/"))) - (target-path-string (string-join target-path "/")) - (normal-path (normalize-pathname target-path-string)) - (normal-list (string-split normal-path "/")) - (ret '())) - (if (string-contains normal-path "..") - (begin - (print "ERROR: Path " new " resolved outside target area ") - #f) - (if(equal? normal-path ".") - ret - (if (not (member (car normal-list) allowed-sheets)) - (begin - (print "ERROR: Permision denied to " new ) - #f) - normal-list))))) - -(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path) - (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )) - (usr (current-user-name) ) ) - (if (not (equal? resolved-path #f)) - (if (null? resolved-path) - #f - (let* ((sheet (car resolved-path)) - (restricted-areas (get-restrictions base-path usr)) - (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*")) - (target-path (if (null? (cdr resolved-path)) - base-path - (conc base-path "/" (string-join (cdr resolved-path) "/"))))) - ; (print restricted-areas) - (if (and (not (equal? restricted-areas "" )) - (string-match (regexp restrictions) target-path)) - (begin - (print "Access denied to " (string-join resolved-path "/")) - ;(exit 1) - #f) - target-path))) - #f))) - -(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) - (if (and (null? base-path-list) (equal? ext-path "") ) - (print (string-intersperse top-areas " ")) - (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))) - ;(print resolved-path) - (if (not (equal? resolved-path #f)) - (if (null? resolved-path) - (print (string-intersperse top-areas " ")) - (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path))) - (print target-path) - (if (not (equal? target-path #f)) - (begin - (cond - ((null? tail-cmd-list) - (run (pipe - (ls "-lrt" ,target-path)))) - ((not (equal? (car tail-cmd-list) "|")) - (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!")) - (else - (run (pipe - (ls "-lrt" ,target-path) - (begin (system (string-join (cdr tail-cmd-list)))))) - ) -))) -)))))) - DELETED sauthorize.scm Index: sauthorize.scm ================================================================== --- sauthorize.scm +++ /dev/null @@ -1,566 +0,0 @@ - -;; Copyright 2006-2013, 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. - -(use defstruct) -(use scsh-process) - -(use srfi-18) -(use srfi-19) -(use refdb) - -(use sql-de-lite srfi-1 posix regex regex-case srfi-69) -(declare (uses common)) - -(declare (uses configf)) -(declare (uses margs)) -(declare (uses megatest-version)) - -(include "megatest-fossil-hash.scm") -;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm. -(include "sauth-paths.scm") -(include "sauth-common.scm") - -;; -;; GLOBALS -;; -(define *verbosity* 1) -(define *logging* #f) -(define *exe-name* (pathname-file (car (argv)))) -(define *sretrieve:current-tab-number* 0) -(define *args-hash* (make-hash-table)) -(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]] - - list : list areas $USER's can access - log : get listing of recent activity. - sauth list-area-user : list the users that can access the area. - sauth open --group : Open up an area. User needs to be the owner of the area to open it. - --code - --retrieve|--publish - sauth grant --area : Grant permission to read or write to a area that is alrady opend up. - --expiration yyyy/mm/dd --retrieve|--publish - [--restrict ] - sauth read-shell : Open sretrieve shell for reading. - sauth write-shell : Open spublish shell for writing. - -Part of the Megatest tool suite. -Learn more at http://www.kiatoa.com/fossils/megatest - -Version: " megatest-fossil-hash)) ;; " - -;;====================================================================== -;; RECORDS -;;====================================================================== - -;;====================================================================== -;; DB -;;====================================================================== - -;; replace (strftime('%s','now')), with datetime('now')) -(define (sauthorize:initialize-db db) - (for-each - (lambda (qry) - (exec (sql db qry))) - (list - "CREATE TABLE IF NOT EXISTS actions - (id INTEGER PRIMARY KEY, - cmd TEXT NOT NULL, - user_id INTEGER NOT NULL, - datetime TIMESTAMP DEFAULT (datetime('now','localtime')), - area_id INTEGER NOT NULL, - comment TEXT DEFAULT '' NOT NULL, - action_type TEXT NOT NULL);" - "CREATE TABLE IF NOT EXISTS users - (id INTEGER PRIMARY KEY, - username TEXT NOT NULL, - is_admin TEXT NOT NULL, - datetime TIMESTAMP DEFAULT (datetime('now','localtime')) - );" - "CREATE TABLE IF NOT EXISTS areas - (id INTEGER PRIMARY KEY, - basepath TEXT NOT NULL, - code TEXT NOT NULL, - exe_name TEXT NOT NULL, - datetime TIMESTAMP DEFAULT (datetime('now','localtime')) - );" - "CREATE TABLE IF NOT EXISTS permissions - (id INTEGER PRIMARY KEY, - access_type TEXT NOT NULL, - user_id INTEGER NOT NULL, - datetime TIMESTAMP DEFAULT (datetime('now','localtime')), - area_id INTEGER NOT NULL, - restriction TEXT DEFAULT '' NOT NULL, - expiration TIMESTAMP DEFAULT NULL);" - ))) - - - - -(define (get-access-type args) - (let loop ((hed (car args)) - (tal (cdr args))) - (cond - ((equal? hed "--retrieve") - "retrieve") - ((equal? hed "--publish") - "publish") - ((equal? hed "--area-admin") - "area-admin") - ((equal? hed "--writer-admin") - "writer-admin") - ((equal? hed "--read-admin") - "read-admin") - - ((null? tal) - #f) - (else - (loop (car tal)(cdr tal)))))) - - - -;; check if user can gran access to an area -(define (can-grant-perm username access-type area) - (let* ((isadmin (is-admin username)) - (is-area-admin (is-user "area-admin" username area )) - (is-read-admin (is-user "read-admin" username area) ) - (is-writer-admin (is-user "writer-admin" username area) ) ) - (cond - ((equal? isadmin #t) - #t) - ((equal? is-area-admin #t ) - #t) - ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve")) - #t) - ((and (equal? is-read-admin #t ) (equal? access-type "retrieve")) - #t) - - (else - #f)))) - -(define (sauthorize:list-areausers area ) - (sauthorize:db-do (lambda (db) - (print "Users having access to " area ":") - (query (for-each-row - (lambda (row) - (let* ((exp-date (cadr row))) - (if (is-access-valid exp-date) - (apply print (intersperse row " | ")))))) - (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'")))))) - - - - -; check if executable exists -(define (exe-exist exe access-type) - (let* ((filepath (conc *exe-path* "/" access-type "/" exe))) - ; (print filepath) - (if (file-exists? filepath) - #t - #f))) - -(define (copy-exe access-type exe-name group) - (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type))) - (let* ((spath (conc *exe-src* "/s" access-type)) - (dpath (conc *exe-path* "/" access-type "/" exe-name))) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd "/bin/cp" (list spath dpath )) - (if (equal? access-type "publish") - (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) - (begin - (if (equal? group "none") - (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath)) - (begin - (run-cmd "/bin/chgrp" (list group dpath)) - (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath)))))))) - (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type))))) - -(define (get-exe-name path group) - (let ((name "")) - (sauthorize:do-as-calling-user - (lambda () - (if (equal? (current-effective-user-id) (file-owner path)) - (set! name (conc (current-user-name) "_" group)) - (begin - (print "You cannot open areas that you dont own!!") - (exit 1))))) -name)) - -(define (sauthorize:valid-unix-user username) - (let* ((ret-val #f)) - (let-values (((inp oup pid) - (process "/usr/bin/id" (list username)))) - (let loop ((inl (read-line inp))) - (if (string? inl) - (if (string-contains inl "No such user") - (set! ret-val #f) - (set! ret-val #t))) - (if (eof-object? inl) - (begin - (close-input-port inp) - (close-output-port oup)) - (loop (read-line inp))))) - ret-val)) - - -;check if a paths/codes are vaid and if area is alrady open -(define (open-area group path code access-type) - (let* ((exe-name (get-exe-name path group)) - (path-obj (get-obj-by-path path)) - (code-obj (get-obj-by-code code))) - ;(print path-obj) - (cond - ((not (null? path-obj)) - (if (equal? code (car path-obj)) - (begin - (if (equal? exe-name (cadr path-obj)) - (begin - (if (not (exe-exist exe-name access-type)) - (copy-exe access-type exe-name group) - (begin - (print "Area already open!!") - (exit 1)))) - (begin - (if (not (exe-exist exe-name access-type)) - (copy-exe access-type exe-name group)) - ;; update exe-name in db - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj))))) - ))) - (begin - (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type ) - (exit 1)))) - - ((not (null? code-obj)) - (print "Code " code " is used for diffrent path. Please try diffrent value of --code" ) - (exit 1)) - (else - ; (print (exe-exist exe-name access-type)) - (if (not (exe-exist exe-name access-type)) - (copy-exe access-type exe-name group)) - (sauthorize:db-do (lambda (db) - ;(print (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') ")) - (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') ")))))))) - -(define (user-has-open-perm user path access) - (let* ((has-access #f) - (eid (current-user-id))) - (cond - ((is-admin user) - (set! has-access #t )) - ((and (is-read-admin user) (equal? access "retrieve")) - (set! has-access #t )) - (else - (print "User " user " does not have permission to open areas"))) - has-access)) - - -;;check if user has group access -(define (is-group-washed req_grpid current-grp-list) - (let loop ((hed (car current-grp-list)) - (tal (cdr current-grp-list))) - (cond - ((equal? hed req_grpid) - #t) - ((null? tal) - #f) - (else - (loop (car tal)(cdr tal)))))) - -;create executables with appropriate suids -(define (sauthorize:open user path group code access-type) - (let* ((gpid (group-information group)) - (req_grpid (if (equal? group "none") - group - (if (equal? gpid #f) - #f - (caddr gpid)))) - (current-grp-list (get-groups)) - (valid-grp (if (equal? group "none") - group - (is-group-washed req_grpid current-grp-list)))) - (if (and (not (equal? group "none")) (equal? valid-grp #f )) - (begin - (print "Group " group " is not washed in the current xterm!!") - (exit 1)))) - (if (not (file-write-access? path)) - (begin - (print "You can open areas owned by yourself. You do not have permissions to open path." path) - (exit 1))) - (if (user-has-open-perm user path access-type) - (begin - ;(print "here") - (open-area group path code access-type) - (sauthorize:grant user user code "2017/12/25" "read-admin" "") - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )")))) - (print "Area has " path " been opened for " access-type )))) - -(define (sauthorize:grant auser guser area exp-date access-type restrict) - ; check if user exist in db - (let* ((area-obj (get-area area)) - (auser-obj (get-user auser)) - (user-obj (get-user guser))) - - (if (null? user-obj) - (begin - ;; is guser a valid unix user - (if (not (sauthorize:valid-unix-user guser)) - (begin - (print "User " guser " is Invalid unix user!!") - (exit 1))) - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') ")))) - (set! user-obj (get-user guser)))) - (let* ((perm-obj (get-perm (car user-obj) (car area-obj)))) - (if(null? perm-obj) - (begin - ;; insert permissions - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')"))))) - (begin - ;update permissions - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj))))))) - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )")))) - (print "Permission has been sucessfully granted to user " guser)))) - -(define (sauthorize:process-action username action . args) - (case (string->symbol action) - ((grant) - (if (< (length args) 6) - (begin - (print "ERROR: Missing arguments; " (string-intersperse args ", ")) - (exit 1))) - (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0)) - (guser (car args)) - (restrict (or (args:get-arg "--restrict") "")) - (area (or (args:get-arg "--area") "")) - (exp-date (or (args:get-arg "--expiration") "")) - (access-type (get-access-type remargs))) - ; (print "version " guser " restrict " restrict ) - ; (print "area " area " exp-date " exp-date " access-type " access-type) - (cond - ((equal? guser "") - (print "Username not found!! Try \"sauthorize help\" for useage ") - (exit 1)) - ((equal? area "") - (print "Area not found!! Try \"sauthorize help\" for useage ") - (exit 1)) - ((equal? access-type #f) - (print "Access type not found!! Try \"sauthorize help\" for useage ") - (exit 1)) - ((equal? exp-date "") - (print "Date of expiration not found!! Try \"sauthorize help\" for useage ") - (exit 1))) - (if (not (area-exists area)) - (begin - (print "Area does not exisit!!") - (exit 1))) - (if (can-grant-perm username access-type area) - (begin - (print "calling sauthorize:grant ") - (sauthorize:grant username guser area exp-date access-type restrict)) - (begin - (print "User " username " does not have permission to grant permissions to area " area "!!") - (exit 1))))) - ((list-area-user) - (if (not (equal? (length args) 1)) - (begin - (print "Missing argument area code to list-area-user ") - (exit 1))) - (let* ((area (car args))) - (if (not (area-exists area)) - (begin - (print "Area does not exisit!!") - (exit 1))) - - (sauthorize:list-areausers area ) - )) - ((read-shell) - (if (not (equal? (length args) 1)) - (begin - (print "Missing argument area code to read-shell ") - (exit 1))) - (let* ((area (car args)) - (code-obj (get-obj-by-code area))) - (if (or (null? code-obj) - (not (exe-exist (cadr code-obj) "retrieve"))) - (begin - (print "Area " area " is not open for reading!!") - (exit 1))) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area )))))) - ((write-shell) - (if (not (equal? (length args) 1)) - (begin - (print "Missing argument area code to read-shell ") - (exit 1))) - (let* ((area (car args)) - (code-obj (get-obj-by-code area))) - (if (or (null? code-obj) - (not (exe-exist (cadr code-obj) "publish"))) - (begin - (print "Area " area " is not open for Writing!!") - (exit 1))) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area)))))) - ((publish) - (if (< (length args) 2) - (begin - (print "Missing argument to publish. \n publish [opts] ") - (exit 1))) - (let* ((action (car args)) - (area (cadr args)) - (cmd-args (cddr args)) - (code-obj (get-obj-by-code area))) - (if (or (null? code-obj) - (not (exe-exist (cadr code-obj) "publish"))) - (begin - (print "Area " area " is not open for writing!!") - (exit 1))) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args)))))) - - ((retrieve) - (if (< (length args) 2) - (begin - (print "Missing argument to publish. \n publish [opts] ") - (exit 1))) - (let* ((action (car args)) - (area (cadr args)) - (cmd-args (cddr args)) - (code-obj (get-obj-by-code area))) - (if (or (null? code-obj) - (not (exe-exist (cadr code-obj) "retrieve"))) - (begin - (print "Area " area " is not open for reading!!") - (exit 1))) - (sauthorize:do-as-calling-user - (lambda () - (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args)))))) - - - - ((open) - (if (< (length args) 6) - (begin - (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open --group --code --retrieve|--publish") - (exit 1))) - (let* ((remargs (args:get-args args '("--group" "--code") '() args:arg-hash 0)) - (path (car args)) - (group (or (args:get-arg "--group") "")) - (area (or (args:get-arg "--code") "")) - (access-type (get-access-type remargs))) - (cond - ((equal? path "") - (print "path not found!! Try \"sauthorize help\" for useage ") - (exit 1)) - ((equal? area "") - (print "--code not found!! Try \"sauthorize help\" for useage ") - (exit 1)) - ((equal? access-type #f) - (print "Access type not found!! Try \"sauthorize help\" for useage ") - (exit 1)) - ((and (not (equal? access-type "publish")) - (not (equal? access-type "retrieve"))) - (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ") - (exit 1))) - - (sauthorize:open username path group area access-type))) - ((area-admin) - (let* ((usr (car args)) - (usr-obj (get-user usr)) - (user-id (car (get-user username)))) - - (if (is-admin username) - (begin - ; (print usr-obj) - (if (null? usr-obj) - (begin - (sauthorize:db-do (lambda (db) - ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")) - (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))))) - (begin - ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) )) - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj))))))) - (print "User " usr " is updated with area-admin access!")) - (print "Admin only function")) - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" )))))) - - ((register-log) - (if (< (length args) 4) - (print "Invalid arguments")) - ;(print args) - (let* ((cmd-line (car args)) - (user-id (cadr args)) - (area-id (caddr args)) - (user-obj (get-user username)) - (cmd (cadddr args))) - - (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj)))) - (begin - (sauthorize:db-do (lambda (db) - (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" ))))) - (print "You ar not authorised to run this cmd") - -))) - - - (else (print 0 "Unrecognised command " action)))) - -(define (main) - (let* ((args (argv)) - (prog (car args)) - (rema (cdr args)) - (username (current-user-name))) - ;; preserve the exe data in the config file - (cond - ;; one-word commands - ((eq? (length rema) 1) - (case (string->symbol (car rema)) - ((help -h -help --h --help) - (print sauthorize:help)) - ((list) - - (sauthorize:db-do (lambda (db) - (print "My Area accesses: ") - (query (for-each-row - (lambda (row) - (let* ((exp-date (car row))) - (if (is-access-valid exp-date) - (apply print (intersperse (cdr row) " | ")))))) - (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'")))))) - - ((log) - (sauthorize:db-do (lambda (db) - (print "Logs : ") - (query (for-each-row - (lambda (row) - - (apply print (intersperse row " | ")))) - (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id "))))) - (else - (print "ERROR: Unrecognised command. Try \"sauthorize help\"")))) - ;; multi-word commands - ((null? rema)(print sauthorize:help)) - ((>= (length rema) 2) - (apply sauthorize:process-action username (car rema)(cdr rema))) - (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\""))))) - -(main) - - - DELETED thunk-utils.scm Index: thunk-utils.scm ================================================================== --- thunk-utils.scm +++ /dev/null @@ -1,121 +0,0 @@ -(use srfi-18) - - -;; wrap a proc with a mutex so that two threads may not call proc simultaneously. -;; will catch exceptions to ensure mutex is unlocked even if exception is thrown. -;; will generate a unique mutex for proc unless one is specified with canned-mutex: option -;; -;; example 1: (define thread-safe-+ (make-synchronized-proc +)) -;; example 2: (define thread-safe-plus -;; (make-synchronized-proc -;; (lambda (x y) -;; (+ x y)))) - -(define (make-synchronized-proc proc - #!key (canned-mutex #f)) - (let* ((guard-mutex (if canned-mutex canned-mutex (make-mutex))) - (guarded-proc ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result. - (lambda args - (mutex-lock! guard-mutex) - (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision with a proc that returns a pair having the first element be our flag. gensym guarantees the symbol is unique. - (res - (condition-case - (apply proc args) ;; this is what we are guarding the execution of - [x () (cons EXCEPTION x)] - ))) - (mutex-unlock! guard-mutex) - (cond - ((and (pair? res) (eq? (car res) EXCEPTION)) - (raise (cdr res))) - (else - res)))))) - guarded-proc)) - - -;; retry an operation (depends on srfi-18) -;; ================== -;; idea here is to avoid spending time on coding retrying something. Trying to be generic here. -;; -;; Exception handling: -;; ------------------- -;; if evaluating the thunk results in exception, it will be retried. -;; on last try, if final-failure-returns-actual is true, the exception will be re-thrown to caller. -;; -;; look at options below #!key to see how to configure behavior -;; -;; - -(define (retry-thunk - the-thunk - #!key ;;;; options below - (accept-result? (lambda (x) x)) ;; retry if predicate applied to thunk's result is false - (retries 4) ;; how many tries - (failure-value #f) ;; return this on final failure, unless following option is enabled: - (final-failure-returns-actual #f) ;; on failure, on the last try, just return the result, not failure-value - - (retry-delay 0.1) ;; delay between tries - (back-off-factor 1) ;; multiply retry-delay by this factor on retry - (random-delay 0.1) ;; add a random portion of this value to wait - - (chatty #f) ;; print status as we go, for debugging. - ) - - (when chatty (print) (print "Entered retry-thunk") (print "-=-=-=-=-=-")) - (let* ((guarded-thunk ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result. - (lambda () - (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision - (res - (condition-case - (the-thunk) ;; this is what we are guarding the execution of - [x () (cons EXCEPTION x)] - ))) - (cond - ((and (pair? res) (eq? (car res) EXCEPTION)) - (if chatty - (print " - the-thunk threw exception >"(cdr res)"<")) - (cons 'exception (cdr res))) - (else - (if chatty - (print " - the-thunk returned result >"res"<")) - (cons 'regular-result res))))))) - - (let loop ((guarded-res (guarded-thunk)) - (retries-left retries) - (fail-wait retry-delay)) - (if chatty (print " ==========")) - (let* ((wait-time (+ fail-wait (+ (* fail-wait back-off-factor) - (* random-delay - (/ (random 1024) 1024) )))) - (res-type (car guarded-res)) - (res-value (cdr guarded-res))) - (cond - ((and (eq? res-type 'regular-result) (accept-result? res-value)) - (if chatty (print " + return result that satisfied accept-result? >"res-value"<")) - res-value) - - ((> retries-left 0) - (if chatty (print " - sleep "wait-time)) - (thread-sleep! wait-time) - (if chatty (print " + retry ["retries-left" tries left]")) - (loop (guarded-thunk) - (sub1 retries-left) - wait-time)) - - ((eq? res-type 'regular-result) - (if final-failure-returns-actual - (begin - (if chatty (print " + last try failed- return the result >"res-value"<")) - res-value) - (begin - (if chatty (print " + last try failed- return canned failure value >"failure-value"<")) - failure-value))) - - (else ;; no retries left; result was not accepted and res-type can only be 'exception - (if final-failure-returns-actual - (begin - (if chatty (print " + last try failed with exception- re-throw it >"res-value"<")) - (abort res-value)); re-raise the exception. TODO: find a way for call-history to show as though from entry to this function - (begin - (if chatty (print " + last try failed with exception- return canned failure value >"failure-value"<")) - failure-value)))))))) - Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -1,7 +1,10 @@ #! /usr/bin/env bash +# This file installs prerequisites for megatest (chicken, eggs, etc.) +# Before running this script, set PREFIX environment variable +# to chicken install target area. /opt/chicken is a typical value # set -x # Copyright 2007-2014, Matthew Welland. # # This program is made available under the GNU GPL version 2.0 or @@ -8,16 +11,20 @@ # 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. + +if [[ $OPTION=="" ]]; then + export OPTION=std +fi echo You may need to do the following first: echo sudo apt-get install libreadline-dev echo sudo apt-get install libwebkitgtk-dev echo sudo apt-get install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake -echo sudo apt-get install libssl-dev +echo sudo apt-get install libssl-dev uuid-dev echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 echo echo Set OPTION to std, currently OPTION=$OPTION echo echo Additionally, if you want mysql-client, you will need to make sure @@ -56,11 +63,11 @@ CDVER=5.4.1 IUPVER=3.5 IMVER=3.6.3 ;; esac - + echo KTYPE=$KTYPE echo CDVER=$CDVER echo IUPVER=$IUPVER echo IMVER=$IMVER # NOTES: @@ -172,11 +179,24 @@ tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) fi fi fi + + + cd $BUILDHOME +for egg in "sqlite3" sql-de-lite # nanomsg +do + echo "Installing $egg" + CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg + #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg + if [ $? -ne 0 ]; then + echo "$egg failed to install" + exit 1 + fi +done # Some eggs are quoted since they are reserved to Bash # for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do # $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing for egg in matchable readline apropos base64 regex-literals format "regex-case" "test" \ @@ -206,20 +226,10 @@ if [[ -e `which mysql_config` ]]; then $CHICKEN_INSTALL $PROX -keep-installed mysql-client fi -for egg in "sqlite3" sql-de-lite # nanomsg -do - echo "Installing $egg" - CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg - #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg - if [ $? -ne 0 ]; then - echo "$egg failed to install" - exit 1 - fi -done cd $BUILDHOME cd `$PREFIX/bin/csi -p '(chicken-home)'` curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx cd $BUILDHOME @@ -342,12 +352,18 @@ CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw cd $BUILDHOME +# install ducttape +cd ../ducttape +$CHICKEN_INSTALL + +cd $BUILDHOME echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh echo file can be found in the current directory which should work for setting up to run chicken4x + echo Testing iup $PREFIX/bin/csi -b -eval '(use iup)(print "Success")'