Index: misc/checklist.tcl ================================================================== --- misc/checklist.tcl +++ misc/checklist.tcl @@ -76,24 +76,25 @@ } # 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()}] - checklist-verify-login wapp-trim { 
%html([wapp-debug-env])}
   wapp-subst {SQLite = %html($v)
\n
\n} + checklist-common-footer } # Show the complete text of this script. # proc wapp-page-self {} { wapp-cache-control max-age=3600 - wapp-subst {
\n} + checklist-common-header set fd [open [wapp-param SCRIPT_FILENAME] rb] set script [read $fd] close $fd wapp-trim {

The following is the complete text of the @@ -100,11 +101,11 @@ Wapp script that implements this Fossil CGI extension:

%html($script)
} - wapp-subst {
\n} + checklist-common-footer } # Check user permissions provided to use by Fossil in the FOSSIL_USER # and FOSSIL_CAPABILITIES environment variables. Set the Wapp parameters @@ -116,20 +117,14 @@ # # The database should already be open. # proc checklist-verify-login {} { global env - if {[info exists env(FOSSIL_USER)]} { - wapp-set-param CKLIST_USER $env(FOSSIL_USER) - } else { - wapp-set-param CKLIST_USER {} - } - if {[info exists env(FOSSIL_CAPABILITIES)]} { - set perm $env(FOSSIL_CAPABILITIES) - } else { - set perm {} - } + 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 @@ -169,26 +164,24 @@ } checklist-verify-login wapp-subst {
\n} set base [wapp-param BASE] set this [wapp-param PATH_HEAD] - if {$this!="index"} { - wapp-subst {Checklist\n} - } + wapp-subst {Checklist\n} + set dir [wapp-param ROOT_URL] + wapp-subst {Catalog\n} set admin [wapp-param CKLIST_ADMIN 0] if {$admin} { + if {$this!="cklistedit"} { + wapp-subst {Edit-checklist\n} + } if {$this!="sql"} { wapp-subst {SQL\n} } - if {$this!="cklistedit"} { - wapp-subst {Edit-checklist\n} - } wapp-subst {CGI-environment} wapp-subst {Source-code} } - set dir [wapp-param ROOT_URL] - wapp-subst {Catalog\n} wapp-subst {
\n} return 0 } # Close out a web page. Close the database connection that was opened ADDED misc/dashboard.tcl Index: misc/dashboard.tcl ================================================================== --- /dev/null +++ misc/dashboard.tcl @@ -0,0 +1,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 { +
+
+ } + 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 { + %html($name) + } + } + } + wapp-subst {
\n} +} +proc common-footer {} { + wapp-subst {
\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 {
%html([wapp-debug-env])
} + 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 { +

Test Outcomes As Of %html($now)

+ } + wapp-subst { + } + wapp-trim { + + } + 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 { + + + + + } + set base [wapp-param BASE_URL] + open-database + db eval {SELECT name, ostype, owner, description, rowid + FROM platform ORDER BY 1} { + wapp-trim { + + + } + } + wapp-trim { + +
Name + OS-Type + Owner + Description +   +
%html($name) + %html($ostype) + %html($owner) + %html($description) + Details +
+ + } + 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 {

No such platform: %html($id)

\n} + common-footer + return + } + common-header "Details For Platform $name" + set u [wapp-param BASE_URL] + wapp-trim { + + + + + + + + + +
Name:%html($name)
OS-Type:%html($ostype)
OS:%html($os)
Location:%html($location)
Description:%html($description)
Owner:%html($owner)
Date:%html($ctime)
dashconfig:%html($u $platformId)
+ } + 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 { +

+ The platform name "%html($nm)" is already used. Choose another. +

+ } + } 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 { + +
+ + + + + + + + + + +
Name:
Class:
OS:
Location:
Description:
+ + } + 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 Index: misc/dashlib.tcl ================================================================== --- /dev/null +++ misc/dashlib.tcl @@ -0,0 +1,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 +}