ADDED client/pkgr.eagle Index: client/pkgr.eagle ================================================================== --- client/pkgr.eagle +++ client/pkgr.eagle @@ -0,0 +1,634 @@ +############################################################################### +# +# 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 1 $script(inner)] + } + Tcl { + # + # NOTE: The target language is Tcl; therefore, a bit of + # special handling is needed here. + # + {%tclMustBeReady%}; return [tcl eval \ + [tcl master] $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 } { + set data [getLookupData [getLookupApiKey] $package $version] + set code [getLookupCodeFromData $data] + set result [getLookupResultFromData $data] + + if {![isLookupCodeOk $code]} then { + error $result + } + + extractAndVerifyLookupMetadata $result metadata + 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 > 10} 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"}] +} + ADDED client/pkgr.eagle.harpy Index: client/pkgr.eagle.harpy ================================================================== --- client/pkgr.eagle.harpy +++ client/pkgr.eagle.harpy @@ -0,0 +1,50 @@ + + + + None + Mistachkin Systems + b69d609c-3b52-493c-87f8-d8b346636433 + SHA512 + Script + 2016-08-13T04:17:06.7998046Z + -1.00:00:00 + 0x2c322765603b5278 + + jXBpsUsOVA85vHjyXALN5e3JoJffjbhvyG4So3O/F6hBHoSsX2A2a62O0gWozfceicrVpYhpiDHP + E9nxJZMWLyKtfkj9Ftt2GX8DUsWLy1hCqidfjTFGJoAG8UKi323Gu6pzL8Cugk3fb4jYDBrO6dR7 + nDqYnsE9XO91jLUjBMwmxq3/sOM/aSOjaEDhiDA6W3+hqg8wP9SfHdKZM2qnah5Og5FMpptaCOVY + +TeqG38gFMtokEgd75jBOacc1EW/Dy40s733m/3P+mx2pux7xVjZTPrX3oLY/Ded+jg81VJp/ZRp + JIe5VTVLNvdyQZVy0vtP48l6UhZAKv1wQ3CVqSoRz3/nlcyj15BAMLCNB74MgLe2Hm/F3bbnpUsQ + VHAAmAK3nDgQMtU7oZS//J2S7w+9cFO8gI8OrpSUz/CkPmA1Nm3Ap4weo0QmE5hwlO8U5OGg9hBJ + YwpTUnq7BUcH8bwKW4435VjrswOO4WxjwMUf6XK+q8IhLrIS1o0h9ln2jMzyM2vLMJVLHQGnouuJ + MqZbYEZJXVIWt3OTTrFU8sOaYVCcl5jUluEkzPe/UHmXadujL2VVEbXdJS0eNlepcpNy672uMlZY + MJlN5RRo9IhJiASiz1H7VYGQJ3agY+o2qyFG0RM7DBKztP7iXCmemm3J+u+Akzd8WTrJw/eiw8+D + //asO6qLqHw+NWabCGkKJLJtD1umrbke2KGkpYL59uls6vNVNjd/FhAHCs1o5P2pidzi69jc4S89 + MFfltAvDuq5GycCoLnUlZaMyK2F48/blVL3kAAWGIEsvxFNM2taxwIsyKss+X4d0mCVHK4xO1uOl + Mueu/ma/xo8c0Vb70nQoc6LcqiElQkc0CV/Q64HRqCG5er51+ysXr7arW+1cPjQzB9ebWZNyF2tG + itclZMl1RYtcEnpzizWnAfOzc6phmBgG00sU9vIIoEnOOu8IajyyykWzgl3RWANP84ljbles+7f7 + CqfO0XoudPX7cvTUD081JMZ5z2Adm/ADXpM6COePE6zKUM7G7RNvcR89ZguL0zxnc4z8Awtq04tL + 5LW85btErQPX2lbj0I3vpVY+pCQElzJNPcHzARk4iymmS7jTlqLUJrm8I5vRt1DVJRL3ivvdD+Lg + 5dShVo1g37kxNNmgW6+ykesPpycKbNXyQXovGnMq+k03ocwj8Fu1vCX7AaQUsOQuciUkj2PyKE9s + bv3od/vqhgPk582U1pYF0VzWYU412zxnGoCp+hcY4ZC81YyvDPejUyMUJhMHeqy6Z3Ot5NbUkp9l + oAoblWlABjQtWrC7oJZWTwsxhegXkNmAnvk2cy3u/DxSBgnnjc7vMht4w9AXPiuzq0glHlMJeg== + +