2015-03-28 Sean Woods <[email protected]>
	* Started work on v4
	* Tclhttpd now targets 8.6+
	* Many evals replaced with the expansion operator {*}
	* "lib" directory restructured into a tcllib style "modules" directory
	* NOTE: Changes are now maintained in the fossil repo

2005-04-26 Michael Thomas <[email protected]>
        * bin/httpd.tcl:  Don't [fork] if we're in a threaded interpreter
          since [fork] doesn't play well with threads.

2005-04-09 Colin McCormack <[email protected]>

    if {[catch {package require httpd::stdin}]} {
	puts "No command loop available"
	set Config(debug) 0
    }
}

if {$Config(compat)} {
    if {[catch {
    package require httpd::compat
    httpd::compat_level $Config(compat)

    }]} {
	puts stderr "tclhttpd$Config(compat) compatibility mode failed."
    } else {
	# Messages here just confuse people
    }
}

###################

}
# These packages are required for "normal" web servers

# doc
# provides access to files on the local file systems.

package require httpd::doc
package require httpd::qwiki

set mainconfig {}
dict set mainconfig filename $Config(MainDatabaseFile)
foreach {f v} [array get Config] {
  dict set mainconfig $f $v
}

tao::class mainclass {
  superclass httpd.qwiki
  
  option docRoot {}
  
  
  ###
  # The main page reads from the docroot
  ###
  method /html resultObj {
    ###
    # By default, act as a conduit to DocRoot
    ###
    ::DocDomain [my cget virtual] [my cget docRoot] [$resultObj sock] [$resultObj cget suffix]
  }
}

mainclass create MAIN / $mainconfig

# Doc_Root defines the top-level directory, or folder, for
# your web-visible file structure.

Doc_Root			$Config(docRoot)

# Merge in a second file system into the URL tree.

if {[catch {
    Auth_InitCrypt			;# Probe for crypt module
} err]} {
    catch {puts "No .htaccess support: $err"}
}






#######################################
# Load Custom Code
#######################################

if {[info exist Config(library)] && [string length $Config(library)]} {
    if {![file isdirectory $Config(library)]} {

# Default group file - used if .htaccess doesn't specify AuthGroupFile
# this defaults to the authentication array authdefault()
#Config AuthGroupFile {}

# Default mail servers - the smtp servers to use when sending mail
Config MailServer {}

# Default master index file location
Config MainDatabaseFile [file join [Config home] httpd.sqlite]

    if {[catch {package require httpd::stdin}]} {
	puts "No command loop available"
	set Config(debug) 0
    }
}

if {$Config(compat)} {
    if {[catch {
    package require httpd::compat
    httpd::compat_level $Config(compat)
    } err]} {
	puts stderr "tclhttpd$Config(compat) compatibility mode failed: $err \n $::errorInfo"
    } else {
	# Messages here just confuse people
    }
}

###################
# Start the server

oo::class create ootest {
  superclass httpd.url

  ###
  # title: Implement html content at a toplevel
  ###
  method /html resultObj {
    $resultObj configure title {Welcome!}
    $resultObj puts [my pageHeader]
    $resultObj puts {





Hello World!
<p>
Try the following links:
<ul>
    }
    set prefix [$resultObj cget url_prefix]
    foreach {url comment} {
      errorurl {Throw an internal error from Tcl}
      deadurl  {Page that generates a 505 error}
      suburl   {Valid Suburl}
      missing  {Non-existent url}
    } {
      $resultObj puts "<li><a href=$prefix/$url>$url</a> - $comment</li>"
    }

    $resultObj puts {</ul>}


    $resultObj puts [my pageFooter]
  }

  method /html/errorurl resultObj {
    error "Die Yuppie Scum!"
  }

  method /html/deadurl resultObj {
    $resultObj configure title {Page Error!}

    $resultObj configure code 501
    $resultObj puts [my pageHeader]

    $resultObj puts {
I threw an error this way

    }

    $resultObj puts [my pageFooter]
  }

  ###
  # title: Implement html content at a toplevel
  ###
  method /html/suburl resultObj {
    $resultObj configure title {Sub Url!}
    $resultObj puts [my pageHeader]
    $resultObj puts {Sub Url}
    $resultObj puts "<p><a href=\"[my cget virtual]\">Back</a>"
    $resultObj puts [my pageFooter]
  }

  ###
  # title: Implement html content at a toplevel
  ###
  method /html/default resultObj {
    $resultObj configure title {Not Found}

    $resultObj configure code 404
    $resultObj puts [my pageHeader]







    $resultObj puts "The page: [$resultObj cgi get REQUEST_URI] coult not be cound}




    $resultObj puts "<p><a href=\"[my cget virtual]\">Back</a>"
    $resultObj puts [my pageFooter]








  }
}
ootest create OOTEST /ootest {}

vwait forever
if 0 {
# Start up the user interface and event loop.

# Configure the auto_path so we can find the script library.
# home is the directory containing this script

set home [string trimright [file dirname [info script]] ./]
set home [file normalize [file join [pwd] $home ..]]
set Config(lib) [file join $home .. modules]
set Config(MainDatabaseFile) [file join $home test qwiki.sqlite]
source $home/test/common.tcl

###
# Begin the test
###
package require httpd::qwiki

tao::class qwikitest {
  superclass httpd.qwiki

  ###
  # title: Implement html content at a toplevel
  ###
  method /html resultObj {


    $resultObj configure title {Welcome to Qwiki!}

    $resultObj puts [my pageHeader]
    $resultObj puts {
Hello World!
<p>
    }
    $resultObj puts "Logged in as user: [$resultObj session get username]<br>"

    $resultObj puts "Logged with session: [$resultObj cget sessionid]<br>"

    $resultObj puts {
Try the following links:
<ul>
    }
    set prefix [my cget virtual]
    foreach {url comment} {
      errorurl {Throw an internal error from Tcl}
      deadurl  {Page that generates a 505 error}
      suburl   {Valid Suburl}
      missing  {Non-existent url}
      login    {Log In}
      logout   {Log Out}
    } {
      $resultObj puts "<li><a href=$prefix/$url>$url</a> - $comment</li>"
    }
    $resultObj puts {</ul>}
    $resultObj puts [my pageFooter]

  }


  method /html/errorurl resultObj {
    error "Die Yuppie Scum!"
  }

  method /html/deadurl resultObj {
    $resultObj configure title {Page Error!}

    $resultObj configure code 501
    $resultObj puts [my pageHeader]
    $resultObj puts {
I threw an error this way
    }
    $resultObj puts [my pageFooter]
  }

  ###
  # title: Implement html content at a toplevel
  ###
  method /html/suburl resultObj {
    $resultObj configure title {Sub Url!}
    $resultObj puts [my pageHeader]
    $resultObj puts {Sub Url}
    $resultObj puts "<p><a href=\"[my cget virtual]\">Back</a>"
    $resultObj puts [my pageFooter]
  }

  ###
  # title: Implement html content at a toplevel
  ###













  method /html/default resultObj {
    $resultObj configure title {Not Found}

    $resultObj configure code 404
    $resultObj puts [my pageHeader]
    $resultObj puts "The page: [$resultObj cgi get REQUEST_URI] coult not be cound"
    $resultObj puts "<p><a href=\"[my cget virtual]\">Back</a>"


    $resultObj puts [my pageFooter]
  }
}

qwikitest create HOME /home [list filename [Config MainDatabaseFile]]
HOME task_daily

vwait forever
if 0 {
# Start up the user interface and event loop.
package require Tk
package require httpd::srvui
package require httpd::stdin

## Properties

* create\_sql - An SQL script that implements the schema

## Options

* filename - Path to a file which stores the sqlite database for the community (default in-memory)
* virtual - Root Url of this object.

## Attached Objects

Community objects (and their derived classes) contain an embedded sqlite
database. This database can be accessed via that \<db\> method.

###
# Facilities for user, group, and community management
###
package require tao
package require sqlite3
package require tao-sqlite
package require md5 2
package require sha1 2

package require httpd::directoo
package require httpd::cookie	;# Cookie_GetSock Cookie_Make
package require httpd::doc	;# Doc_Root
package require httpd::utils	;# Stderr file iscommand randomx
package require httpd::jshash   ;# Javascript password hashes
package require httpd::bootstrap
package require cron

tao::class community.layer {
  superclass httpd.url tao::layer taodb::table

  ###
  # Code to produce the schema in sql
  ###
  property schema create_sql {}
  property schema version 0.1
  property module {}
  
  constructor {sharedobjects threadargs args} {
    foreach {organ object} $sharedobjects {
      my graft $organ $object
    }
    my graft layer [self]
    my configurelist [::tao::args_to_options {*}$args]
    ::Url_PrefixInstall [my cget virtual] [namespace code {my httpdDirect}] {*}$threadargs
  }
  
  destructor {
    catch {::Url_PrefixRemove [my cget virtual]}
  }
  
  method schema_check {} {
    set module [my property module]
    set version [my property schema version]
    ###
    # Create our schema if it doesn't exist
    ###
    if {![my <db> exists {select version from module where name=:module}]} {
      my <db> eval [my property schema create_sql]
      my <db> eval {insert or replace into module(name,version) VALUES (:module,:version)}
      # Send a signal to child classes calling us through [next]
      return 1
    }
    ###
    # From here on out, swap out components to incrementally update
    # the schema
    ###
    return 0
  }
  
  method initialize {} {
    my schema_check
  }

  #
  #	Use the url prefix, suffix, and cgi values (set with the
  #	ncgi package) to create a Tcl command line to invoke.
  #
  # Arguments:
  #	suffix		The part of the url after the domain prefix.
  #
  # Results:
  #	Returns a Tcl command line.
  #
  # Side effects:
  #	If the suffix (and query args) do not map to a Tcl procedure,
  #	returns empty string.
  method httpdMarshalArguments resultObj {
    set prefix [$resultObj cget url_prefix]
    set suffix [$resultObj cget url_suffix]
    set uuid {}
    if { $suffix in {/ {}} } {
      set method /html
    } else {
      set parts [split [string trim $suffix /] /]
      set uuid [lindex $parts 0]
      set method /html/[join [lrange $parts 1 end] /]
    }
    set pkey  [my property schema primary_key]
    foreach {name value} [$resultObj query] {
      if { $name in [list uuid $pkey]} {
        set uuid $value
      }
      if { $name eq "method" } {
        set method /html/$value
        break
      }
    }
    if {$uuid ne {}} {
      resultObj configure uuid $uuid
    }
    return [list my $method $resultObj]
  }
  
  ###
  # topic: 88c79c0e9188a477f535b66b01631961
  ###
  method node_is_managed unit {
    set prefix [my cget prefix]
    if { $unit eq $prefix } {
      return 1
    }
    set table [my property schema table]
    set pkey  [my property schema primary_key]
    return [my <db> exists "select $pkey from $table where $pkey=:unit"]
  }
  
  ###
  # Return a command if this object hijacks a method
  # from the community
  ###
  method url_is_managed resultObj {
   return {}
  }
  
  method task_hourly {} {}
  method task_daily {} {}
  
  method /html resultObj {
    $resultObj puts [my <community> pageHeader]
    $resultObj puts "Node: [$resultObj cget uuid]
    $resultObj puts [my <community> pageFooter]
  }
}

tao::class community.layer.user {
  superclass community.layer

  property module user
  property schema version 1.0  
  property schema table users
  property schema primary_key userid
  property schema create_sql {
    CREATE TABLE if not exists users (
      userid string default (uuid_generate()),
      username  STRING,
      password  STRING,
      name  STRING,
      email  STRING,
      type  STRING,
      primary key (userid)
    );
    CREATE UNIQUE INDEX if not exists username  on users (username);
    
    create table if not exists user_property (
      userid    string references users (userid) ON UPDATE CASCADE ON DELETE CASCADE,
      field      string,
      value      string,
      primary key (userid,field)
    );
insert into users(userid,username,password) VALUES ('local.webmaster','webmaster',sha1((select value from config where name='community-id')||'password'));
insert into users(userid,username,password) VALUES ('local.anonymous','anonymous','');  
  }
  
  method /html resultObj {    
    set uuid [$resultObj cget uuid]
    set method [lindex $parts 1]
    
    set props [my <db> eval {select field,value from user_property where userid=:uuid}]
    my <db> eval {select * from users where userid=:uuid} record break
    $resultObj configure title "User $record(username)"
    $resultObj puts [my <community> pageHeader]    
    $resultObj puts "<TABLE>"
    foreach {field value} [array get record] {
      $resultObj puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }    
    foreach {field value} $props {
      $resultObj puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }
    my <db> eval {select distinct acl_name from acl} {
      $resultObj puts "<TR><TH>Rights $acl_name</TH><Td>[my aclRights $acl_name $record(userid)]</TD></TR>"
    }
    $resultObj puts "</TABLE>"
    $resultObj puts <hr>
    $resultObj puts "<hr>Session<p>"
    $resultObj puts "<TABLE>"
    foreach {field value} [$resultObj session dump] {
      $resultObj puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }
    $resultObj puts "</TABLE>"
    $resultObj puts "<hr>ENV<p>"
    $resultObj puts "<TABLE>"
    foreach {field value} [$resultObj cgi dump] {
      $resultObj puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }
    $resultObj puts "</TABLE>"
    $resultObj puts [my <community> pageFooter]    

  }
  

}

tao::class community.layer.group {
 superclass community.layer

  property module group
  property schema version 1.0  
  property schema table groups
  property schema primary_key groupid
  property schema create_sql {
    CREATE TABLE if not exists groups (
      groupid string default (uuid_generate()),
      groupname STRING,
      acl_name  string references acl (acl_name) ON UPDATE CASCADE ON DELETE SET NULL,
      primary key (groupid)
    );
    CREATE TABLE if not exists group_members (
      groupid string references groups (groupid) ON UPDATE CASCADE ON DELETE CASCADE,
      userid string references users (userid) ON UPDATE CASCADE ON DELETE CASCADE
    );
    create table if not exists group_property (
      groupid    string references groups (groupid) ON UPDATE CASCADE ON DELETE CASCADE,
      field      string,
      value      string,
      primary key (groupid,field)
    );
insert into groups(groupid,groupname) VALUES ('local.wheel','wheel');
insert into group_members(userid,groupid) VALUES ('local.webmaster','local.wheel');
  }
}

tao::class community.layer.session {
  superclass community.layer
  property module session

  property module session
  property schema version 1.0  
  property schema table session
  property schema primary_key sesid
  
  property schema create_sql {
    CREATE TABLE session (
      sesid string default (uuid_generate()),
      userid string references users (userid) ON UPDATE CASCADE ON DELETE CASCADE,
      expires   int,
      primary key (sesid)
    );
    
    create table if not exists session_property (
      sesid    string references session (sesid) ON UPDATE CASCADE ON DELETE CASCADE,
      field      string,
      value      string,
      primary key (sesid,field)
    );
  }
  
  method task_hourly {} {
    set now [clock seconds]
    my <db> eval {delete from session where expires<:now;}
  }
}

tao::class community.layer.acl {
  superclass community.layer
  property module acl

  property module acl
  property schema version 1.0  
  property schema table acl
  property schema primary_key acl_name
  
  property schema create_sql {
    CREATE TABLE acl (
    parent   string references acl (acl_name) ON UPDATE CASCADE ON DELETE SET NULL,
    acl_name text not null,
    primary key (acl_name)
    );
    CREATE TABLE acl_grants (
    acl_name  string references acl (acl_name) ON UPDATE CASCADE ON DELETE SET NULL,
    userid    string references users (userid) ON UPDATE CASCADE ON DELETE SET NULL,
    grant     int default 1,
    right     text,
    UNIQUE (acl_name,userid,right)
    );
    
insert into acl (acl_name) VALUES ('admin');
insert into acl_grants (acl_name,userid,grant,right) VALUES ('admin','local.wheel',1,'all');

insert into acl (acl_name) VALUES ('default');
insert into acl_grants (acl_name,userid,grant,right) VALUES ('default',NULL,1,'view');
  }
}

tao::class httpd.community {  
  superclass httpd.url taodb::connection.sqlite
  
  option virtual {}

  option community-id {}


















  ###
  # This class extents the yggdrasil schema to
  # include session management, user management,
  # and access control lists
  ###
  property schema create_sql {
    CREATE TABLE if not exists config(
      name TEXT PRIMARY KEY,
      value ANY
    );






























































    CREATE TABLE if not exists module(









      name TEXT PRIMARY KEY,






      version ANY





    );







































--- POPULATE WITH DATA ---
insert into config(name,value) VALUES ('community-id',uuid_generate());
  }
  
  destructor {
    next
    cron::cancel [self].session_flush
    cron::cancel [self].backup_db
  }
  
  method Shared_Organs {} {
    set shared {}
    dict set shared db [my organ db]
    dict set shared community [self]
    return $shared
  }
  
  method active_layers {} {
    return {
      user    {prefix uid class community.layer.user}
      group   {prefix gid class community.layer.group}
      session {prefix sesid class community.layer.session}
      acl     {prefix acl class community.layer.acl}
    }
  }

  ###
  # topic: 81232b0943dce1f2586e0ac6159b1e2e
  ###
  method activate_layers {{force 0}} {
    set self [self]
    my variable layers
    set result {}
    set active [my active_layers]

    ###
    # Destroy any layers we are not using
    ###
    set lbefore [get layers]
    foreach {lname obj} $lbefore {
      if {![dict exists $active $lname] || $force} {
        $obj destroy
        dict unset layers $lname
      }
    }

    ###
    # Create or Morph the objects to represent
    # the layers, and then stitch them into
    # the application, and the application to
    # the layers
    ###
    set shared [my Shared_Organs]
    set root [my cget virtual]
    set threadargs [my cget threadargs]
    foreach {lname info} $active {
      set created 0
      set prefix [dict get $info prefix]
      set class  [dict get $info class]
      set layer_obj [my SubObject layer $lname]
      dict set layers $lname $layer_obj
      if {[info command $layer_obj] == {} } {
        $class create $layer_obj $shared $threadargs virtual $root/$prefix prefix $prefix layer_name $lname threadargs $threadargs
        set created 1
        foreach {organ object} $shared {
          $layer_obj graft $organ $object
        }
      } else {
        foreach {organ object} $shared {
          $layer_obj graft $organ $object
        }
        $layer_obj morph $class
      }
      ::ladd result $layer_obj
      $layer_obj event subscribe [self] *
      $layer_obj initialize
    }
    my action activate_layers
    return $result
  }

  method initialize {} {
    if {[my cget filename] eq {}} {
      my configure filename :memory:
    }
    my Database_Attach [my cget filename]
    my configurelist [my <db> eval {select name,value from config}]
    if {[my cget community-id] eq {}} {
      my configure community-id [::tao::uuid_generate]
    }
    my activate_layers
    ###
    # Clean up expired sessions
    ### 
    cron::every [self].hourly [expr {3600}] [namespace code {my task_hourly}]
    
    ###
    # Back up the database every day
    ###
    cron::every [self].daily [expr {3600*24}] [namespace code {my task_daily}]
  }

  method task_hourly {} {
    my variable layers
    foreach {name obj} $layers {
      $obj task_hourly
    }
  }
  
  method task_daily {} {
    my variable layers
    my Database_Backup
    foreach {name obj} $layers {
      $obj task_hourly
    }
  }
  
  method Database_Create {} {
    my <db> eval [my schema create_sql]
  }
  
  method ClockFormat {time {format {}}} {
    if { $format eq {} } {
      return [clock format $time]
    }
    return [clock format $time -format $format]
  }
  
  method ClockScan {time {format {}}} {
    if { $format eq {} } {
      return [clock format $time]
    }
    return [clock scan $time -format $format]
  }

  method Database_Functions {} {
    set seed [info hostname]
    my <db> function uuid_generate ::tao::uuid_generate
    my <db> function sha1    {::sha1::sha1 -hex}
    my <db> function now   {clock seconds}
    my <db> function clock_format [namespace code {my ClockFormat}]
    my <db> function clock_scan   [namespace code {my ClockScan}]

  }

  method aclAccessTypes {} {
    set aclAccessTypes {admin edit view}
    foreach type [my <db> eval "select distinct right from acl_grants order by right"] {
        logicset add aclAccessTypes $type
    }     

          }
        }
      }
    }
    return $rights
  }
  
  #
  #	Use the url prefix, suffix, and cgi values (set with the
  #	ncgi package) to create a Tcl command line to invoke.
  #
  # Arguments:
  #	suffix		The part of the url after the domain prefix.
  #
  # Results:
  #	Returns a Tcl command line.
  #
  # Side effects:
  #	If the suffix (and query args) do not map to a Tcl procedure,
  #	returns empty string.
  method httpdMarshalArguments resultObj {
    my variable layers
    ###
    # Try to pass the page off to one of my layers
    ###
    foreach {lname layer} $layers {
      if {[set cmd [$layer url_is_managed $resultObj]] ne {}} {
        return $cmd





      }
    }
    ###
    # Otherwise look for a local method
    ###
    return [next $resultObj]

  }
  
  method httpdSessionLoad {resultObj prefix suffix} {

    set found 0
    set sessionid {}
    set userid    {}
    
    ###
    # Look for a session id in the query
    ###
    foreach {field value} [$resultObj query] {
      if {$field eq "sessionid"} {
        set stmt {select userid from session where sesid=:value}
        if {[my <db> exists $stmt]} {

          set userid [my <db> one $stmt]
          set sessionid $value

          break
        }
      }
    }
    if {$sessionid eq {}} {
      ###
      # Look for a sessionid in cookies
      ###
      foreach {value} [$resultObj cookie_get sessionid] {


        set stmt {select userid from session where sesid=:value}
        if {[my <db> exists $stmt]} {
          set userid [my <db> one $stmt]
          set sessionid $value
          break
        }
      }
    }
    if {![my <db> exists {select username from users where userid=:userid}]} {
      set userid local.anonymous
      set username anonymous
      set anonymous 1
    } else {
      set username [my <db> one {select username from users where userid=:userid}]
      if { $userid == "local.anonymous" } {

        set anonymous 1
      } else {
        set anonymous 0
      }



    }



    if {$sessionid eq {}} {
      set sessionid [::tao::uuid_generate]

      my <db> eval {

insert into session(sesid,userid) VALUES (:sessionid,:userid);
      }

    }

    $resultObj configure \
      sessionid $sessionid \
      userid $userid \
      username $username
    
    set session [my <db> eval {select field,value from session_property where sesid=:sessionid}]
    dict set session userid $userid
    dict set session username $username
    dict set session anonymous $anonymous
    $resultObj session build $session

    # Save any return cookies which have been set.
    # This works with the Doc_SetCookie procedure that populates
    # the global cookie array.

    set expdate  [expr {14*86400}]
    set expires  [expr {[clock seconds]+$expdate}]
    my <db> eval {update session set expires=:expires where sesid=:sesid;}
    $resultObj cookie_set sessionid $sessionid $expdate
  }
    
  method httpdSessionSave result {
    dict unset result body

    set sesid   [dict get $result sessionid]
    set session [dict get $result session]
    set session_delta [my <db> eval {select field,value from session_property where sesid=:sesid}]
    set add {}
    set delete {}
    set modify {}

    foreach {field value} $session {
      if {![dict exists $session_delta $field]} {
        lappend add $field $value
      } elseif {$value != [dict get $session_delta $field]} {
        lappend modify $field $value
      }
    }
    foreach {field value} $session_delta {
      if {![dict exists $session $field]} {
        lappend delete $field $value
      }
    }

    if {[llength $add]||[llength $delete]||[llength $modify]} {
      my db eval "BEGIN TRANSACTION"
      foreach {field value} $add {
        my <db> eval {insert or replace into session_property(sesid,field,value) VALUES (:sessionid,:field,:value);}
      }
      foreach {field value} $modify {
        my <db> eval {update session_property set value=:value where sesid=:sessionid and field=:field;}

    return {
<script type="text/javascript" src="/bootstrap/js/bootstrap.min.js"></script>
<script type="text/javascript" src="/bootstrap/js/jquery.min.js"></script>
</BODY></HTML>
    }
  }

  method /html/logout resultObj {

    set sesid [$resultObj cget sessionid]
    my <db> eval {
update session set userid='local.anonymous' where sesid=:sesid;
delete from session_property where sesid=:sesid;
}
    $resultObj session build username anonymous userid local.anonymous anonymous 1

    $resultObj configure login-message {You have been logged out}
    my /html/login $resultObj
  }
  
  method /html/login resultObj {

    set sessionid [$resultObj cget sessionid]
    $resultObj reset
    $resultObj puts <html>
    $resultObj puts {
  <head>
    <link rel="stylesheet" href="/bootstrap/css/bootstrap.min.css">
    <script type="text/javascript" src="/bootstrap/js/bootstrap.min.js"></script>
    <script type="text/javascript" src="/bootstrap/js/jquery.min.js"></script>
    <TITLE>Log In</TITLE>
    <script type="text/javascript" src="/jshash/sha1-min.js"></script>
    <script type="text/javascript">  

    hash.value = h;
    var f = document.getElementById('finalform');  
    f.submit();  
}  
    </script>
  </head>
    }    
    $resultObj puts {
  <body>
    }
    set msg [$resultObj cget login-message]
    if { $msg ne {} } {
      $resultObj puts "<pre><font color=ÓredÓ face=Ósans-serifÓ size=Ó1Ó>$msg</font></pre><hr>"
    }
    $resultObj puts {
<table>
<form action="authenticate" method="post" id="finalform">
<tr><th>Username:</th><td><input name="uid" id="uid" /></td></tr>
<input type="hidden" name="hash" id="hash" />  
</form>
    }
    $resultObj puts {<form action="javascript:login()" method="post" >}
    $resultObj puts "<input type=\"hidden\" id=\"key\" value=\"[my cget community-id]\" />"  
    $resultObj puts "<input type=\"hidden\" id=\"sesid\" value=\"$sessionid\" />"  
    $resultObj puts {
<tr><th>Password:</th><td><input type="password" id="pass" /></td></tr>
<tr><th>&nbsp</th></th><td><input type="submit" value="Log In" /></td></tr>
</table>
    </form>  

  </body>
    }
    $resultObj puts </html>
  }

  method /html/authenticate resultObj {
    set sessionid [$resultObj cget sessionid]
    foreach {field value} [$resultObj query] {
      if {$field eq "uid"} {
        set username $value
        foreach {field value} [$resultObj query] {
          if {$field eq "hash"} {
            set passhash [my <db> one {select password from users where username=:username}]
            set realhash [::sha1::sha1 -hex "$sessionid$passhash"]
            if { $realhash eq $value } {
              set userid [my <db> one {select userid from users where username=:username}]
              my <db> eval {
update session set userid=:userid where sesid=:sessionid;


}
              $resultObj session set username $username
              $resultObj session set userid $userid
              set root [my cget virtual]
              $resultObj puts "<HTML><HEAD><META HTTP-EQUIV=\"Refresh\" CONTENT=\"1; URL=$root\"></HEAD>"
              $resultObj puts {
<BODY>
You are now being logged in. You will be redirected in a moment.
<p>
              }
              $resultObj puts "<A href=\$root\>Home...</a>"
              $resultObj puts </BODY></HTML>
              return
            }
          }
        }
      }
    }
    $resultObj configure login-message {Password or Username was incorrect or invalid.}
    my /html/login $resultObj
  }
  
  method /html/env resultObj {
    if {[$resultObj session anonymous]} {
      $resultObj configure code 401
      return
    }
    $resultObj puts [my pageHeader]
    $resultObj puts "<TABLE>"
    foreach {field value} [$resultObj cgi dump] {
      $resultObj puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }    
    $resultObj puts "</TABLE>"
    $resultObj puts [my pageFooter]
  }

  method /html/session resultObj {
    if {[$resultObj session anonymous]} {
      $resultObj configure code 401
      return
    }
    $resultObj puts [my pageHeader]
    $resultObj puts "<TABLE>"
    foreach {field value} [$resultObj session dump] {
      $resultObj puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }    
    $resultObj puts "</TABLE>"
    $resultObj puts [my pageFooter]
  }
}

package provide httpd::community 0.1

package provide httpd::compat 4.0

namespace eval ::httpd {}
set ::httpd::compat_dir [file dirname [file normalize [info script]]]

proc httpd::compat_level level {
  set cfiles {}
  foreach file [lsort -dictionary -decreasing [glob -nocomplain [file join $::httpd::compat_dir version-*.tcl]]] {
    set version [lindex [split [file tail $file] -] 1]
    if { "$version" >= $level } { source $file }
  }
}

package ifneeded httpd::compat 4.0 [list source [file join $dir compat.tcl]]

# compat.tcl
#@c Compatibility layer - deprecated
#
# Derived from doc.tcl
# Stephen Uhler / Brent Welch (c) 1997-1998 Sun Microsystems
# Brent Welch (c) 1998-2000 Ajuba Solutions
# Colin McCormack (c) 2002
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#



foreach {oldname newname} {
    Doc_Cookie	        Cookie_Get
    Doc_GetCookie	Cookie_Get
    Doc_SetCookie	Cookie_Set
    Doc_IsLinkToSelf	Url_IsLinkToSelf
    Doc_Redirect	Redirect_To
    Doc_RedirectSelf	Redirect_Self

# Compat routines with 3.4 routines

catch {interp alias {} Doc_Dynamic {} Template_Dynamic}
catch {interp alias {} Doc_Redirect {} Redirect_To}
catch {interp alias {} Doc_RedirectSelf {} Redirect_Self}

catch {interp alias {} Doc_Webmaster {} Httpd_Webmaster}
catch {interp alias {} Httpd_RedirectDir {} Redirect_Dir}

###
# script to maintain compadibilty with Tclhttpd 3.5
###

###
# This package adds support for direct URLs implemented by
# TclOO Objects. They need a little extra massaging as an
# object may have its own rules about which method is being
# exercised
#
# Derived from direct.tcl
###

package provide httpd::directoo 0.1

package require httpd	;# Httpd_Redirect Httpd_ReturnData
package require httpd::cgi	;# Cgi_SetEnv

package require httpd::doc_error	;# Doc_NotFound
package require httpd::url	;# Url_PrefixInstall Url_PrefixRemove Url_QuerySetup
package require httpd::utils	;# file iscommand
package require TclOO
package require tao

###
# Class that represents a web page in
# progress
###
tao::class httpd.result {
  superclass
  
  variable sock
  variable data
  variable state
  variable body
  variable cookie
  variable query
  variable session_data
  
  option cache-until {type unixtime default 0}
  option url_prefix {}
  option url_suffix {}
  option code {
    default 200
  }
  option content-type {
    default text/html
  }
  option title {}
  option redirect {}
  
  constructor {newsock prefix suffix} {
    my variable sock cgienv
    set sock $newsock
    my configurelist [list url_prefix $prefix url_suffix $suffix]

    # Set up the environment a-la CGI.
    ::Cgi_SetEnv $sock $prefix$suffix [my varname cgienv]

    # Prepare an argument data from the query data.
    my variable query
    ::Url_QuerySetup $sock
    set query [ncgi::nvlist]
  }
  
  destructor {
    
  }
  
  method sock {} {
    my variable sock
    return $sock
  }
  
  method data_get {field} {
    my variable sock
    upvar #0 Httpd$sock data
    if {![info exists data($field)]} {
      return {}
    }
    return $data(field)
  }
  
  method cgi {method args} {
    my variable cgienv
    switch $method {
      dump {
        return [array get cgienv]
      }
      get {
        set field [lindex $args 0]
        if {[info exists cgienv($field)]} {
          return $cgienv($field)
        }
        return {}
      }
      varname {
        return [my varname cgienv]
      }
      default {
        error "Valid: dump,get,varname"
      }
    }
  }

  method httpdHostName {} {
    my variable cgienv
    return [lindex [split [get cgienv(HTTP_HOST)] :] 0]
  }
  
  ###
  # Return a dict with:
  # * body
  # * content-type
  # * code (200,404,etc)
  # * cache-until (Unix datestamp when cache of this data expires, or 0)
  ###
  method httpReply {} {
    my variable body session_data
    set result {}
    dict set result content-type [my cget content-type]
    dict set result code         [my cget code]
    dict set result cache-until  [my cget cache-until]
    dict set result redirect     [my cget redirect]
    dict set result sessionid    [my cget sessionid]
    dict set result session       $session_data
    dict set result body $body

    return $result
  }
  
  method body {} {
    my variable body
    set title [my cget title]
    return [string map [list @TITLE@ $title] $body]
  }
  
  method query {} {
    my variable query
    return $query
  }
  
  method reset {} {
    my variable body
    set body {}
  }
  
  method puts args {
    my variable body
    append body {*}$args \n
  }
  
  #
  #@c	Return a *list* of cookie values, if present, else ""
  #@c	It is possible for multiple cookies with the same key
  #@c	to be present, so we return a list.
  #@c     This always gets the cookie state associated with the specified
  #@c     socket, unlike Cookie_Get that looks at the environment.
  #
  # Arguments:
  #@a	cookie	The name of the cookie (the key)
  #@a	sock	A handle on the socket connection
  # Returns:
  #@r	a list of cookie values matching argument
  method cookie_get {cookie} {
    my variable sock
    upvar #0 Httpd$sock data
    set result ""
    set rawcookie ""
    if {[info exist data(mime,cookie)]} {
        set rawcookie $data(mime,cookie)
    }
    foreach pair [split $rawcookie \;] {
        lassign [split [string trim $pair] =] key value
        if {[string compare $cookie $key] == 0} {
            lappend result $value
        }
    }
    return $result
  }
    
  #$c	make a cookie from name value pairs
  #
  # Arguments:
  #	args	Name value pairs, where the names are:
  #@a		-name	Cookie name
  #@a		-value	Cookie value
  #@a		-path	Path restriction
  #@a		-domain	domain restriction
  #@a		-expires	Time restriction
  #@a		-secure Append "secure" to cookie attributes
  #@r	a formatted cookie
  
  method cookie_make {args} {
    array set opt $args
    set line "$opt(-name)=$opt(-value) ;"
    foreach extra {path domain} {
        if {[info exist opt(-$extra)]} {
            append line " $extra=$opt(-$extra) ;"
        }
    }
    if {[info exist opt(-expires)]} {
        switch -glob -- $opt(-expires) {
            *GMT {
                set expires $opt(-expires)
            }
            default {
                set expires [clock format [clock scan $opt(-expires)] \
                        -format "%A, %d-%b-%Y %H:%M:%S GMT" -gmt 1]
            }
        }
        append line " expires=$expires ;"
    }
    if {[info exist opt(-secure)]} {
        append line " secure "
    }
    return $line
  }
  
  method cookie_set {field value {expire {}}} {
    my variable sock
    upvar #0 Httpd$sock data
    
    foreach host [my httpdHostName] {
      if { $host eq "localhost" } { set host {} }
      set cookie_args [list -name $field \
        -value $value \
        -domain $host \
        -path [my cget virtual]]
      if {[string is integer expire]} {
        lappend cookie_args -expires [clock format [expr [clock seconds] + [set expire]] -format "%Y-%m-%d"]
      }
      # Appending to the data(set-cookie) elimates the entire
      # kangaroo code that normally goes on with httpd
      lappend data(set-cookie) [my cookie_make {*}$cookie_args]
    }
  }
  
  method session {method args} {
    my variable session_data
    switch $method {
      anonymous {
        if {[dict getnull $session_data username] in {{} nobody anonymous}} {
          return 1
        }
        return 0
      }
      build {
        set session_data [::tao::args_to_options {*}$args]
      }
      dump {
        return $session_data
      }
      get {
        return [dict getnull $session_data [lindex $args 0]]
      }
      userid {
        set userid [dict getnull $session_data userid]
        if { $userid eq {} } {
          return local.anonymous
        }
        return $userid
      }
      set {
        #dict set session_data {*}args
        foreach {key value} [::tao::args_to_options {*}$args] {
          dict set session_data $key $value
        }
      }
      unset {
        dict unset session_data {*}args
      }
      varname {
        return [my varname session_data]
      }
      default {
        error "Valid: build.dump,get,set,unset,varname"
      }
    }
  }
}

###
# Create a standalone class suitable for using in a pure tcloo
# environment
###
tao::class httpd.url {
  superclass 
  aliases httpd.meta httpd.taourl
  
  property options_strict 0
  option virtual {}
  option threadargs {}
  
  #method Option_set::virtual newvalue {
  #  
  #}
  
  constructor {virtual {localopts {}} args} {
    my configurelist [list virtual $virtual threadargs $args {*}$localopts]
    ::Url_PrefixInstall $virtual [namespace code {my httpdDirect}] {*}$args
    my initialize
  }
  

  destructor {
    catch {::Url_PrefixRemove [my cget virtual]}
  }
  
  method initialize {} {}
  
  # This calls out to the Tcl procedure named "$prefix$suffix",
  # with arguments taken from the form parameters.
  # Example:
  # httpdDirect /device Device
  # if the URL is /device/a/b/c, then the Tcl command to handle it
  # should be

  #	If code 0 is passed, the result is returned to the client.
  #	If any other code is passed, an exception is raised, which
  #	will cause a stack trace to be returned to the client.
  #


  method httpdDirect {sock suffix} {



    set prefix [my cget virtual]
    set resultObj [httpd.result new $sock $prefix $suffix]
    my httpdSessionLoad $resultObj $prefix $suffix
    set cmd [my httpdMarshalArguments $resultObj]
    # Eval the command.  Errors can be used to trigger redirects.

    if [catch $cmd] {

      ::Httpd_ReturnData $sock text/html "<HTML><BODY>Error: <PRE><VERBATIM>$::errorInfo</VERBATIM></PRE></BODY></HTML>" 505
      $resultObj destroy
      return
    }
    set result [$resultObj httpReply]
    set code [dict get $result code]
    if {[string index $code 0] in {0 2}} {
      # Normal reply
      my httpdSessionSave $result
    }
    
    switch $code {
      401 {
        ::Httpd_ReturnData $sock text/html $::HttpdAuthorizationFormat $code

      }
      404 {
        ::Doc_NotFound $sock

      }
      302 {
        # Redirect.
        ::Httpd_Redirect [dict get $result redirect] $sock

      }
      default {

        if {[dict get $result cache-until] > 0} {
          ::Httpd_ReturnCacheableData $sock [dict get $result content-type] [dict get $result body] [dict get $result cache-until] [dict get $result code]
        } else {
          ::Httpd_ReturnData $sock [dict get $result content-type] [dict get $result body] [dict get $result code]
        }

      }
    }
    $resultObj destroy

  }









  


  method httpdSessionLoad {resultObj prefix suffix} {}





  

  method httpdSessionSave result {}





  
  #
  #	Use the url prefix, suffix, and cgi values (set with the
  #	ncgi package) to create a Tcl command line to invoke.
  #
  # Arguments:
  #	suffix		The part of the url after the domain prefix.
  #
  # Results:
  #	Returns a Tcl command line.
  #
  # Side effects:
  #	If the suffix (and query args) do not map to a Tcl procedure,
  #	returns empty string.
  method httpdMarshalArguments resultObj {
    set prefix [$resultObj cget url_prefix]
    set suffix [$resultObj cget url_suffix]

    if { $suffix in {/ {}} } {
      set method /html
    } else {
      set method /html$suffix
    }
    foreach {name value} [$resultObj query] {
      if { $name eq "method" } {
        set method /html/$value
        break
      }
    }
    return [list my $method $resultObj]
  }
  










  method unknown {args} {
    if {[string range [lindex $args 0] 0 4] eq "/html"} {
      my HtmlNotFound {*}$args





      return
    }






    next {*}$args


  }




  
















  ###
  # title: Implement html content at a toplevel
  ###
  method /html resultObj {
    $resultObj reset
    $resultObj configure title {Welcome!}

    $resultObj puts [my pageHeader]
    $resultObj puts {
Hello World
    }
    $resultObj puts [my pageFooter]
  }
  
  method HtmlNotFound args {
    set resultObj [lindex $args 0]
    $resultObj configure code 404
    $resultObj configure title {Page Not Found}
  }
  
  method pageHeader {} {
    return {
<HTML>
<HEAD>
    <TITLE>@TITLE@</TITLE>
    <link rel="stylesheet" href="/bootstrap/css/bootstrap.min.css">
</HEAD>

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded httpd::directoo 0.1 [list source [file join $dir directoo.tcl]]

  }
} else {
  proc DocPathNormalize {path} {
    return [file normalize $path]
  }
}

	}
	return $Httpd(webmaster)
    } else {
	set Httpd(webmaster) $email
    }
}

# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded httpd 1.7 [list source [file join $dir httpd.tcl]]
package ifneeded httpd::admin 1.0 [list source [file join $dir admin.tcl]]
package ifneeded httpd::auth 2.0 [list source [file join $dir auth.tcl]]
package ifneeded httpd::cgi 1.1 [list source [file join $dir cgi.tcl]]

package ifneeded httpd::config 1.0 [list source [file join $dir config.tcl]]
package ifneeded httpd::cookie 1.0 [list source [file join $dir cookie.tcl]]
package ifneeded httpd::counter 2.0 [list source [file join $dir counter.tcl]]
package ifneeded httpd::debug 1.0 [list source [file join $dir debug.tcl]]
package ifneeded httpd::digest 1.0 [list source [file join $dir digest.tcl]]
package ifneeded httpd::direct 1.1 [list source [file join $dir direct.tcl]]
package ifneeded httpd::dirlist 1.1 [list source [file join $dir dirlist.tcl]]

###
# Implements a barebone wiki in a community object
###

package require httpd::community

tao::class qwiki.layer.wiki {
  superclass community.layer


  property module user
  property schema version 1.0  
  property schema table qwiki

  property schema primary_key entryid

  
  property schema create_sql {
    create table if not exists qwiki (
      qwikid uuid default (uuid_generate()),
      indexed integer default 0,

      parent uuid references qwiki (qwikid) ON UPDATE CASCADE ON DELETE SET NULL,
      acl_name  string references acl (acl_name) ON UPDATE CASCADE ON DELETE SET NULL,

      class string,



      format string,
      title string,


      body text,
      ctime unixtime default now(),

      mtime unixtime default now(),

      primary key (qwikid)





    );









    create table if not exists qwiki_property (
      qwikid    string references qwiki (qwikid) ON UPDATE CASCADE ON DELETE CASCADE,
      field      string,



      value      string,



      primary key (qwikid,field)
    );




    create table if not exists qwiki_link (




      linktype string,





      qwiki integer references qwiki (qwikid) ON UPDATE CASCADE ON DELETE CASCADE,
      refqwiki integer references qwiki (qwikid)  ON UPDATE CASCADE ON DELETE CASCADE
    );
    

    -- Generate initial content
    insert into qwiki(qwikid,title,class,format,page) VALUES (local.homepage,'Home','page','markdown','Welcome to Qwiki!');
    -- Generate a FTS
    CREATE VIRTUAL TABLE qwiki_search USING fts4(title, body);
  }








  



}





tao::class httpd.qwiki {
  superclass httpd.community

  constructor {virtual {localopts {}} args} {
    my configurelist [list virtual $virtual threadargs $args {*}$localopts]
    ::Url_PrefixInstall $virtual [namespace code {my httpdDirect}] {*}$args
    my initialize




  }






  method active_layers {} {
    return {
      user    {prefix uid class community.layer.user}
      group   {prefix gid class community.layer.group}
      session {prefix sesid class community.layer.session}
      acl     {prefix acl class community.layer.acl}
      wiki    {prefix wiki class qwiki.layer.wiki}

    }


  }
  

  method /html args {

    my layer wiki /html local.homepage


  }













}

package provide httpd::qwiki 0.1

  method Database_Functions {} {
  }

  ###
  # topic: 62f531b6d83adc8a10d15b27ec17b675
  ###
  method schema::create_sql {} {
    set result [my property schema create_sql]
    foreach {layer obj} [my layers] {
      set table [$obj property schema table]
      append result "-- BEGIN $table" \n
      append result [$obj property schema create_sql] \n
      append result "-- END $table" \n
    }
    return $result

    my graft $alias $objname
    my Database_Functions
    my attach_sqlite_methods $objname
    if {!$exists} {
      my Database_Create
    }
  }
  
  ###
  # Perform a daily backup of the database
  ###
  method Database_Backup {} {
    set filename [my cget filename]
    set now [clock seconds]
    set today [clock format $now -format "%Y-%m-%d-%H"]
    set path [file join [file dirname $filename] backups]
    if {![file exists $path]} {
      file mkdir $path
    }
    set bkuplink [file join $path [file rootname $filename].latest.sqlite]
    file delete $bkuplink
    set bkupfile [file join $path [file tail [file rootname $filename]].$today.sqlite]
    my <db> backup $bkupfile
    file link $bkuplink $bkupfile
    
    ###
    # Keep:
    # * one backup per hour for the past day
    # * one backup per day for the past week
    # * one per week for the past 2 months
    # * one per month for the past year
    # * one every 6 months for years beyond
    ###
    set day [expr {3600*24}]
    set week [expr {$day*7}]
    set month [expr {$week*4}]
    set year [expr {$month*12}]
    set halfyear [expr {$month*6}]    

    
    foreach file [glob -nocomplain [file join $path *.sqlite]] {
      set age [expr {$now - [file mtime $file]}]
      if { $age < $day } continue
      if { $age < $week } {
        lappend daily([expr {$age/$day}]) $age $file
        continue
      }
      if { $age < ($month*2) } {
        lappend weekly([expr {$age/$week}]) $age $file
        continue
      }
      if { $age < ($halfyear*2) } {
        lappend monthly([expr {$age/$month}]) $age $file
        continue
      }
      lappend halfyearly([expr {$age/$halfyear}]) $age $file
    }

    foreach {bin backups} [array get daily] {
      foreach {mtime file} [lrange [lsort -stride 2 -integer $backups] 2 end] {
        file delete $file
      }
    }
    foreach {bin backups} [array get weekly] {
      foreach {mtime file} [lrange [lsort -stride 2 -integer $backups] 2 end] {
        file delete $file
      }
    }
    foreach {bin backups} [array get monthly] {
      foreach {mtime file} [lrange [lsort -stride 2 -integer $backups] 2 end] {
        file delete $file
      }
    }
    foreach {bin backups} [array get halfyearly] {
      foreach {mtime file} [lrange [lsort -stride 2 -integer $backups] 2 end] {
        file delete $file
      }
    }
  }
  
  ###
  # topic: 6319133f765170f9949de3e3329bf07f
  # description:
  #    Action to perform when database is busy
  #    return "1" to cause action to fail,
  #    0 to allow Sqlite to wait and try again
  ###
  method Database_Busy {} {
    after 1
    return 0
  }

  ###
  # topic: 4251a1e7abd66d20c66f9dcd25bb1e54
  # description:
  #    Deep wizardry

    return 0
  }

  ###
  # topic: 6292ac0c78dbb91c7aaa629f48a301a3
  ###
  method Database_Create {} {
    my <db> eval [my property schema create_sql]
  }

  ###
  # topic: 582bb8d10136f632866e73a6b72a9c32
  ###
  method Database_Functions {} {
    my <db> function uuid_generate ::tao::uuid_generate

###
# Structure that manages an interactive help system
###
package provide ::tao::helpdoc 0.1

###
# topic: f5641520f17f23259b96facbe936c875
###
tao::class taodb::yggdrasil {
  aliases tao.yggdrasil
  superclass taodb::module.sqlite
  
  property schema create_sql {
    CREATE TABLE if not exists config(
      name TEXT PRIMARY KEY,
      value ANY
    );
    create table if not exists entry (
      entryid string default (uuid_generate()),
      indexed integer default 0,

}

###
# topic: b8897eebb90a62e0bac262762116b6b5
###
proc ::tao::script_path {} {
  set path [file dirname [file normalize [info script]]]





  return $path

}

set ::tao::root [::tao::script_path]
::tao::load_path $::tao::root {
  event.tcl

	append result "<tr><td colspan=5><input type=submit value=\"$submit\">"
	append result "</tr>\n"
	append result </form>\n
    }
    append result </table>\n
}













proc Snmp_setMib {session mib} {
    upvar #0 Session:$session state

    foreach {num type value}  [lindex [$state(snmp) get $mib] 0] {}
    set names [lindex [mib tc $mib] 3]
    if {[llength $names] >1} {
    	append result "<select name=\"[mib name $mib]\">\n"
    	foreach name $names {
	    lassign $name choice index
	    set s [expr {("$value" == "$choice") ? "SELECTED" : ""}]
	    append result "  <option value=$index$s>$choice\n"
	}
	append result "</select>"
    } else {
    	append result "<input name=\"[mib name $mib]\" value=\"$value\">"
    }