Updated 2014-01-25 15:42:56 by dkf

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.

*** 10 July 2003 Jeff Smith A Starkit with a few extra features can be found at [1] ***

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 "<META HTTP-EQUIV=\"REFRESH\" CONTENT=\"3;URL=$Fmkt(startpage)\">"
         append result $error<BR><P>
         append result " This page will redirect to the <A HREF=$Fmkt(startpage)>start page</A>"
         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 "<input type=hidden name=session value=\"$session\">"
     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 /htdocs directory

************ Begin start.tml ****************
 [
 Doc_Dynamic
 ]

 <!Doctype HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
 <Html>
 <Head>
 <Title>Start.tml</Title>
 </Head>
 <Body>

 <p>
 This an example of a username/password database..
 <p>
 <a HREF="page1.fmkt?session=new">Start Session</a>

 </Body>
 </Html>

****************** End start.tml ******************

******************Begin page1.fmkt ****************
 [
 DbView users details
 ]
 
 <html>
 <head>
 <meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
 <title>Page1.fmkt</title>
 </head> 

 <body>
 <H3>Add or Edit a User</H3>
 <form method="POST" action="page2.fmkt">
 [formSession]
 <p><input type="submit" value="Add/Edit a Username" ><input type="text" name="user" size="25"></p>
 </form>
 <form method="POST" action="page1.fmkt">
 <p>
 <input type="submit" value="Cancel"><input type="hidden" name="cancel">
 </form>
 </body>
 </html>

**************** End page1.fmkt ******************

**************** Begin page2.fmkt ****************
 <html>
 <head>
 <meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
 <title>Page2.fmkt</title>
 </head> 

 <body>
 <form method="POST" action="page2.fmkt">
 
 [formSession]
 [DbLookup]
 <input type=hidden name=save value=1>
 <TABLE width=\"600\" bgcolor=\"#cc3300\" border=\"1\" cellpadding=\"3\" cellspacing=\"3\">
 <TR>
 <TD>Username:</TD><TD>$user</TD>
 </TR><TR>
 <TD>Name:</TD><TD><INPUT type=\"TEXT\" size=\"25\" name=\"longname\" value=\"$longname\"></TD>
 </TR><TR>
 <TD>Location:</TD><TD><INPUT type=\"TEXT\" size=\"25\" name=\"location\" value=\"$location\"></TD>
 </TR><TR>
 <TD>Phone:</TD><TD><INPUT type=\"TEXT\" size=\"25\" name=\"phone\" value=\"$phone\"></TD>
 </TR><TR>
 <TD>Email:</TD><TD><INPUT type=\"TEXT\" size=\"25\" name=\"email\" value=\"$email\"></TD>
 </TR><TR>
 <TD>Enter Password:</TD><TD><INPUT type=\"PASSWORD\" size=\"25\" name=\"newpass\" value=\"$newpass\"></TD>
 </TR><TR>
 <TD>Verify Password:</TD><TD><INPUT type=\"PASSWORD\" size=\"25\" name=\"vfypass\" value=\"$vfypass\"></TD>
 </TR>
 </TABLE>
 <p><input type="submit" value="Save" ></p>
 </form>
 [errorPass]
 <form method="POST" action="page2.fmkt">
 <p>
 <input type="submit" value="Cancel"><input type="hidden" name="cancel">
 </form>
 </body>
 </html>

************************ End page2.fmkt **********************************

NB I've just tried this and having a bit of a problem. I first had to prepend Fmkt_ to your procs in the the three pages, and now the procs are found. Submitting from start.tml, the server just hangs....w/out error...This is on WinXP, tclhttpd3.4, and one of the latest tclkits. Custom code gets loaded, and db is created...

NB OOP's I take the above back. On Jeff's advice I dropped the above into an unwrapped headsup, and things work as expected. Guess I must check my tclhttpd instal....

DKF: I was just wondering if it would wondering if it would be possible to hook up to an LDAP-hosted password database. That sort of thing is popular round here...

Jeff Smith Just a thought, Squid [2] uses many types of authentication. From the Squid FAQ [3]
 Authentication is actually performed outside of main Squid process. When Squid starts, it spawns a
 number of authentication subprocesses. These processes read usernames and passwords on stdin, and
 reply with "OK" or "ERR" on stdout. This technique allows you to use a number of different
 authentication schemes, although currently you can only use one scheme at a time.

 The Squid source code comes with a few authentcation processes. These include:

 LDAP: Uses the Lightweight Directory Access Protocol
 NCSA: Uses an NCSA-style username and password file.
 MSNT: Uses a Windows NT authentication domain.
 PAM: Uses the Linux Pluggable Authentication Modules scheme.
 SMB: Uses a SMB server like Windows NT or Samba.
 getpwam: Uses the old-fashioned Unix password file.

 In order to authenticate users, you need to compile and install one of the supplied authentication
 modules, one of the others, or supply your own.

 You tell Squid which authentcation program to use with the authenticate_program option in squid.conf.
 You specify the name of the program, plus any command line options if necessary. For example:

 authenticate_program /usr/local/squid/bin/ncsa_auth /usr/local/squid/etc/passwd''

Maybe if you could somehow make Tclhttpd look like Squid to the above authentication modules it could be a solution.

schlenk It is simple to authenticate against LDAP with the ldap module in tcllib, basically just try an ldap::bind with the users DN and his password.