###############################################################################
#
# pkgr_upload.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Package Repository Client (Upload Tool)
#
# 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 ::PackageUploader {
#
# NOTE: This procedure is used to report errors that prevent this tool
# from running to completion (e.g. invalid command line arguments,
# etc). It may be used to report a specific error. It will always
# emit the command line usage information.
#
proc usage { {error ""} } {
if {[string length $error] > 0} then {puts stdout $error}
puts stdout "usage:\
[file tail [info nameofexecutable]]\
[file tail [info script]] \[apiKey\] \[name\] \[version\] \[language\]\
\[fileName1\] ... \[fileNameN\]"
exit 1
}
#
# NOTE: This procedure sets up the default values for all configuration
# parameters used by the package uploader client. The script
# argument is the fully qualified path and file name for the script
# being evaluated.
#
proc setupUploadVars { script } {
#
# NOTE: What is the fully qualified path to the directory containing the
# checkout for the package client?
#
variable checkoutDirectory
if {![info exists checkoutDirectory]} then {
set checkoutDirectory [file dirname $script]
}
#
# NOTE: The command to use when attempting to stage package files using
# Fossil.
#
variable fossilAddCommand; # DEFAULT fossil add {${fileName}}
if {![info exists fossilAddCommand]} then {
set fossilAddCommand {fossil add {${fileName}}}
}
#
# NOTE: The command to use when attempting to commit package files using
# Fossil.
#
variable fossilCommitCommand; # DEFAULT fossil commit ...
if {![info exists fossilCommitCommand]} then {
set fossilCommitCommand {fossil commit -m {${comment}}\
--branch {${branch}} --user anonymous --chdir \
{${checkoutDirectory}} --no-prompt}
}
#
# NOTE: The regular expression pattern used when attempting to verify
# that Fossil committed a set of files.
#
variable fossilCommitPattern; # DEFAULT: {^New_Version: ([0-9a-f]{40})$}
if {![info exists fossilCommitPattern]} then {
set fossilCommitPattern {^New_Version: ([0-9a-f]{40})$}
}
#
# NOTE: Emit diagnostic messages when a new package is submitted?
#
variable verboseMetadataSubmit; # DEFAULT: false
if {![info exists verboseMetadataSubmit]} then {
set verboseMetadataSubmit false
}
}
#
# NOTE: This procedure returns a string value, formatted for use within a
# script block being processed by the [string map] command. The
# value argument is the string value to format. No return value is
# reserved to indicate an error. This procedure may not raise any
# script errors.
#
proc formatStringMapValue { value } {
if {[string length $value] == 0} then {
return \"\"
}
set list [list $value]
if {$value eq $list} then {
return $value
} else {
return $list
}
}
#
# NOTE: This procedure counts the common path components for two paths. The
# count is returned, zero if there are no common path components. The
# path1 and path2 arguments are the paths to compare. This procedure
# may not raise script errors.
#
proc countCommonPathParts { path1 path2 } {
set parts1 [file split $path1]
set length1 [llength $parts1]
set parts2 [file split $path2]
set length2 [llength $parts2]
set length [expr {min($length1, $length2)}]
for {set index 0} {$index < $length} {incr index} {
set part1 [lindex $parts1 $index]
set part2 [lindex $parts2 $index]
if {$part1 ne $part2} then {
return $index
}
}
return $length
}
#
# NOTE: This procedure processes a list of (fully?) qualified file names and
# tries to determine their common containing directory, if any. The
# fileNames argument is the list of (fully?) qualified file names to
# process. This procedure may not raise script errors. If there is
# no common containing directory, an empty string is returned.
#
proc getCommonContainingDirectory { fileNames } {
set length [llength $fileNames]
if {$length == 0} then {
return ""
}
set oldFileName [lindex $fileNames 0]
if {$length == 1} then {
return [file dirname $oldFileName]
}
set minimumCount 0
for {set index 1} {$index < $length} {incr index} {
set newFileName [lindex $fileNames $index]
set newCount [countCommonPathParts $oldFileName $newFileName]
if {$newCount == 0} then {
return ""
}
if {$minimumCount == 0 || $newCount < $minimumCount} then {
set oldFileName $newFileName
set minimumCount $newCount
}
}
if {$minimumCount == 0} then {
return ""
}
incr minimumCount -1
return [eval file join [lrange [file split $oldFileName] 0 $minimumCount]]
}
#
# NOTE: This procedure attempts to process a list of (fully?) qualified file
# names and return the corresponding list of relative file names. The
# fileNames argument is the list of (fully?) qualified file names to
# process. The maximumLevels argument is the maximum path depth that
# is allowed for all file names. This procedure may raise script
# errors.
#
proc getRelativeFileNames { fileNames maximumLevels } {
set directory [getCommonContainingDirectory $fileNames]
set directoryParts [file split $directory]
set fileNameIndex [expr {[llength $directoryParts] - 1}]
if {$fileNameIndex < 0} then {
error [appendArgs \
"invalid containing directory \"" $directory \
"\": cannot go up one level"]
}
set relativeFileNames [list]
foreach fileName $fileNames {
set fileNameParts [lrange \
[file split $fileName] $fileNameIndex end]
if {$maximumLevels > 0 && \
[llength $fileNameParts] > $maximumLevels} then {
error [appendArgs \
"depth for file name \"" $fileName \
"\" exceeds maximum (" $maximumLevels )]
}
set relativeFileName [eval file join $fileNameParts]
if {[string length $relativeFileName] == 0 || \
[file pathtype $relativeFileName] ne "relative"} then {
error [appendArgs \
"bad file name \"" $relativeFileName "\", not relative"]
}
lappend relativeFileNames $relativeFileName
}
return $relativeFileNames
}
#
# NOTE: This procedure attempts to create a script chunk that appends the
# specified list of file names to a list variable. The fileNames
# argument is the list of (fully?) qualified file names to append to
# the list variable. The maximumLevels argument is the maximum path
# depth that is allowed for all file names. This procedure may raise
# script errors.
#
proc getScriptChunkForFileNames { fileNames maximumLevels } {
set result ""
set relativeFileNames [getRelativeFileNames $fileNames $maximumLevels]
foreach relativeFileName $relativeFileNames {
if {[string length $result] > 0} then {
append result \n
}
append result { lappend fileNames [file join }
append result [file split $relativeFileName]
append result \]
}
return $result
}
#
# NOTE: This procedure creates and returns a script block designed for use
# with the package repository server in order to download and provide
# a package consisting of a set of files. The serverId argument is
# the identifier for the specific server to use, if any. The
# versionId argument is the identifier for the specific version to use,
# if any. The language argument must be the literal string "eagle" or
# the literal string "tcl". The version argument must be one of the
# literal strings "8.4", "8.5", or "8.6" when the language is "tcl"
# -OR- the literal string "1.0" when the language is "eagle". The
# platform argument must be an empty string -OR- one of the literal
# strings "neutral", "win32-arm", "win32-x86", "win64-arm64",
# "win64-ia64", or "win64-x64". The fileNames argument is the list of
# (fully?) qualified file names to be downloaded when the associated
# package is being provided. The options argument is reserved for
# future use, it should be an empty list.
#
# <public>
proc createRepositoryScript {
serverId versionId language version platform fileNames options } {
::PackageDownloader::verifyServerId $serverId
::PackageDownloader::verifyVersionId $versionId
::PackageDownloader::verifyLanguageAndVersion $language $version isClient
set prologue ""
if {[string length $serverId] > 0} then {
append prologue " ::PackageDownloader::useServerId " $serverId \n
}
if {[string length $versionId] > 0} then {
append prologue " ::PackageDownloader::useVersionId " $versionId \n
}
append prologue " "
return [string trim [string map [list \r\n \n \
%language% [formatStringMapValue $language] \
%version% [formatStringMapValue $version] \
%platform% [formatStringMapValue $platform] \
%prologue% $prologue %ns% ::PackageDownloader \
%backslash% \\ %fileNames% \
[getScriptChunkForFileNames $fileNames 2]] {
apply [list [list] {
package require Eagle.Package.Downloader
%prologue%%ns%::resetCookieAndLoginSimple
set fileNames [list]
%fileNames%
set options [list %backslash%
-persistent false -usePgp true -useAutoPath true]
%ns%::downloadFiles %language% %version% %platform% $fileNames $options
%ns%::logoutAndResetCookie
}]
}]]
}
#
# NOTE: This procedure creates textual data that conforms to the content
# type "multipart/form-data", per RFC 2388. The boundary argument
# is a boundary value, as specified in section 4.1 of the RFC. The
# request argument is the dictionary of name/value pairs to include
# in the form body. This procedure may not raise script errors.
#
proc createMultipartFormData { boundary request } {
set result ""
foreach {name value} $request {
append result -- $boundary \r\n
append result "Content-Disposition: form-data; name=\""
append result $name \"\r\n\r\n
append result $value \r\n
}
if {[string length $result] > 0} then {
append result -- $boundary --\r\n
}
if {[isEagle]} then {
return [object create -alias String $result]
} else {
return $result
}
}
#
# NOTE: This procedure returns the full URI to use when submitting a new
# package to the package repository server. There are no arguments.
# This procedure may raise script errors.
#
proc getSubmitUri {} {
#
# NOTE: Fetch the base URI for the package repository server. If it
# is not available for some reason, just return an empty string
# to the caller (i.e. as we cannot do anything productive).
#
set baseUri [::PackageRepository::getLookupBaseUri]
if {[string length $baseUri] == 0} then {
return ""
}
#
# NOTE: Build the HTTP request URI and include the standard query
# parameters (with constant values) for this request type.
#
if {[isEagle]} then {
return [appendArgs \
$baseUri ?raw=1&method=submit]
} else {
package require http 2.0
return [appendArgs \
$baseUri ? [::http::formatQuery raw 1 method submit]]
}
}
#
# NOTE: This procedure attempts to submit the metadata for a new package to
# the package repository server. Upon success, an empty string will
# be returned. Upon failure, a script error will be raised. The
# apiKey argument is the list of API keys to use. The package argument
# is the name of the package. The patchLevel argument is the specific
# patch level being submitted. The language argument must be an empty
# string, "Tcl", or "Eagle". If it is an empty string, the current
# language will be assumed. The script argument is the script to be
# evaluated when the package needs to be provided. The certificate
# argument is the certificate associated with the script, which may be
# an OpenPGP signature or a Harpy script certificate.
#
# <public>
proc submitPackageMetadata {
apiKey package patchLevel language script certificate } {
variable verboseMetadataSubmit
#
# NOTE: Fetch the submission URI for the package repository server. If
# it is not available for some reason, raise a script error.
#
set uri [getSubmitUri]
if {[string length $uri] == 0} then {
error ""
}
if {[string length $language] == 0} then {
set language [expr {[isEagle] ? "Eagle" : "Tcl"}]
}
if {[isEagle]} then {
set boundary [string map \
[list + "" / "" = ""] [base64 encode [expr {randstr(50)}]]]
} else {
set boundary [::PackageRepository::getUniqueSuffix]
}
set contentType [appendArgs \
"multipart/form-data; boundary=" $boundary]
set formData [createMultipartFormData $boundary \
[list apiKey $apiKey package $package patchLevel \
$patchLevel language $language script $script \
certificate $certificate]]
if {[isEagle]} then {
if {![object invoke Eagle._Tests.Default \
TestHasScriptNewWebClientCallback ""]} then {
set error null
set code [object invoke Eagle._Tests.Default \
TestSetScriptNewWebClientCallback "" true true error]
if {$code ne "Ok"} then {
error [getStringFromObjectHandle $error]
}
}
set script [object create String {
if {[methodName ToString] eq "GetWebRequest"} then {
webRequest ContentType $contentType
}
}]
return [uri upload \
-inline -raw -encoding identity -webclientdata \
$script -data $formData $uri]
} else {
set options [list \
-binary true -type $contentType -query $formData]
return [eval ::PackageRepository::getFileViaHttp \
[list $uri] [list 20] [list stdout] [list \
[expr {!$verboseMetadataSubmit}]] $options]
}
}
#
# NOTE: This procedure attempts to stage the specified package files using
# Fossil. The fileNames argument is a list of (fully?) qualified
# local file names to stage.
#
# <public>
proc stagePackageFiles { language version platform fileNames } {
variable checkoutDirectory
variable fossilAddCommand
set relativeFileNames [getRelativeFileNames $fileNames]
set savedPwd [pwd]; cd $checkoutDirectory
foreach fileName $fileNames relativeFileName $relativeFileNames {
file mkdir [file join \
$language $version $platform [file dirname $relativeFileName]]
file copy $fileName $relativeFileName
set fileName $relativeFileName
if {[isEagle]} then {
set fileName [::PackageRepository::formatExecArgument $fileName]
if {[catch {
eval exec -success Success [subst $fossilAddCommand]
} error]} then {
cd $savedPwd
error [appendArgs \
"failed to stage file \"" $fileName "\": " $error]
}
} else {
if {[catch {
eval exec [subst $fossilAddCommand]
} error]} then {
cd $savedPwd
error [appendArgs \
"failed to stage file \"" $fileName "\": " $error]
}
}
}
cd $savedPwd
}
#
# NOTE: This procedure attempts to commit the staged package files to the
# remote package file repository using Fossil. The varName argument
# is the name of a scalar variable in the context of the immediate
# caller that will receive the resulting Fossil check-in identifier.
#
# <public>
proc commitPackageFiles { varName } {
variable checkoutDirectory
variable fossilCommitCommand
variable fossilCommitPattern
set branch ""; # TODO: Figure out a good branch.
set comment ""; # TODO: Figure out a good comment.
if {[isEagle]} then {
if {[catch {
eval exec -nocarriagereturns -stdout output -stderr error \
[subst $fossilCommitCommand]
} result] == 0} then {
set result [appendArgs $output $error]
} else {
return false
}
} else {
if {[catch {
eval exec [subst $fossilCommitCommand]
} result]} then {
return false
}
}
if {[string length $varName] > 0} then {
upvar 1 $varName checkin
}
if {![info exists result] || \
![regexp -line -- $fossilCommitPattern $result dummy checkin]} then {
return false
}
return true
}
#
# NOTE: Figure out the fully qualified path to the current script file.
# If necessary, add it to the auto-path for the interpreter. The
# necessary supporting packages (i.e. the Package Repository and
# other support packages) that are assumed to exist in the same
# directory as the current script file.
#
variable pkgr_path; # DEFAULT: <unset>
if {![info exists pkgr_path]} then {
set pkgr_path [file normalize [file dirname [info script]]]
if {![info exists ::auto_path] || \
[lsearch -exact $::auto_path $pkgr_path] == -1} then {
lappend ::auto_path $pkgr_path
}
}
#
# NOTE: *TODO* Pre-create the namespace for the Package Repository Client
# package and then forcibly adjust various settings to the values
# necessary for this tool. In the future, this section may need to
# be tweaked to account for changes to the Package Repository Client
# package.
#
namespace eval ::PackageRepository {
variable verboseUriDownload true
variable autoRequireGaruda false
variable autoLoadTcl false
variable autoHook false
}
#
# NOTE: This package requires both the package repository and downloader
# client packages.
#
package require Eagle.Package.Downloader
#
# 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.
#
::PackageRepository::maybeReadSettingsFile [info script]
#
# NOTE: Setup the variables, within this namespace, used by this script.
#
setupUploadVars [info script]
#
# NOTE: Provide the package to the interpreter.
#
package provide Eagle.Package.Uploader \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
#
# NOTE: Verify that the number of command line arguments meets the basic
# requirements of this tool.
#
if {[info exists ::argv] && [llength $::argv] >= 5} then {
#
# NOTE: All the necessary arguments were supplied on the command line,
# use batch mode.
#
} else {
#
# NOTE: One or more of the necessary arguments were not supplied on the
# command line, use interactive mode. This will create a graphical
# user interface, using Tk or WinForms. If any of the necessary
# arguments were supplied on the command line, they will be used to
# populate those fields on the graphical user interface.
#
if {[isEagle]} then {
} else {
}
}
}