Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch test-dashboard Excluding Merge-Ins
This is equivalent to a diff from b1400ebb42 to 44eb5d574e
2019-08-14
| ||
16:54 | Merge the test dashboard development line into trunk. (check-in: ed6e0d08a7 user: drh tags: trunk) | |
2019-08-12
| ||
10:27 | Minor improvements to dashboard. (Closed-Leaf check-in: 44eb5d574e user: drh tags: test-dashboard) | |
2019-08-07
| ||
19:23 | Minor changes to the dashboard. (check-in: 90a47a80c2 user: drh tags: test-dashboard) | |
2019-08-02
| ||
17:54 | In the checklist application, improve the submenu and simplify the login processing. (Originally checked in on the wrong branch.) (check-in: ee656f1e92 user: drh tags: trunk) | |
2019-08-01
| ||
20:50 | Initial code for a testing dashboard application. Not yet functional. (check-in: 67d3af93de user: drh tags: test-dashboard) | |
16:46 | Update the /env method of the checklist application to work better with the latest version of Wapp for CGI. (check-in: b1400ebb42 user: drh tags: trunk) | |
16:36 | Fix the checklist editing function on the checklist application so that it works correctly with Fossil CGI. (check-in: 9d872b74d9 user: drh tags: trunk) | |
Changes to misc/checklist.tcl.
︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 | } wapp-subst {</ol></div>\n</html>\n} } # Show the CGI environment for testing purposes. # proc wapp-page-env {} { sqlite3 db :memory: set v [db one {SELECT sqlite_source_id()}] | > < > | | | | < | < < | < < < | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | } wapp-subst {</ol></div>\n</html>\n} } # Show the CGI environment for testing purposes. # proc wapp-page-env {} { checklist-common-header sqlite3 db :memory: set v [db one {SELECT sqlite_source_id()}] wapp-trim { <div class='fossil-doc' data-title='Checklist Environment'> <pre>%html([wapp-debug-env])} wapp-subst {SQLite = %html($v)</pre>\n</div>\n} checklist-common-footer } # Show the complete text of this script. # proc wapp-page-self {} { wapp-cache-control max-age=3600 checklist-common-header set fd [open [wapp-param SCRIPT_FILENAME] rb] set script [read $fd] close $fd wapp-trim { <p>The following is the complete text of the <a href='https://wapp.tcl.tk/'>Wapp script</a> that implements this <a href='https://fossil-scm.org/home/doc/trunk/www/serverext.wiki'>Fossil CGI extension</a>:</p> <pre>%html($script)</pre> } checklist-common-footer } # Check user permissions provided to use by Fossil in the FOSSIL_USER # and FOSSIL_CAPABILITIES environment variables. Set the Wapp parameters # as follows: # # CKLIST_USER Name of the user. Empty string if not logged in # CKLIST_WRITE True if the user is allowed to make updates # CKLIST_ADMIN True if the user is an administrator. # # The database should already be open. # proc checklist-verify-login {} { global env set usr [wapp-param FOSSIL_USER] wapp-set-param CKLIST_USER $usr if {$usr!=""} wapp-allow-xorigin-params set perm [wapp-param FOSSIL_CAPABILITIES] wapp-set-param CKLIST_WRITE [string match {*i*} $perm] wapp-set-param CKLIST_ADMIN [string match {*[as]*} $perm] } # Print the common header shown on most pages # # Return 1 to abort. Return 0 to continue with page generation. |
︙ | ︙ | |||
167 168 169 170 171 172 173 | } </style> } checklist-verify-login wapp-subst {<div class="submenu">\n} set base [wapp-param BASE] set this [wapp-param PATH_HEAD] | < | < > > > > > < < < < < | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | } </style> } checklist-verify-login wapp-subst {<div class="submenu">\n} set base [wapp-param BASE] set this [wapp-param PATH_HEAD] wapp-subst {<a href='%html($base/index)'>Checklist</a>\n} set dir [wapp-param ROOT_URL] wapp-subst {<a href='%html($dir/listing)'>Catalog</a>\n} set admin [wapp-param CKLIST_ADMIN 0] if {$admin} { if {$this!="cklistedit"} { wapp-subst {<a href='%html($base/cklistedit)'>Edit-checklist</a>\n} } if {$this!="sql"} { wapp-subst {<a href='%html($base/sql)'>SQL</a>\n} } wapp-subst {<a href='%html($base/env)'>CGI-environment</a>} wapp-subst {<a href='%html($base/self)'>Source-code</a>} } wapp-subst {</div>\n} return 0 } # Close out a web page. Close the database connection that was opened # by checklist-common-header. # |
︙ | ︙ |
Added misc/dashboard.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | #!/usr/bin/wapptclsh # package require wapp if {![info exists env(FOSSIL_URI)]} { error "This script must be run as a Fossil CGI extension" } proc open-database {} { set self [wapp-param SCRIPT_FILENAME] set dir [file dir $self] set dbname [file dir $self]/-[file rootname [file tail $self]].db sqlite3 db $dbname db eval { CREATE TABLE IF NOT EXISTS outcome( testId TEXT PRIMARY KEY, -- large random hex key platformId TEXT, -- references platform testName TEXT, -- ex: th3.t05, releasetest.default status TEXT, -- "pass", "fail", "running" mtime INT, -- When this record received, seconds since 1970 ipaddr TEXT, -- received from this IP address elapsetm INT, -- Time test took to run, seconds srchash TEXT, -- SQLite source_id() srcdate TEXT, -- SQLite version date, ISO8601 toolhash TEXT, -- Test script source_id() tooldate TEXT, -- Test script version date, ISO8610 expiretm INT, -- When this record expires, seconds since 1970 branch TEXT, -- Branch name for SQLite code report TEXT, -- Final test result text (maybe NULL) testcase BLOB -- Testcase (probably NULL except failures) ); CREATE TABLE IF NOT EXISTS platform( platformId TEXT PRIMARY KEY, -- large random hex key mtime INT, -- time of last change, sec since 1970 ipaddr TEXT, -- IP address of last change name TEXT UNIQUE, -- Short name ostype TEXT, -- 'linux','windows','mac','sparc' os TEXT, -- ex: 'Ubuntu 18.04', 'Windows 10' owner TEXT, -- ex: 'drh' location TEXT, -- ex: 'Charlotte, NC' description TEXT -- ex: 'Yoga laptop' ); } db timeout 5000 } proc common-header {{title {Test Dashboard}} {exlist {}} {newlist {}}} { wapp-trim { <div class='fossil-doc' data-title='%html($title)'> <div class='submenu'> } set base [wapp-param BASE_URL] set sub(Outcomes) olist set sub(Platforms) plist foreach {name link} $newlist {set sub($name) $link} foreach name [lsort [array names sub]] { set link $sub($name) if {$link ni $exlist} { wapp-trim { <a class='label' href='%unsafe($base/$link)'>%html($name)</a> } } } wapp-subst {</div>\n} } proc common-footer {} { wapp-subst {</div>\n} } proc wapp-page-env {} { wapp-allow-xorigin-params common-header {Wapp Environment} foreach key [array names ::env FOSSIL_*] { wapp-set-param $key $::env($key) } wapp-trim {<pre>%html([wapp-debug-env])</pre>} common-footer } # Show a list of test outcomes # proc wapp-page-olist {} { open-database common-header "Test Outcomes" olist set now [db one {SELECT datetime('now')}] wapp-trim { <p>Test Outcomes As Of %html($now)</p> } wapp-subst {<ul>\n} set last_srchash {} set inner_close {} db eval {SELECT status, testName, platform.name AS pname, srchash, srcdate, datetime(srcdate) AS sdate, datetime(max(outcome.mtime),'unixepoch') AS odate, report FROM outcome, platform WHERE outcome.mtime>CAST(strftime('%s','now','-1 month') AS INT) AND platform.platformId=outcome.platformId GROUP BY testName, srchash, outcome.platformId ORDER BY srcdate DESC, outcome.mtime DESC, status DESC} { if {$srchash!=$last_srchash} { wapp-trim { %unsafe($inner_close) <li><a href='https://sqlite.org/src/timeline?c=%html($srchash)'> %html%($sdate)% %html%([string range $srchash 0 16])%</a> <ol> } set inner_close </ol></li> set last_srchash $srchash } set clr black switch $status { fail {set clr red} running {set clr gray} ok - pass {set clr green} } wapp-trim { <li><span style='color:%html($clr);'> <b>%html($status)</b> - %html($testName at $pname) <small>(%html($odate)) } if {[string length $report]} { wapp-trim {- %html($report)} } wapp-trim {</small></span></li>} } wapp-trim { %unsafe($inner_close) </ul> } wapp-trim { <script nonce='%html([wapp-param FOSSIL_NONCE])'> setTimeout(function(){location.reload();},1000*60); </script> } common-footer } # Make sure the Fossil user has the listed capability. # Return 0 on success. If the capability is missing, # redirect to the login page and return 1. # proc check-capability {cap} { if {[string match *${cap}* $::env(FOSSIL_CAPABILITIES)]} { return 0 } wapp-redirect $::env(FOSSIL_URI)/login?g=[wapp-param REQUEST_URI] return 1 } # List all available platforms # proc wapp-page-plist {} { if {[check-capability i]} return common-header "Test Platforms" plist {{New Platform} padd} wapp-trim { <table class='sortable' border='1' cellspacing='0' cellpadding='2'\ data-column-types='ttttx' data-init-sort='1'> <thead><tr> <th>Name <th>OS-Type <th>Owner <th>Description <th> </tr></thead> <tbody> } set base [wapp-param BASE_URL] open-database db eval {SELECT name, ostype, owner, description, rowid FROM platform ORDER BY 1} { wapp-trim { <tr> <td>%html($name) <td>%html($ostype) <td>%html($owner) <td>%html($description) <td><a href="%html($base)/pdetail/%html($rowid)">Details</a> </tr> } } wapp-trim { </tbody> </table> <script src='%url([wapp-param FOSSIL_URI])/builtin/sorttable.js'></script> } common-footer } # Show the details of a single platform entry # proc wapp-page-pdetail {} { if {[check-capability i]} return set id 0 scan [wapp-param PATH_TAIL] %d id open-database set seen 0 db eval {SELECT *, datetime(mtime,'unixepoch') AS ctime FROM platform WHERE rowid=$id} {set seen 1; break} if {!$seen} { common-header "Platform Not Found" wapp-subst {<h1>No such platform: %html($id)</h1>\n} common-footer return } common-header "Details For Platform $name" set u [wapp-param BASE_URL] wapp-trim { <table class="label-value"> <tr><th>Name:</td><td>%html($name)</td> <tr><th>OS-Type:</td><td>%html($ostype)</td> <tr><th>OS:</td><td>%html($os)</td> <tr><th>Location:</td><td>%html($location)</td> <tr><th>Description:</td><td>%html($description)</td> <tr><th>Owner:</td><td>%html($owner)</td> <tr><th>Date:</td><td>%html($ctime)</td> <tr><th><tt>dashconfig</tt>:</td><td>%html($u $platformId)</td> <table> } common-footer } # Add a new platform entry # proc wapp-page-padd {} { if {[check-capability i]} return open-database set nm [wapp-param nm] set ostype [wapp-param ostype linux] set os [wapp-param os] set ds [wapp-param ds] set loc [wapp-param loc] common-header "Define A New Platform" if {$nm!=""} { db eval BEGIN if {[db exists {SELECT 1 FROM platform WHERE name=$nm}]} { wapp-trim { <p class='generalError'> The platform name "%html($nm)" is already used. Choose another. </p> } } else { set ipaddr [wapp-param REMOTE_ADDR] set owner [wapp-param FOSSIL_USER] db eval { INSERT INTO platform(platformId,mtime,ipaddr,name,ostype, os,owner,location,description) VALUES(lower(hex(randomblob(20))),strftime('%s','now'), $ipaddr,$nm,$ostype,$os,$owner,$loc,$ds) } set redir [wapp-param BASE_URL]/pdetail/[db last_insert_rowid] db eval COMMIT db close wapp-redirect $redir return } db eval COMMIT db close } wapp-trim { <form method="POST"> <table class="label-value"> <tr><th>Name:</th> <td><input type='text' size='15' name='nm' value='%html($nm)'></td></tr> <tr><th>Class:</th> <td><select name='ostype' size='1'> } foreach x {linux mac windows other} { wapp-subst {<option value='%html($x)'} if {$x==$ostype} { wapp-subst { selected='selected'} } wapp-subst {>%html($x)</option>\n} } wapp-trim { <tr><th>OS:</th> <td><input type='text size='20' name='os' value='%html($os)'></td></tr> <tr><th>Location:</th> <td><input type='text size='40' name='loc' value='%html($loc)'></td></tr> <tr><th>Description:</th> <td><input type='text size='40' name='ds' value='%html($ds)'></td></tr> <tr><th></th><td><input type='submit' value='Create'></td></tr> </table> </form> } common-footer } set UPLOAD_DEBUG 1 # Report an upload failure # proc upload-failure {code reason} { global UPLOAD_DEBUG if {$UPLOAD_DEBUG} { puts stderr "***** upload failed: $reason" } wapp-reply-code $code wapp-mimetype text/plain wapp-subst {%unsafe($reason)} } # Receive an outcome upload # proc wapp-page-upload {} { global UPLOAD_DEBUG if {$UPLOAD_DEBUG} { puts stderr "****************** upload ************************" foreach key [lsort [wapp-param-list]] { if {[string index $key 0]=="."} continue if {$key=="CONTENT" && [string match text/* [wapp-param CONTENT_TYPE]]==0} continue puts stderr "$key = [list [wapp-param $key]]" } } set rc [catch {wapp-page-upload-unsafe} msg] if {$rc && $UPLOAD_DEBUG} { puts stderr "ERROR: $msg" } } proc wapp-page-upload-unsafe {} { if {[wapp-param CONTENT_TYPE]!="application/x-sqlite"} { upload-failure 400 {wrong content type} return } sqlite3 memdb :memory: memdb deserialize [wapp-param CONTENT] if {[memdb one {PRAGMA quick_check}]!="ok"} { memdb close upload-failure 400 {corrupt payload} return } memdb eval {SELECT k, v FROM up} { set data($k) $v } memdb close foreach key {testId platformId testName status branch} { if {![info exists data($key)]} { upload-failure 400 "missing parameter: $key" return } } open-database if {![db exists {SELECT 1 FROM platform WHERE platformId=$data(platformId)}]} { upload-failure 401 "unauthorized" return } set ipaddr [wapp-param REMOTE_ADDR] db eval { REPLACE INTO outcome(testId, platformId, testName, status, mtime, ipaddr, elapsetm, srchash, srcdate, toolhash, tooldate, expiretm, branch, report, testcase) VALUES($data(testid),$data(platformId),$data(testName),$data(status), strftime('%s','now'),$ipaddr,$data(elapsetm), $data(srchash), $data(srcdate), $data(toolhash), $data(tooldate), strftime('%s','now')+$data(ttl), $data(branch), $data(report), $data(testcase)); } db close wapp-mimetype text/plain wapp-subst {Ok} } proc wapp-default {} { wapp-page-olist } wapp-start {} |
Added misc/dashlib.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | # # This is TCL library for uploading a test outcome to the testing dashboard. # Test scripts can "source" this library and then invoke its methods in order # to report test success and/or failure to the dashboard. # # Requirements: # # * SQLite needs to be loaded into the TCL interpreter # # * A recent "fossil" command needs to be available to "exec". # # * A platform configuration file needs to be configured. The # platform configuration is a file named "./dashconfig" or # "~/.dashconfig" (searched in that order) that is a single # line of two fields, the URL of the dashboard server and the # platform code. # # Usage: # # The test script must invoke "dashboard-init" exactly once in order # to initialize the uplink library. # # Each test scenario run by the script must be given its own name. # Call it $testName. For each test scenario, the script must run: # # dashboard-config $testName $key1 $value1 $key2 $value2 ... # # The dashboard-config command can be run multiple times. Duplicate # keys silently overwrite. The following keys are supported: # # srchash (REQUIRED) The SHA3 hash of the SQLite version under test # # srcdate (REQUIRED) Dates of the SQLite version under test in the # ISO8601 format: "YYYY-MM-DD HH:MM:SS" # # branch (REQUIRED) The branch from which srchash is taken # # toolhash (optional) SHA3 hash of the system doing the testing # # tooldate (optional) ISO8601 date corresponding to toolhash # # elapsetm (optional) Number of seconds for which the test ran # # expire (optional) This report should expire after this many # seconds. Used for "running" reports to indicate that # the script expects to update the report later. # # report (optional) Output from the test run. This should be # abbreviated to show the final test results, or perhaps # some error diagnostics in the event of a failure. While # very large reports are accepted, it is best to keep them # small by removing extraneous text prior to upload. # # testcase (optional) The testcase that provoked a failure in # a fuzz-testing scenario # # Note in particular that srchash and srcdate must be set! # # After the scenario is configured, invoke one of the following to upload # the report to the dashboard: # # dashboard-running $testName # dashboard-pass $testName # dashboard-fail $testName # # The dashboard-running command can be invoked multiple times. After # dashboard-pass or dashboard-fail, however, the scenario is finish and # cannot be reused without reconfiguring it from scratch. # proc dashboard-init {} { upvar #0 dashboard-global G set miss {} foreach x {./dashconfig ~/.dashconfig} { set x [file normalize $x] if {[file readable $x]} { set fd [open $x rb] foreach {url platformId} [read $fd] break close $fd break } else { lappend miss $x } } if {![info exists url]} { return "cannot find the dashboard upload configuration any of: $miss" } if {[catch {package require sqlite3}]} { return "cannot load the sqlite3 package" } set G(url) $url set G(platformId) $platformId set G(trace) 0 package require sqlite3 sqlite3 dashboard-db :memory: dashboard-db eval {PRAGMA page_size=512} dashboard-db eval {CREATE TABLE up(k,v)} return {} } proc dashboard-remote {} { upvar #0 dashboard-global G if {[info exists G(url)]} {return $G(url)} return {} } proc dashboard-uuid {} { return [dashboard-db eval {SELECT lower(hex(randomblob(20)))}] } proc dashboard-config {name args} { upvar #0 dashboard-data-$name D dashboard-global G if {![info exists G(url)]} return foreach {key value} $args { set D($key) $value } if {![info exists D(testId)]} { set D(testId) [dashboard-uuid] } } proc dashboard-unconfig {name} { upvar #0 dashboard-data-$name D unset -nocomplain D } proc dashboard-trace {bool} { upvar #0 dashboard-global G set G(trace) $bool } proc dashboard-send {name} { upvar #0 dashboard-data-$name D dashboard-global G if {![info exists G(url)]} return if {![info exists D]} { error "no such testcase: $name" } if {$G(trace)} { puts "DASHBOARD-TRACE: send $name" } dashboard-db eval {DELETE FROM up} set D(platformId) $G(platformId) set D(testName) $name foreach key [array names D] { set val $D($key) dashboard-db eval {INSERT INTO up VALUES($key,$val)} } set uid [dashboard-uuid] set fup dashboard-uplink-$uid.db set fdown dashboard-downlink-$uid.txt dashboard-db eval {VACUUM} dashboard-db backup $fup dashboard-db eval {DELETE FROM up} set cmd "exec fossil test-httpmsg $G(url)/upload $fup \ --mimetype application/x-sqlite >$fdown" set rc [catch $cmd msg] if {$G(trace)} { puts "DASHBOARD-TRACE: $cmd" if {$rc} { puts "DASHBOARD-TRACE: upload failed: $msg" } } if {$rc} { puts stderr "dashboard uplink to $G(url) failed" puts stderr "error-message: \"$msg\"" puts stderr "uplink-command: $cmd" } else { file delete $fup file delete $fdown } } proc dashboard-running {name} { dashboard-config $name status running dashboard-send $name } proc dashboard-pass {name} { dashboard-config $name status pass dashboard-send $name dashboard-unconfig $name } proc dashboard-fail {name} { dashboard-config $name status fail dashboard-send $name dashboard-unconfig $name } |