tclhttpd

Check-in [d1004ea2ce]
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Fixed the library path in the httpd.tcl script Adding a new unified session/login/contact/access control manager calleed "community" (half baked) Adding a quick and dirty wiki (qwiki). This code is being ported from the generators that run etoyoc.com, and I'm only part of the way there so far, but the functions that are working can be exercised in bin/test/ (The test build an in-memory database)
Timelines: family | ancestors | descendants | both | 4_0
Files: files | file ages | folders
SHA1: d1004ea2ce9efd000d79a421d90396ef178faa79
User & Date: hypnotoad 2015-04-02 00:03:27
Context
2015-04-02
09:19
Moved DirectOO to its own module. Adding markdown files in the source to make maintaining the code simpler check-in: 701281756f user: hypnotoad tags: 4_0
00:03
Fixed the library path in the httpd.tcl script Adding a new unified session/login/contact/access control manager calleed "community" (half baked) Adding a quick and dirty wiki (qwiki). This code is being ported from the generators that run etoyoc.com, and I'm only part of the way there so far, but the functions that are working can be exercised in bin/test/ (The test build an in-memory database) check-in: d1004ea2ce user: hypnotoad tags: 4_0
2015-04-01
09:36
Tweak to bootstrap Added openWysiwyg check-in: 2f4e7a3332 user: hypnotoad tags: 4_0
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to bin/httpd.tcl.

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
set auto_path [concat [list $Config(lib)] $auto_path]

# Search around for the Standard Tcl Library
# We used to require "tcllib", but that now causes complaints
# Tcllib 1.6 has inconsistencies with md5 1.4.3 and 2.0.0,
# and requiring 1.0 cures later conflicts with 2.0

if {![catch {package require md5 1}]} {
    # Already available in environment
} elseif {[file exist [file join $home ../tcllib]]} {
    lappend auto_path [file join $home ../tcllib]
} else {
    # Look for the CVS development sources
    set cvs [lindex [lsort -decreasing \
	[glob -nocomplain [file join $home ../../tcllib*]]] 0]






|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
set auto_path [concat [list $Config(lib)] $auto_path]

# Search around for the Standard Tcl Library
# We used to require "tcllib", but that now causes complaints
# Tcllib 1.6 has inconsistencies with md5 1.4.3 and 2.0.0,
# and requiring 1.0 cures later conflicts with 2.0

if {![catch {package require md5 2}]} {
    # Already available in environment
} elseif {[file exist [file join $home ../tcllib]]} {
    lappend auto_path [file join $home ../tcllib]
} else {
    # Look for the CVS development sources
    set cvs [lindex [lsort -decreasing \
	[glob -nocomplain [file join $home ../../tcllib*]]] 0]

Added bin/test/common.tcl.




























































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
#
# Tcl HTTPD
#
# This is the main script for an HTTP server. 
# To test out of the box, do
# tclsh httpd.tcl -debug 1
# or
# wish httpd.tcl -debug 1
#
# For a quick spin, just pass the appropriate settings via the command line.
# For fully custom operation, see the notes in README_custom.
#
# A note about the code structure:
# ../lib	The script library that contains most of the TclHttpd
#		implementation
# ../tcllib	The Standard Tcl Library.  TclHttpd ships with a copy
#		of this library because it depends on it.  If you already
#		have copy installed TclHttpd will attempt to find it.
#
# TclHttpd now requires Tcl 8.0 or higher because it depends on some
#	modules in the Standard Tcl Library (tcllib) that use namespaces.
#	In practice, some of the modules in tcllib may depend on
#	new string commands introduced in Tcl 8.2 and 8.3.  However,
#	the server core only depends on the base64 and ncgi packages
#	that may/should be/are compatible with Tcl 8.0
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Scriptics Corporation
# Copyright (c) 2001-2002 Panasas
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: httpd.tcl,v 1.61 2006/04/27 00:24:51 wart Exp $
#

# Auto-detect the configuration
# 1. Development - look for $home/../lib and $home/../../tcllib/modules
# 2. Standalone install - look for $home/../lib/tclhttpd $home/tcllib
# 3. Tcl package install - look for $tcl_library/../tclhttpd

set v 4.0.0

# Put the library in front in case there is both the development
# library and an installed library

set auto_path [concat [list $Config(lib)] $auto_path]

# Search around for the Standard Tcl Library
# We used to require "tcllib", but that now causes complaints
# Tcllib 1.6 has inconsistencies with md5 1.4.3 and 2.0.0,
# and requiring 1.0 cures later conflicts with 2.0

if {![catch {package require md5 2}]} {
    # Already available in environment
} elseif {[file exist [file join $home ../tcllib]]} {
    lappend auto_path [file join $home ../tcllib]
} else {
    # Look for the CVS development sources
    set cvs [lindex [lsort -decreasing \
	[glob -nocomplain [file join $home ../../tcllib*]]] 0]
    if {[file exist [file join $cvs modules]]} {
	lappend auto_path [file join $cvs modules]
    } elseif {[file exist [file join $cvs pkgIndex.tcl]]} {
	lappend auto_path $cvs
    } else {
	error "Cannot find Standard Tcl Library in auto_path:\n[join $auto_path \n]"
    }
}

set Config(home) $home
unset home

# Add operating-specific directories to the auto_path for
# the binary extensions

regsub -all { } $tcl_platform(os) {} tmp
foreach dir [list \
	[file join $Config(lib) Binaries $tmp] \
	[file join $Config(lib) Binaries $tmp $tcl_platform(osVersion)] \
	] {
    if {[file isdirectory $dir]} {
	lappend auto_path $dir
    }
}
unset tmp dir

proc ::Config {field args} {
  switch {[llength $args]>1} {
    error "Usage: Config field ?value?"
  }
  global Config
  if {[llength $args]} {
    set Config($field) [lindex $args 0]
  }
  if {[info exists Config($field)]} {
    return $Config($field)
  }
}
##############
# Config file
##############

# Load the configuration file into the Config array
# First, we preload a couple of defaults

set Config(docRoot) [file join [file dirname [Config home]] htdocs]
set Config(library) [file join [file dirname [Config home]] custom]
set Config(main) [file join [Config home] httpdthread.tcl]
set Config(debug) 0
set Config(compat) 3.3

# The configuration bootstrap goes like this:
# 1) Look on the command line for a -config rcfile name argument
# 2) Load this configuration file via the config module
# 3) Process the rest of the command line arguments so the user
#       can override the settings in the rc file with them.

set ix [lsearch $argv -config]
if {$ix >= 0} {
    incr ix
    set Config(config) [lindex $argv $ix]
} else {
    set Config(config) [file join [Config home] tclhttpd.rc]
}

package require httpd 1.6
package require httpd::version		;# For Version proc
package require httpd::utils		;# For Stderr
package require httpd::counter		;# For Count
package require fileutil                ;# For tempdir support: needed on Windows

package require httpd::config		;# for config::init


proc ::cget {field} {
  global Config
  if {[info exists Config($field)]} {
    return $Config($field)
  }
}
proc ::DebugCheckRandomPassword input {
  return 1
}
array set Config {
  debug 1
  port 8015
  https_port	8016
  uid 50
  gid 50
  ipaddr {}
  https_ipaddr {}
  secsPerMinute	60
  threads 0
  gui        1
LogFlushMinutes 0
LogDebug 0
CompressProg gzip
MaxFileDescriptors	256
SSL_REQUEST	0
SSL_REQUIRE	0
SSL_CAFILE 	""
}
Config docroot [file join [Config home] .. htdocs]
Config library [file join [Config home] .. custom]
Config main [file join [Config home]  httpdthread.tcl]
Config host [info hostname]
Config https_host [info hostname]
Config webmaster	[email protected][info hostname]
Config LogFile [file join [::fileutil::tempdir] log]
Config SSL_CADIR	[file join [file dirname [Config home]] certs])
Config SSL_CERTFILE	[file join [Config SSL_CADIR] server.pem]
Config MailServer {}
# The Config array now reflects the info in the configuration file

#########################
# command line arguments
#########################

# Override config file settings with command line arguments.
# The CommandLineOptions global is known to some of the
# web pages that document the server.

package require cmdline
set CommandLineOptions [list \
        [list virtual.arg      [cget virtual]      {Virtual host config list}] \
        [list config.arg       [cget config]       {Configuration File}] \
        [list main.arg         [cget main]         {Per-Thread Tcl script}] \
        [list docRoot.arg      [cget docRoot]      {Root directory for documents}] \
        [list port.arg         [cget port]         {Port number server is to listen on}] \
        [list host.arg         [cget host]         {Server name, should be fully qualified}] \
        [list ipaddr.arg       [cget ipaddr]       {Interface server should bind to}] \
        [list https_port.arg   [cget https_port]   {SSL Port number}] \
        [list https_host.arg   [cget https_host]   {SSL Server name, should be fully qualified}] \
        [list https_ipaddr.arg [cget https_ipaddr] {Interface SSL server should bind to}] \
        [list webmaster.arg    [cget webmaster]    {E-mail address for errors}] \
        [list uid.arg          [cget uid]          {User Id that server runs under}] \
        [list gid.arg          [cget gid]          {Group Id for caching templates}] \
        [list secs.arg          [cget secsPerMinute] {Seconds per "minute" for time-based histograms}] \
        [list threads.arg      [cget threads]      {Number of worker threads (zero for non-threaded)}] \
        [list library.arg      [cget library]      {Directory list where custom packages and auto loads are}] \
        [list debug.arg	       0	        {If true, start interactive command loop}] \
        [list compat.arg       3.3	        {version compatibility to maintain}] \
        [list gui.arg           [cget gui]      {flag for launching the user interface}] \
        [list mail.arg           [cget MailServer]      {Mail Servers for sending email from tclhttpd}] \
        [list daemon.arg        0      		   {Run in the background as a daemon process.  Requires the 'Expect' package.}] \
    ]
array set Config [cmdline::getoptions argv $CommandLineOptions \
    "usage: httpd.tcl options:"]

if {[string length $Config(library)]} {
    lappend auto_path $Config(library)
}

if {$Config(debug)} {
    puts stderr "auto_path:\n[join $auto_path \n]"
    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
###################

Httpd_Init
#Counter_Init $Config(secs)

# Open the listening sockets
Httpd_Server $Config(port) $Config(host) $Config(ipaddr)
append startup "httpd started on port $Config(port)\n"

if {[catch {source $Config(main)} message]} then {
    global errorInfo
    set error "Error processing main startup script \"[file nativename $Config(main)]\"."
    append error "\n$errorInfo"
    error $error
}

# The main thread owns the log

Log_CompressProg	[cget CompressProg]
Log_SetFile		[cget LogFile]$Config(port)_
Log_FlushMinutes	[cget LogFlushMinutes]
Log_Flush

Changes to bin/test/directoo.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275

276
277
278
279
280
281
282
###
# Test for DirectOO
###
#!/bin/sh
#
# Tcl HTTPD
#
# This is the main script for an HTTP server. 
# To test out of the box, do
# tclsh httpd.tcl -debug 1
# or
# wish httpd.tcl -debug 1
#
# For a quick spin, just pass the appropriate settings via the command line.
# For fully custom operation, see the notes in README_custom.
#
# A note about the code structure:
# ../lib	The script library that contains most of the TclHttpd
#		implementation
# ../tcllib	The Standard Tcl Library.  TclHttpd ships with a copy
#		of this library because it depends on it.  If you already
#		have copy installed TclHttpd will attempt to find it.
#
# TclHttpd now requires Tcl 8.0 or higher because it depends on some
#	modules in the Standard Tcl Library (tcllib) that use namespaces.
#	In practice, some of the modules in tcllib may depend on
#	new string commands introduced in Tcl 8.2 and 8.3.  However,
#	the server core only depends on the base64 and ncgi packages
#	that may/should be/are compatible with Tcl 8.0
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Scriptics Corporation
# Copyright (c) 2001-2002 Panasas
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: httpd.tcl,v 1.61 2006/04/27 00:24:51 wart Exp $
#
# \
exec tclsh "$0" ${1+"[email protected]"}

############
# auto_path
############

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

# Auto-detect the configuration
# 1. Development - look for $home/../lib and $home/../../tcllib/modules
# 2. Standalone install - look for $home/../lib/tclhttpd $home/tcllib
# 3. Tcl package install - look for $tcl_library/../tclhttpd

set v 4.0.0

# Put the library in front in case there is both the development
# library and an installed library

set auto_path [concat [list $Config(lib)] $auto_path]

# Search around for the Standard Tcl Library
# We used to require "tcllib", but that now causes complaints
# Tcllib 1.6 has inconsistencies with md5 1.4.3 and 2.0.0,
# and requiring 1.0 cures later conflicts with 2.0

if {![catch {package require md5 1}]} {
    # Already available in environment
} elseif {[file exist [file join $home ../tcllib]]} {
    lappend auto_path [file join $home ../tcllib]
} else {
    # Look for the CVS development sources
    set cvs [lindex [lsort -decreasing \
	[glob -nocomplain [file join $home ../../tcllib*]]] 0]
    if {[file exist [file join $cvs modules]]} {
	lappend auto_path [file join $cvs modules]
    } elseif {[file exist [file join $cvs pkgIndex.tcl]]} {
	lappend auto_path $cvs
    } else {
	error "Cannot find Standard Tcl Library in auto_path:\n[join $auto_path \n]"
    }
}

set Config(home) $home
unset home

# Add operating-specific directories to the auto_path for
# the binary extensions

regsub -all { } $tcl_platform(os) {} tmp
foreach dir [list \
	[file join $Config(lib) Binaries $tmp] \
	[file join $Config(lib) Binaries $tmp $tcl_platform(osVersion)] \
	] {
    if {[file isdirectory $dir]} {
	lappend auto_path $dir
    }
}
unset tmp dir

proc ::Config {field args} {
  switch {[llength $args]>1} {
    error "Usage: Config field ?value?"
  }
  global Config
  if {[llength $args]} {
    set Config($field) [lindex $args 0]
  }
  if {[info exists Config($field)]} {
    return $Config($field)
  }
}
##############
# Config file
##############

# Load the configuration file into the Config array
# First, we preload a couple of defaults

set Config(docRoot) [file join [file dirname [Config home]] htdocs]
set Config(library) [file join [file dirname [Config home]] custom]
set Config(main) [file join [Config home] httpdthread.tcl]
set Config(debug) 0
set Config(compat) 3.3

# The configuration bootstrap goes like this:
# 1) Look on the command line for a -config rcfile name argument
# 2) Load this configuration file via the config module
# 3) Process the rest of the command line arguments so the user
#       can override the settings in the rc file with them.

set ix [lsearch $argv -config]
if {$ix >= 0} {
    incr ix
    set Config(config) [lindex $argv $ix]
} else {
    set Config(config) [file join [Config home] tclhttpd.rc]
}

package require httpd 1.6
package require httpd::version		;# For Version proc
package require httpd::utils		;# For Stderr
package require httpd::counter		;# For Count
package require fileutil                ;# For tempdir support: needed on Windows

package require httpd::config		;# for config::init


proc ::cget {field} {
  global Config
  if {[info exists Config($field)]} {
    return $Config($field)
  }
}
proc ::DebugCheckRandomPassword input {
  return 1
}
array set Config {
  debug 1
  port 8015
  https_port	8016
  uid 50
  gid 50
  ipaddr {}
  https_ipaddr {}
  secsPerMinute	60
  threads 0
  gui        1
LogFlushMinutes 0
LogDebug 0
CompressProg gzip
MaxFileDescriptors	256
SSL_REQUEST	0
SSL_REQUIRE	0
SSL_CAFILE 	""
}
Config docroot [file join [Config home] .. htdocs]
Config library [file join [Config home] .. custom]
Config main [file join [Config home]  httpdthread.tcl]
Config host [info hostname]
Config https_host [info hostname]
Config webmaster	[email protected][info hostname]
Config LogFile [file join [::fileutil::tempdir] log]
Config SSL_CADIR	[file join [file dirname [Config home]] certs])
Config SSL_CERTFILE	[file join [Config SSL_CADIR] server.pem]
Config MailServer {}
# The Config array now reflects the info in the configuration file

#########################
# command line arguments
#########################

# Override config file settings with command line arguments.
# The CommandLineOptions global is known to some of the
# web pages that document the server.

package require cmdline
set CommandLineOptions [list \
        [list virtual.arg      [cget virtual]      {Virtual host config list}] \
        [list config.arg       [cget config]       {Configuration File}] \
        [list main.arg         [cget main]         {Per-Thread Tcl script}] \
        [list docRoot.arg      [cget docRoot]      {Root directory for documents}] \
        [list port.arg         [cget port]         {Port number server is to listen on}] \
        [list host.arg         [cget host]         {Server name, should be fully qualified}] \
        [list ipaddr.arg       [cget ipaddr]       {Interface server should bind to}] \
        [list https_port.arg   [cget https_port]   {SSL Port number}] \
        [list https_host.arg   [cget https_host]   {SSL Server name, should be fully qualified}] \
        [list https_ipaddr.arg [cget https_ipaddr] {Interface SSL server should bind to}] \
        [list webmaster.arg    [cget webmaster]    {E-mail address for errors}] \
        [list uid.arg          [cget uid]          {User Id that server runs under}] \
        [list gid.arg          [cget gid]          {Group Id for caching templates}] \
        [list secs.arg          [cget secsPerMinute] {Seconds per "minute" for time-based histograms}] \
        [list threads.arg      [cget threads]      {Number of worker threads (zero for non-threaded)}] \
        [list library.arg      [cget library]      {Directory list where custom packages and auto loads are}] \
        [list debug.arg	       0	        {If true, start interactive command loop}] \
        [list compat.arg       3.3	        {version compatibility to maintain}] \
        [list gui.arg           [cget gui]      {flag for launching the user interface}] \
        [list mail.arg           [cget MailServer]      {Mail Servers for sending email from tclhttpd}] \
        [list daemon.arg        0      		   {Run in the background as a daemon process.  Requires the 'Expect' package.}] \
    ]
array set Config [cmdline::getoptions argv $CommandLineOptions \
    "usage: httpd.tcl options:"]

if {[string length $Config(library)]} {
    lappend auto_path $Config(library)
}

if {$Config(debug)} {
    puts stderr "auto_path:\n[join $auto_path \n]"
    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
###################

Httpd_Init
#Counter_Init $Config(secs)

# Open the listening sockets
Httpd_Server $Config(port) $Config(host) $Config(ipaddr)
append startup "httpd started on port $Config(port)\n"

if {[catch {source $Config(main)} message]} then {
    global errorInfo
    set error "Error processing main startup script \"[file nativename $Config(main)]\"."
    append error "\n$errorInfo"
    error $error
}

# The main thread owns the log

Log_CompressProg	[cget CompressProg]
Log_SetFile		[cget LogFile]$Config(port)_
Log_FlushMinutes	[cget LogFlushMinutes]
Log_Flush


###
# Begin the test

###
package require httpd::directoo

oo::class create ootest {
  superclass httpd.url

  ###
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
>









1



































2
3
4
5
6
7
8
.
9
10
11
12
13
14
15
16



17























































































































































































































18

19
20
21
22
23
24
25
26


#!/bin/sh



































# \
exec tclsh "$0" ${1+"[email protected]"}

############
# auto_path
############

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

source $home/test/common.tcl



























































































































































































































###

# Test for DirectOO
###
package require httpd::directoo

oo::class create ootest {
  superclass httpd.url

  ###

Added bin/test/qwiki.tcl.










































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#!/bin/sh
# \
exec tclsh "$0" ${1+"[email protected]"}

############
# auto_path
############

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

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
    array set result {
      code 200
      type text/html
    }
    set body {
<HTML><BODY>
Hello World!
<p>
    }
    if {[info exists result(userid)]} {
      append body "Logged in as user: $result(userid)<br>"
    }
    if {[info exists result(sessionid)]} {
      append body "Logged with session: $result(sessionid)<br>"
    }
    append body {
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
    }
  }
}

qwikitest create HOME /home {db {}}

vwait forever
if 0 {
# Start up the user interface and event loop.
package require Tk
package require httpd::srvui
package require httpd::stdin
SrvUI_Init "Tcl HTTPD $Httpd(version)"
Stderr $startup
if {[info commands "console"] == "console"} {
    console show
} else {
    Stdin_Start "httpd % "
    Httpd_Shutdown
}
}

Added modules/community/community.tcl.












































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
###
# Facilities for user, group, and community management
###
package require httpd::directoo
package require sqlite3
package require tao
package require tao-sqlite
package require md5 2
package require sha1 2

package require httpd::cookie	;# Cookie_GetSock Cookie_Make
package require httpd::doc	;# Doc_Root
package require httpd::utils	;# Stderr file iscommand randomx

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

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

  method initialize {} {
    if {[my cget dbfile] eq {}} {
      my configure dbfile :memory:
    }
    my Database_Attach [my cget dbfile]
  }

  ###
  # 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 users(userid,username,password) VALUES ('local.webmaster','webmaster',sha1('local.webmaster'||'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 accessTypes {} {
    set accessTypes {admin edit view}
    foreach type [my <db> eval "select distinct right from acl_grants order by right"] {
        logicset add accessTypes $type
    }     
    return $accessTypes    
  }

  method aclRights {aclname userid} {
    set parentlist {}
    set thisnode $aclname
    
    while 1 {
      set parentlist [linsert $parentlist 0 $thisnode]
      set parent [my one "select parent from acl where acl_name=:thisnode"]
      if { $parent == {} } { 
          break
      }
      # Something is mislinked, stop early
      if {$parent in $parentlist} break
      set thisnode $parent
    }
  
    ###
    #  Build grouplist
    ###
    set rights {}
    ###
    # Apply default rights
    ###
    foreach {right grant} [my <db> eval "select right,grant from acl_grants where acl_name='default'"] {
      if { $grant == "0"} {
          if { $right == "all" } { 
              set rights {}
          } else {
              logicset remove rights $right
          }
      } else {
        if { $right eq "all" } {
          logicset add rights {*}[my accessTypes]
        } else {
          logicset add rights $right
        }
      }
    }
    
    foreach p $parentlist {
        set stmt "select right,grant from acl_grants where \
  acl_name=:p and userid=:userid or userid=(select username from users where userid=:userid) or userid in (select groupid from group_members where userid=:userid);
  "
      foreach {right grant} [my <db> eval $stmt] {
        if { $grant == "0"} {
            if { $right == "all" } { 
                set rights {}
            } else {
                logicset remove rights $right
            }
        } else {
          if { $right eq "all" } {
            logicset add rights {*}[my accessTypes]
          } else {
            logicset add rights $right
          }
        }
      }
    }
    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) [my <db> one {select userid from users where name='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 cookieSet session $result(sessionid) $expdate
  }
  
  method cookieSet {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) host] :] 0]
  }
  
  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;}
      }
      foreach {field value} $delete {
        my <db> eval {delete from session_property where sesid=:sessionid and field=:field;}
      }
      my <db> eval "COMMIT"
    }
  }
}

package provide httpd::community 0.1

Added modules/community/pkgIndex.tcl.






















>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
# 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::community 0.1 [list source [file join $dir community.tcl]]

Changes to modules/httpd/directoo.tcl.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
..
81
82
83
84
85
86
87
88
89

90
91
92
93
94
95
96
97
98
99
100
101

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
135
136
137
138
139
140
141



























142
143
144
145
146
147
148
...
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176










177
178
179
180
181
182
183
184
185
































186
187
188
189
190
191
192
...
196
197
198
199
200
201
202
203
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

oo::class create httpd.url {  
  variable virtual
  variable config
  
  constructor {virtual {localopts {}} args} {
    my variable config
    dict set config virtual $virtual
    my configurelist $localopts
    ::Url_PrefixInstall $virtual [namespace code {my httpdDirect}] {*}$args
  }
  
  destructor {
    catch {::Url_PrefixRemove [my cget virtual]}
  }
  
  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 {}
  }
  
  # 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
  # [self] /html/Device/a/b/c
................................................................................
  #	will cause a stack trace to be returned to the client.
  #


  method httpdDirect {sock suffix} {
    global env
    upvar #0 Httpd$sock data
    my variable config result cgidat
    

    array set result {
      code 200
      date  0
      header {}
      footer {}
      body {}
      content-type text/html
    }
    set result(sock) $sock
    set result(datavar) ::Httpd$sock 
    
    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
      
      # Save any return cookies which have been set.
      # This works with the Doc_SetCookie procedure that populates
      # the global cookie array.
      ::Cookie_Save $sock
    }
    switch $result(code) {
      401 {
        ::Httpd_ReturnData $sock text/html $::HttpdAuthorizationFormat $result(code)
        return
      }
      404 {
................................................................................
          ::Httpd_ReturnData $sock $result(content-type) $result(body) $result(code)
        }
        return
      }
    }
  }
  



























  #
  #	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.
  #
................................................................................
  # 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 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]
    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 unknown {args} {
    if {[string range [lindex $args 0] 0 4] ne "/html"} {
      next {*}$args
    }
    my variable result
    set result(code) 404
  }

































  
  ###
  # title: Implement html content at a toplevel
  ###
  method /html {} {
    my variable result
    array set result {
................................................................................
Hello World
</BODY></HTML>
}
      content-type text/html
    }
  }
}







|
|
|
|
|
<
<
<
<
<





|
<
<
<
|
|
<
<
<
<
<
<
<
<
<







 







|
<
>
|
<
<
<
<
<
<
<
<
<
<

>









<
<
<
<
|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<













>
>
>
>
>
>
>
>
>
>








|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
13
14
15
16
17
18
19
20
21
22
23
24





25
26
27
28
29
30



31
32









33
34
35
36
37
38
39
..
64
65
66
67
68
69
70
71

72
73










74
75
76
77
78
79
80
81
82
83
84




85
86
87
88
89
90
91
92
...
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
149
150
151
152
153
154
155





156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
...
230
231
232
233
234
235
236

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














  # 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
  # [self] /html/Device/a/b/c
................................................................................
  #	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]
    ::Stderr $cmd
    # 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 {
................................................................................
          ::Httpd_ReturnData $sock $result(content-type) $result(body) $result(code)
        }
        return
      }
    }
  }
  
  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]
  }
  
  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.
  #
................................................................................
  # 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
    array set result {
................................................................................
Hello World
</BODY></HTML>
}
      content-type text/html
    }
  }
}

Changes to modules/httpd/md5hex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This is a shim layer to deal with the inconsistencies
# between md5 1 and md5 2 (grr)

package provide httpd::md5hex 1.0
catch {
    # for some reason pkg_mkIndex barfs on this ... hide it.
    package require md5

    # md5hex always returns a hex version of the md5 hash

    if {[package vcompare [package present md5] 2.0] > -1} {
	# we have md5 v2 - it needs to be told to return hex
	interp alias {} md5hex {} ::md5::md5 -hex --
    } else {
	# we have md5 v1 - it returns hex anyway
	interp alias {} md5hex {} ::md5::md5
    }
}





|











1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This is a shim layer to deal with the inconsistencies
# between md5 1 and md5 2 (grr)

package provide httpd::md5hex 1.0
catch {
    # for some reason pkg_mkIndex barfs on this ... hide it.
    package require md5 2

    # md5hex always returns a hex version of the md5 hash

    if {[package vcompare [package present md5] 2.0] > -1} {
	# we have md5 v2 - it needs to be told to return hex
	interp alias {} md5hex {} ::md5::md5 -hex --
    } else {
	# we have md5 v1 - it returns hex anyway
	interp alias {} md5hex {} ::md5::md5
    }
}

Added modules/qwiki/pkgIndex.tcl.






















>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
# 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::qwiki 0.1 [list source [file join $dir qwiki.tcl]]

Added modules/qwiki/qwiki.tcl.


































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
###
# 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