###############################################################################
#
# pkgd.eagle --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Package Downloader 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 ::PackageDownloader {
#
# NOTE: This procedure sets up the default values for all configuration
# parameters used by the package downloader client. There are no
# arguments.
#
proc setupDownloadVars { script } {
#
# NOTE: What is the fully qualified path to the directory containing the
# package downloader client?
#
variable clientDirectory
if {![info exists clientDirectory]} then {
set clientDirectory [file dirname $script]
}
#
# NOTE: This is the HTTP(S) login cookie to use when downloading files
# from the package file server.
#
variable loginCookie; # DEFAULT: NONE
if {![info exists loginCookie]} then {
set loginCookie [list]
}
#
# NOTE: Prevent progress messages from being displayed while downloading
# from the repository, etc? By default, this is enabled.
#
variable quiet; # DEFAULT: true
if {![info exists quiet]} then {
set quiet true
}
#
# NOTE: The base URI used to build the URIs for the package file server.
#
variable baseUri; # DEFAULT: https://urn.to/r
if {![info exists baseUri]} then {
set baseUri https://urn.to/r
}
#
# NOTE: The URI where a login request may be sent. This should return a
# payload containing the necessary HTTP(S) cookie information.
#
variable loginUri; # DEFAULT: ${baseUri}/pkgd_login?...
if {![info exists loginUri]} then {
set loginUri [string trim {
${baseUri}/pkgd_login?name=${userName}&password=${password}
}]
}
#
# NOTE: The URI where a single package file may be found. This file will
# belong to a specific version of one package.
#
variable downloadUri; # DEFAULT: ${baseUri}/pkgd_file?...
if {![info exists downloadUri]} then {
set downloadUri [string trim {
${baseUri}/pkgd_file?download&ci=trunk&filename=${fileName}
}]
}
#
# NOTE: The root directory where any persistent packages will be saved.
#
variable persistentRootDirectory; # DEFAULT: [getPersistentRootDirectory]
if {![info exists persistentRootDirectory]} then {
set persistentRootDirectory [getPersistentRootDirectory]
}
#
# NOTE: The root directory where any temporary packages will be written.
#
variable temporaryRootDirectory; # DEFAULT: [getFileTempDirectory PKGD_TEMP]
if {![info exists temporaryRootDirectory]} then {
set temporaryRootDirectory \
[::PackageRepository::getFileTempDirectory PKGD_TEMP]
}
}
#
# NOTE: This procedure returns the root directory where any packages that
# are downloaded should be saved to permanent storage for subsequent
# use. There are no arguments.
#
proc getPersistentRootDirectory {} {
#
# NOTE: Return a directory parallel to the one containing the library
# directory.
#
return [file join [file dirname [info library]] pkgd]
}
#
# NOTE: This procedure returns non-zero if the specified file seems to be
# an OpenPGP signature file. The fileName argument is the name of
# the file to check, which may or may not exist. The nameOnly
# argument should be non-zero to ignore the contents of the file.
#
proc isPgpSignatureFileName { fileName nameOnly } {
if {[string length $fileName] == 0} then {
return false
}
set extension [file extension $fileName]
if {$extension eq ".asc"} then {
if {!$nameOnly && [file exists $fileName]} then {
return [::PackageRepository::isPgpSignature [readFile $fileName]]
} else {
return true
}
} else {
return false
}
}
#
# NOTE: This procedure returns non-zero if the specified file seems to be
# a Harpy script certificate file. The fileName argument is the name
# of the file to check, which may or may not exist. The nameOnly
# argument should be non-zero to ignore the contents of the file.
#
# <notUsed>
proc isHarpyCertificateFileName { fileName nameOnly } {
if {[string length $fileName] == 0} then {
return false
}
set extension [file extension $fileName]
if {$extension eq ".harpy"} then {
if {!$nameOnly && [file exists $fileName]} then {
return [::PackageRepository::isHarpyCertificate [readFile $fileName]]
} else {
return true
}
} else {
return false
}
}
#
# NOTE: This procedure adds a directory to the auto-path of the specified
# language (i.e. native Tcl or Eagle). The directory will not be
# added if it is already present. The language argument must be the
# literal string "eagle" or the literal string "tcl". The directory
# argument is the fully qualified path for the directory to add to
# the auto-path.
#
# <public>
proc addToAutoPath { language directory } {
#
# NOTE: Add the specified directory to the auto-path if not already
# present.
#
if {[string length $language] == 0 || $language eq "eagle"} then {
if {[isEagle]} then {
if {![info exists ::auto_path] || \
[lsearch -exact $::auto_path $directory] == -1} then {
lappend ::auto_path $directory
}
} else {
::PackageRepository::eagleMustBeReady
eagle [string map [list %directory% $directory] {
if {![info exists ::auto_path] || \
[lsearch -exact $::auto_path {%directory%}] == -1} then {
lappend ::auto_path {%directory%}
}
}]
}
} elseif {$language eq "tcl"} then {
if {[isEagle]} then {
tcl eval [tcl master] [string map [list %directory% $directory] {
if {![info exists ::auto_path] || \
[lsearch -exact $::auto_path {%directory%}] == -1} then {
lappend ::auto_path {%directory%}
}
}]
} else {
if {![info exists ::auto_path] || \
[lsearch -exact $::auto_path $directory] == -1} then {
lappend ::auto_path $directory
}
}
} else {
error "unsupported language, no idea how to modify auto-path"
}
}
#
# NOTE: This procedure verifies the combination of language and version
# specified by the caller. The language argument must be one of the
# literal strings "eagle", "tcl", or "client". 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 either "eagle" or "client". The varName argument is the name
# of a scalar variable in the context of the immediate caller that
# will receive a boolean value indicating if the specified language
# is actually a reference to the package downloader client itself.
#
proc verifyLanguageAndVersion { language version varName } {
if {[string length $varName] > 0} then {
upvar 1 $varName isClient
}
set isClient false
if {[string length $language] == 0 || $language eq "eagle"} then {
if {$version ne "1.0"} then {
error "unsupported Eagle version"
}
} elseif {$language eq "tcl"} then {
if {$version ne "8.4" && $version ne "8.5" && $version ne "8.6"} then {
error "unsupported Tcl version"
}
} elseif {$language eq "client"} then {
if {$version ne "1.0"} then {
error "unsupported client version"
}
set isClient true
} else {
error "unsupported language"
}
}
#
# NOTE: This procedure issues a request to an HTTP(S) server. It returns
# the raw response data verbatim. It may raise a script error. It
# will always use the currently configured HTTP(S) login cookie, if
# any; therefore, it should really only be used for requests to the
# package file server. The uri argument is the fully qualified URI
# to request.
#
proc getPackageFile { uri } {
variable loginCookie
variable quiet
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]
}
}
if {[info exists loginCookie] && [llength $loginCookie] == 2} then {
set script [object create String {
if {[methodName ToString] eq "GetWebRequest"} then {
webRequest Headers.Add Cookie [join $loginCookie =]
}
}]
return [uri download -inline -webclientdata $script -- $uri]
} else {
return [uri download -inline -- $uri]
}
} else {
set options [list -binary true]
if {[info exists loginCookie] && [llength $loginCookie] == 2} then {
lappend options -headers [list Cookie [join $loginCookie =]]
}
return [eval ::PackageRepository::getFileViaHttp \
[list $uri] [list 20] [list stdout] [list $quiet] $options]
}
}
#
# NOTE: This procedure resets the currently configured login cookie, if
# any, and then attempts to login using the specified user name and
# password. Upon success, it will set the login cookie to the one
# from the raw response data. Upon failure, a script error will be
# raised. The userName argument must be the name of a package file
# server user with at least Fossil Check-Out (o) permissions on the
# package file server. The password argument must be the plaintext
# password that is associated with the specified user name.
#
# <public>
proc resetCookieAndLogin { userName password } {
variable baseUri
variable loginCookie
variable loginUri
#
# NOTE: Build the full URI for the login request.
#
set uri [subst $loginUri]
#
# NOTE: Reset the old login cookie, if any. Then, issue a new login
# request, capturing the raw response data.
#
set loginCookie [list]; set data [getPackageFile $uri]
#
# NOTE: Attempt to extract the necessary values from the raw response
# data.
#
set pattern(1) {"authToken":"(.*?)"}; # TODO: *HACK* Keep updated.
if {![regexp -- $pattern(1) $data dummy authToken]} then {
error "login response missing \"authToken\""
}
set pattern(2) {"loginCookieName":"(.*?)"}; # TODO: *HACK* Keep updated.
if {![regexp -- $pattern(2) $data dummy loginCookieName]} then {
error "login response missing \"loginCookieName\""
}
#
# NOTE: Set the login cookie to the one freshly extracted from the raw
# response data.
#
set loginCookie [list $loginCookieName $authToken]
#
# NOTE: Always return an empty string (i.e. and not the login data).
#
return ""
}
#
# NOTE: This procedure checks if there is a higher version available of the
# specified package on the package file server. The language argument
# must be one of the literal strings "eagle", "tcl", or "client". 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 either "eagle" or "client". The packageName argument
# is a directory name relative to the language and version-specific
# directory on the package file server and may be an empty string. The
# usePgp argument should be non-zero when an OpenPGP signature file
# needs to be downloaded and verified for the downloaded file.
#
# <public>
proc checkForHigherVersion { language version packageName usePgp } {
variable clientDirectory
variable temporaryRootDirectory
verifyLanguageAndVersion $language $version isClient
set temporaryDirectory [file join \
$temporaryRootDirectory [appendArgs \
pkgd_ver_ [::PackageRepository::getUniqueSuffix]]]
if {$isClient} then {
set persistentDirectory $clientDirectory
} else {
set persistentDirectory $persistentRootDirectory
}
set fileName [file join $packageName VERSION]
set downloadFileName [file join $temporaryDirectory $fileName]
file mkdir [file dirname $downloadFileName]
downloadOneFile $language $version $fileName $downloadFileName $usePgp
if {$usePgp} then {
downloadOneFile $language $version [appendArgs $fileName .asc] \
[appendArgs $downloadFileName .asc] $usePgp
}
set localFileName [file join $persistentDirectory $fileName]
set compare [package vcompare \
[string trim [readFile $downloadFileName]] \
[string trim [readFile $localFileName]]]
if {[isEagle]} then {
file delete -recursive -- $temporaryDirectory
} else {
file delete -force -- $temporaryDirectory
}
return [expr {$compare > 0}]
}
#
# NOTE: This procedure downloads a single file from the package file server,
# writing its contents to the specified local file name. It can also
# verify the OpenPGP signatures. When an OpenPGP signature file is
# downloaded, this procedure assumes the corresponding data file was
# already downloaded (i.e. since OpenPGP needs both to perform the
# signature checks). The language argument must be one of the
# literal strings "eagle", "tcl", or "client". 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 either "eagle" or "client". The fileName argument is a file
# name relative to the language and version-specific directory on the
# package file server. The localFileName argument is the file name
# where the downloaded file should be written. The usePgp argument
# should be non-zero when an OpenPGP signature file needs to be
# downloaded and verified for the downloaded file.
#
proc downloadOneFile { language version fileName localFileName usePgp } {
variable baseUri
variable downloadUri
#
# NOTE: First, build the full relative file name to download from
# the remote package repository.
#
set fileName [file join $language $version $fileName]
set uri [subst $downloadUri]
#
# NOTE: Then, in one step, download the file from the package file
# server and write it to the specified local file.
#
writeFile $localFileName [getPackageFile $uri]
#
# NOTE: Is use of OpenPGP for signature verification enabled? Also,
# did we just download an OpenPGP signature file?
#
if {$usePgp && [isPgpSignatureFileName $localFileName true]} then {
#
# NOTE: Attempt to verify the OpenPGP signature. If this fails,
# an error is raised.
#
if {![::PackageRepository::verifyPgpSignature $localFileName]} then {
error [appendArgs \
"bad PGP signature \"" $localFileName \"]
}
}
}
#
# NOTE: This procedure attempts to download a list of files, optionally
# persistening them for subsequent uses by the target language.
# The language argument must be one of the literal strings "eagle",
# "tcl", or "client". 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 either "eagle"
# or "client". The fileNames argument must be a well-formed list
# of file names to download, each one relative to the language and
# version-specific directory on the package file server. The
# persistent argument should be non-zero if the downloaded files
# should be saved to permanent storage for subsequent use. The
# usePgp argument should be non-zero when an OpenPGP signature file
# needs to be downloaded and verified for each downloaded file. The
# useAutoPath argument should be non-zero to modify the auto-path
# to include the temporary or persistent directories containing
# the downloaded files.
#
# <public>
proc downloadFiles {
language version fileNames persistent usePgp useAutoPath } {
variable clientDirectory
variable persistentRootDirectory
variable temporaryRootDirectory
verifyLanguageAndVersion $language $version isClient
set temporaryDirectory [file join \
$temporaryRootDirectory [appendArgs \
pkgd_lib_ [::PackageRepository::getUniqueSuffix]]]
if {$isClient} then {
set persistentDirectory $clientDirectory
} else {
set persistentDirectory $persistentRootDirectory
}
set downloadedFileNames [list]
foreach fileName $fileNames {
if {[string length $fileName] == 0 || \
[file pathtype $fileName] ne "relative"} then {
error [appendArgs \
"bad file name \"" $fileName "\", not relative"]
}
set directoryParts [file split [file dirname $fileName]]
if {[llength $directoryParts] == 0} then {
error [appendArgs \
"bad file name \"" $fileName "\", no directory parts"]
}
set directory(temporary) [file normalize [eval \
file join [list $temporaryDirectory] $directoryParts]]
set directory(persistent) [file normalize [eval \
file join [list $persistentDirectory] $directoryParts]]
set fileNameOnly [file tail $fileName]
set downloadFileName [file normalize [file join \
$directory(temporary) $fileNameOnly]]
if {[file exists $downloadFileName]} then {
error [appendArgs \
"temporary file name \"" $downloadFileName \
"\" already exists"]
}
file mkdir [file dirname $downloadFileName]
downloadOneFile $language $version $fileName $downloadFileName $usePgp
lappend downloadedFileNames [list \
$fileNameOnly $directory(temporary) $directory(persistent)]
if {$usePgp && ![isPgpSignatureFileName $downloadFileName true]} then {
downloadOneFile $language $version [appendArgs $fileName .asc] \
[appendArgs $downloadFileName .asc] $usePgp
lappend downloadedFileNames [list \
[appendArgs $fileNameOnly .asc] $directory(temporary) \
$directory(persistent)]
}
}
set downloadDirectories [list]
foreach downloadedFileName $downloadedFileNames {
set directory(temporary) [lindex $downloadedFileName 1]
if {$persistent} then {
set fileNameOnly [lindex $downloadedFileName 0]
set directory(persistent) [lindex $downloadedFileName 2]
file mkdir $directory(persistent)
set command [list file copy]
if {$isClient} then {
lappend command -force
}
lappend command --
lappend command [file join $directory(temporary) $fileNameOnly]
lappend command [file join $directory(persistent) $fileNameOnly]
eval $command
lappend downloadDirectories $directory(persistent)
} else {
lappend downloadDirectories $directory(temporary)
}
}
set downloadDirectories [lsort -unique $downloadDirectories]
if {$useAutoPath} then {
foreach downloadDirectory $downloadDirectories {
addToAutoPath $language $downloadDirectory
}
}
if {$persistent} then {
if {[isEagle]} then {
file delete -recursive -- $temporaryDirectory
} else {
file delete -force -- $temporaryDirectory
}
}
return $downloadDirectories
}
#
# NOTE: This package requires the package repository client package.
#
package require Eagle.Package.Repository
#
# 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.
#
setupDownloadVars [info script]
#
# NOTE: Provide the package to the interpreter.
#
package provide Eagle.Package.Downloader \
[expr {[isEagle] ? [info engine PatchLevel] : "1.0"}]
}