web/cgi/session/setauth.tcl

   1 #!./tclsh
   2 # $Id: setauth.tcl 764 2007-10-23 23:44:49Z hubert@u.washington.edu $
   3 # ========================================================================
   4 # Copyright 2006 University of Washington
   5 #
   6 # Licensed under the Apache License, Version 2.0 (the "License");
   7 # you may not use this file except in compliance with the License.
   8 # You may obtain a copy of the License at
   9 #
  10 #     http://www.apache.org/licenses/LICENSE-2.0
  11 #
  12 # ========================================================================
  13
  14 #  setauth.tcl
  15 #
  16 #  Purpose:  CGI script to generate html form used to ask for authentication
  17 #            credentials
  18
  19 #  Input:
  20 set auth_vars {
  21   {cid          "Missing Command ID"}
  22   {authcol      "No Authorization Collection"}
  23   {authfolder   "No Authorization Folder"}
  24   {authpage     "No Post Authorization Instructions"}
  25   {authcancel   "No Auth Cancel Instructions"}
  26   {auths        ""      0}
  27   {user         ""      0}
  28   {pass         ""      0}
  29   {cancel       ""      0}
  30 }
  31
  32 #  Output:
  33 #
  34 #       Redirect to specified post-authentication page
  35
  36 # inherit global config
  37 source ./alpine.tcl
  38
  39
  40 WPEval $auth_vars {
  41
  42   if {$cid != [WPCmd PEInfo key]} {
  43     error [list _action open "Invalid Operation ID" "Click Back button to try again."]
  44   }
  45
  46   # if NOT cancelled
  47   if {[string compare $auths "Login"] == 0
  48       && [string length $user]
  49       && [catch {WPCmd PESession creds $authcol $authfolder $user $pass}] == 0} {
  50     set redirect $authpage
  51   } else {
  52     set redirect $authcancel
  53   }
  54
  55   cgi_http_head {
  56     # redirect to the place we stuffed the export info.  use the ip address
  57     # to foil spilling any session cookies or the like
  58
  59     if {[info exists env(SERVER_PROTOCOL)] && [regexp {[Hh][Tt][Tt][PP]/([0-9]+)\.([0-9]+)} $env(SERVER_PROTOCOL) m vmaj vmin] && $vmaj >= 1 && $vmin >= 1} {
  60       cgi_puts "Status: 303 Temporary Redirect"
  61     } else {
  62       cgi_puts "Status: 302 Redirected"
  63     }
  64
  65     cgi_puts "URI: $redirect"
  66     cgi_puts "Location: $redirect"
  67   }
  68 }