###############################################################################
#
# 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 {

    }
  }
}
