tclhttpd

2015-03-28 Sean Woods <[email protected]>
	* Started work on v4



	* 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]>

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}]} {



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

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

    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



























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

# This is currently broken
if {0} {
    package require httpd::safetcl	;# External process running safetcl shells
}

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

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

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


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

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

    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 {} {
    my variable result
    array set result {
      code 200
      type text/html
    }
    set body {
<HTML><BODY>
Hello World!
<p>
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}
    } {
      append body "<li><a href=$prefix/$url>$url</a> - $comment</li>"
    }
    append body {
</ul>
</BODY></HTML>
}
    set result(body) $body
  }

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

  method /html/deadurl {} {
    my variable result
    array set result {
      code 501

      body {
<HTML><BODY>
I threw an error this way
</BODY></HTML>
}
      content-type text/html

    }
  }

  ###
  # title: Implement html content at a toplevel
  ###
  method /html/suburl {} {
    my variable result
    array set result {
      code 200
      body {
<HTML><BODY>


Sub Url
</BODY></HTML>


}
      type text/html
    }
  }

  ###
  # title: Implement html content at a toplevel
  ###
  method /html/default {} {
    my variable result
    array set result {

      code 404
      body {
<HTML><BODY>
Not Found
</BODY></HTML>
}
      type text/html
    }




  }
}
ootest create OOTEST /ootest {}

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

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(dbfile) [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 {} {
    my variable result
    my reset
    set result(title) {Welcome to Qwiki!}

    my puts [my pageHeader]
    my puts {
Hello World!
<p>
    }
    my puts "Logged in as user: [dict getnull $result(session) username]<br>"
    if {[info exists result(sessionid)]} {
      my puts "Logged with session: $result(sessionid)<br>"
    }
    my 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}
    } {
      my puts "<li><a href=$prefix/$url>$url</a> - $comment</li>"
    }
    my puts {
</ul>
</BODY></HTML>
}
  }

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

  method /html/deadurl {} {
    my variable result
    my reset
    set result(code) 501
    my puts [my pageHeader]
    my puts {
I threw an error this way
    }
    my puts [my pageFooter]
  }

  ###
  # title: Implement html content at a toplevel
  ###
  method /html/suburl {} {
    my variable result
    my reset

    my puts [my pageHeader]
    my puts {
This is a suburl!
    }

    my puts [my pageFooter]
  }

  ###
  # title: Implement html content at a toplevel
  ###
  method /html/default {} {
    my variable result
    my reset
    set result(code) 404


    my puts [my pageHeader]
    my puts {
Not Found
    }


    my puts [my pageFooter]
  }
}

qwikitest create HOME /home [list dbfile [Config dbfile]]


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

# 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

* dbfile - 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.

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

###
package require tao
package require sqlite3
package require tao-sqlite
package require md5 2
package require sha1 2

package require httpd::taourl
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


tao::class httpd.community {  
  superclass httpd.taourl taodb::yggdrasil
  
  option virtual {}
  option dbfile {}

  option community-id {}





  set dir [file dirname [file normalize [info script]]]
  foreach jsfile [glob -nocomplain [file join $dir *.js]] {
    property js [file tail $jsfile] [cat $jsfile]



  }




























  method initialize {} {
    if {[my cget dbfile] eq {}} {






































      my configure dbfile :memory:
    }
    my Database_Attach [my cget dbfile]














































































    my configurelist [my <db> eval {select name,value from config}]
    if {[my cget community-id] eq {}} {
      my configure community-id [::tao::uuid_generate]

    }
    my variable config






  }















































































































  ###
  # This class extents the yggdrasil schema to
  # include session management, user management,
  # and access control lists
  ###
  property 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,
      parent integer references entry (entryid) ON UPDATE CASCADE ON DELETE SET NULL,
      acl_name  string references acl (acl_name) ON UPDATE CASCADE ON DELETE SET NULL,
      class string,
      name string,
      mtime integer,
      primary key (entryid)
    );

    create table if not exists property (
      entryid    string references entry (entryid) ON UPDATE CASCADE ON DELETE CASCADE,
      field      string,
      value      string,
      primary key (entryid,field)
    );

    create table if not exists link (
      linktype string,
      entry integer references entry (entryid) ON UPDATE CASCADE ON DELETE CASCADE,
      refentry integer references entry (entryid)  ON UPDATE CASCADE ON DELETE CASCADE
    );

    create table if not exists idset (
      class string,
      id    integer,
      name  string,
      primary key (class,id)
    );
    create table if not exists aliases (
      class string,
      alias string,
      cname string references entry (name),
      primary key (class,alias)
    );
    create table if not exists repository (
      handle string,
      localpath string,
      primary key (handle)
    );
    create table if not exists file (
      fileid         string default (uuid_generate()),
      repo           string references repository (handle) ON UPDATE CASCADE ON DELETE CASCADE,
      path           string,  --path relative to repo
      localpath      string,  --cached path to local file
      filename       string,  --filename
      content_type   string,  --Content/Type of file
      package        string,  --Name of any packages provided,
      size           integer, --File size in bytes
      mtime          integer, --mtime in unix time
      hash           string,   --sha1 hash of file
      replaces       string references file (fileid) ON UPDATE CASCADE ON DELETE SET NULL,
      primary key (fileid)
    );
    create table if not exists filelink (
      linktype string,
      entryid integer references entry (entryid)  ON UPDATE CASCADE ON DELETE CASCADE,
      fileid integer references file   (fileid)  ON UPDATE CASCADE ON DELETE CASCADE
    );
    
    --BEGIN COMMUNITY EXTENSIONS--
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)
);

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)
);


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)
);

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)
);

--- POPULATE WITH DATA ---
insert into config(name,value) VALUES ('community-id',uuid_generate());

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','');

insert into groups(groupid,groupname) VALUES ('local.wheel','wheel');
insert into group_members(userid,groupid) VALUES ('local.webmaster','local.wheel');

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');

  }

  method Database_Functions {} {
    set seed [info hostname]
    my <db> function uuid_generate ::tao::uuid_generate
    my <db> function sha1    {::sha1::sha1 -hex}

  }

  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
  }
  
  method httpdSessionLoad {sock prefix suffix} {














    my variable result
    array set result {
      code 200
      date  0
      header {}
      footer {}
      body {}
      content-type text/html






    }
    set result(sock) $sock
    set result(datavar) ::Httpd$sock 

    # Set up the environment a-la CGI.
    ::Cgi_SetEnv $sock $prefix$suffix [my varname env]
    # Prepare an argument data from the query data.
    ::Url_QuerySetup $sock
    set result(query) [ncgi::nvlist]
    ###











    # Look for a session id in the query
    ###
    foreach {field value} $result(query) {
      if {$field eq "sessionid"} {
        set stmt {select userid from session where sesid=:value}
        if {[my <db> exists $stmt]} {
          set result(sessionid) $value
          set result(userid) [my <db> one $stmt]
          set result(session) [my <db> eval {select field,value from session_property where sesid=:value}]
          set result(session_delta) $result(session)
          return
        }
      }
    }
    ###
    # Look for a sessionid in cookies
    ###
    foreach {item} [split [get env(HTTP_COOKIE)] ;] {
      set field [lindex [split $item =] 0]
      set value [lindex [split $item =] 1]
      set stmt {select userid from session where sesid=:value}
      if {[my <db> exists $stmt]} {
        set result(sessionid) $value
        set result(userid) [my <db> one $stmt]
        set result(session) [my <db> eval {select field,value from session_property where sesid=:value}]
        set result(session_delta) $result(session)
        return
      }
    }
    if {![info exists result(userid)]} {
      set result(userid) local.anonymous
      dict set result(session) username anonymous
    }
    set expdate  [expr {14*86400}]
    set expires [expr {[clock seconds]+$expdate}]]
    if {![info exists result(sessionid)]} {
      # Generate a session
      set sesid [::tao::uuid_generate]
      set result(sessionid) $sesid
      my <db> eval {insert into session(sesid,userid,expires) VALUES (:sesid,:result(userid),:expires)}
    } else {
      my <db> eval {update session set expires=:expires where sesid=:sesid;}
    }
    my httpdCookieSet session $result(sessionid) $expdate
  }
    
  method httpdSessionSave sock {








    # Save any return cookies which have been set.
    # This works with the Doc_SetCookie procedure that populates
    # the global cookie array.
    
    ::Cookie_Save $sock
    if {![info exists result(sessionid)]} return
    my variable result
    set sessionid $result(sessionid)
    







    set add {}
    set delete {}
    set modify {}

    foreach {field value} $result(session) {
      if {![dict exists $result(session_delta) $field]} {
        lappend add $field $value
      } else {$value != [dict get $result(session_delta)]} {
        lappend modify $field $value
      }
    }
    foreach {field value} $result(session_deleta) {
      if {![dict exists $result(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 {} {
    my variable result
    set sesid $result(sessionid)
    my <db> eval {
update session set userid='local.anonymous' where sesid=:sesid;
delete from session_property where sesid=:sesid;
}
    dict set result(session) username anonymous
    dict set result(session) userid local.anonymous
    set result(message) {You have been logged out}
    my /html/login
  }
  
  method /html/login {} {
    my variable result
    

    my reset
    my puts <html>
    my 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>
    }    
    my puts {
  <body>
    }
    set msg [get result(message)]
    if { $msg ne {} } {
      my puts "<pre><font color=ÓredÓ face=Ósans-serifÓ size=Ó1Ó>$msg</font></pre><hr>"
    }
    my 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>
    }
    my puts {<form action="javascript:login()" method="post" >}
    my puts "<input type=\"hidden\" id=\"key\" value=\"[my cget community-id]\" />"  
    my puts "<input type=\"hidden\" id=\"sesid\" value=\"$result(sessionid)\" />"  
    my 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>
    }
    my puts </html>
  }

  method /html/authenticate {} {
    my variable result
    foreach {field value} $result(query) {
      if {$field eq "uid"} {
        set username $value
        foreach {field value} $result(query) {
          if {$field eq "hash"} {
            set passhash [my <db> one {select password from users where username=:username}]
            set realhash [::sha1::sha1 -hex "$result(sessionid)$passhash"]
            if { $realhash eq $value } {
              set userid [my <db> one {select username from users where username=:username}]

              my <db> eval {update session set userid=:userid where sesid=:result(sessionid)}
              dict set result(session) username $username
              dict set result(session) userid $userid



              set root [my cget virtual]
              my puts "<HTML><HEAD><META HTTP-EQUIV=\"Refresh\" CONTENT=\"1; URL=$root\"></HEAD>"
              my puts {
<BODY>
You are now being logged in. You will be redirected in a moment.
<p>
              }
              my puts "<A href=\$root\>Home...</a>"
              my puts </BODY></HTML>
              return
            }
          }
        }
      }
    }
    set result(message) {Password or Username was incorrect or invalid.}
    my /html/login
  }
}





























package provide httpd::community 0.1

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

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

package provide httpd::compat 3.3

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

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

# 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::cookie	;# Cookie_Save
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


###
# Seperate out the working bits so that Tao and TclOO can share
# the same core functions

###
oo::class create httpd.meta {


  


































  destructor {
    catch {::Url_PrefixRemove [my cget virtual]}
  }
  

  method initialize {} {}


  


















































































































































  method httpdCookieSet {field value {expire {}}} {



    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"]
      }
      ::Cookie_Set {*}$cookie_args


    }
  }

  method httpdHostName {} {

    my variable env
    return [lindex [split [get env(HTTP_HOST)] :] 0]




  }

































































  
  # 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} {
    global env
    upvar #0 Httpd$sock data
    my variable result
    set prefix [my cget virtual]

    my httpdSessionLoad $sock $prefix $suffix
    set cmd [my httpdMarshalArguments $sock $suffix]
    # Eval the command.  Errors can be used to trigger redirects.

    if [catch $cmd] {
      set result(code) 505
      set result(body) "<HTML><BODY>Error: <PRE><VERBATIM>$::errorInfo</VERBATIM></PRE></BODY></HTML>"

      set result(content-type) text/html 
    }


    if {[string index $result(code) 0] in {0 2}} {
      # Normal reply
      my httpdSessionSave $sock
    }

    switch $result(code) {
      401 {
        ::Httpd_ReturnData $sock text/html $::HttpdAuthorizationFormat $result(code)
        return
      }
      404 {
        ::Doc_NotFound $sock
        return
      }
      302 {
        # Redirect.
        ::Httpd_Redirect $result(redirect) $sock
        return
      }
      default {

        set body [string map [list @[email protected] $result(title)] $result(body)]
        if {$result(date)} {
          ::Httpd_ReturnCacheableData $sock $result(content-type) $body $result(date) $result(code)
        } else {
          ::Httpd_ReturnData $sock $result(content-type) $body $result(code)

        }
        return
      }
    }

  }
  
  method httpdSessionLoad {sock prefix suffix} {
    my variable result
    array set result {
      code 200
      date  0
      title {}
      body {}
      redirect {}
      content-type text/html
    }
    set result(sock) $sock
    set result(datavar) ::Httpd$sock 


    # Set up the environment a-la CGI.
    ::Cgi_SetEnv $sock $prefix$suffix [my varname env]
    # Prepare an argument data from the query data.
    ::Url_QuerySetup $sock
    set result(query) [ncgi::nvlist]
  }
  
  method httpdSessionSave sock {
    # Save any return cookies which have been set.
    # This works with the Doc_SetCookie procedure that populates
    # the global cookie array.
    ::Cookie_Save $sock 
  }
  
  #
  #	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 {sock suffix} {
    my variable result
    set prefix [my cget virtual]

    if { $suffix in {/ {}} } {
      set method /html
    } else {
      set method /html$suffix
    }
    foreach {name value} $result(query) {
      if { $name eq "method" } {
        set method /html/$value
        break
      }
    }
    return [list my $method]
  }
  
  method reset {} {
    my variable result
    set result(body) {}
  }
  
  method puts args {
    my variable result
    append result(body) {*}$args \n
  }
  
  method unknown {args} {
    if {[string range [lindex $args 0] 0 4] ne "/html"} {
      next {*}$args

    }
    my variable result
    set result(code) 404
  }
}


###
# Create a standalone class suitable for using in a pure tcloo
# environment
###
oo::class create httpd.url {
  superclass httpd.meta
  
  variable virtual
  variable config
  
  constructor {virtual {localopts {}} args} {
    my configurelist [list virtual $virtual {*}$localopts]
    ::Url_PrefixInstall $virtual [namespace code {my httpdDirect}] {*}$args
    my initialize
  }
  
  method configurelist localopts {
    my variable config
    foreach {field value} $localopts {
      dict set config $field $value
    }
  }
  
  method cget field {
    my variable config
    if {[dict exists $config $field]} {
      return [dict get $config $field]
    }
    return {}
  }
  
  ###
  # title: Implement html content at a toplevel
  ###
  method /html {} {
    my variable result
    set result(title) {Welcome!}
    my reset

    my puts [my pageHeader]
    my puts {
Hello World
    }
    my puts [my pageFooter]
  }
  






  method pageHeader {} {
    return {
<HTML>
<HEAD>
    <TITLE>@[email protected]</TITLE>
    <link rel="stylesheet" href="/bootstrap/css/bootstrap.min.css">
</HEAD>

# 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 @[email protected] $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>@[email protected]</TITLE>
    <link rel="stylesheet" href="/bootstrap/css/bootstrap.min.css">
</HEAD>

# "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]]
package ifneeded httpd::taourl 0.1 [list source [file join $dir taourl.tcl]]

# "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]]

*httpd.taourl* is an implementation of [httpd.url](wiki?name=DirectOO) in the [Tao](../tao.md) framework. Tao offers enhanced 
option handling and a system for tracking properties of classes and object.

*httpd.taourl* has the all of the same methods and variables as [httpd.url](directoo.md), with additional methods provided 
by the Tao framework.

package require tao
package require httpd::directoo


tao::class httpd.taourl {
  superclass httpd.meta

  property options_strict 0

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

package provide httpd::taourl 0.1

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

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

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

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

# this is too much of a compatibility hassle, so we alias
catch {interp alias {} Doc_Webmaster {} Httpd_Webmaster}
catch {interp alias {} Httpd_RedirectDir {} Redirect_Dir}

	}
	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::compat 3.3 [list source [file join $dir compat.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]]

# 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 httpd.qwiki {
  superclass httpd.community
  
  #

  #	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 {sock suffix} {
    my variable result
    set prefix [my cget virtual]





    set realm /html
    if { $suffix in {/ {}} } {
      set method /html
    } else {
      set parts [split [string trim $suffix /] /]
      set node [lindex $parts 0]
      if {[my <db> exists {select entryid from entry where entryid like :node}]} {
        return [list my /wiki $parts]

      }
      if {[my <db> exists {select userid from users where userid like :node}]} {
        return [list my /user $parts]



      }
      if {[my <db> exists {select groupid from groups where groupid like :node}]} {
        return [list my /group $parts]




      }
      set method /html$suffix
    }
    set qmethod {}
    set quuid {}
    foreach {name value} $result(query) {
      if { $name eq "uuid" } {
        if {[my <db> exists {select entryid from entry where entryid like :node}} {
          set real /wiki
          set quuiid $value
        }
        if {[my <db> exists {select userid from users where userid like :node}} {
          set real /user
          set quuiid $value
        }
        if {[my <db> exists {select groupid from groups where groupid like :node}} {
          set real /group
          set quuiid $value
        }


      }
      if { $name eq "method" } {
        set qmethod $value
        break




      }
    }
    if {$quuid != {}} {
      return [list my $realm [list $quuid $qmethod]]
    } else {
      if {$qmethod != {}} {
        return [list my /html/$qmethod]
      } else {

        return [list my $method]





      }
    }
  }
  
  method /user parts {
    my variable result env
    
    set uuid [lindex $parts 0]
    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
    my reset
    my puts {
<html><head><title>User $record(username)</title></head><body>
    }
    my puts "<TABLE>"
    foreach {field value} [array get record] {
      my puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }    
    foreach {field value} $props {
      my puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }
    my <db> eval {select distinct acl_name from acl} {
      my puts "<TR><TH>Rights $acl_name</TH><Td>[my aclRights $acl_name $record(userid)]</TD></TR>"
    }
    my puts "</TABLE>"
    my puts <hr>
    my puts "<TABLE>"
    foreach {field value} [array get result] {
      if { $field in {body session session_delta} } continue
      my puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }
    my puts "</TABLE>"
    my puts "<hr>Session<p>"
    my puts "<TABLE>"
    foreach {field value} [get result(session)] {
      my puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }
    my puts "</TABLE>"
    my puts "<hr>ENV<p>"
    my puts "<TABLE>"
    foreach {field value} [array get env] {
      my puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }
    my puts "</TABLE>"
    my puts "</BODY></HTML>"
  }
  

  method /html/env args {
    my variable env

    
    set uuid [lindex $parts 0]
    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
    my reset
    my puts "
<html><head><title>User $record(username)</title></head><body>
    "
    my puts "<TABLE>"
    foreach {field value} [array get env] {
      my puts "<TR><TH>$field</TH><TD>$value</TD></TR>"
    }    
    my puts "</TABLE>"
    my puts "</BODY></HTML>"
  }
}

package provide httpd::qwiki 0.1

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









































































  ###
  # 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 {} {
    update
    return 0
  }

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

  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 create_sql]
  }

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

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

###
# topic: f5641520f17f23259b96facbe936c875
###
tao::class taodb::yggdrasil {
  aliases tao.yggdrasil
  superclass taodb::module.sqlite
  
  property 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: 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]]]
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string index $path 1] eq ":"} {
      set path [string range $path 2 end]
    }
  }
  return $path

}

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

}

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

# Get an item as a form element

proc Snmp_lassign {varList value} {
    if {[string length $value] == 0} {
	foreach var $varList {
	    uplevel [list set $var {}]
	}
    } else {
	uplevel [list foreach $varList $value { break }]
    }
}

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 {
	    Snmp_lassign {choice index} $name
	    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\">"
    }

	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\">"
    }