Package Downloads Server: Artifact [e316f32d33]

Artifact e316f32d33ac4b60aa385b28b82148efc26b904a:

File client/1.0/neutral/common.tcl — part of check-in [8121dfaed6] at 2022-10-16 02:38:54 on branch trunk — Pickup the common HTTP package updates from upstream again. (user: mistachkin, size: 20725) [annotate] [blame] [check-ins using]
###############################################################################
#
# common.tcl --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle Common Tools Package
#
# Copyright (c) 2007-2012 by Joe Mistachkin.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
#
###############################################################################

#
# NOTE: This script file uses features that are only present in Tcl 8.4 or
#       higher (e.g. the "eq" operator for [expr], etc).
#
if {![package vsatisfies [package provide Tcl] 8.4]} then {
  error "need Tcl 8.4 or higher"
}

#
# NOTE: This script file uses features that are not available or not needed
#       in Eagle (e.g. the "http" and "tls" packages, etc).
#
if {[catch {package present Eagle}] == 0} then {
  error "need native Tcl"
}

###############################################################################

namespace eval ::Eagle::Tools::Common {
  #
  # NOTE: *HACK* Skip defining this procedure if it is already defined in the
  #       global namespace.
  #
  if {[llength [info commands ::appendArgs]] == 0} then {
    #
    # NOTE: This procedure was stolen from the "auxiliary.eagle" script.
    #       This procedure accepts an any number of arguments.  The arguments
    #       are appended into one big string, verbatim.  The resulting string
    #       is returned.  Normally, this procedure is used to avoid undesired
    #       string interpolation operations.
    #
    # <ignore>
    proc appendArgs { args } {
      eval append result $args
    }
  }

  #
  # NOTE: *HACK* Skip defining this procedure if it is already defined in the
  #       global namespace.
  #
  if {[llength [info commands ::makeBinaryChannel]] == 0} then {
    #
    # NOTE: This procedure was stolen from the "file1.eagle" script.  This
    #       procedure reconfigures the specified channel to full binary mode.
    #
    # <ignore>
    proc makeBinaryChannel { channel } {
      fconfigure $channel -encoding binary -translation binary; # BINARY DATA
    }
  }

  #
  # NOTE: *HACK* Skip defining this procedure if it is already defined in the
  #       global namespace.
  #
  if {[llength [info commands ::writeFile]] == 0} then {
    #
    # NOTE: This procedure was stolen from the "file1.eagle" script.  This
    #       procedure writes all data to the specified binary file and returns
    #       an empty string.  Previous data contained in the file, if any, is
    #       lost.
    #
    # <ignore>
    proc writeFile { fileName data } {
      set channel [open $fileName {WRONLY CREAT TRUNC}]
      makeBinaryChannel $channel
      puts -nonewline $channel $data
      close $channel
      return ""
    }
  }

  #
  # NOTE: This procedure was stolen from the "common.tcl" script.  This
  #       procedure sets up the default values for all HTTP configuration
  #       parameters used by this package.  If the force argument is
  #       non-zero, any existing values will be overwritten and set back
  #       to their default values.
  #
  proc setupCommonVariables { force } {
    #
    # NOTE: Should the HTTP request processor attempt to force the use of
    #       HTTPS for URIs that were originally HTTP?  This setting is only
    #       applicable to native Tcl.
    #
    variable forceSecureUri; # DEFAULT: true

    if {$force || ![info exists forceSecureUri]} then {
      set forceSecureUri true
    }

    #
    # NOTE: Should the HTTP request processor fail if the "tls" package is
    #       not available?
    #
    variable mustHaveTls; # DEFAULT: true

    if {$force || ![info exists mustHaveTls]} then {
      set mustHaveTls true
    }

    #
    # NOTE: Is this HTTP request processor allowed to use plain HTTP if/when
    #       the "tls" package is not available?  This should only be changed
    #       if the "tls" package cannot be easily installed for use with the
    #       native Tcl interpreter in use.  It should be noted here that the
    #       official package repository server reserves the right to refuse
    #       plain HTTP connections, which means that changing this setting
    #       may be totally pointless.
    #
    variable allowInsecureUri; # DEFAULT: false

    if {$force || ![info exists allowInsecureUri]} then {
      set allowInsecureUri false
    }

    #
    # NOTE: Emit diagnostic messages when the [::http::geturl] procedure is
    #       about to be called?
    #
    variable verboseGetUrl; # DEFAULT: false

    if {$force || ![info exists verboseGetUrl]} then {
      set verboseGetUrl false
    }

    #
    # NOTE: Is this HTTP request processor allowed to use plain HTTP if/when
    #       the server responds with an HTTP redirect location to an original
    #       URI that was HTTPS?  Otherwise, a script error will result.
    #
    variable allowInsecureRedirect; # DEFAULT: false

    if {![info exists allowInsecureRedirect]} then {
      set allowInsecureRedirect false
    }

    #
    # NOTE: How long should we wait for the HTTP request to complete?  This
    #       value is the number of milliseconds.
    #
    variable timeoutGetUrl; # DEFAULT: 0

    if {![info exists timeoutGetUrl]} then {
      set timeoutGetUrl 0
    }
  }

  #
  # NOTE: This procedure was stolen from the "common.tcl" script.  It is
  #       designed to emit a message to the console.  The channel argument
  #       is the channel where the message should be written.  The string
  #       argument is the content of the message to emit.  If the channel
  #       argument is an empty string, nothing is written.
  #
  proc pageOut { channel string } {
    if {[string length $channel] > 0} then {
      catch {
        puts -nonewline $channel $string; flush $channel
      }
    }
  }

  #
  # NOTE: This procedure was stolen from the "common.tcl" script.  It is
  #       designed to emit a message to the HTTP client log.  The string
  #       argument is the content of the message to emit.  If the string
  #       argument is an empty string, nothing is written.
  #
  proc pageLog { string } {
    if {[string length $string] > 0} then {
      catch {
        tclLog [appendArgs \
            [pid] " : " [clock seconds] " : http : " $string]
      }
    }
  }

  #
  # NOTE: This procedure was stolen from the "common.tcl" script.  It is
  #       designed to setup the pending progress indicator callback and
  #       save its working state.
  #
  proc setupPageProgress { channel type milliseconds } {
    #
    # NOTE: This variable is used to keep track of the currently scheduled
    #       (i.e. pending) [after] event.
    #
    variable afterForPageProgress

    #
    # NOTE: Scheduled the necessary [after] event, using the [pageProgress]
    #       procedure, which is defined further down in this file.
    #
    set afterForPageProgress [after $milliseconds [namespace code \
        [list pageProgress $channel $type $milliseconds]]]
  }

  #
  # NOTE: This procedure was stolen from the "common.tcl" script.  It is
  #       designed to cancel the pending progress indicator callback and
  #       cleanup its working state.
  #
  proc cancelPageProgress {} {
    #
    # NOTE: This variable is used to keep track of the currently scheduled
    #       (i.e. pending) [after] event.
    #
    variable afterForPageProgress

    #
    # NOTE: If there is a currently scheduled [after] event, cancel it.
    #
    if {[info exists afterForPageProgress]} then {
      catch {after cancel $afterForPageProgress}
      unset -nocomplain afterForPageProgress
    }
  }

  #
  # NOTE: This procedure was stolen from the "common.tcl" script.  It is
  #       designed to emit a progress indicator while an HTTP request is
  #       being processed.  The channel argument is the Tcl channel where
  #       the progress indicator should be emitted.  The type argument is
  #       the single-character progress indicator.  The milliseconds
  #       argument is the number of milliseconds to wait until the next
  #       periodic progress indicator should be emitted.  This procedure
  #       reschedules its own execution.
  #
  proc pageProgress { channel type milliseconds } {
    #
    # NOTE: Show that something is happening...
    #
    pageOut $channel $type

    #
    # NOTE: Make sure that we are scheduled to run again, if requested;
    #       also, before doing that, make sure there is not already an
    #       associated [after] event pending.
    #
    cancelPageProgress

    if {$milliseconds > 0} then {
      setupPageProgress $channel $type $milliseconds
    }
  }

  #
  # NOTE: This procedure was stolen from the "common.tcl" script.  It is
  #       designed to process a single HTTP request, including any HTTP
  #       3XX redirects (up to the specified limit), and return the raw
  #       HTTP response data.  It may raise any number of script errors.
  #
  # <public>
  proc getFileViaHttp { uri redirectLimit channel quiet args } {
    #
    # NOTE: This global variable is used to check the running version of
    #       Tcl.
    #
    global tcl_version

    #
    # NOTE: This variable is used to determine if plain HTTP URIs should be
    #       converted to HTTPS, if the "tls" package is available.
    #
    variable forceSecureUri

    #
    # NOTE: This variable is used to determine if an error should be raised
    #       if the "tls" package is not available.
    #
    variable mustHaveTls

    #
    # NOTE: This variable is used to determine if plain HTTP is allowed if
    #       the "tls" package is not available.
    #
    variable allowInsecureUri

    #
    # NOTE: This variable is used to determine if a diagnostic message is
    #       emitted when [::http::geturl] is about to be called.
    #
    variable verboseGetUrl

    #
    # NOTE: This variable is used to determine if plain HTTP is allowed if
    #       an HTTP redirect response contains an HTTP URI and the original
    #       URI was HTTPS.
    #
    variable allowInsecureRedirect

    #
    # NOTE: This variable is used to determine the timeout milliseconds for
    #       HTTP requests.
    #
    variable timeoutGetUrl

    #
    # NOTE: This procedure requires the modern version of the HTTP package,
    #       which is typically included with the Tcl core distribution.
    #
    package require http 2.0

    #
    # NOTE: Tcl 8.6 added support for IPv6; however, on some machines this
    #       support can cause sockets to hang for a long time.  Therefore,
    #       for now, by default, always force the use of IPv4.
    #
    if {![info exists ::no(tclSocketAfInet)] && \
        [info exists tcl_version] && $tcl_version >= 8.6} then {
      namespace eval ::tcl::unsupported {}
      set ::tcl::unsupported::socketAF inet
    }

    #
    # NOTE: Setup lowercase URI scheme prefixes used within this procedure
    #       to detect and/or change the URI scheme used.  By default, this
    #       procedure will always attempt to force HTTPS use when the "tls"
    #       package is available -AND- it disallows redirects from HTTPS to
    #       HTTP -AND- it disallows using HTTP when the "tls" package is
    #       unavailable.
    #
    set http http://
    set httpLen [string length $http]
    set httpEnd [expr {$httpLen - 1}]

    set https https://
    set httpsLen [string length $https]
    set httpsEnd [expr {$httpsLen - 1}]

    #
    # NOTE: If the "tls" package is available, always attempt to use HTTPS;
    #       otherwise, only attempt to use HTTP if explicitly allowed.
    #
    if {[catch {package require tls} error] == 0} then {
      ::http::register https 443 [list ::tls::socket -tls1 true]

      if {$forceSecureUri} then {
        if {[string tolower [string range $uri 0 $httpEnd]] eq $http} then {
          set uri [appendArgs $https [string range $uri $httpLen end]]
        }
      }
    } else {
      if {$mustHaveTls} then {
        error [appendArgs \
            "the \"tls\" package cannot be loaded: " $error]
      }

      if {$allowInsecureUri} then {
        if {[string tolower [string range $uri 0 $httpsEnd]] eq $https} then {
          set uri [appendArgs $http [string range $uri $httpsLen end]]
        }
      }
    }

    #
    # NOTE: Unless the caller forbids it, display progress messages during
    #       the download.
    #
    if {!$quiet} then {
      pageProgress $channel . 250
    }

    #
    # NOTE: All downloads are handled synchronously, which is not ideal;
    #       however, it is simple.  Keep going as long as there are less
    #       than X redirects.
    #
    set redirectCount 0

    while {1} {
      #
      # NOTE: Build the (optional?) list of options for the HTTP call.
      #
      set localArgs [list]

      if {$timeoutGetUrl != 0} then {
        lappend localArgs -timeout $timeoutGetUrl; # milliseconds
      }

      if {[llength $args] > 0} then {
        eval lappend localArgs $args
      }

      #
      # NOTE: Issue the HTTP request now, grabbing the resulting token.
      #
      if {$verboseGetUrl} then {
        #
        # NOTE: Emit important diagnostic information related to this
        #       HTTP request here.  This may be enhanced in the future.
        #
        pageLog [appendArgs \
            "attempting to download URL \"" $uri "\" with arguments \"" \
            $localArgs \"...]
      }

      #
      # NOTE: Attempt to perform the actual HTTP request.  This can fail
      #       in an almost unlimited number of ways, which is fun.
      #
      set token [eval ::http::geturl [list $uri] $localArgs]

      #
      # NOTE: Grab the HTTP status.  It must be "ok" in order to proceed.
      #
      set status [::http::status $token]

      if {$status ne "ok"} then {
        error [appendArgs \
            "bad HTTP status \"" $status "\" is not \"ok\""]
      }

      #
      # NOTE: Grab the HTTP response code and data now as they are needed
      #       in almost all cases.
      #
      set code [::http::ncode $token]; set data [::http::data $token]

      #
      # NOTE: If the HTTP response code is an empty string that may
      #       indicate a serious bug in the tls (or http) package for
      #       this platform.  So far, this issue has only been seen
      #       with the tls 1.6.1 package that shipped with macOS.
      #
      if {[string length $code] == 0} then {
        error [appendArgs \
            "received empty HTTP response code for URL \"" $uri \
            "\", the \"tls\" (and/or \"http\") package(s) may be " \
            "broken for this Tcl installation (or platform)"]
      }

      #
      # NOTE: Check the HTTP response code, in order to follow any HTTP
      #       redirect responses.
      #
      switch -glob -- $code {
        100 -
        101 -
        102 {
          ::http::cleanup $token; error [appendArgs \
              "unsupported informational HTTP response status code " \
              $code ", data: " $data]
        }
        200 -
        201 -
        202 -
        203 -
        204 -
        205 -
        206 -
        207 -
        208 -
        226 {
          #
          # NOTE: Ok, the HTTP response is actual data of some kind (which
          #       may be empty).
          #
          ::http::cleanup $token; break
        }
        301 -
        302 -
        303 -
        307 -
        308 {
          #
          # NOTE: Unless the caller forbids it, display progress messages
          #       when an HTTP redirect is returned.
          #
          if {!$quiet} then {
            pageProgress $channel > 0
          }

          #
          # NOTE: We hit another HTTP redirect.  Stop if there are more
          #       than X.
          #
          incr redirectCount

          #
          # TODO: Maybe make this limit more configurable?  The caller
          #       can pass any negative integer to disable it entirely
          #       -OR- zero to completely disallow any redirects.
          #
          if {$redirectLimit >= 0 && \
              $redirectCount > $redirectLimit} then {
            #
            # NOTE: Just "give up" and raise a script error.
            #
            ::http::cleanup $token; error [appendArgs \
                "redirection limit of " $redirectLimit " exceeded"]
          }

          #
          # NOTE: Grab the metadata associated with this HTTP response.
          #
          unset -nocomplain meta; array set meta [::http::meta $token]

          #
          # NOTE: Is there actually a new URI (location) to use?
          #
          if {[info exist meta(Location)]} then {
            #
            # NOTE: Ok, grab it now.  Later, at the top of the loop,
            #       it will be used in the subsequent HTTP request.
            #
            set location $meta(Location); unset meta

            #
            # NOTE: For security, by default, do NOT follow an HTTP
            #       redirect if it attempts to redirect from HTTPS
            #       to HTTP.
            #
            if {!$allowInsecureRedirect && \
                [string tolower [string range \
                    $uri 0 $httpsEnd]] eq $https && \
                [string tolower [string range \
                    $location 0 $httpsEnd]] ne $https} then {
              #
              # NOTE: Just "give up" and raise a script error.
              #
              ::http::cleanup $token; error [appendArgs \
                  "refused (insecure) redirect from \"" $uri \
                  "\" to \"" $location \
                  "\" with HTTP response status code " $code]
            }

            #
            # NOTE: Replace the original URI with the new one, for
            #       use in the next HTTP request.
            #
            set uri $location

            #
            # NOTE: Cleanup the current HTTP token now beause a new
            #       one will be created for the next request.
            #
            ::http::cleanup $token
          } else {
            #
            # NOTE: Just "give up" and raise a script error.
            #
            ::http::cleanup $token; error [appendArgs \
                "redirect from \"" $uri \
                "\" missing location, HTTP response status code " \
                $code ", data: " $data]
          }
        }
        300 -
        304 -
        305 -
        306 {
          ::http::cleanup $token; error [appendArgs \
              "unsupported redirection HTTP response status code " \
              $code ", data: " $data]
        }
        4?? {
          ::http::cleanup $token; error [appendArgs \
              "client error HTTP response status code " $code ", data: " \
              $data]
        }
        5?? {
          ::http::cleanup $token; error [appendArgs \
              "server error HTTP response status code " $code ", data: " \
              $data]
        }
        default {
          ::http::cleanup $token; error [appendArgs \
              "unrecognized HTTP response status code " $code ", data: " \
              $data]
        }
      }
    }

    #
    # NOTE: If there is a currently scheduled [after] event, cancel it.
    #       This is NOT done if the caller enabled quiet mode, because
    #       there should be none of our [after] events present in that
    #       case.
    #
    if {!$quiet} then {
      cancelPageProgress
    }

    #
    # NOTE: If progress messages were emitted, start a fresh line.
    #
    if {!$quiet} then {
      pageOut $channel [appendArgs " " $uri \n]
    }

    return $data
  }

  #
  # NOTE: First, setup the variables associated with this package.
  #
  setupCommonVariables false

  #
  # NOTE: Export the procedures from this namespace that are designed to be
  #       used by external scripts.
  #
  namespace export appendArgs getFileViaHttp pageOut writeFile

  #
  # NOTE: Provide the package to the interpreter.
  #
  package provide Eagle.Tools.Common 1.0
}