Open Mash Cross Reference
mash/tcl/srmv2-cache/proxy.tcl

   # proxy.tcl --
   #
   #       FIXME: This file needs a description here.
   #
   # Copyright (c) 1998-2002 The Regents of the University of California.
   # All rights reserved.
   #
   # Redistribution and use in source and binary forms, with or without
   # modification, are permitted provided that the following conditions are met:
  #
  # A. Redistributions of source code must retain the above copyright notice,
  #    this list of conditions and the following disclaimer.
  # B. Redistributions in binary form must reproduce the above copyright notice,
  #    this list of conditions and the following disclaimer in the documentation
  #    and/or other materials provided with the distribution.
  # C. Neither the names of the copyright holders nor the names of its
  #    contributors may be used to endorse or promote products derived from this
  #    software without specific prior written permission.
  #
  # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
  # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
  # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  #
  #  @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/srmv2-cache/proxy.tcl,v 1.5 2002/02/03 04:30:05 lim Exp $
  
  
  import HTTP_Server
  
  Class SRMv2_CacheProxy -superclass HTTP_Server -configuration {
          srmv2CachePort 3468
  }
  
  
  SRMv2_CacheProxy public open { {port {}} } {
          if { $port=={} } {
                  set port [$self get_option srmv2CachePort]
          }
          $self next $port
  }
  
  
  SRMv2_CacheProxy public handle_request { socket headers data } {
          # extract the URL
  
          $self headers_to_array $headers hdr_array
          set url $hdr_array(url)
          puts '$url'
          flush stdout
          if [regexp {^/[a-zA-Z]*://} $url] {
                  set url [string range $url 1 end]
                  $self start_fetch $url $socket
          } elseif [regexp {^[a-zA-Z]*://} $url] {
                  $self start_fetch $url $socket
          } else {
                  # this URL seems relative to myself
                  # we should check the Referer: tag
  
                  if [info exists hdr_array(referer)] {
                          set referer $hdr_array(referer)
                  } else {
                          set referer ""
                  }
  
                  set prefix [$self referer $referer]
                  if { $prefix=={} } {
                          $self instvar last_url_
                          if [info exists last_url_] {
                                  set prefix [$self referer $last_url_]
                          }
                  }
  
                  if { $prefix!={} } {
                          set data "<h1>302 Object has moved</h1>"
                          set headers "HTTP/1.0 302 Object has moved\n"
                          append headers "Location: $prefix$url\n"
                  } else {
                          set data "<h1>500 Cannot resolve relative URL</h1>\n\
                                          <i>$url</i>"
                          set headers "HTTP/1.0 500 Cannot resolve relative\
                                          URL\n"
                  }
                  append headers "Content-type: text/html\n"
                  append headers "Content-length: [string length $data]\n\n"
  
                  puts "---------------------------------------------"
                  puts "sending headers: '$headers'"
                  puts "sending data: '$data'"
                  puts "---------------------------------------------"
                  $socket send $headers
                  $socket send $data
                  $socket close
                  $socket shutdown
         }
 }
 
 
 SRMv2_CacheProxy private referer { url } {
         set expr {^([a-zA-Z]*)://([^/]*)/([a-zA-Z]*)://([^/]*)/}
         if ![regexp $expr $url dummy proto1 proxy proto2 server] {
                 set expr {^([a-zA-Z]*)://([^/]*)/}
                 if ![regexp $expr $url dummy proto2 server] {
                         return ""
                 }
                 set proto1 http
                 set proxy "127.0.0.1:[$self port]"
         }
 
         return $proto1://$proxy/$proto2://$server
 }
 
 
 SRMv2_CacheProxy private start_fetch { url socket } {
         $self instvar wc_
         puts "wcp: start_fetch $url"
         $wc_ get $url $socket
 }
 
 
 SRMv2_CacheProxy private done_fetch { url socket filename } {
         puts "wcp: done_fetch $url"
 
         set f [open $filename]
         fconfigure $f -translation binary
         set buffer ""
         while { ![eof $f] } {
                 append buffer [read $f 4096]
         }
         close $f
         puts -nonewline [$socket channel] $buffer
 
         $socket close
         $socket shutdown
 }