Wapp

#!/usr/bin/wapptclsh
#
# Invoke as "tclsh test01.tcl" and then surf the website that pops up
# to verify the logic in wapp.
#
if {[catch {package require wapp}]} {
  source [file dir [file dir [info script]]]/wapp.tcl
}
proc wapp-default {} {
  global wapp
  set B [wapp-param BASE_URL]
  set R [wapp-param SCRIPT_NAME]
  wapp-cache-control max-age=15
  wapp "<h1>Hello, World!</h1>\n"
  wapp "<ol>"
  wapp-unsafe "<li><p><a href='$R/env'>Wapp Environment</a></p>\n"
  wapp-subst {<li><p><a href='env2'>Environment using wapp-debug-env</a>\n}
   wapp-subst {<li><p><a href='%url($B)/fullenv'>Full Environment</a>\n}
  set crazy [lsort [wapp-param-list]]
  wapp-subst {<li><p><a href='%url($B)/env?keys=%url($crazy)'>}
  wapp "Environment with crazy URL</a>\n"
  wapp-trim {
    <li><p><a href='%url($B)/lint'>Lint</a>
    <li><p><a href='%url($B)/errorout'>Deliberate error</a>
    <li><p><a href='%url($B)/encodings'>Encoding checks</a>
    <li><p><a href='%url($B)/redirect'>Redirect to env</a>
    <li><p><a href='%url($B)/globals'>TCL global variables</a>
    <li><p><a href='%url($B)/csptest'>Content Security Policy</a>
    <li><p><a href='%url($B)/fileupload'>File Upload
    Using multipart/form-data</a>
    <li><p><a href='%url($B)/self'>The source code to this script</a>
  }
  set x "%string(...)"
  set v abc'def\"ghi\\jkl
  wapp-subst {<li>%html($x) substitution test: "%string($v)"\n}
  wapp "</ol>"
  if {[wapp-param-exists showenv]} {
    wapp-page-env
  }
  wapp-trim {
    <p>The creator of Wapp:<br>
    <img src="%url($R/drh.jpg)">
  }
}
proc wapp-page-redirect {} {
  wapp-redirect env
}
proc wapp-page-globals {} {
  wapp-trim {
    <h1>TCL Global Variables</h1>
    <ul>
  }
  foreach vname [lsort [uplevel #0 info vars]] {
    set val ???
    catch {set val [set ::$vname]}
    set len [string length $val]
    if {$len>100} {
      wapp-subst {<li>%html($vname) = <i>... %html($len) byte string...</i>\n}
    } else {
      wapp-subst {<li>%html($vname = [list $val])</li>\n}
    }
  }
}
proc wapp-page-env2 {} {
  wapp-allow-xorigin-params
  wapp-trim {
    <h1>Wapp Environment using wapp-debug-env</h1>
    <p>This page uses wapp-allow-xorigin-params so that new
       query parameters may be added manually to the URL.</p>
    <pre>%html([wapp-debug-env])</pre>
  }
}
proc wapp-page-env {} {
  global wapp
  wapp-set-cookie env-cookie simple
  wapp "<h1>Wapp Environment</h1>\n"
  wapp-unsafe "<form method='GET' action='[wapp-param SELF_URL]'>\n"
  wapp "<input type='checkbox' name='showhdr'"
  if {[wapp-param-exists showhdr]} {
    wapp " checked"
  }
  wapp "> Show Header\n"
  wapp "<input type='submit' value='Go'>\n"
  wapp "</form>"
  wapp "<pre>\n"
  foreach var [lsort [wapp-param-list]] {
    if {[string index $var 0]=="." &&
         ($var!=".header" || ![wapp-param-exists showhdr])} continue
    wapp-subst {%html($var) = %html([list [wapp-param $var]])\n}
  }
  wapp "</pre>"
  wapp-unsafe "<p><a href='[wapp-param BASE_URL]/'>Home</a></p>\n"
}
proc wapp-page-fullenv {} {

  wapp-set-cookie env-cookie full
  wapp "<h1>Wapp Full Environment</h1>\n"
  wapp-unsafe "<form method='POST' action='[wapp-param SELF_URL]'>\n"
  wapp "<input type='checkbox' name='var1'"
  if {[wapp-param-exists showhdr]} {
    wapp " checked"
  }
  # Deliberately unsafe calls to wapp-subst and wapp-trim, added here
  # to test wapp-safety-check
  #
  wapp-subst "> Var1\n"
  wapp-trim "<input type='submit' name='s1' value='Go'>\n"
  wapp "<input type='hidden' name='hidden-parameter-1' "
  wapp "value='the long value / of ?$ hidden-1..<hi>'>\n"
  wapp "</form>"
  wapp "<pre>\n"
  foreach var [lsort [wapp-param-list]] {
    if {$var==".reply"} continue
    wapp-subst {%html($var) = %html([list [wapp-param $var]])\n\n}
  }
  wapp "</pre>"
  wapp-subst {<p><a href='%html([wapp-param BASE_URL])/'>Home</a></p>\n}
}
proc wapp-page-lint {} {
  wapp "<h1>Potental Cross-Site Injection Vulerabilities In This App</h1>\n"
  set res [wapp-safety-check]
  if {$res==""} {
    wapp "<p>No problems found.</p>\n"
  } else {