###############################################################################
#
# 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: If there is an "Eagle1.0" sub-directory present right beneath where
# this script was evaluated from, add it to the auto-path; otherwise,
# we assume that we are running from inside the source tree. In that
# case, modify the auto-path to include the "Eagle1.0" sub-directory
# within "externals". Only native Tcl needs to be able to locate the
# packages from the sub-directory being added to the auto-path here
# because they were already shipped in the Eagle core script library
# (as of Beta 37). The expression used for Eagle detection here was
# stolen from the Eagle core script library [isEagle] procedure.
#
variable pkgr_path; # DEFAULT: <unset>
if {![info exists ::tcl_platform(engine)] || \
[string compare -nocase eagle $::tcl_platform(engine)] != 0} then {
set pkgr_path [file normalize [file dirname [info script]]]
if {[file isdirectory [file join $pkgr_path Eagle1.0]]} then {
lappend ::auto_path [file join $pkgr_path Eagle1.0]
} else {
lappend ::auto_path [file join [file dirname [file dirname \
[file dirname $pkgr_path]]] externals Eagle lib Eagle1.0]
}
}
#
# NOTE: This package requires several packages from the Eagle core script
# library, even when it is being used by native Tcl. If necessary,
# prior to evaluating this file in native Tcl, its auto-path should
# be modified to include an "Eagle1.0" directory (i.e. a directory
# containing the Eagle core script library files "auxiliary.eagle",
# "file1.eagle", and "platform.eagle").
#
package require Eagle.Platform
package require Eagle.Auxiliary
package require Eagle.File
#
# NOTE: This block is intended to be evaluated successfully by native Tcl
# only. It serves two purposes:
#
# 1. Import the Eagle core script library procedures that are used
# by this package into the global namespace.
#
# 2. Unset the "pkgr_path" (namespace) variable that was created by
# the auto-path adjustment script fragment (above).
#
if {[info exists pkgr_path]} then {
catch {
::Eagle::exportAndImportPackageCommands ::Eagle \
[list appendArgs getDictionaryValue isEagle \
isWindows readFile writeFile] false false
}
unset -nocomplain pkgr_path
}
#
# NOTE: This procedure is used to provide a TIP #194 compatible [apply]
# command to the native Tcl 8.4 interpreter. Eagle and native Tcl
# 8.5 (or higher) have this command built-in. The lambdaExpr
# argument must be a list with two or three elements. The first
# element is the list of arguments to the procedure. The second
# element is the body of the procedure. The third element is the
# target namespace for the procedure. If the third element is not
# specified, the global namespace is used. Any remaining arguments
# are passed to the procedure verbatim.
#
if {[llength [info commands ::apply]] == 0} then {
proc ::apply { lambdaExpr args } {
set length [llength $lambdaExpr]
if {$length < 2 || $length > 3} {
error [appendArgs \
"can't interpret \"" $lambdaExpr "\" as a lambda expression"]
}
foreach {procArgs procBody procNamespace} $lambdaExpr {break}
set procNameSuffix [::PackageRepository::getUniqueSuffix 2]
set procName [appendArgs :: $procNamespace ::lambda_ $procNameSuffix]
set procPreBody {rename [lindex [info level 0] 0] "";}
proc $procName $procArgs [appendArgs $procPreBody $procBody]
return [uplevel 1 [list $procName] $args]
}
}
#
# NOTE: This procedure returns a formatted, possibly version-specific,
# package name, for use in logging. The package argument is the
# name of the package. The version argument is the version of the
# package.
#
proc formatPackageName { package version } {
return [string trim [appendArgs $package " " $version]]
}
#
# NOTE: This procedure returns a formatted script result. If the string
# result is empty, only the return code is used. The code argument
# must be an integer Tcl return code (e.g. from [catch]) and the
# result argument is the script result or error message.
#
proc formatResult { code result } {
switch -exact -- $code {
0 {set codeString ok}
1 {set codeString error}
2 {set codeString return}
3 {set codeString break}
4 {set codeString continue}
default {set codeString [appendArgs unknown( $code )]}
}
if {[string length $result] > 0} then {
return [appendArgs \
"code " $codeString ", result " [list $result]]
} else {
return $codeString
}
}
#
# NOTE: This procedure emits a message to the package repository client
# log. The string argument is the content of the message to emit.
#
proc pkgLog { string } {
catch {
tclLog [appendArgs [pid] " : " [clock seconds] " : pkgr : " $string]
}
}
#
# NOTE: This procedure attempts to determine if a string is a valid list
# and returns non-zero when that is true. The value argument is
# the string to check.
#
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
}
}
}
#
# NOTE: This procedure returns non-zero if the specified string value
# looks like a Harpy (script) certificate. The value argument is
# the string to check. The value 14 used within this procedure is
# the length of the literal string "</Certificate>".
#
# <public>
proc isHarpyCertificate { value } {
set value [string trim $value]
set length [string length $value]
if {$length == 0 || ([string first [string trim {
<?xml version="1.0" encoding="utf-8"?>
}] $value] == 0 && [string first [string trim {
<Certificate xmlns="https://eagle.to/2011/harpy"
}] $value] != -1 && [string first [string trim {
</Certificate>
}] $value] == ($length - 14))} then {
return true
} else {
return false
}
}
#
# NOTE: This procedure returns non-zero if the specified string value
# looks like an OpenPGP signature. The value argument is the string
# to check. The value 27 used within this procedure is the length
# of the literal string "-----END PGP SIGNATURE-----".
#
# <public>
proc isOpenPgpSignature { value } {
set value [string trim $value]
set length [string length $value]
if {$length == 0 || ([string first [string trim {
-----BEGIN PGP SIGNATURE-----
}] $value] == 0 && [string first [string trim {
-----END PGP SIGNATURE-----
}] $value] == ($length - 27))} then {
return true
} else {
return false
}
}
#
# NOTE: This procedure returns the fully qualified name of the directory
# where temporary files should be written. The envVarName argument
# is an optional extra environment variable to check (first).
#
# <public>
proc getFileTempDirectory { {envVarName ""} } {
global env
if {[string length $envVarName] > 0 && \
[info exists env($envVarName)]} then {
return $env($envVarName)
} elseif {[info exists env(TEMP)]} then {
return $env(TEMP)
} elseif {[info exists env(TMP)]} then {
return $env(TMP)
} else {
if {[string length $envVarName] > 0} then {
set defEnvVarName $envVarName
} elseif {[isWindows]} then {
set defEnvVarName TEMP
} else {
set defEnvVarName TMP
}
error [appendArgs \
"please set the \"" $defEnvVarName \
"\" environment variable to the path of a temporary directory"]
}
}
#
# NOTE: This procedure returns a unique temporary file name. A script
# error is raised if this task cannot be accomplished. There are
# no arguments.
#
proc getFileTempName {} {
if {[isEagle]} then {
return [file tempname]
} else {
set directory [getFileTempDirectory PKGR_TEMP]
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
}
}
}
#
# NOTE: This procedure attempts to verify the OpenPGP signature contained
# in the specified (named) file. Non-zero is only returned if the
# OpenPGP signature is verified successfully. A script error should
# not be raised by this procedure. The fileName argument must be
# the fully qualified path and file name of the OpenPGP signature
# file to verify.
#
# <public>
proc verifyOpenPgpSignature { fileName } {
variable openPgpCommand
if {[isEagle]} then {
set fileName [appendArgs \" $fileName \"]
if {[catch {
eval exec -success Success [subst $openPgpCommand]
}] == 0} then {
return true
}
} else {
if {[catch {
eval exec [subst $openPgpCommand] 2>@1
}] == 0} then {
return true
}
}
return false
}
#
# NOTE: This procedure returns the prefix for fully qualified variable
# names that MAY be present in the global namespace. There are
# no arguments.
#
proc getLookupVarNamePrefix {} {
return ::pkgr_; # TODO: Make non-global?
}
#
# NOTE: This procedure returns a name suffix (directory, variable, etc)
# that is unique to the running process at the current point in
# time. It is used (internally) to avoid name collisions with any
# preexisting variables or commands that may be present in the
# global namespace. The paranoia argument represents the relative
# level of paranoia required by the caller; the higher this level,
# the more uniqueness is required.
#
# <public>
proc getUniqueSuffix { {paranoia 1} } {
set result [string trim [pid] -]
if {$paranoia > 0} then {
append result _ [string trim [clock seconds] -]
}
if {$paranoia > 1} then {
append result _ [string trim \
[clock clicks -milliseconds] -]; # TODO: Bad?
}
return $result
}
#
# NOTE: This procedure returns the list of API keys to use when looking
# up packages via the package repository server. An empty list
# is returned if no API keys are currently configured. The prefix
# argument is an extra variable name prefix to check prior to any
# that are already configured. The prefixOnly argument should be
# non-zero to exclude any API keys other than those based on the
# prefix specified by the caller.
#
# <internal>
proc getApiKeys { {prefix ""} {prefixOnly false} } {
global env
variable autoApiKeys
#
# NOTE: If the caller specified a variable name prefix, try to use it
# first.
#
set prefixes [list]
if {[string length $prefix] > 0} then {
lappend prefixes $prefix
}
#
# NOTE: Next, fallback to the variable name prefix for this package,
# unless the caller has forbidden us to do so.
#
if {!$prefixOnly} then {
lappend prefixes [getLookupVarNamePrefix]
}
#
# NOTE: Try each variable name prefix, in order, until a set of API
# keys is found.
#
foreach prefix $prefixes {
#
# NOTE: If an empty prefix is seen, force it to use the "api_keys"
# variable from the global namespace.
#
if {[string length $prefix] == 0} then {
set prefix ::; # TODO: Make non-global?
}
#
# NOTE: Check for the variable, in whatever namespace it resides,
# and return its value verbatim if it exists.
#
set varName [appendArgs $prefix api_keys]
if {[info exists $varName]} then {
return [set $varName]
}
#
# NOTE: Fallback to using an environment variable with the same
# base name and returns its value verbatim if it exists.
#
set varName [string trim $varName :]
if {[info exists env($varName)]} then {
return $env($varName)
}
}
#
# NOTE: If there is a default list of API keys, just return it,
# unless the caller has forbidden us to do so.
#
if {!$prefixOnly && \
[info exists autoApiKeys] && [llength $autoApiKeys] > 0} then {
return $autoApiKeys
}
#
# NOTE: Otherwise, return the system default, which is "anonymous"
# packages only (i.e. those without any owners).
#
return [list]
}
#
# NOTE: This procedure returns the base URI for the package repository
# server. There are no arguments.
#
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.
}
#
# NOTE: This procedure returns the full URI to use when looking up a
# specific package via the package repository server. The apiKeys
# argument is the list of API keys to use -OR- an empty list if a
# public package is being looked up. The package argument is the
# name of the package being looked up, it cannot be an empty
# string. The version argument is the specific version being
# looked up -OR- an empty string for any available version. There
# are no HTTP requests issued by this procedure; it simply returns
# the URI to use.
#
proc getLookupUri { apiKeys 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.
#
set anonymousApiKey ""
if {[isEagle]} then {
if {[llength $apiKeys] > 0} then {
return [appendArgs \
$baseUri ?raw=1&method=lookup&apiKeys= [uri escape uri \
[join $apiKeys ,]] &package= [uri escape uri $package] \
&version= [uri escape uri $version]]
} else {
return [appendArgs \
$baseUri ?raw=1&method=lookup&apiKey= [uri escape uri \
$anonymousApiKey] &package= [uri escape uri $package] \
&version= [uri escape uri $version]]
}
} else {
package require http 2.0
if {[llength $apiKeys] > 0} then {
return [appendArgs \
$baseUri ? [::http::formatQuery raw 1 method lookup \
apiKeys [join $apiKeys ,] package $package version \
$version]]
} else {
return [appendArgs \
$baseUri ? [::http::formatQuery raw 1 method lookup \
apiKey $anonymousApiKey package $package version \
$version]]
}
}
}
#
# NOTE: This procedure returns the version of the package that should be
# used to lookup the associated [package ifneeded] script -OR- an
# empty string if no such version exists. The package argument is
# the name of the package, it cannot be an empty string. The
# version argument is the specific version being looked up -OR- an
# empty string for any available version.
#
proc getIfNeededVersion { package version } {
if {[string length $version] > 0} then {
return $version
}
return [lindex [package versions $package] 0]
}
#
# NOTE: This procedure accepts a package requirement (spec) and returns
# a simple package version, if possible. An empty string will be
# returned, if appropriate (i.e. any version should be allowed).
# The requirement argument must be a package specification that
# conforms to TIP #268.
#
proc packageRequirementToVersion { requirement } {
set result $requirement
if {[set index [string first - $result]] != -1} then {
incr index -1; set result [string range $result 0 $index]
}
if {[set index [string first a $result]] != -1 || \
[set index [string first b $result]] != -1} then {
incr index -1; set result [string range $result 0 $index]
}
if {$result eq "0"} then {
set result ""
} elseif {[regexp -- {^\d+$} $result]} then {
append result .0
}
return $result
}
#
# NOTE: This procedure issues an HTTP request that should return metadata
# that can be used to load and/or provide the specified package.
# The apiKeys argument is the list of API keys to use -OR- an empty
# list if a public package is being looked up. The package argument
# is the name of the package, it cannot be an empty string. The
# version argument is the specific version being looked up -OR- an
# empty string for any available version. This procedure may raise
# script errors. All line-endings are normalized to Unix-style;
# therefore, all script signatures must assume this.
#
proc getLookupData { apiKeys package version } {
variable verboseUriDownload
set uri [getLookupUri $apiKeys $package $version]
if {[string length $uri] == 0} then {
return ""
}
if {$verboseUriDownload} then {
pkgLog [appendArgs \
"attempting to download URI \"" $uri \"...]
}
if {[isEagle]} then {
set data [uri download -inline $uri]
} else {
set data [getFileViaHttp \
$uri 20 stdout [expr {!$verboseUriDownload}] -binary true]
}
if {$verboseUriDownload} then {
pkgLog [appendArgs \
"raw response data is: " $data]
}
set data [string map [list <\; < >\; > "\; \" &\; &] $data]
set data [string map [list \r\n \n \r \n] $data]
set data [string trim $data]
return $data
}
#
# NOTE: This procedure attempts to extract the lookup code from the raw
# HTTP response data. The data argument is the raw HTTP response
# data. An empty string is returned if no lookup code is available.
#
proc getLookupCodeFromData { data } {
if {![stringIsList $data] || [llength $data] < 1} then {
return ""
}
return [lindex $data 0]
}
#
# NOTE: This procedure attempts to extract the lookup result from the raw
# HTTP response data. The data argument is the raw HTTP response
# data. An empty string is returned if no lookup result is available.
#
proc getLookupResultFromData { data } {
if {![stringIsList $data] || [llength $data] < 2} then {
return ""
}
return [lindex $data 1]
}
#
# NOTE: This procedure returns non-zero if the specified lookup response
# code indicates success. The code argument is the extracted HTTP
# lookup response code.
#
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"}]
}
#
# NOTE: This procedure was stolen from the "common.tcl" script used by the
# package repository server. It has been modified to support both
# native Tcl and Eagle. It should be noted here that TIP #268 syntax
# is not supported by Eagle. For native Tcl, the requirement argument
# must be a package version or requirement conforming to the TIP #268
# syntax. For Eagle, the requirement argument must be a simple dotted
# package version, with up to four components, without any 'a' or 'b'.
# The emptyOk argument should be non-zero if an empty string should be
# considered to be valid by the caller. The rangeOk argument should
# be non-zero if the version range syntax is allowed; this argument is
# ignored for Eagle because it requires TIP #268 support.
#
proc isValidPackageRequirement { requirement rangeOk {emptyOk false} } {
if {$emptyOk && [string length $requirement] == 0} then {
return true
}
if {[isEagle]} then {
#
# NOTE: Eagle does not support TIP #268. Use the built-in sub-command
# that checks a version number.
#
return [string is version -strict $requirement]
} else {
#
# HACK: If a version range is not allowed, make sure that the dash
# character is not present.
#
if {!$rangeOk && [string first - $requirement] != -1} then {
return false
}
#
# HACK: There is no direct way to check if a package requirement
# that uses the TIP #268 syntax is valid; however, we can
# purposely "misuse" the [package present] command for this
# purpose. We know the "Tcl" package is always present;
# therefore, if an error is raised here, then the package
# requirement is probably invalid. Unfortunately, the error
# message text has to be checked as well; otherwise, there
# is no way to verify version numbers that happen to be less
# than the running patch level of Tcl.
#
if {[catch {package present Tcl $requirement} error] == 0} then {
return true
} else {
#
# TODO: Maybe this will require updates in the future?
#
set pattern(1) "expected version number but got *"
set pattern(2) "expected versionMin-versionMax but got *"
if {![string match $pattern(1) $error] && \
![string match $pattern(2) $error]} then {
return true
} else {
return false
}
}
}
}
#
# NOTE: This procedure attempts to extract the package lookup metadata from
# the lookup result. The result argument is the lookup result. The
# varName argument is the name of an array variable, in the call frame
# of the immediate caller, that should receive the extracted package
# lookup metadata. The caller argument must be an empty string -OR-
# the literal string "handler".
#
proc extractAndVerifyLookupMetadata { result varName caller } {
variable strictUnknownLanguage
#
# NOTE: Grab the returned patch level. It cannot be an empty string
# and it must conform to the TIP #268 requirements for a single
# package version.
#
set patchLevel [getDictionaryValue $result PatchLevel]
if {[string length $patchLevel] == 0} then {
error "missing patch level"
}
if {![isValidPackageRequirement $patchLevel false]} then {
error "bad patch level"
}
#
# 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 script [getDictionaryValue $result Script]
if {[string length $script] == 0} then {
error "missing 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 lookup metadata, use their
# array variable name.
#
if {[string length $varName] > 0} then {
upvar 1 $varName metadata
set metadata(patchLevel) $patchLevel
set metadata(language) $language
set metadata(script) $script
set metadata(certificate) $certificate
}
}
#
# NOTE: This procedure, which may only be used from an Eagle script, checks
# if a native Tcl library is loaded and ready. If not, a script error
# is raised. There are no arguments.
#
proc tclMustBeReady {} {
#
# NOTE: This procedure is useless when running in native Tcl; therefore,
# forbid its use there.
#
if {![isEagle]} then {
error "already running in Tcl language"
}
#
# NOTE: This procedure is not allowed to actually load a native Tcl
# library; therefore, one must already be loaded.
#
if {![tcl ready]} then {
error "cannot use Tcl language, supporting library is not loaded"
}
}
#
# NOTE: This procedure is designed for Eagle. It attempts to load the
# "best" native Tcl library. It may raise any number of script
# errors. There are no arguments.
#
proc makeTclReady {} {
#
# NOTE: This procedure is useless when running in native Tcl; therefore,
# forbid its use there.
#
if {![isEagle]} then {
error "already running in Tcl language"
}
#
# NOTE: Load a native Tcl library. It absolutely must be signed with a
# valid Authenticode signature.
#
tcl load -findflags +TrustedOnly -loadflags +SetDllDirectory
#
# NOTE: Verify that the native Tcl library appears to have beed loaded
# into this interpreter.
#
tclMustBeReady
}
#
# NOTE: This procedure, which may only be used from a native Tcl script,
# checks if Garuda and Eagle are loaded and ready. If not, a script
# error is raised. There are no arguments.
#
proc eagleMustBeReady {} {
#
# NOTE: This procedure is useless when running in Eagle; therefore,
# forbid its use there.
#
if {[isEagle]} then {
error "already running in Eagle language"
}
#
# NOTE: This procedure is not allowed to actually load Garuda (and
# Eagle); therefore, they must already be loaded.
#
if {[llength [info commands eagle]] == 0} then {
error "cannot use Eagle language, supporting package is not loaded"
}
}
#
# NOTE: This procedure is designed for native Tcl. It attempts to load
# the Garuda package and gain access to Eagle. It may raise any
# number of script errors. There are no arguments.
#
proc makeEagleReady {} {
#
# NOTE: This procedure is useless when running in Eagle; therefore,
# forbid its use there.
#
if {[isEagle]} then {
error "already running in Eagle language"
}
#
# TODO: Assume the Garuda package is trusted? How can we verify it
# at this point?
#
package require Garuda
#
# NOTE: Verify that the Garuda package appears to have been fully and
# successfully loaded into this interpreter.
#
eagleMustBeReady
}
#
# NOTE: This procedure returns non-zero if the current script is being
# evaluated in Eagle with signed-only script security enabled.
# There are no arguments.
#
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
}
#
# NOTE: This procedure uses the package lookup metadata. If the package
# script is properly signed, an attempt will be made to evaluate it
# in the target language. If the script was signed using OpenPGP,
# then a conforming implementation of the OpenPGP specification (e.g.
# gpg2) must be installed locally. If the script was signed using
# Harpy then Garuda, Eagle, and Harpy must be installed locally.
# This procedure is designed to work for both native Tcl and Eagle
# packages. Additionally, it is designed to work when evaluated
# using either native Tcl or Eagle; however, it is up to the package
# script itself to either add the package or provide the package to
# the language(s) supported by that package. The varName argument
# is the name of an array variable in the call frame of the
# immediate caller, that contains the package lookup metadata. This
# procedure may raise script errors.
#
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 patch level for the package is mising, fail.
#
if {![info exists metadata(patchLevel)]} then {
error "missing patch level"
}
#
# 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(script)]} then {
error "missing 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)] && [file isfile $fileName(2)]} then {
if {![info exists ::env(pkgr_keep_files)]} then {
catch {file delete $fileName(2)}
}
unset -nocomplain fileName(2)
}
if {[string length $fileName(1)] > 0 && \
[file exists $fileName(1)] && [file isfile $fileName(1)]} then {
if {![info exists ::env(pkgr_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_ [getUniqueSuffix 2]]
set newVarName(2) [appendArgs \
[getLookupVarNamePrefix] cleanup_ [getUniqueSuffix 2]]
set newProcName(1) [appendArgs \
[getLookupVarNamePrefix] eagleHasSecurity_ [getUniqueSuffix 2]]
set newProcName(2) [appendArgs \
[getLookupVarNamePrefix] getFileTempName_ [getUniqueSuffix 2]]
set newProcName(3) [appendArgs \
[getLookupVarNamePrefix] tclMustBeReady_ [getUniqueSuffix 2]]
#
# 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 script, there is nothing we
# can do here.
#
if {[string length ${%metadata%(script)}] > 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%(script)}
#
# 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 {[isOpenPgpSignature $metadata(certificate)]} then {
#
# NOTE: If there is no package script, there is nothing we
# can do here.
#
if {[string length $metadata(script)] > 0} then {
#
# NOTE: Figure out temporary file name for the downloaded script
# and its associated OpenPGP signature.
#
set fileName(1) [getFileTempName]
set fileName(2) [appendArgs $fileName(1) .asc]
#
# NOTE: Write downloaded script to a temporary file.
#
writeFile $fileName(1) $metadata(script)
#
# NOTE: Write downloaded script OpenPGP signature a temporary file.
#
if {[string length $metadata(certificate)] > 0} then {
writeFile $fileName(2) $metadata(certificate)
}
#
# NOTE: Attempt to verify the OpenPGP signature for the package
# script.
#
if {[verifyOpenPgpSignature $fileName(2)]} then {
#
# NOTE: Delete the temporary files that we created for the
# OpenPGP signature verification.
#
eval $script(cleanup)
} else {
#
# NOTE: Delete the temporary files that we created for the
# OpenPGP signature verification.
#
eval $script(cleanup)
#
# NOTE: OpenPGP signature verification failed. Raise an error
# and do not proceed with evaluating the package script.
#
error "bad OpenPGP signature"
}
#
# NOTE: The OpenPGP signature was verified; use the downloaded
# package script verbatim.
#
set script(inner) $metadata(script)
#
# 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"
}
}
#
# NOTE: This procedure returns non-zero if the specified package appears to
# be present. The package argument is the name of the package being
# sought, it cannot be an empty string. The version argument must be
# a specific version -OR- a package specification that conforms to TIP
# #268.
#
proc isPackagePresent { package version } {
variable verboseUnknownResult
set command [list package present $package]
if {[string length $version] > 0} then {lappend command $version}
if {[set code [catch $command result]] == 0} then {
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"package \"" [formatPackageName $package $version] \
"\" was loaded: " [formatResult $code $result]]
}
return true
} else {
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"package \"" [formatPackageName $package $version] \
"\" was not loaded: " [formatResult $code $result]]
}
return false
}
}
#
# NOTE: This procedure returns non-zero if the specified package appears to
# be available. The package argument is the name of the package being
# sought, it cannot be an empty string. The version argument must be
# a specific version -OR- a package specification that conforms to TIP
# #268.
#
proc isPackageAvailable { package version } {
variable verboseUnknownResult
set packageVersions [package versions $package]
if {[llength $packageVersions] == 0} then {
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"package \"" [formatPackageName $package $version] \
"\" is not available: no versions"]
}
return false
}
if {[string length $version] == 0} then {
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"package \"" [formatPackageName $package $version] \
"\" is available: no version"]
}
return true
}
foreach packageVersion $packageVersions {
if {[package vsatisfies $packageVersion $version]} then {
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"package \"" [formatPackageName $package $version] \
"\" is available: version satisfied by \"" \
[formatPackageName $package $packageVersion] \"]
}
return true
}
}
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"package \"" [formatPackageName $package $version] \
"\" is not available: version not satisfied"]
}
return false
}
#
# NOTE: This procedure returns non-zero if the specified package can be
# downloaded, i.e. because it is not required for the downloading
# process itself to be functional, etc. The package argument is
# the name of the package to check.
#
proc canDownloadPackage { package } {
#
# NOTE: Since all the functionality needed by this package is built-in
# to Eagle, there are no download restrictions when it is being
# used.
#
if {[isEagle]} then {
return true
}
#
# NOTE: Since the "http" and "tls" packages are required from within
# the custom [package unknown] itself, in order to locate and
# download the requested package, we must return false here to
# prevent needless recursion.
#
if {[lsearch -exact [list http tls] $package] != -1} then {
return false
}
#
# NOTE: Currently, all other packages, including Garuda, are legal to
# handle from the custom [package unknown] handler.
#
return true
}
#
# NOTE: This procedure performs initial setup of the package repository
# client, using the current configuration parameters. There are
# no arguments. It may load the Garuda package when evaluated in
# native Tcl. It may load a native Tcl library when evaluated in
# Eagle. It may install the [package unknown] hook.
#
proc setupPackageUnknownHandler {} {
variable autoApiKeys
variable autoHook
variable autoLoadTcl
variable autoRequireGaruda
#
# NOTE: Should we attempt to automatically load the Garuda package for
# native Tcl?
#
if {$autoRequireGaruda && ![isEagle] && [isWindows]} then {
makeEagleReady
}
#
# NOTE: Should we attempt to automatically load a native Tcl library
# for Eagle?
#
if {$autoLoadTcl && [isEagle]} then {
makeTclReady
}
#
# NOTE: Should we attempt to hook the [package unknown] handler. This
# is done for both native Tcl and Eagle.
#
if {$autoHook && ![isPackageUnknownHandlerHooked]} then {
#
# NOTE: Install our [package unknown] handler and save the original
# one for our use as well.
#
hookPackageUnknownHandler
}
}
#
# NOTE: This procedure returns non-zero if the [package unknown] handler
# has already been hooked by the package repository client. There
# are no arguments.
#
proc isPackageUnknownHandlerHooked {} {
return [info exists [appendArgs \
[getLookupVarNamePrefix] saved_package_unknown]]
}
#
# NOTE: This procedure attempts to hook the [package unknown] handler. It
# will raise a script error if this has already been done. The old
# [package unknown] handler is saved and will be used by the new one
# as part of the overall package loading process. There are no
# arguments.
#
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]
}
#
# NOTE: This procedure attempts to unhook the [package unknown] handler.
# It will raise a script error if the [package unknown] handler is
# not hooked. The old [package unknown] handler is restored and
# the saved [package unknown] handler is cleared. There are no
# arguments.
#
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
}
#
# NOTE: The procedure runs the saved [package unknown] handler. Any script
# errors are raised to the caller. The package and version arguments
# are passed in from the current [package unknown] handler verbatim.
#
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 procedure is the [package unknown] handler entry point called
# by native Tcl and Eagle. The package argument is the name of the
# package being sought, it cannot be an empty string. The version
# argument must be a specific version -OR- a package specification
# that conforms to TIP #268. This version argument must be optional
# here, because Eagle does not add a version argument when one is
# not explicitly supplied to the [package require] sub-command.
#
proc packageUnknownHandler { package {version ""} } {
variable verboseUnknownResult
#
# NOTE: First, run the saved [package unknown] handler.
#
set code(1) [catch {
runSavedPackageUnknownHandler $package $version
} result(1)]
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"initial saved handler results for package \"" \
[formatPackageName $package $version] "\" are " \
[formatResult $code(1) $result(1)]]
}
#
# NOTE: Did the saved [package unknown] handler succeed?
#
if {$code(1) == 0} then {
#
# NOTE: Is the package now available -OR- somehow already present?
#
if {[isPackagePresent $package $version] || \
[isPackageAvailable $package $version]} then {
#
# NOTE: Skip using the package repository.
#
return
}
}
#
# NOTE: Next, run our special [package unknown] handler.
#
if {[canDownloadPackage $package]} then {
set code(2) [catch {
getPackageFromRepository $package $version handler
} result(2)]
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"repository handler results for package \"" \
[formatPackageName $package $version] "\" are " \
[formatResult $code(2) $result(2)]]
}
}
#
# NOTE: Next, run the saved [package unknown] handler.
#
set code(3) [catch {
runSavedPackageUnknownHandler $package $version
} result(3)]
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"subsequent saved handler results for package \"" \
[formatPackageName $package $version] "\" are " \
[formatResult $code(3) $result(3)]]
}
#
# NOTE: Maybe check for the package and then optionally log results.
#
if {$verboseUnknownResult} then {
set ifNeededVersion [getIfNeededVersion \
$package [packageRequirementToVersion $version]]
if {[string length $ifNeededVersion] > 0} then {
set command [list package ifneeded $package $ifNeededVersion]
if {[set code(4) [catch $command result(4)]] == 0 && \
[string length $result(4)] > 0} then {
pkgLog [appendArgs \
"package script for \"" [formatPackageName $package \
$ifNeededVersion] "\" was added: " [formatResult \
$code(4) $result(4)]]
} else {
pkgLog [appendArgs \
"package script for \"" [formatPackageName $package \
$ifNeededVersion] "\" was not added: " [formatResult \
$code(4) $result(4)]]
}
} else {
pkgLog [appendArgs \
"package script for \"" [formatPackageName $package \
$ifNeededVersion] "\" was not added"]
}
#
# NOTE: Check (and log) if the package is now present. The return
# value here is ignored.
#
isPackagePresent $package $version
}
}
#
# NOTE: This procedure evaluates the package repository client settings
# script file, if it exists. Any script errors raised are not
# masked. The script argument must be the fully qualified path
# and file name for the primary package repository client script
# file.
#
# <public>
proc maybeReadSettingsFile { script } {
global tcl_platform
if {[string length $script] == 0 || \
![file exists $script] || ![file isfile $script]} then {
return
}
set prefixes [list]
if {[info exists tcl_platform(user)]} then {
lappend prefixes $tcl_platform(user)
}
lappend prefixes ""
foreach prefix $prefixes {
if {[string length $prefix] > 0} then {
set prefix [appendArgs . $prefix]
}
set fileName [appendArgs \
[file rootname $script] .settings $prefix [file extension \
$script]]
if {[file exists $fileName] && [file isfile $fileName]} then {
uplevel 1 [list source $fileName]
}
}
}
#
# NOTE: This procedure sets up the default values for all configuration
# parameters used by the package repository client. There are no
# arguments.
#
proc setupPackageUnknownVars {} {
#
# 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 {![info exists forceSecureUri]} then {
set forceSecureUri 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 {![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 {![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: What is the default set of API keys if none were set explicitly?
# This list is subject to change at any time -AND- may be empty or
# may contain non-working API keys, please do not rely on it.
#
variable autoApiKeys; # DEFAULT: 0000000000000000000000000000000000000000
if {![info exists autoApiKeys]} then {
set autoApiKeys [list 0000000000000000000000000000000000000000]
}
#
# 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: <automatic>
if {![info exists autoLoadTcl]} then {
#
# TODO: Better automatic detection of native Tcl installs here?
#
if {[isEagle] && \
[catch {tcl select -architecture}] == 0} then {
set autoLoadTcl true
} else {
set autoLoadTcl false
}
}
#
# NOTE: Automatically [package require Garuda] when this package is
# loaded from the Tcl language?
#
variable autoRequireGaruda; # DEFAULT: <automatic>
if {![info exists autoRequireGaruda]} then {
#
# TODO: Better automatic detection of Garuda here?
#
if {![isEagle] && \
[llength [package versions Garuda]] > 0} then {
set autoRequireGaruda true
} else {
set autoRequireGaruda false
}
}
#
# NOTE: The command to use when verifying OpenPGP signatures for the
# downloaded package scripts.
#
variable openPgpCommand; # DEFAULT: gpg2 --verify {${fileName}}
if {![info exists openPgpCommand]} then {
set openPgpCommand {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
}
#
# NOTE: Emit diagnostic messages when a [package unknown] handler
# is called?
#
variable verboseUnknownResult; # DEFAULT: false
if {![info exists verboseUnknownResult]} then {
set verboseUnknownResult false
}
#
# NOTE: Emit diagnostic messages when a URI is fetched?
#
variable verboseUriDownload; # DEFAULT: false
if {![info exists verboseUriDownload]} then {
set verboseUriDownload false
}
}
#
# NOTE: This procedure is the primary entry point to the package repository
# client. It attempts to lookup the specified package using the
# currently configured package repository server. The package
# argument is the name of the package being sought, it cannot be an
# empty string. The version argument must be a specific version -OR-
# a package specification that conforms to TIP #268. The caller
# argument must be an empty string -OR- the literal string "handler".
#
# <public>
proc getPackageFromRepository { package version caller } {
#
# NOTE: Get the list of API keys and try each one, in order, until
# the package is found.
#
set apiKeys [getApiKeys]
#
# NOTE: Issue the non-anonymous lookup request to the remote
# package repository.
#
set data [getLookupData $apiKeys $package $version]
#
# NOTE: Attempt to grab the lookup code from the non-anonymous
# response data.
#
set code [getLookupCodeFromData $data]
#
# NOTE: If necessary, fallback with to an anonymous request.
#
if {![isLookupCodeOk $code]} then {
#
# NOTE: Issue the anonymous lookup request to the remote
# package repository.
#
set data [getLookupData [list] $package $version]
#
# NOTE: Attempt to grab the lookup code from the anonymous
# 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. 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.
#
proc pageOut { channel string } {
catch {
puts -nonewline $channel $string; flush $channel
}
}
#
# NOTE: This procedure was stolen from the "getEagle.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.
#
proc pageLog { string } {
catch {
tclLog [appendArgs [pid] " : " [clock seconds] " : http : " $string]
}
}
#
# NOTE: This procedure was stolen from the "getEagle.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: This variable is used to keep track of the currently scheduled
# (i.e. pending) [after] event.
#
variable afterForPageProgress
#
# NOTE: Show that something is happening...
#
pageOut $channel $type
#
# NOTE: Make sure that we are scheduled to run again, if requested.
#
if {$milliseconds > 0} then {
set afterForPageProgress [after $milliseconds \
[namespace code [list pageProgress $channel $type \
$milliseconds]]]
} else {
unset -nocomplain afterForPageProgress
}
}
#
# NOTE: This procedure was stolen from the "getEagle.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 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 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 keep track of the currently scheduled
# (i.e. pending) [after] event.
#
variable afterForPageProgress
#
# 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;
# otherwise, only attempt to use HTTP if explicitly allowed.
#
if {[catch {package require tls}] == 0} then {
::http::register https 443 [list ::tls::socket -tls1 true]
if {$forceSecureUri} then {
if {[string range $uri 0 6] eq "http://"} then {
set uri [appendArgs https:// [string range $uri 7 end]]
}
}
} else {
if {$allowInsecureUri} then {
if {[string range $uri 0 7] eq "https://"} then {
set uri [appendArgs http:// [string range $uri 8 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.
#
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 \"...]
}
set token [eval [list ::http::geturl $uri] $args]
#
# 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: 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?
#
if {$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.
#
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 range $uri 0 7] eq "https://" && \
[string range $location 0 7] ne "https://"} then {
#
# NOTE: Just "give up" and raise a script error.
#
::http::cleanup $token; error [appendArgs \
"refused insecure redirect from \"" $uri "\" to \"" \
$location \"]
}
#
# 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, 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.
#
if {[info exists afterForPageProgress]} then {
catch {after cancel $afterForPageProgress}
unset -nocomplain afterForPageProgress
}
#
# NOTE: If progress messages were emitted, start a fresh line.
#
if {!$quiet} then {
pageOut $channel [appendArgs " " $uri \n]
}
return $data
}
###########################################################################
############################## END Tcl ONLY ###############################
###########################################################################
}
#
# NOTE: This package requires that support for namespaces, which is an
# optional feature of Eagle, must be enabled.
#
if {[isEagle] && ![namespace enable]} then {
error "namespaces must be enabled for this package"
}
#
# NOTE: Attempt to read optional settings file now. This may override
# one or more of the variable setup in the next step.
#
maybeReadSettingsFile [info script]
#
# 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"}]
}