Documentation Source Text

    <tr><th></th><td><input type='submit' value='Create'></td></tr>
    </table>
    </form>
  }
  common-footer
}

# A POST message has been received that defines a new platform.
# Try to insert it
































































proc wapp-default {} {
  wapp-page-olist
}
wapp-start {}

    <tr><th></th><td><input type='submit' value='Create'></td></tr>
    </table>
    </form>
  }
  common-footer
}

# Report an upload failure

#
proc upload-failure {code reason} {
  wapp-reply-code $code
  wapp-mimetype text/plain
  wapp-subst {%unsafe($reason)}
}

# Receive an outcome upload
#
proc wapp-page-upload {} {
  if {1} {
    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]]"
    }
  }
  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 {}

#
# 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"
#
#     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 {} {
  sqlite3 dashboard-db :memory:
  dashboard-db eval {PRAGMA page_size=512}
  dashboard-db eval {CREATE TABLE up(k,v)}
}
proc dashboard-uuid {} {
  return [dashboard-db eval {SELECT lower(hex(randomblob(20)))}]
}
proc dashboard-config {name args} {
  upvar #0 dashboard-data-$name D
  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 D
}
proc dashboard-send {name} {
  upvar #0 dashboard-data-$name D
  if {![info exists D]} {
    error "no such testcase: $name"
  }
  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]} {
    error "cannot find the dashboard upload configuration any of: $miss"
  }
  for {set cnt 1} {[info command dashdb-$cnt]!=""} {incr cnt} {}
  dashboard-db eval {DELETE FROM up}
  foreach key [array names D] {
    set val $D($key)
    dashboard-db eval {INSERT INTO up VALUES($key,$val)}
  }
  dashboard-db eval {INSERT INTO up VALUES('platformId',$platformId)}
  set uid [dashboard-uuid]
  set fup dashboard-uplink-$uid.db
  set fdown dashboard-downlink-$uid.txt
  dashboard-db eval {VACUUM INTO $fup}
  dashboard-db eval {DELETE FROM up}
  set cmd "exec fossil test-httpmsg $url/upload $fup \
                  --mimetype application/x-sqlite >$fdown"
  set rc [catch $cmd msg]
  file delete $fup
  file delete $fdown
  if {$rc} {
    error "uplink failed with \"$msg\""
  }
}
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
}