The following example shows a username/password database for Tclhttpd. It uses the following
* Metakit for the database
* logic and code from the [formkit] package
* [crypt in pure tcl] from the wiki for the passwords
* The Tclhttpd session module for row(record) locking and session control.
Create a "dbdata" directory under the Doc_Root directory (usually htdocs).
'''The following files are all saved to the custom directory in Tclhttpd.'''
Get the [crypt in pure tcl] package and save it to tclcrypt.tcl
Change the proc name from crypt to tclcrypt. This is to avoid name conflicts as
Tclhttpd looks for the unix crypt.
Edit the first line and change it from
proc crypt {password salt} {
to
proc tclcrypt {password salt} {
Save the following
************ Begin fmkt.tcl ************************************************
# This an example of a username/password database for the Tclhttpd webserver.
# It uses Metakit for the database and uses ideas from formkit for
# row or record locking. It uses the session module from Tclhttpd for session
# control and crypt in pure tclfrom the wiki.
# Set up the Database
mk::file open users [Doc_Root]/dbdata/users.dat
mk::view layout users.details {user longname location phone email pass }
# Register Document type handler.
Mtype_Add .fmkt application/x-tcl-fmkt
# Set the start page that is used to launch a new session.
set Fmkt(startpage) /start.tml
# Set the time in seconds that a session will last for.
set Fmkt(age) 300
proc Doc_application/x-tcl-fmkt {path suffix sock} {
upvar #0 Httpd$sock data
global Fmkt
append data(query) ""
set queryList [Url_DecodeQuery $data(query)]
# Destroy any old session that are laying around. In this instance
# 5 minutes is the setting.
Session_Reap $Fmkt(age) Fmkt
# Find the current session (or start a new one if session=new).
set session [Session_Match $queryList Fmkt error]
if {$session == {}} {
Fmkt_ErrorPage $sock "The session no longer exists! $error"
return
}
# Process the query data from the previous page.
if [catch {FmktProcess $session $queryList} result] {
Httpd_ReturnData $sock text/html $result
return
}
# Expand the page in the correct session interpreter, or treat
# the page as ordinary html if the session has ended.
switch -exact -- $result {
0 { Httpd_ReturnFile $sock text/html $path }
1 { Doc_Subst $sock $path interp$session }
2 { Fmkt_ErrorPage $sock "This record locked by another user!" }
3 { Fmkt_ErrorPage $sock "Must enter a character!" }
4 { Fmkt_ErrorPage $sock "Record has been saved!" }
}
}
# The purpose of this procedure is to process the form query data.
# Based on the query data certain procedures are triggered.
# Parameters
# session: the session id
# query: a list of names and values produced by Url_DecodeQuery
proc FmktProcess {session query} {
global Fmkt
upvar #0 Session:$session state
set interp $state(interp)
# Process each query item.
# Some items, such as "session" and "user" are treated
# specially.
# Upon completion, zero or more of the following may occur:
# Variables and values are set in the appropriate slave
# interpreter.
# The user is defined in the state array.
# The session is destroyed.
foreach {name value} $query {
if {[string match "user" $name]} {
set user [string trim $value]
if {[string match $user ""]} {
Session_Destroy $session
return 3
} elseif {![info exist state(user)]} {
if {[Fmkt_UserLock $user]} {
Session_Destroy $session
return 2
} else {
set state(user) $user
interp eval $interp [list set user $user]
}
}
} elseif {[string match "cancel" $name] && $value} {
Session_Destroy $session
return 0
} elseif {[string match "save" $name] && $value} {
if {[Fmkt_DbSave $session $query]} {
Session_Destroy $session
return 4
} else {
return 1
}
} else {
# Define variables in the slave interpreter so they are there before
# we do a Doc_Subst on the page!
interp eval $interp [list set $name $value]
}
}
return 1
}
proc Fmkt_ErrorPage {sock error} {
global Fmkt
upvar #0 Httpd$sock data
append result ""
append result $error
append result " This page will redirect to the start page"
Httpd_ReturnData $sock text/html $result
}
# Set the Formkit tag and view for the open datafile.
proc Fmkt_DbView {session db view} {
upvar #0 Session:$session state
set state(db) $db
set state(view) $view
return ""
}
# Check that the row or record is not being edited
# by another session.
proc Fmkt_UserLock {user} {
foreach id [info globals Session:*] {
upvar #0 $id session
if {[info exist session(user)]} {
if {[string match $session(user) $user]} {
return 1
}
}
}
return 0
}
# Retrieve row based on unique "user" and drop values
# in the session's slave interpreter
proc Fmkt_DbLookup {session} {
upvar #0 Session:$session state
set interp $state(interp)
if {[info exists state(errorpass)]} {
return
} else {
set position [mk::select $state(db).$state(view) -exact user $state(user)]
if {[string match "" $position]} {
foreach name [mk::view info $state(db).$state(view)] {
if {[string match "user" $name]} {
continue
} else {
interp eval $interp [list set $name ""]
}
}
} else {
set state(pass) [mk::get $state(db).$state(view)!$position pass]
foreach {name value} [mk::get $state(db).$state(view)!$position] {
interp eval $interp [list set $name $value]
}
}
unset position
interp eval $interp [list set newpass ""]
interp eval $interp [list set vfypass ""]
}
}
# Collect all the return values and check if password and verify password
# match. Crypt the password then write the values back to the database.
proc Fmkt_DbSave {session query} {
upvar #0 Session:$session state
set interp $state(interp)
lappend field_values user $state(user)
foreach {name value} $query {
if {[string match "session" $name]} {
continue
} elseif {[string match "save" $name]} {
continue
} elseif {[string match "newpass" $name]} {
set $name $value
interp eval $interp [list set $name $value]
} elseif {[string match "vfypass" $name]} {
set $name $value
interp eval $interp [list set $name $value]
} else {
set $name $value
lappend field_values $name $value
interp eval $interp [list set $name $value]
}
}
set newpass [string trim $newpass]
set vfypass [string trim $vfypass]
if {![info exists state(pass)]} {
if {[string match $newpass ""]} {
set state(errorpass) "Must enter a password!"
return 0
}
}
if {[string compare $newpass $vfypass] != 0} {
set state(errorpass) "New and Verify Passwords do not match!"
return 0
}
set position [mk::select $state(db).$state(view) -exact user $state(user)]
lappend field_values pass [Fmkt_passCrypt $newpass]
if {[string match "" $position]} {
eval mk::row append $state(db).$state(view) $field_values
} else {
eval mk::set $state(db).$state(view)!$position $field_values
}
mk::file commit $state(db)
unset field_values
return 1
}
proc Fmkt_passCrypt {newpass} {
set passcrypt [tclcrypt $newpass 91]
return $passcrypt
}
proc Fmkt_formSession {session args} {
upvar #0 Session:$session state
append result ""
return $result
}
proc Fmkt_errorPass {session} {
upvar #0 Session:$session state
if {[info exists state(errorpass)]} {
return $state(errorpass)
} else {
return
}
}
# Use this procedure for authentication. It is to be called from
# a .tclaccess file in the Directory you want authenticated access too.
# In the .tclaccess file put the following
# set realm "TclHttpd"
# set callback Fmkt_AuthChecker
proc Fmkt_AuthChecker {sock realm user pass} {
set row [mk::select users.details -exact user $user]
array set userdb [mk::get users.details!$row]
set salt [string range $userdb(pass) 0 1]
set passcrypt [tclcrypt $pass $salt]
if {[string compare $user $userdb(user)] == 0 &&
[string compare $passcrypt $userdb(pass)] == 0} {
return 1
} else {
return 0
}
}
******************************** End fmkt.tcl ******************************
'''The following are placed in the /hdocs directory'''
************ Begin start.tml ****************
[
Doc_Dynamic
]
**************** End page1.fmkt ******************
**************** Begin page2.fmkt ****************
Page2.fmkt
[errorPass]
************************ End page2.tcl **********************************