###############################################################################
#
# 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]
} elseif {[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 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]
}
return ""; # NOTE: System default, which is "public".
}
proc getLookupBaseUri {} {
set varName [appendArgs [getLookupVarNamePrefix] base_uri]
if {[info exists $varName]} then {
return [set $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 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 {
set data [getFileViaHttp $uri 10 stdout false]
}
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 } {
#
# 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: If the caller wants the package metadata, use the array variable
# name they specified.
#
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: 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 [appendArgs \
[getLookupVarNamePrefix] metadata_ [getLookupVarNameSuffix]]
set newProcName(1) [appendArgs \
[getLookupVarNamePrefix] eagleHasSecurity_ [getLookupVarNameSuffix]]
set newProcName(2) [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 %eagleHasSecurity% $newProcName(1) \
%tclMustBeReady% $newProcName(2)] {
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) [file tempname]
set fileName(2) [appendArgs $fileName(1) .harpy]
try {
#
# NOTE: Write the downloaded script to a temporary file.
#
writeFile $fileName(1) ${%metadata%(ifNeeded)}
#
# NOTE: Write the downloaded script certificateto 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: Delete any temporary files that we created during the
# signed script evaluation.
#
if {[string length $fileName(2)] > 0 && \
[file exists $fileName(2)]} then {
catch {file delete $fileName(2)}
unset -nocomplain fileName(2)
}
if {[string length $fileName(1)] > 0 && \
[file exists $fileName(1)]} then {
catch {file delete $fileName(1)}
unset -nocomplain fileName(1)
}
}
} finally {
#
# NOTE: Restore the saved security state for the interpreter.
#
if {!$savedSecurity} then {source disableSecurity}
unset -nocomplain savedSecurity
}
}
} finally {
rename {%tclMustBeReady%} ""
rename {%eagleHasSecurity%} ""
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 [array get metadata]
proc $newProcName(1) {} [info body [appendArgs \
[namespace current] :: eagleHasSecurity]]
proc $newProcName(2) {} [info body [appendArgs \
[namespace current] :: tclMustBeReady]]
return [eval $script(outer)]
} else {
eagleMustBeReady
eagle [list array set $newVarName [array get metadata]]
eagle [list proc $newProcName(1) {} [info body [appendArgs \
[namespace current] :: eagleHasSecurity]]]
eagle [list proc $newProcName(2) {} [info body [appendArgs \
[namespace current] :: tclMustBeReady]]]
return [eagle $script(outer)]
}
}
proc main { package version } {
#
# NOTE: Issue the lookup request to the remote package repository.
#
set data [getLookupData [getLookupApiKey] $package $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
#
# 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: Provide the package to the interpreter.
#
package provide Eagle.Package.Repository \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}