#!/usr/bin/wapptclsh # # This script implements a release-checklist web application. Installation # steps: # # (1) Put the wapptclsh framework binary in /usr/bin (or equivalent) # (2) Create a directory to store checklist databases. Edit this # script to store the database directory in DATADIR # (3) Install at least one template database. Perhaps use one of the # testing databases found in the source code repository for this # script. The details of the checklist, logins and passwords, and # so forth can be edited after the application is running. # (4) Activate the server by one of the following techniques: # (4a) Run "wapptclsh checklist.tcl" for a pop-up instance on the # local machine. # (4b) Run "wapptclsh checklist.tcl --server 8080" for an HTTP server. # (4c) Make this script a CGI script according to however CGI works # on your web server # (4d) Run "wapptclsh checklist.tcl --scgi 9000" to start an SCGI # server, then configure Nginx to relay requests to TCP port 9000. # # Update 2019-07-26: # The script has been revised to run as a Fossil extension. It now uses # Fossil for login and user credentials. Anyone with check-in privilege # can edit. Anyone with Setup privilege can be a checklist admin. # set DATADIR /checklist ;# Edit to be the directory holding checklist databases package require wapp # Any unknown URL dispatches to this routine. List all available # checklists. # proc wapp-default {} { wapp-page-listing } # List all available checklists. # proc wapp-page-listing {} { global DATADIR wapp-trim {
} wapp-subst {
    \n} foreach dbfile [lsort -decreasing [glob -nocomplain $DATADIR/*.db]] { set name [file rootname [file tail $dbfile]] set url [wapp-param BASE_URL]/$name/index wapp-subst {
  1. %html($name)\n} } wapp-subst {
\n\n} } # Show the CGI environment for testing purposes. # proc wapp-page-env {} { sqlite3 db :memory: set v [db one {SELECT sqlite_source_id()}] checklist-verify-login wapp-trim {
%html([wapp-debug-env])}
  global env
  foreach e [array names env] {
    if {![string match FOSSIL* $e]} continue
    set txt "$e = [list $env($e)]\n"
    wapp-subst {%html($txt)}
  }
  wapp-subst {SQLite = %html($v)
\n
\n} } # Check user permissions by looking at the login/password in the # checklist-login cookie. Set the following environment variables: # # 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 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 {} } wapp-set-param CKLIST_WRITE [string match {*i*} $perm] wapp-set-param CKLIST_ADMIN [string match {*[as]*} $perm] } # Print the common header shown on all pages # # Return 1 to abort. Return 0 to continue with page generation. # proc checklist-common-header {} { if {![wapp-param-exists OBJECT] || [set dbfile [wapp-param OBJECT]]==""} { wapp-redirect listing return 1 } sqlite3 db $dbfile -create 0 db timeout 1000 db eval BEGIN set title [db one {SELECT value FROM config WHERE name='title'}] wapp-trim {
} checklist-verify-login wapp-subst {\n} return 0 } # Close out a web page. Close the database connection that was opened # by checklist-common-header. # proc checklist-common-footer {} { wapp-subst {
} catch {db close} } # Show the main checklist page # proc wapp-page-index {} { if {[checklist-common-header]} return set level 0 db eval {SELECT seq, printf('%016llx',itemid) AS itemid, txt FROM checklist ORDER BY seq} { if {$seq%100==0} { set newlevel 1 } else { set newlevel 2 } while {$newlevel>$level} { if {$level==0} { wapp-subst {
    \n} } else { wapp-subst {

      \n} } incr level } while {$newlevel<$level} { wapp-subst {
    \n} incr level -1 } if {$level==1} {wapp-subst {

    }} wapp-trim {

  1. %unsafe($txt)
  2. \n } } while {$level>0} { wapp-subst {
\n} incr level -1 } # Render the edit dialog box. CSS sets "display: none;" on this so that # it does not appear. Javascript will turn it on and position it on # the correct element following any click on the checklist. # if {![wapp-param WRITE 0]} { wapp-trim {
Status: 
Comments: 
} } # The cklistUser object is JSON that contains information about the # login user and the capabilities of the login user, which the # javascript code needs to know in order to activate various features. # wapp-subst {\n} set base [wapp-param BASE] wapp-subst {\n} checklist-common-footer } # The CSS for the main checklist page goes here # proc wapp-page-style.css {} { wapp-mimetype text/css wapp-cache-control max-age=86400 wapp { h1 { text-align: center; } div.ckcom { font-size: 80%; font-style: italic; white-space: pre; } span.ckuid { font-size: 80%; cursor: pointer; } div.mainmenu { text-align: center; border: 1px solid black; padding: 2ex; } div.mainmenu a { margin: 0 1.5ex; } p.error { font-weight: bold; color: red; } #editBox { display: none; border: 1px solid black; } } } # The javascript for the main checklist page goes here # proc wapp-page-cklist.js {} { wapp-mimetype text/javascript wapp-cache-control max-age=86400 set base [wapp-param BASE] wapp-trim { function cklistAjax(uri,data,callback){ var xhttp = new XMLHttpRequest(); xhttp.onreadystatechange = function(){ if(xhttp.readyState!=4) return if(!xhttp.responseText) return var jx = JSON.parse(xhttp.responseText); callback(jx); } if(data){ xhttp.open("POST",uri,true); xhttp.setRequestHeader("Content-Type", "application/x-www-form-urlencoded"); xhttp.send(data) }else{ xhttp.open("GET",uri,true); xhttp.send(); } } function cklistClr(stat){ stat = stat.replace(/\\++/g,''); if(stat=="ok") return '#00a000'; if(stat=="prelim") return '#0080ff'; if(stat=="fail") return '#a00028'; if(stat=="review") return '#007088'; if(stat=="pending") return '#4f0080'; if(stat=="retest") return '#904800'; return '#000000'; } function cklistApplyJstat(jx){ var i; var n = jx.length; for(i=0; i1 ){ s += " " + x.chngcnt + "x)" }else{ s += ")" } e.innerHTML = s if( x.comment && x.comment.length>0 ){ e = document.getElementById("com-"+x.itemid); e.innerHTML = x.comment; } if( editItem && editItem.id==name ){ document.getElementById("editStatus").value = x.status; document.getElementById("editCom").value = x.comment; } } } function clearEditBox(){ document.getElementById("editStatus").value = 'ok'; document.getElementById("editCom").value = ''; } cklistAjax("%string($base/jstat)",null,cklistApplyJstat); var userNode = document.getElementById("cklistUser"); var userInfo = JSON.parse(userNode.textContent||userNode.innerText); if(userInfo.canWrite){ var allItem = document.getElementsByClassName("ckitem"); for(var i=0; iitemid,status,comment} and with owner set to the login user, # before returning the results. # # If the itemid query parameter exists and is not an empty string, # then return only the status to that one checklist item. Otherwise, # return the status of all checklist items. # # The update and itemid parameters come in as hex. They must be # converted to decimal before being used for queries. # proc wapp-page-jstat {} { if {![wapp-param-exists OBJECT] || [set dbfile [wapp-param OBJECT]]==""} { wapp-redirect listing return } wapp-mimetype text/json sqlite3 db $dbfile db eval BEGIN set update [wapp-param update] if {$update!=""} { checklist-verify-login if {[wapp-param CKLIST_WRITE 0] && [scan $update %x update]==1} { set status [wapp-param status] set comment [string trim [wapp-param comment]] set owner [wapp-param CKLIST_USER] db eval { REPLACE INTO ckitem(itemid,mtime,status,owner,comment) VALUES($update,julianday('now'),$status,$owner,$comment); INSERT INTO history(itemid,mtime,status,owner,comment) VALUES($update,julianday('now'),$status,$owner,$comment); } } } set itemid [wapp-param itemid] if {$itemid!="" && [scan $itemid %x itemid]==1} { set sql { SELECT json_group_array( json_object('itemid', printf('%016llx',itemid), 'mtime', strftime('%s',mtime)+0, 'status', rtrim(status,'+'), 'owner', owner, 'comment', comment, 'chngcnt', (SELECT count(*) FROM history WHERE itemid=$itemid))) FROM ckitem WHERE itemid=$itemid } } else { set sql { WITH chngcnt(cnt,itemid) AS ( SELECT count(*), itemid FROM history GROUP BY itemid ) SELECT json_group_array( json_object('itemid', printf('%016llx',itemid), 'mtime', strftime('%s',mtime)+0, 'status', rtrim(status,'+'), 'owner', owner, 'comment', comment, 'chngcnt', COALESCE(chngcnt.cnt,0)) ) FROM ckitem LEFT JOIN chngcnt USING(itemid) } } wapp-unsafe [db one $sql] db eval COMMIT db close # puts "jstat from $dbfile" } # The /history page returns an HTML table that shows the history of # changes to a single checklist item. # # proc wapp-page-history {} { set dbfile [wapp-param OBJECT] set itemid [wapp-param itemid] if {$dbfile=="" || $itemid=="" || [scan $itemid %x itemid]!=1} return wapp-mimetype text/text sqlite3 db $dbfile db eval BEGIN wapp-subst {\n} set date {} db eval {SELECT date(mtime) as dx, strftime('%H:%M',mtime) as tx, owner, rtrim(status,'+') AS status, comment FROM history WHERE itemid=$itemid ORDER BY julianday(mtime) DESC} { if {$dx!=$date} { wapp-subst {\n } } wapp-subst {
%html($dx)\n} set date $dx } wapp-trim {
%html($tx) %html($status) %html($owner) %html($comment)
\n} } # The /sql page for doing arbitrary SQL on the database. # This page is accessible to the administrator only. # proc wapp-page-sql {} { if {[checklist-common-header]} return if {![wapp-param CKLIST_ADMIN 0]} { wapp-redirect index return } set sql [string trimright [wapp-param sql]] wapp-trim {
SQL: 
} if {$sql!=""} { set i 0 wapp-subst {
\n} set rc [catch { db eval $sql x { if {$i==0} { wapp-subst {\n} foreach c $x(*) { wapp-subst {\n} incr i } wapp-subst {\n} foreach c $x(*) { set v [set x($c)] wapp-subst {} } } msg] if {$rc} { wapp-subst {
%html($c)\n} } wapp-subst {
%html($v)\n} } wapp-subst {
ERROR: %html($msg)\n} } wapp-subst {
} } db eval COMMIT checklist-common-footer } # Generate a text encoding of the checklist table # # # (hash) top level item # ## (hash) second-level item # ## (hash) another second-level # # (hash) another top-level # proc checklist-as-text {} { set out {} db eval {SELECT seq, itemid, txt FROM checklist ORDER BY seq} { set id [format %x $itemid] regsub -all {\s+} [string trim $txt] { } txt if {($seq%100)==0} { append out "# ($id) $txt\n" } else { append out "## ($id) $txt\n" } } return $out } # Replace the content of the checklist table with a decoding # of the text string given in the argument. Throw an error and # rollback the change if anything doesn't look right. # proc checklist-rebuild-from-text {txt} { set re {^(\#\#?) (\([0-9a-fA-F]+\) )?(.+)$} db transaction { db eval {DELETE FROM checklist} set i 0 foreach line [split $txt \n] { set line [string trimright $line] if {$line==""} continue if {[regexp $re $line all a h t]} { if {$h==""} {unset h} {scan $h (%x) h} if {$a=="#"} { set i [expr {(int($i/100)+1)*100}] } elseif {$a=="##"} { if {$i==0} {error "\"##\" before any \"#\""} incr i } else { error "unknown line prefix: \"$a\"" } db eval {INSERT INTO checklist(seq,itemid,txt) VALUES($i,COALESCE($h,abs(random())),$t)} } else { error "illegal checklist line: \"$line\"" } } } } # The /cklistedit page allows the administrator to edit the items on # the checklist. # proc wapp-page-cklistedit {} { if {[checklist-common-header]} return if {![wapp-param CKLIST_ADMIN 0]} { wapp-redirect index return } set cklist [string trim [wapp-param cklist]] if {$cklist!=""} { checklist-rebuild-from-text $cklist } set x [checklist-as-text] wapp-trim {

Edit checklist:

} catch {db eval COMMIT} checklist-common-footer } # This dispatch hook checks to see if the first element of the PATH_INFO # is the name of a checklist database. If it is, it makes that database # the OBJECT and shifts a new method name out of PATH_INFO and into # PATH_HEAD for dispatch. # # If the first element of PATH_INFO is not a valid checklist database name, # then change PATH_HEAD to be the database listing method. # proc wapp-before-dispatch-hook {} { global DATADIR set dbname [wapp-param PATH_HEAD] wapp-set-param ROOT_URL [wapp-param BASE_URL] if {[file readable $DATADIR/$dbname.db]} { # an appropriate database has been found wapp-set-param OBJECT $DATADIR/$dbname.db if {[regexp {^([^/]+)(.*)$} [wapp-param PATH_TAIL] all head tail]} { wapp-set-param PATH_HEAD $head wapp-set-param PATH_TAIL [string trimleft $tail /] wapp-set-param SELF_URL /$head } else { wapp-set-param PATH_HEAD {} wapp-set-param PATH_TAIL {} } wapp-set-param BASE [wapp-param BASE_URL]/$dbname } else { # Not a valid database. Change the method to list all available # databases. wapp-set-param OBJECT {} wapp-set-param BASE [wapp-param SCRIPT_NAME] if {$dbname!="env"} {wapp-set-param PATH_HEAD listing} } } # Start up the web-server wapp-start $::argv