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 diff-report.scm pgdb.scm + portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.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 \ ADDED cgisetup/models/pgdb.scm Index: cgisetup/models/pgdb.scm ================================================================== --- /dev/null +++ cgisetup/models/pgdb.scm @@ -0,0 +1,224 @@ +;;====================================================================== +;; Copyright 2017, 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. +;;====================================================================== + +(declare (unit pgdb)) +(declare (uses configf)) + +;; I don't know how to mix compilation units and modules, so no module here. +;; +;; (module pgdb +;; ( +;; open-pgdb +;; ) +;; +;; (import scheme) +;; (import data-structures) +;; (import chicken) + +(use typed-records (prefix dbi dbi:)) + +;; given a configdat lookup the connection info and open the db +;; +(define (pgdb:open configdat #!key (dbname #f)) + (let ((pgconf (configf:lookup configdat "ext-sync" (or dbname "pgdb")))) + (if pgconf + (let* ((confdat (map (lambda (conf-item) + (let ((parts (string-split conf-item ":"))) + (if (> (length parts) 1) + (let ((key (car parts)) + (val (cadr parts))) + (cons (string->symbol key) val)) + (begin + (print "ERROR: Bad config setting " conf-item ", should be key:val") + `(,(string->symbol (car parts)) . #f))))) + (string-split pgconf))) + (dbtype (string->symbol (or (alist-ref 'dbtype confdat) "pg")))) + (if (alist-ref 'dbtype confdat) + (dbi:open dbtype (alist-delete 'dbtype confdat)))) + #f))) + +;;====================================================================== +;; A R E A S +;;====================================================================== + +(defstruct area id area-name area-path last-update) + +(define (pgdb:add-area dbh area-name area-path) + (dbi:exec dbh "INSERT INTO areas (area_name,area_path) VALUES (?,?)" area-name area-path)) + +(define (pgdb:get-areas dbh) + ;; (map + ;; (lambda (row) + ;; (print "row: " row)) + (dbi:get-rows dbh "SELECT id,area_name,area_path,last_sync FROM areas;")) ;; ) + +;; given an area_path get the area info +;; +(define (pgdb:get-area-by-path dbh area-path) + (dbi:get-one-row dbh "SELECT id,area_name,area_path,last_sync FROM areas WHERE area_path=?;" area-path)) + +(define (pgdb:write-sync-time dbh area-info new-sync-time) + (let ((area-id (vector-ref area-info 0))) + (dbi:exec dbh "UPDATE areas SET last_sync=? WHERE id=?;" new-sync-time area-id))) + +;;====================================================================== +;; T A R G E T S +;;====================================================================== + +;; Given a target-spec, return the id. Should probably handle this with a join... +;; if target-spec not found, create a record for it. +;; +(define (pgdb:get-ttype dbh target-spec) + (let ((spec-id (dbi:get-one dbh "SELECT id FROM ttype WHERE target_spec=?;" target-spec))) + (or spec-id + (if (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* "ERROR: cannot create ttype entry, " ((condition-property-accessor 'exn 'message) exn)) + #f) + (dbi:exec dbh "INSERT INTO ttype (target_spec) VALUES (?);" target-spec)) + (pgdb:get-ttype dbh target-spec))))) + +;;====================================================================== +;; R U N S +;;====================================================================== + +;; given a target spec id, target and run-name return the run-id +;; if no run found return #f +;; +(define (pgdb:get-run-id dbh spec-id target run-name) + (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=?;" + spec-id target run-name)) + +;; given a run-id return all the run info +;; +(define (pgdb:get-run-info dbh run-id) ;; to join ttype or not? + (dbi:get-one-row + dbh ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 + "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id + FROM runs WHERE id=?;" run-id)) + +;; refresh the data in a run record +;; +(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count) ;; area-id) + (dbi:exec + dbh + "UPDATE runs SET + state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? + WHERE id=?;" + state status owner event-time comment fail-count pass-count run-id)) + +;; given all needed info create run record +;; +(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count) + (dbi:exec + dbh + "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count) + VALUES (?,?,?,?,?,?,?,?,?,?);" + ttype-id target run-name state status owner event-time comment fail-count pass-count)) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +;; given run-id, test_name and item_path return test-id +;; +(define (pgdb:get-test-id dbh run-id test-name item-path) + (dbi:get-one + dbh + "SELECT id FROM tests WHERE run_id=? AND test_name=? AND item_path=?;" + run-id test-name item-path)) + +;; create new test record +;; +(define (pgdb:insert-test dbh run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived) + (dbi:exec + dbh + "INSERT INTO tests (run_id,test_name,item_path,state,status,host,cpuload,diskfree,uname,rundir,final_logf,run_duration,comment,event_time,archived) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);" + + run-id test-name item-path state status host cpuload diskfree uname + run-dir log-file run-duration comment event-time archived)) + +;; update existing test record +;; +(define (pgdb:update-test dbh test-id run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived) + (dbi:exec + dbh + "UPDATE tests SET + run_id=?,test_name=?,item_path=?,state=?,status=?,host=?,cpuload=?,diskfree=?,uname=?,rundir=?,final_logf=?,run_duration=?,comment=?,event_time=?,archived=? + WHERE id=?;" + + run-id test-name item-path state status host cpuload diskfree uname + run-dir log-file run-duration comment event-time archived test-id)) + +(define (pgdb:get-tests dbh target-patt) + (dbi:get-rows + dbh + "SELECT t.id,t.run_id,t.test_name,t.item_path,t.state,t.status,t.host,t.cpuload,t.diskfree,t.uname,t.rundir,t.final_logf,t.run_duration,t.comment,t.event_time,t.archived, + r.id,r.target,r.ttype_id,r.run_name,r.state,r.status,r.owner,r.event_time,r.comment + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE r.target LIKE ?;" target-patt)) + +(define (pgdb:get-stats-given-target dbh target-patt) + (dbi:get-rows + dbh + "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY t.status,r.target;" target-patt)) + +(define (pgdb:get-target-types dbh) + (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;")) + +;; +(define (pgdb:get-targets dbh target-patt) + (let ((ttypes (pgdb:get-target-types dbh))) + (map + (lambda (ttype-dat) + (let ((tt-id (vector-ref ttype-dat 0)) + (ttype (vector-ref ttype-dat 1))) + (cons ttype + (dbi:get-rows + dbh + "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt tt-id)) + )) + ttypes))) + +(define (pgdb:get-targets-of-type dbh ttype-id target-patt) + (dbi:get-rows dbh "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt ttype-id)) + +;;====================================================================== +;; V A R I O U S D A T A M A S S A G E R O U T I N E S +;;====================================================================== + +;; probably want to move these to a different model file + +;; create a hash of hashes with keys extracted from all-parts +;; using row-or-col to choose row or column +;; ht{row key}=>ht{col key}=>data +;; +(define (pgdb:coalesce-runs dbh runs all-parts row-or-col) + (let* ((data (make-hash-table))) + ;; (rnums ( + ;; for now just do first => remainder + (for-each + (lambda (run) + (let* ((target (vector-ref run 2)) + (parts (string-split target "/")) + (first (car parts)) + (rest (string-intersperse (cdr parts) "/")) + (coldat (hash-table-ref/default data first #f))) + (if (not coldat)(let ((newht (make-hash-table))) + (hash-table-set! data first newht) + (set! coldat newht))) + (hash-table-set! coldat rest run))) + runs) + data)) Index: cgisetup/pages/index.scm ================================================================== --- cgisetup/pages/index.scm +++ cgisetup/pages/index.scm @@ -1,14 +1,15 @@ -;; (require-library chicken) -;; (import chicken) - -(include "../../pgdb.scm") -(declare (uses pgdb)) - -;; (include "src/common_records.scm") -(include "pages/index_ctrl.scm") -(define (pages:index session db shared) - ;; (s:log " HTTP_COOKIE=" (get-environment-variable "HTTP_COOKIE")) - (include "pages/index_view.scm") - ;; (s:html (s:head "head")(s:body "Got here" (current-directory))) -) +;;====================================================================== +;; Copyright 2017, 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. +;;====================================================================== + +(load "models/pgdb.scm") +(include "pages/index_ctrl.scm") +(include "pages/index_view.scm") Index: cgisetup/pages/index_ctrl.scm ================================================================== --- cgisetup/pages/index_ctrl.scm +++ cgisetup/pages/index_ctrl.scm @@ -14,15 +14,26 @@ (define (index-action action) (case (string->symbol action) ((filter) (let ((target-type (s:get-input 'target-type)) (target-filter (s:get-input 'tfilter)) - (target (s:get-input 'target))) + (target (s:get-input 'target)) + (row-or-col (s:get-input 'row-or-col))) + ;; should not be using session vars for these, session vars are not multi-tab + ;; resistant (thinking of you Jeff!) + (s:session-var-set! "row-or-col" (if (list? row-or-col) + (string-intersperse row-or-col ",") + row-or-col)) (s:session-var-set! "target-type" target-type) (s:set! "tfilter" target-filter) (s:session-var-set! "target" target) (s:session-var-set! "target-filter" target-filter))))) + +;;====================================================================== +;; Below are the raw chunks of html, css and jquery stuff needed to make +;; html kickstart and other useful things work +;;====================================================================== (define index:kickstart-junk #< @@ -53,14 +64,13 @@ #< EOF )) - (define index:javascript #< EOF ) Index: cgisetup/pages/index_view.scm ================================================================== --- cgisetup/pages/index_view.scm +++ cgisetup/pages/index_view.scm @@ -7,52 +7,117 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -;; index - -(let* ((dbh (s:db)) - (ttypes (pgdb:get-target-types dbh)) - (selected (string->number (or (s:session-var-get "target-type") "0"))) - (tfilter (or (s:session-var-get "target-filter") "%")) - (targets (pgdb:get-targets-of-type dbh selected tfilter)) - (target (s:session-var-get "target"))) - (list - "" - (s:html - (s:title (conc "Megatest")) - (s:head - index:kickstart-junk - ) - (s:body - (s:div 'class "grid flex" 'id "top_of_page" - ;; add visible to columns to help visualize them e.g. "col_12 visible" - ;; BEGINNING OF HEADER - (s:div 'class "col_12" - (s:form - 'action "index.filter" 'method "post" - (s:select (map (lambda (x) - (let ((tt-id (vector-ref x 0)) - (ttype (vector-ref x 1))) - (if (eq? tt-id selected) - (list ttype tt-id ttype #t) - (list ttype tt-id ttype #f)))) - ttypes) - 'name 'target-type) - (s:input-preserve 'name "tfilter" 'placeholder "Filter targets") - (s:select (map (lambda (x) - (let ((t (vector-ref x 0))) - (list t t t (equal? t target)))) - targets) - 'name 'target) - (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit" 'class "col_3") - ;; (s:h1 (s:session-var-get "target-type")) - (map (lambda (area) - (s:p "data=" (conc area))) - ;; (pgdb:get-tests dbh (or target "%")) - (pgdb:get-stats-given-target dbh (or target "%")) - ) - index:jquery - index:javascript - ))))))) - +(define (pages:index session db shared) + (let* ((dbh (s:db)) + (ttypes (pgdb:get-target-types dbh)) + (selected (string->number (or (s:session-var-get "target-type") "0"))) + (curr-trec (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes)) + (curr-ttype (if (and selected + (not (null? curr-trec))) + (vector-ref (car curr-trec) 1) #f)) + (all-parts (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '())) + (tfilter (or (s:session-var-get "target-filter") "%")) + (targets (pgdb:get-targets-of-type dbh selected tfilter)) + ;; (target (s:session-var-get "target")) + ;; (target-patt (or target "%")) + (row-or-col (string-split (or (s:session-var-get "row-or-col") "") ",")) + (all-data (pgdb:get-stats-given-target dbh tfilter)) + ;; (all-data (pgdb:get-tests dbh tfilter)) + (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col))) + + (list + "" + (s:html + (s:title (conc "Megatest")) + (s:head + index:kickstart-junk + ) + (s:body + ;; (s:session-var-get "target-type") + ;; (conc " selected = " selected ", ttypes = " ttypes ", curr-ttype = " curr-ttype ", curr-trec = " curr-trec) + (conc (hash-table->alist ordered-data)) + (s:div 'class "grid flex" 'id "top_of_page" + ;; add visible to columns to help visualize them e.g. "col_12 visible" + ;; BEGINNING OF HEADER + (s:div 'class "col_12" + (s:fieldset + "Area type and target filter" + (s:form + 'action "index.filter" 'method "post" + (s:div 'class "col_12" + (s:select (map (lambda (x) + (let ((tt-id (vector-ref x 0)) + (ttype (vector-ref x 1))) + (if (eq? tt-id selected) + (list ttype tt-id ttype #t) + (list ttype tt-id ttype #f)))) + ttypes) + 'name 'target-type) + (s:input-preserve 'name "tfilter" 'placeholder "Filter targets") + (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit" 'class "col_3")) + ;; use radio buttons to select whether to put this identifier in row or column. + ;; this seems clumsly and takes up a lot of screen realestate + (s:div 'class "col_12" + (s:div 'class "col_1" "identifier") + (map (lambda (target-var) + (s:div 'class "col_1" target-var)) + all-parts)) + (s:div 'class "col_12" + (s:div 'class "col_1" "row") + (map (lambda (target-var) + (s:div 'class "col_1" (s:input 'type "checkbox" 'name "row-or-col" 'value target-var + ;; this silly trick preserves the checkmark + (if (member target-var row-or-col) 'checked "") + ""))) + all-parts)))) + (s:fieldset + (conc "Runs data for " tfilter) + ;; + ;; This is completely wrong!!! However it may provide some ideas! + ;; + (s:table + (map + (lambda (key) + (let ((subdat (hash-table-ref ordered-data key))) + (s:tr (s:td key) + (map + (lambda (remkey) + (s:td remkey + (let ((dat (hash-table-ref subdat remkey))) + (s:td (vector-ref dat 1) (vector-ref dat 0))))) + (sort (hash-table-keys subdat) string>=?))))) + (sort (hash-table-keys ordered-data) string>=?))) + + ;;(map (lambda (area) + ;; (s:p "data=" (conc area))) + ;; ;; (pgdb:get-tests dbh tfilter)) + ;; (pgdb:get-stats-given-target dbh tfilter)) + + + + + index:jquery + index:javascript + )))))))) + + + ;; (s:div 'class "col_12" + ;; (s:div 'class "col_1" "row") + ;; (map (lambda (target-var) + ;; (s:div 'class "col_1" (s:input 'type "radio" 'name target-var 'value "row"))) + ;; all-parts)) + ;; (s:div 'class "col_12" + ;; (s:div 'class "col_1" "col") + ;; (map (lambda (target-var) + ;; (s:div 'class "col_1" (s:input 'type "radio" 'name target-var 'value "col"))) + ;; all-parts))) + ;; '()) + ;; (s:h1 (s:session-var-get "target-type")) + + ;; (s:select (map (lambda (x) + ;; (let ((t (vector-ref x 0))) + ;; (list t t t (equal? t target)))) + ;; targets) + ;; 'name 'target) DELETED pgdb.scm Index: pgdb.scm ================================================================== --- pgdb.scm +++ /dev/null @@ -1,197 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2017, 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. -;;====================================================================== - -(declare (unit pgdb)) -(declare (uses configf)) - -;; I don't know how to mix compilation units and modules, so no module here. -;; -;; (module pgdb -;; ( -;; open-pgdb -;; ) -;; -;; (import scheme) -;; (import data-structures) -;; (import chicken) - -(use typed-records (prefix dbi dbi:)) - -;; given a configdat lookup the connection info and open the db -;; -(define (pgdb:open configdat #!key (dbname #f)) - (let ((pgconf (configf:lookup configdat "ext-sync" (or dbname "pgdb")))) - (if pgconf - (let* ((confdat (map (lambda (conf-item) - (let ((parts (string-split conf-item ":"))) - (if (> (length parts) 1) - (let ((key (car parts)) - (val (cadr parts))) - (cons (string->symbol key) val)) - (begin - (print "ERROR: Bad config setting " conf-item ", should be key:val") - `(,(string->symbol (car parts)) . #f))))) - (string-split pgconf))) - (dbtype (string->symbol (or (alist-ref 'dbtype confdat) "pg")))) - (if (alist-ref 'dbtype confdat) - (dbi:open dbtype (alist-delete 'dbtype confdat)))) - #f))) - -;;====================================================================== -;; A R E A S -;;====================================================================== - -(defstruct area id area-name area-path last-update) - -(define (pgdb:add-area dbh area-name area-path) - (dbi:exec dbh "INSERT INTO areas (area_name,area_path) VALUES (?,?)" area-name area-path)) - -(define (pgdb:get-areas dbh) - ;; (map - ;; (lambda (row) - ;; (print "row: " row)) - (dbi:get-rows dbh "SELECT id,area_name,area_path,last_sync FROM areas;")) ;; ) - -;; given an area_path get the area info -;; -(define (pgdb:get-area-by-path dbh area-path) - (dbi:get-one-row dbh "SELECT id,area_name,area_path,last_sync FROM areas WHERE area_path=?;" area-path)) - -(define (pgdb:write-sync-time dbh area-info new-sync-time) - (let ((area-id (vector-ref area-info 0))) - (dbi:exec dbh "UPDATE areas SET last_sync=? WHERE id=?;" new-sync-time area-id))) - -;;====================================================================== -;; T A R G E T S -;;====================================================================== - -;; Given a target-spec, return the id. Should probably handle this with a join... -;; if target-spec not found, create a record for it. -;; -(define (pgdb:get-ttype dbh target-spec) - (let ((spec-id (dbi:get-one dbh "SELECT id FROM ttype WHERE target_spec=?;" target-spec))) - (or spec-id - (if (handle-exceptions - exn - (begin - (print-call-chain) - (debug:print 0 *default-log-port* "ERROR: cannot create ttype entry, " ((condition-property-accessor 'exn 'message) exn)) - #f) - (dbi:exec dbh "INSERT INTO ttype (target_spec) VALUES (?);" target-spec)) - (pgdb:get-ttype dbh target-spec))))) - -;;====================================================================== -;; R U N S -;;====================================================================== - -;; given a target spec id, target and run-name return the run-id -;; if no run found return #f -;; -(define (pgdb:get-run-id dbh spec-id target run-name) - (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=?;" - spec-id target run-name)) - -;; given a run-id return all the run info -;; -(define (pgdb:get-run-info dbh run-id) ;; to join ttype or not? - (dbi:get-one-row - dbh ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 - "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id - FROM runs WHERE id=?;" run-id)) - -;; refresh the data in a run record -;; -(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count) ;; area-id) - (dbi:exec - dbh - "UPDATE runs SET - state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? - WHERE id=?;" - state status owner event-time comment fail-count pass-count run-id)) - -;; given all needed info create run record -;; -(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count) - (dbi:exec - dbh - "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count) - VALUES (?,?,?,?,?,?,?,?,?,?);" - ttype-id target run-name state status owner event-time comment fail-count pass-count)) - -;;====================================================================== -;; T E S T S -;;====================================================================== - -;; given run-id, test_name and item_path return test-id -;; -(define (pgdb:get-test-id dbh run-id test-name item-path) - (dbi:get-one - dbh - "SELECT id FROM tests WHERE run_id=? AND test_name=? AND item_path=?;" - run-id test-name item-path)) - -;; create new test record -;; -(define (pgdb:insert-test dbh run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived) - (dbi:exec - dbh - "INSERT INTO tests (run_id,test_name,item_path,state,status,host,cpuload,diskfree,uname,rundir,final_logf,run_duration,comment,event_time,archived) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);" - - run-id test-name item-path state status host cpuload diskfree uname - run-dir log-file run-duration comment event-time archived)) - -;; update existing test record -;; -(define (pgdb:update-test dbh test-id run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived) - (dbi:exec - dbh - "UPDATE tests SET - run_id=?,test_name=?,item_path=?,state=?,status=?,host=?,cpuload=?,diskfree=?,uname=?,rundir=?,final_logf=?,run_duration=?,comment=?,event_time=?,archived=? - WHERE id=?;" - - run-id test-name item-path state status host cpuload diskfree uname - run-dir log-file run-duration comment event-time archived test-id)) - -(define (pgdb:get-tests dbh target-patt) - (dbi:get-rows - dbh - "SELECT t.id,t.run_id,t.test_name,t.item_path,t.state,t.status,t.host,t.cpuload,t.diskfree,t.uname,t.rundir,t.final_logf,t.run_duration,t.comment,t.event_time,t.archived, - r.id,r.target,r.ttype_id,r.run_name,r.state,r.status,r.owner,r.event_time,r.comment - FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id - WHERE r.target LIKE ?;" target-patt)) - -(define (pgdb:get-stats-given-target dbh target-patt) - (dbi:get-rows - dbh - "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id - WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY t.status,r.target;" target-patt)) - -(define (pgdb:get-target-types dbh) - (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;")) - -;; -(define (pgdb:get-targets dbh target-patt) - (let ((ttypes (pgdb:get-target-types dbh))) - (map - (lambda (ttype-dat) - (let ((tt-id (vector-ref ttype-dat 0)) - (ttype (vector-ref ttype-dat 1))) - (cons ttype - (dbi:get-rows - dbh - "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt tt-id)) - )) - ttypes))) - -(define (pgdb:get-targets-of-type dbh ttype-id target-patt) - (dbi:get-rows dbh "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt ttype-id)) -