###############################################################################
#
# pkgr.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Package Repository Client
#
# 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: Use our own namespace here because even though we do not directly
# support namespaces ourselves, we do not want to pollute the global
# namespace if this script actually ends up being evaluated in Tcl.
#
namespace eval ::PackageRepository {
#
# NOTE: This package absolutely requires the Eagle core script library
# package, even when it is being used by native Tcl. If needed,
# prior to loading this package, the native Tcl auto-path should
# be modified to include the "Eagle1.0" directory (i.e. the one
# containing the Eagle core script library file "init.eagle").
#
package require Eagle.Library
proc stringIsList { value } {
if {[isEagle]} then {
return [string is list $value]
} else {
global tcl_version
if {[info exists tcl_version] && $tcl_version >= 8.5} then {
return [string is list $value]
} elseif {[catch {llength $value}] == 0} then {
return true
} else {
return false
}
}
}
proc isHarpyCertificate { value } {
if {[string length $value] == 0 || [string first [string trim {
<Certificate xmlns="https://eagle.to/2011/harpy"
}] $value] != -1} then {
return true
} else {
return false
}
}
proc isPgpSignature { value } {
if {[string length $value] == 0 || [string first [string trim {
-----BEGIN PGP SIGNATURE-----
}] $value] != -1} then {
return true
} else {
return false
}
}
proc getFileTempName {} {
if {[isEagle]} then {
return [file tempname]
} else {
global env
if {[info exists env(PKGR_TEMP)]} then {
set directory $env(PKGD_TEMP)
} elseif {[info exists env(TEMP)]} then {
set directory $env(TEMP)
} elseif {[info exists env(TMP)]} then {
set directory $env(TMP)
} else {
error "please set PKGR_TEMP (via environment) to temporary directory"
}
set counter [expr {[pid] ^ int(rand() * 0xFFFF)}]
while {1} {
set fileNameOnly [format tcl%04X.tmp $counter]
set fileName [file join $directory $fileNameOnly]
if {![file exists $fileName]} then {
return $fileName
}
incr counter
}
}
}
proc verifyPgpSignature { fileName } {
variable pgpCommand
if {[isEagle]} then {
set fileName [appendArgs \" $fileName \"]
if {[catch {
eval exec -success Success [subst $pgpCommand]
}] == 0} then {
return true
}
} else {
if {[catch {
eval exec [subst $pgpCommand] 2>@1
}] == 0} then {
return true
}
}
return false
}
proc getLookupVarNamePrefix {} {
return ::rpkg_; # TODO: Make non-global?
}
proc getLookupVarNameSuffix {} {
return [appendArgs \
[string trim [pid] -] _ [string trim [clock seconds] -] _ \
[string trim [clock clicks -milliseconds] -]]; # TODO: Bad?
}
proc getLookupApiKey {} {
set varName [appendArgs [getLookupVarNamePrefix] api_key]
if {[info exists $varName]} then {
return [set $varName]
}
global env
set varName [string trim $varName :]
if {[info exists env($varName)]} then {
return $env($varName)
}
return ""; # NOTE: System default, which is "public".
}
proc getLookupBaseUri {} {
set varName [appendArgs [getLookupVarNamePrefix] base_uri]
if {[info exists $varName]} then {
return [set $varName]
}
global env
set varName [string trim $varName :]
if {[info exists env($varName)]} then {
return $env($varName)
}
return https://urn.to/r/pkg; # NOTE: System default.
}
proc getLookupUri { apiKey package version } {
set baseUri [getLookupBaseUri]
if {[string length $baseUri] == 0} then {
return ""
}
#
# NOTE: Build the HTTP request URI using the specified query parameter
# values, escaping them as necessary. Also, include the standard
# query parameters with constant values for this request type.
#
if {[isEagle]} then {
return [appendArgs \
$baseUri ?raw=1&method=lookup&apiKey= [uri escape uri $apiKey] \
&package= [uri escape uri $package] &version= [uri escape uri \
$version]]
} else {
package require http 2.0
return [appendArgs \
$baseUri ? [http::formatQuery raw 1 method lookup apiKey $apiKey \
package $package version $version]]
}
}
proc getLookupVersion { requirement } {
if {[set index [string first - $requirement]] != -1} then {
incr index -1; set requirement [string range $requirement 0 $index]
}
if {[set index [string first a $requirement]] != -1 || \
[set index [string first b $requirement]] != -1} then {
incr index -1; set requirement [string range $requirement 0 $index]
}
if {$requirement eq "0"} then {
set requirement ""
} elseif {[regexp -- {^\d+$} $requirement]} then {
append requirement .0
}
return $requirement
}
proc getLookupData { apiKey package version } {
set uri [getLookupUri $apiKey $package $version]
if {[string length $uri] == 0} then {
return ""
}
if {[isEagle]} then {
set data [uri download -inline $uri]
} else {
variable quiet
set data [getFileViaHttp $uri 10 stdout $quiet]
}
set data [string map [list <\; < >\; > "\; \" &\; &] $data]
set data [string map [list \r\n \n \r \n] $data]
set data [string map [list \n \r\n] $data]
set data [string trim $data]
return $data
}
proc getLookupCodeFromData { data } {
if {![stringIsList $data] || [llength $data] < 1} then {
return ""
}
return [lindex $data 0]
}
proc getLookupResultFromData { data } {
if {![stringIsList $data] || [llength $data] < 2} then {
return ""
}
return [lindex $data 1]
}
proc isLookupCodeOk { code } {
#
# NOTE: The code must be the literal string "OK" for the package lookup
# request to be considered successful.
#
return [expr {$code eq "OK"}]
}
proc extractAndVerifyLookupMetadata { result varName caller } {
variable strictUnknownLanguage
#
# NOTE: Grab the language for the package script. It must be an empty
# string, "Tcl", or "Eagle". If it is an empty string, "Eagle"
# will be assumed.
#
set language [getDictionaryValue $result Language]
if {[lsearch -exact [list "" Tcl Eagle] $language] == -1} then {
error "unsupported language"
}
#
# NOTE: Grab the package script. If it is an empty string, then the
# package cannot be loaded and there is nothing to do. In that
# case, just raise an error.
#
set ifNeeded [getDictionaryValue $result IfNeeded]
if {[string length $ifNeeded] == 0} then {
error "missing ifneeded script"
}
#
# NOTE: Grab the package script certificate. If it is an empty string
# then the package script is unsigned, which is not allowed by
# this client. In that case, just raise an error.
#
set certificate [getDictionaryValue $result Certificate]
if {[string length $certificate] == 0} then {
error "missing script certificate"
}
#
# NOTE: Are we being called from the [package unknown] handler
# in "strict" mode?
#
if {$strictUnknownLanguage && $caller eq "handler"} then {
#
# NOTE: If so, the package script must be targeted at the this
# language; otherwise, there exists the possibility that
# the package may not be provided to this language.
#
if {[isEagle]} then {
if {$language ne "Eagle"} then {
error "repository package is not for Eagle"
}
} else {
if {$language ne "Tcl"} then {
error "repository package is not for Tcl"
}
}
}
#
# NOTE: If the caller wants the package metadata, use their array
# variable name.
#
if {[string length $varName] > 0} then {
upvar 1 $varName metadata
set metadata(language) $language
set metadata(ifNeeded) $ifNeeded
set metadata(certificate) $certificate
}
}
proc tclMustBeReady {} {
#
# NOTE: This procedure is not allowed to actually load a native Tcl
# library; therefore, one must already be loaded.
#
if {![isEagle]} then {
error "already running in Tcl language"
}
if {![tcl ready]} then {
error "cannot use Tcl language, supporting library is not loaded"
}
}
proc eagleMustBeReady {} {
#
# NOTE: This procedure is not allowed to actually load Garuda (and
# Eagle); therefore, they must already be loaded.
#
if {[isEagle]} then {
error "already running in Eagle language"
}
if {[llength [info commands eagle]] == 0} then {
error "cannot use Eagle language, supporting package is not loaded"
}
}
proc eagleHasSecurity {} {
#
# NOTE: If possible, check if the current interpreter has security
# enabled.
#
if {[isEagle] && [llength [info commands object]] > 0} then {
if {[catch {
object invoke -flags +NonPublic Interpreter.GetActive HasSecurity
} security] == 0 && $security} then {
return true
}
}
return false
}
proc processLookupMetadata { varName } {
#
# NOTE: If the metadata variable name appears to be invalid, fail.
#
if {[string length $varName] == 0} then {
error "bad metadata"
}
#
# NOTE: This procedure requires that the metadata array variable is
# present in the call frame immediately above this one.
#
upvar 1 $varName metadata
#
# NOTE: If the entire package metadata array is missing, fail.
#
if {![info exists metadata]} then {
error "missing metadata"
}
#
# NOTE: If the language for the package script is mising, fail.
#
if {![info exists metadata(language)]} then {
error "missing language"
}
#
# NOTE: If the package script is mising, fail.
#
if {![info exists metadata(ifNeeded)]} then {
error "missing ifneeded script"
}
#
# NOTE: If the package script certificate is mising, fail.
#
if {![info exists metadata(certificate)]} then {
error "missing script certificate"
}
#
# NOTE: Create common cleanup script block that deletes any temporary
# files created for the script verification process.
#
set script(cleanup) {
if {[string length $fileName(2)] > 0 && \
[file exists $fileName(2)]} then {
if {![info exists ::env(rpkg_keep_files)]} then {
catch {file delete $fileName(2)}
}
unset -nocomplain fileName(2)
}
if {[string length $fileName(1)] > 0 && \
[file exists $fileName(1)]} then {
if {![info exists ::env(rpkg_keep_files)]} then {
catch {file delete $fileName(1)}
}
unset -nocomplain fileName(1)
}
}
#
# NOTE: Figure out the "type" of script certificate we are now dealing
# with.
#
if {[isHarpyCertificate $metadata(certificate)]} then {
#
# NOTE: Attempt to create a completely unique array variable name to
# hold the package metadata in this scripting language as well
# as possibly in the other necessary scripting language(s).
#
set newVarName(1) [appendArgs \
[getLookupVarNamePrefix] metadata_ [getLookupVarNameSuffix]]
set newVarName(2) [appendArgs \
[getLookupVarNamePrefix] cleanup_ [getLookupVarNameSuffix]]
set newProcName(1) [appendArgs \
[getLookupVarNamePrefix] eagleHasSecurity_ [getLookupVarNameSuffix]]
set newProcName(2) [appendArgs \
[getLookupVarNamePrefix] getFileTempName_ [getLookupVarNameSuffix]]
set newProcName(3) [appendArgs \
[getLookupVarNamePrefix] tclMustBeReady_ [getLookupVarNameSuffix]]
#
# NOTE: Create the Eagle script block that will be used to securely
# evaluate a signed package script. This must be evaluated in
# Eagle because it uses several plugins only available there.
#
set script(outer) [string map [list \
%metadata% $newVarName(1) %cleanup% $newVarName(2) \
%eagleHasSecurity% $newProcName(1) %getFileTempName% \
$newProcName(2) %tclMustBeReady% $newProcName(3)] {
try {
#
# NOTE: If there is no package ifneeded script, there is nothing we
# can do here.
#
if {[string length ${%metadata%(ifNeeded)}] > 0} then {
#
# NOTE: Save the security state for the interpreter. Then, attempt
# to enable it. This will fail if one of the needed plugins
# cannot be loaded.
#
set savedSecurity [{%eagleHasSecurity%}]
if {!$savedSecurity} then {source enableSecurity}
try {
#
# NOTE: Figure out temporary file name for the downloaded script
# and its associated script certificate.
#
set fileName(1) [{%getFileTempName%}]
set fileName(2) [appendArgs $fileName(1) .harpy]
try {
#
# NOTE: Write downloaded script to a temporary file.
#
writeFile $fileName(1) ${%metadata%(ifNeeded)}
#
# NOTE: Write downloaded script certificate to a temporary
# file.
#
if {[string length ${%metadata%(certificate)}] > 0} then {
writeFile $fileName(2) ${%metadata%(certificate)}
}
#
# NOTE: This seems stupid. Why are we reading the downloaded
# script from the temporary file when we already had it
# in memory? The reason is that we need to make sure
# that the Harpy policy engine has a chance to check the
# downloaded script against its associated certificate.
# This will raise a script error if the script signature
# is missing or invalid.
#
set script(inner) [interp readorgetscriptfile -- \
"" $fileName(1)]
#
# NOTE: Determine the target language for the package script,
# which may or may not be the language that is currently
# evaluating this script (Eagle). The default language,
# when one was not explicitly specified, is Eagle. In
# the future, this may be changed, e.g. to use the file
# extension of the client script.
#
switch -exact -- ${%metadata%(language)} {
"" -
Eagle {
#
# NOTE: The target language is Eagle, which is evaluating
# this script. No special handling is needed here.
#
return [uplevel #0 $script(inner)]
}
Tcl {
#
# NOTE: The target language is Tcl; therefore, a bit of
# special handling is needed here.
#
{%tclMustBeReady%}; return [tcl eval [tcl master] [list \
uplevel #0 $script(inner)]]
}
default {
error "unsupported language"
}
}
} finally {
#
# NOTE: Perform any necessary cleanup steps.
#
eval ${%cleanup%}
}
} finally {
#
# NOTE: Restore the saved security state for the interpreter.
#
if {!$savedSecurity} then {source disableSecurity}
unset -nocomplain savedSecurity
}
}
} finally {
rename {%tclMustBeReady%} ""
rename {%getFileTempName%} ""
rename {%eagleHasSecurity%} ""
unset -nocomplain {%cleanup%}
unset -nocomplain {%metadata%}
}
}]
#
# NOTE: Copy the package metadata into the fresh array variable,
# if necessary, marshalling it from native Tcl to Eagle.
#
if {[isEagle]} then {
array set $newVarName(1) [array get metadata]
set $newVarName(2) $script(cleanup)
proc $newProcName(1) {} [info body [appendArgs \
[namespace current] ::eagleHasSecurity]]
proc $newProcName(2) {} [info body [appendArgs \
[namespace current] ::getFileTempName]]
proc $newProcName(3) {} [info body [appendArgs \
[namespace current] ::tclMustBeReady]]
return [eval $script(outer)]
} else {
eagleMustBeReady
eagle [list array set $newVarName(1) [array get metadata]]
eagle [list set $newVarName(2) $script(cleanup)]
eagle [list proc $newProcName(1) {} [info body [appendArgs \
[namespace current] ::eagleHasSecurity]]]
eagle [list proc $newProcName(2) {} [info body [appendArgs \
[namespace current] ::getFileTempName]]]
eagle [list proc $newProcName(3) {} [info body [appendArgs \
[namespace current] ::tclMustBeReady]]]
return [eagle $script(outer)]
}
} elseif {[isPgpSignature $metadata(certificate)]} then {
#
# NOTE: If there is no package ifneeded script, there is nothing we
# can do here.
#
if {[string length $metadata(ifNeeded)] > 0} then {
#
# NOTE: Figure out temporary file name for the downloaded script
# and its associated PGP signature.
#
set fileName(1) [getFileTempName]
set fileName(2) [appendArgs $fileName(1) .asc]
#
# NOTE: Write downloaded script to a temporary file.
#
writeFile $fileName(1) $metadata(ifNeeded)
#
# NOTE: Write downloaded script PGP signature a temporary file.
#
if {[string length $metadata(certificate)] > 0} then {
writeFile $fileName(2) $metadata(certificate)
}
#
# NOTE: Attempt to verify the PGP signature for the package script.
#
if {[verifyPgpSignature $fileName(2)]} then {
#
# NOTE: Delete the temporary files that we created for the PGP
# signature verification.
#
eval $script(cleanup)
} else {
#
# NOTE: Delete the temporary files that we created for the PGP
# signature verification.
#
eval $script(cleanup)
#
# NOTE: PGP signature verification failed. Raise an error and
# do not proceed with evaluating the package script.
#
error "bad PGP signature"
}
#
# NOTE: The PGP signature was verified; use the downloaded package
# script verbatim.
#
set script(inner) $metadata(ifNeeded)
#
# NOTE: Determine the target language for the package script, which
# may or may not be the language that is currently evaluating
# this script (Eagle). The default language, when one was not
# explicitly specified, is Eagle. In the future, this may be
# changed, e.g. to use the file extension of the client script.
#
switch -exact -- $metadata(language) {
"" -
Eagle {
if {[isEagle]} then {
return [uplevel #0 $script(inner)]
} else {
eagleMustBeReady
return [eagle [list uplevel #0 $script(inner)]]
}
}
Tcl {
if {[isEagle]} then {
tclMustBeReady; return [tcl eval [tcl master] [list \
uplevel #0 $script(inner)]]
} else {
return [uplevel #0 $script(inner)]
}
}
default {
error "unsupported language"
}
}
}
} else {
error "unsupported script certificate"
}
}
proc setupPackageUnknownHandler {} {
variable autoHook
variable autoLoadTcl
variable autoRequireGaruda
if {$autoRequireGaruda && ![isEagle]} then {
#
# TODO: Assume this package is trusted? How can we verify it
# at this point?
#
package require Garuda
}
if {$autoLoadTcl && [isEagle]} then {
#
# NOTE: Load a native Tcl library. It must be signed with a valid
# Authenticode signature.
#
tcl load -findflags +TrustedOnly -loadflags +SetDllDirectory
}
if {$autoHook} then {
#
# NOTE: Install our [package unknown] handler and save the original
# one for our use as well.
#
hookPackageUnknownHandler
}
}
proc hookPackageUnknownHandler {} {
set varName [appendArgs [getLookupVarNamePrefix] saved_package_unknown]
if {[info exists $varName]} then {
error "package unknown handler already hooked"
}
set $varName [package unknown]
package unknown [appendArgs [namespace current] ::packageUnknownHandler]
}
proc unhookPackageUnknownHandler {} {
set varName [appendArgs [getLookupVarNamePrefix] saved_package_unknown]
if {![info exists $varName]} then {
error "package unknown handler is not hooked"
}
package unknown [set $varName]
unset $varName
}
proc runSavedPackageUnknownHandler { package version } {
#
# NOTE: See if there is a saved [package unknown] handler. If so, then
# attempt to use it.
#
set varName [appendArgs [getLookupVarNamePrefix] saved_package_unknown]
set oldHandler [expr {[info exists $varName] ? [set $varName] : ""}]
if {[string length $oldHandler] > 0} then {
lappend oldHandler $package $version; uplevel #0 $oldHandler
}
}
#
# NOTE: This version argument to this procedure must be optional, because
# Eagle does not add a version argument when one is not supplied to
# the [package require] sub-command itself.
#
proc packageUnknownHandler { package {version ""} } {
#
# NOTE: First, run our [package unknown] handler.
#
if {[catch {main $package $version handler} error(1)] == 0} then {
#
# NOTE: The repository [package unknown] handler succeeded, run the
# saved [package unknown] handler.
#
if {[catch {
runSavedPackageUnknownHandler $package $version
} error(2)] == 0} then {
#
# NOTE: Success? Just return and let Tcl (or Eagle) handle the
# rest. This is the "happy" path.
#
return
} else {
#
# NOTE: Failure? Attempt to log the error message.
#
catch {
tclLog [appendArgs \
"pkgr: saved handler failed for \"" [appendArgs [string \
trim $package " " $version]] "\", error: " $error(2)]
}
}
} else {
#
# NOTE: Failure? Attempt to log the error message and then maybe
# try the original [package unknown] handler.
#
catch {
tclLog [appendArgs \
"pkgr: new handler failed for \"" [appendArgs [string \
trim $package " " $version]] "\", error: " $error(1)]
}
#
# NOTE: The repository [package unknown] handler failed, run the
# saved [package unknown] handler anyway. There is almost
# no chance of this actually providing the package.
#
if {[catch {
runSavedPackageUnknownHandler $package $version
} error(2)] == 0} then {
#
# NOTE: Success? Just return and let Tcl (or Eagle) handle the
# rest.
#
return
} else {
#
# NOTE: Failure? Attempt to log the error message.
#
catch {
tclLog [appendArgs \
"pkgr: old handler failed for \"" [appendArgs [string \
trim $package " " $version]] "\", error: " $error(2)]
}
}
}
#
# NOTE: Both [package unknown] handlers failed in some way, return the
# error messages (i.e. both of them).
#
error [array get error]
}
proc setupPackageUnknownVars {} {
#
# NOTE: Prevent progress messages from being displayed while downloading
# from the repository, etc? By default, this is enabled.
#
variable quiet; # DEFAULT: true
if {![info exists quiet]} then {
set quiet true
}
#
# NOTE: Automatically install our [package unknown] handler when this
# package is loaded?
#
variable autoHook; # DEFAULT: true
if {![info exists autoHook]} then {
set autoHook true
}
#
# NOTE: Automatically [tcl load] when this package is loaded from the
# Eagle language?
#
variable autoLoadTcl; # DEFAULT: true
if {![info exists autoLoadTcl]} then {
set autoLoadTcl true
}
#
# NOTE: Automatically [package require Garuda] when this package is
# loaded from the Tcl language?
#
variable autoRequireGaruda; # DEFAULT: true
if {![info exists autoRequireGaruda]} then {
set autoRequireGaruda true
}
#
# NOTE: The command to use when verifying OpenPGP signatures for the
# downloaded package scripts.
#
variable pgpCommand; # DEFAULT: gpg2 --verify {${fileName}}
if {![info exists pgpCommand]} then {
set pgpCommand {gpg2 --verify {${fileName}}}
}
#
# NOTE: Verify that the package script matches the current language
# when called from the [package unknown] handler?
#
variable strictUnknownLanguage; # DEFAULT: true
if {![info exists strictUnknownLanguage]} then {
set strictUnknownLanguage true
}
}
proc main { package version caller } {
#
# NOTE: Issue the lookup request to the remote package repository.
#
set data [getLookupData \
[getLookupApiKey] $package [getLookupVersion $version]]
#
# NOTE: Attempt to grab the lookup code from the response data.
#
set code [getLookupCodeFromData $data]
#
# NOTE: Attempt to grab the lookup data from the response data.
# Upon failure, this should contain the error message.
#
set result [getLookupResultFromData $data]
#
# NOTE: Did the lookup operation fail?
#
if {![isLookupCodeOk $code]} then {
#
# NOTE: Is there an error message?
#
if {[string length $result] > 0} then {
#
# NOTE: Yes. Use the returned error message verbatim.
#
error $result
} else {
#
# NOTE: No. Use the whole response data string as the error
# message.
#
error $data
}
}
#
# NOTE: Process the lookup data into the pieces of metadata that we
# need to load the requested package.
#
extractAndVerifyLookupMetadata $result metadata $caller
#
# NOTE: Attempt to load the requested package using the metadata
# extracted in the previous step.
#
processLookupMetadata metadata
}
if {![isEagle]} then {
###########################################################################
############################# BEGIN Tcl ONLY ##############################
###########################################################################
#
# NOTE: This procedure was stolen from the "getEagle.tcl" script.
#
proc pageProgress { channel type milliseconds } {
#
# NOTE: Show that something is happening...
#
catch {puts -nonewline $channel $type; flush $channel}
#
# NOTE: Make sure that we are scheduled to run again.
#
if {$milliseconds > 0} then {
after $milliseconds [namespace code [list pageProgress \
$channel $type $milliseconds]]
}
}
#
# NOTE: This procedure was stolen from the "getEagle.tcl" script.
#
proc getFileViaHttp { uri redirectLimit channel quiet args } {
#
# 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: If the 'tls' package is available, always attempt to use HTTPS.
#
if {[catch {package require tls}] == 0} then {
::http::register https 443 ::tls::socket
if {[string range $uri 0 6] eq "http://"} then {
set uri [appendArgs https:// [string range $uri 7 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: Issue the HTTP request now, grabbing the resulting token.
#
set token [eval [list ::http::geturl $uri] $args]
#
# NOTE: Check the HTTP response code, in order to follow any HTTP
# redirect responses.
#
switch -exact -- [http::ncode $token] {
301 -
302 -
303 -
307 {
#
# 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 configurable?
#
if {$redirectCount > $redirectLimit} then {
#
# NOTE: Just "give up" and return whatever data that we have
# now.
#
set data [::http::data $token]
::http::cleanup $token; break
}
#
# NOTE: Grab the metadata associated with this HTTP response.
#
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, do NOT follow an HTTP redirect if
# it attempts to redirect from HTTPS to HTTP.
#
if {[string range $uri 0 7] eq "https://" && \
[string range $location 0 7] ne "https://"} then {
#
# NOTE: Just "give up" and return whatever data that
# we have now.
#
set data [::http::data $token]
::http::cleanup $token; break
}
#
# 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 return whatever data that we
# have now.
#
set data [::http::data $token]
::http::cleanup $token; break
}
}
default {
#
# NOTE: Ok, the HTTP response is actual data of some kind
# (which may be an error); however, it is not any
# kind of supported HTTP redirect.
#
set data [::http::data $token]
::http::cleanup $token; break
}
}
}
#
# NOTE: If progress messages were emitted, start a fresh line.
#
if {!$quiet} then {
catch {puts $channel [appendArgs " " $uri]; flush $channel}
}
return $data
}
###########################################################################
############################## END Tcl ONLY ###############################
###########################################################################
}
#
# NOTE: Setup the variables, within this namespace, used by this script.
#
setupPackageUnknownVars
#
# NOTE: Setup for our [package unknown] handler, which may involve a few
# different operations.
#
setupPackageUnknownHandler
#
# NOTE: Provide the package to the interpreter.
#
package provide Eagle.Package.Repository \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}