Open Mash Cross Reference
mash/tcl/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/cache/proxy.tcl,v 1.8 2002/02/03 04:25:37 lim Exp $
  
  
  import HTTP_Server
  
  Class WebCacheProxy -superclass HTTP_Server -configuration {
          port 3468
  }
  
  
  WebCacheProxy public open { {port {}} } {
          if { $port=={} } {
                  set port [$self get_option port]
          }
          puts "opening proxy on port '$port'"
          $self next $port
  }
  
  
  WebCacheProxy public handle_request { socket hdr_var data } {
          # extract the URL
          upvar $hdr_var headers
  
          set url $headers(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 headers(referer)] {
                          set referer $headers(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 rdata "<h1>302 Object has moved</h1>"
                          set rheaders "HTTP/1.0 302 Object has moved\n"
                          append rheaders "Location: $prefix$url\n"
                  } else {
                          set rdata "<h1>500 Cannot resolve relative URL</h1>\n\
                                          <i>$url</i>"
                          set rheaders "HTTP/1.0 500 Cannot resolve relative\
                                          URL\n"
                  }
                  append rheaders "Content-type: text/html\n"
                  append rheaders "Content-length: [string length $data]\n\n"
  
                  puts "---------------------------------------------"
                  puts "sending headers: '$rheaders'"
                  puts "sending data: '$rdata'"
                  puts "---------------------------------------------"
                  $socket send $rheaders
                  $socket send $rdata
                  $socket close
                 $socket shutdown
                 delete $socket
         }
         return 0
 }
 
 
 WebCacheProxy 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
 }
 
 
 WebCacheProxy private start_fetch { url socket } {
         $self instvar cache_
         puts "proxy: start_fetch $url"
         $cache_ get $url $socket
         $self set last_url_ $url
 }
 
 
 WebCacheProxy private done_fetch { url socket filename } {
         puts "************************************proxy: 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
         delete $socket
 }
 
 
 WebCacheProxy private done_partial_fetch { url socket filename } {
         puts "proxy: done_partial_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
 
         # don't close socket, because more data coming
 }