Wapp

File Content
Login

Latest version of file 'tests/test01.tcl':


#!/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 BX(y) $B
  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%($BX(y))%/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</script>
  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-allow-xorigin-params
  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"
  wapp-trim {<h1>Using &#37;string</h1>}
  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) = %string([list [wapp-param $var]])\n}
  }
  wapp "</pre>"
}
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 {
    wapp-trim {
      <pre>
      %html($res)
      </pre>
    }
  }
}
proc wapp-page-fileupload {} {
  wapp-content-security-policy {default_src 'self' 'inline'}
  wapp-trim {
    <h1>Wapp File Upload Form Test</h1>
    <p><form method="POST" enctype="multipart/form-data">
    <input type="file" name="f1"><br>
    <input type="file" name="f2"><br>
    <input type="file" name="f3"><br>
    <input type="submit" value="Upload Files">
    </form></p>
  }
  foreach name {f1 f2 f3} {
    if {[wapp-param $name.filename]==""} continue
    wapp-subst {<h2>%html($name): %html([wapp-param $name.filename])</h2>\n}
    set mimetype [wapp-param $name.mimetype]
    if {[string match text/* $mimetype]} {
      wapp-subst {<pre>%html([wapp-param $name.content])</pre>\n}
    } elseif {[string match image/* $mimetype]} {
      set data [binary encode base64 [wapp-param $name.content]]
      wapp-subst {<img src="data:%url($mimetype);base64,%unsafe($data)">\n}
    } else {
      wapp-subst {<p>Unrenderable mime-type: %html($mimetype)</p>\n}
    }
    wapp-set-param $name.content \
       "... [string length [wapp-param $name.content]] bytes of data ..."
  }
  wapp-trim {
    <h2>Environment</h2>
    <pre>%html([wapp-debug-env])
    .header = %html([wapp-param .header])
    </pre>
  }
}

proc wapp-page-encodings {} {
  set strlist {
     {Johann Strauß}
     {Вагиф Сәмәдоғлу}
     {中国}
     {$[hi]{there}$}
     {https://drh@sqlite.org/info?name=trunk#block2}
  }
  wapp-subst {
     <h1>Test the %qp substitutions</h1>
     <table border=1 cellpadding=5>
     <tr><th>Original<th>Encoded<th>Round-Trip</tr>
  }
  foreach str $strlist {
    wapp-subst {<tr><td>%unsafe($str)<td>%qp($str)}
    set x [wappInt-decode-url [wappInt-enc-qp $str]]
    wapp-subst {<td>%unsafe($x)</tr>\n}
  }
  wapp-subst {</table>}

  wapp-subst {
     <h1>Test the %url substitutions</h1>
     <table border=1 cellpadding=5>
     <tr><th>Original<th>Encoded<th>Round-Trip</tr>
  }
  foreach str $strlist {
    wapp-subst {<tr><td>%unsafe($str)<td>%url($str)}
    set x [wappInt-decode-url [wappInt-enc-url $str]]
    wapp-subst {<td>%unsafe($x)</tr>\n}
  }
  wapp-subst {</table>}
}
# Deliberately generate an error to test error handling.
proc wapp-page-errorout {} {
  wapp "<h1>Intentially generate an error</h1>\n"
  wapp "<p>This test should be ignored by the error handler\n"
  # The following line deliberately throws an error to test the
  # error recovering logic within Wapp
  wapp $noSuchVariable
  wapp "This is a $test of wapp-safety-check"
  wapp "This is another [test of] wapp-safety-check"
  wapp "<p>After the error\n"
}
proc wapp-page-csptest {} {
  wapp-allow-xorigin-params
  if {[wapp-param-exists csp]} {
    wapp-content-security-policy [wapp-param csp]
  }
  wapp-trim {
    <h1>Content Security Policy Test Page</h1>
    <p> There is a &lt;script&gt; at the bottom of
    this page that will invoke an alert().  The
    script will be disabled by the default CSP.
    <p>Use the csp= query parameter to change CSP.
    <script>alert("This is the alert");</script>
  }
}
proc wapp-page-self {} {
  set fd [open [wapp-param SCRIPT_FILENAME] rb]
  set script [read $fd]
  close $fd
  wapp-content-security-policy {default-src 'inline' 'unsafe-inline'}
  wapp-trim {
    <h1>Source code to this script</h1>
    <pre style='border: 1px solid black;'>%html($script)</pre>
  }
}
proc wapp-page-drh.jpg {} {
  wapp-mimetype image/jpeg
  wapp-cache-control max-age=3600
  wapp-unsafe [binary decode base64 {
    /9j/4AAQSkZJRgABAQEAlgCWAAD//gAeTEVBRCBUZWNobm9sb2dpZXMgSW5jLiBW
    MS4wMf/bAEMACAYGBwYFCAcHBwkJCAoMFA0MCwsMGRITDxQdGh8eHRocHCAkLicg
    IiwjHBwoNyksMDE0NDQfJzk9ODI8LjM0Mv/bAEMBCQkJDAsMGA0NGDIhHCEyMjIy
    MjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMv/A
    ABEIAJIAlAMBEQACEQEDEQH/xAAcAAABBQEBAQAAAAAAAAAAAAACAAEDBAUGBwj/
    xAA9EAACAQMCAwYDBgQDCQAAAAABAgMABBEFIRIxQQYTIjJRYQdxkTNCgaGxwRQW
    I1IVJHI0Q2JzgrLR4fD/xAAZAQEBAAMBAAAAAAAAAAAAAAAAAQIDBAX/xAAkEQEB
    AAICAgIDAAMBAAAAAAAAAQIRAzESIQRBEyJhBTJRQv/aAAwDAQACEQMRAD8A9y5C
    oyRDeT5URKfLRQt5hRErfYmgzR9qKiro3RqolG8YoGXmRQCNiaBKeGSgNxQKPxIy
    HpREGOFyKKI0DYoFigVAqoM7LUEcYySaCVugoBb7QUEr/ZGgzR9ov41FXE8rVUSp
    9kKAeIKck0ArIknjjZXU7cSnIqBN0NUSndAaAFPDID0O1EKZcHNFBzFAqBGgVA1A
    UhwlA0Q8FAZ81Ax+1oJX+yNEZTyJF/UkZURQSzMcAD1JqK5LtD8UdH0azc2Ob+4J
    wFTIQe5P/ipasxrhdQ+NOtTxt/Aw2tnHjIZl7xh9dvyqeTKYOMvu1+sakjpdapcy
    I5yQ0pCk+wHSi6Qaf2l1HSnUWN/cW7q3Ee5kIA/DkadGtt5fib2lSfvTqnA4IypQ
    EMfcEYxTdTxj1fsj8U9I1x0sb1xaXjABWfaOQ+gPQ+xrKVjrTvTuvyqoPzx560EI
    2OKB6BqBUCoFN0FAajCigcbvQCN5aCWTaI0Hj/xO7Vwx93oMD5kk8U+DyXop+fOs
    azxjxu/ubnVL9+5VuFWAXgHQc/rWFsnbbjhculq27J308amYFVPQda13ljonxcvt
    pR9lpU8HdzA+oGTWP5Wc+P8AxN/JN5/DmSONvXDDBNT8y34l7Y19oF7bFiVPFjfP
    Wtk5JWjLgsZ0cM1u68S4GcnbetkylabhZ2+hvhV2lOoaMNKvLjvLq3yYixyXi6b+
    oO3yxWUrVlNV6Gh4WK1kxM64bNANAqBqBqBPvIB6UEooHX1oAXeWga/uobPT5rmd
    wkMaF3Y9AKJHzFrNsNa7Q3WpMZAkj8USMd+HkM/hWu3Ub8MN3TqNJ0S3soQFiHER
    kk71xZ5b7exxccxmo6KzssbBcj3Fa7XRqaakNsE8iBc+1NpUrQNjltUTcZV/o0Nx
    45oFY+uKylsSzGuX1fsvHKe8t0wccgfzrZjnpzcvFKxLOS77P3Nvf2jNDdRPxLg7
    SAeZT8xkfKuvG/bzOTHV0+jbS5W7tILpBhZUVwPQEZra0LR8SUEeKBsUCxQLagEb
    yE0EvrQEo50AR+cmg574icX8ialwHB4V/wC4VL0uPbxKxtzLdQ4Oc4yScnGcjP1r
    RyX06/jz9nZwIS6r05VxWvWnTpLJhFHjh3I3qyscvaY44jtUtZfQs7csiiFK6mBl
    4RyrLfphr2wpAO99qxjOuQ1S074XEQUkpIWQ+ldnFfTy/kT9nr3Y6WSfsjpzSvxO
    IQpOMctv2rojjvbeQ4yKqEw32opsUQ1AqAYxkk0EgoDGwNAEQ3oOb+I7BewuocS8
    SkICP+oVL0uPbxbS7hItQCEglQBn36flXPyT07OC6rtrY5kGOorjr08em7AeRJA2
    p7FlShOMjNNKcsqnciqiOTxL4SD7U1U2y5lAk5YHtUXbkby5jXVWGRgsc5+WK6+L
    p53yPdem/D+Qydloc4Kh2Cn2zXTHFe3UYwarEfMUAYoEaKbFENGMCgP79QG2y1QM
    XM0GF26thedi9ThLBCYuIEnqCDj57VMr6ZYS26j56iDQ3EbjZGYAb8t+VaM+nVxz
    Vd8b5dOtzIsfG4XCrXJrft6Ny16c3ddtdSZo4rSQu0h4VKR8QJ9AcYzW6cds3pov
    NJdbbegaxqt2ym5bjA2YYwQflWnLTpwtvbW1y5vILcyQt3ZC5JNSM8uvTh013tAl
    7EpkuHjmZu7Axlsc8fKujHjuU3HFny+GWrXSaLrM15xxTuz4JAZgQyMOasDyNacp
    qtuOXrbnNaZodTu1C5YbqB1BHT8638V9OXnn7aewfDmFbfshDDxZlR2Mq/2E7gfT
    FdGGUs9OTlwywusnXcwDWbUQoGIzQNRSxRDJyoCHOoCfy1Qo6Dme30EkuiQSIzAR
    XKlwp5ggj9SK0fI/1dv+P1+Wz+PLr/s7bT3SyQ3YEz4do8ct+eK5pyXWnbycM8vJ
    pPp7XyNDtwEb+p9q1W1umMpn7NRu9swtouK3+zO44OfID5n61nOTKfaXixt3Yupa
    iybjbh7wnJxzOTkk1ha2Y4replZ+AAncc6hpmHs3FNJBM8MEphOYywwVz6VnMrPt
    rywl7iy+kFJpLmPwu3m22PvWFtNT7VDYWDanHdz578ngTfYkCtky9aY48cuW3onZ
    Gz/h9IllZQGuJS4HsNh+hrr4J+u/+vO+dnLy+M+o3V6it7kPyNEP0oBoGopLsKiH
    XnQPIfDVDx0EWoWsd7Yy20vkkXhPt71jljMpqsuPO4ZzKfTyaTSzY6peSzL/AFQA
    qn033H47GvOuNxy1XvZckz45cV2xZUYDoax+1xu1vUdQtrC3MjuBgVdNk/rIku1m
    RZnZUB2wTvTSWrc7wdyGS5jLDbB2q+KXJHb6tFa3a2054Q4yp6H5VLKvbYmnjaIF
    GBzUYWMmLTDqF5FChAkEyspx7f8A30rLHHy1GH5fxzLKvUbNFhhSFNkRQo/CvSk1
    NPCytyvlRMMNQPVQhQMaKGgYeWogl51QpOWKAo+dAcnkoOJ7TWEs0yTQwyScQ4GE
    a5OelcvPhbZY7/icuMxuOVch3zJIqDZskVyXt3cdZfEL+77+4k4gjHuocehxxH9q
    2Ys7n70sXWkW+oLHLJAJXQ5QsM4PyrLpN7V49A7wOl5CZIyc4YZFXcY6s7Tajb2z
    WJjnbgjj3VxsUI5EGsVufo+j3szQPHM/e903CJMbOMZB+hrXlPfpl5bjuuyli9xd
    m9YDuoyRnPNsbD8810cGFt8v+OD5PLJjcPuuyTwyV2POSSDYGhAg0D0DGimoBHIU
    QS0DOfGKA4uVAUnkoRnE4Y/OorzDV4ms9UnUDeKUkfI7j8q87kmsrHscOe8JWNca
    PZ6rHKkqlHbxI6MVZT6gipjlcW3WOc1Vi0smiPB/Duw5My3TJw8sEDryO3vWze0/
    Fn/5q01scPg3JHQS3OMjHPw+/SpGX4+Sz9sme+gxS3Iuro8YiU92hJIXP3sE7mmW
    epqJjxyXfaaBVihWJAAWYs37D9K1scsnqnZO3NvoMTMMGZjJ+HIfpXdwzWDyvkZe
    XJWw4wc1uaEoPElBGNjRT0CNENvQAOYoDXrUAsfHVEicz86ApPLQZkjBA7HkBmoP
    IpdVudYn1C8uMZS7khVQMcKJgCuPm95vS+Pjri8jW+Sy8Jwem9aHTjfa+luZRgOR
    6j0qy1ukg009kPEGO1XyZWQEuFJUcgevWse+2F1E+h6dHqurxQSycEbElj1YDfhH
    ua28WHllquPm5LjhuPWERY41RFCqoAAHICu55ZMMrVCiO2KBMN6KYUD0Q2KCNT4j
    QGOVAH36CZOfzFAp3WOPidgq+rHFBgXV3HKhWGQNk4JFRjll6ec3VmmnalewjZZp
    jcKP9fP8wa4uaWZvW+JlMuHTKldraYSRHw8+Gse2dxuN9Jo9eiibBbh9QanhWePN
    PsX8wxBzwy8/enjVvNBC8a6OEBAPU+lNaYXK59NDTbg2/aTRoIvM8rsQPRUOf1rb
    w/7baPlzXHI9gBz+O9dbzjdDVAr4XoJG3oI870U4NA9BCvWiGeeOJfG4B9Ov0ols
    ipJf4+ziJ92OKjG5KcmoXrsVEqxj/gX9zRjcqxpGlvr8xySOwUZLMcmoxtWoVVE4
    AMYJAoRhdrLCWXThfW6Fri1y/AP94n3l/ce4rXyY+UdXxea8ef8AK5e1MF7Ek6Nx
    xvuNulcd9PY3LDz9n4LtweIKcb461fKxjePGzavF2YSCbvGkJUetW5VjOOdtX+Hh
    iXCDFYt2M0tdkrU3+t3GrMMw2ym3gPqx87fkB+Brp4cdTbzPncu74x6EmrtA6pLH
    xIB5l5iuhw+emhBfW9x9nIMn7p2NGcylStsc1VSjcUEZFFKgVBRZncebA9F2qNVy
    R92FBIABox2ApvmibV5Ys7jmKG2Qxa21IyMMKwwaIsgEkuvLINQeW9ovihftrlzp
    emW8MEEEhiMk6cTSEHB25AfnV0u6lmt20fUFkReHTr4CWMA5CMRllz7E/QiuTkx1
    Xq/G5fLHTVKSKqvG4I6Vrdcujkzzc/CPais+/lmuLq30m1b/ADN24jDLzVep+mau
    GO618vJ4Yuv7M652auBNomj3qNc2JKvFjGQDglT94Z6iu2Y6jxc8vK7roNmUb75z
    VYQLxK49D6igkhu7u2wvH3qDo9GUysalpqsM2EcGJ/RuR/GqzmUq8aMw5oh9qCip
    BAxjcbVHOTDbGKgjYbUELbZ23qoqXVus6YI3oKMRktmMcgJToaDzD4h9lGW/XWrF
    crMcSAD7/wD7H6VFbvZ23/xPsssFyC0RAG/NCORHuKlxlmmXHyXDKWJ4tO1DT14Z
    IxPABtJF4tvlzFcuXHY9jj58M+qfjluQUt4jt5m5BfnWOONyuo258uPHN5VzvaZ5
    NF0+Z9NDm/mjKPeuMGNDzWMfdz1bn8q6+PCYvI5vk5ct/jH+FvZm7TXYNYkRkhhD
    Hi5cRIIC/nk1ntz7e3x5bxHmagMnh2qqE89zselDYlGdiNvSibXLa6lt8DJeP+08
    x8qrPHLTTR1kUOpBBo2y7FmqMe3kBmnjU7A8Q9vWsXOvKeIZoGxk1ALx56VRWljI
    3AoiHMZ8MqjB60GZrWlzT6c0NvCbhGdHVVHUMMj6Zqa9r9aRrpUVuZDaKYwTl4Rs
    VPqPUVWKKJ5AGjIV0zzJ3HuKM8c9JTAWYM6lsdDUS5W9sDWdKbUr+xtZIsW08pWQ
    j+0AnH44okdNHaLEixW8QjhjGEVRgAUhe06wybZqgmBU881A6ptk71RKgoJQu1FP
    HK9s3Epyp8y1WcumqG4gCp2PKja53Sj/AJt/9JqOZsRUUZ5UD0EZqCpOBjlVRFYs
    2OZ+tAr7zxN1zzoMm1H9e4/537UGkgGDt0oI79VxaeEbTL09jUGkgHdLsOQqqil5
    UFRfOaiJ1qgxzqqc0BS+Vqirll/sw+ZqtmPT/9k=
  }]
}
wapp-start $::argv