Documentation Source Text

  }
  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.

    }
    </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.
#

#!/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>&nbsp;
    </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 {}

#
# 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
}