set UPLOAD_TOOL [file join $srcdir upload-ftp-v1.2.pl]
-proc upload_exit {} {}
+# invoked by DejaGnu framework when a failure is recorded
+proc upload_count_failures { args } {
+ global upload_failure_count
+ incr upload_failure_count
+}
+set local_record_procs(fail) upload_count_failures
+
+proc put_file { file string } {
+ set chan [open $file w]
+ puts -nonewline $chan $string
+ close $chan
+}
+proc age_file { file to } {
+ file mtime $file [clock scan $to]
+}
+
+proc new_test_environment { stem } {
+ set count 1
+ set name "${stem}.1"
+ while { [file exists $name] } {
+ incr count
+ set name "${stem}.${count}"
+ }
+
+ global upload_failure_count
+ set upload_failure_count 0
+
+ make_test_environment $name
+ return $name
+}
+proc close_test_environment { name } {
+ global upload_failure_count
+ # delete the environment iff no tests failed
+ if { $upload_failure_count == 0 } {
+ file delete -force -- $name
+ }
+}
+
+proc make_test_environment { base_dir } {
+ file mkdir $base_dir
+ file mkdir [file join $base_dir packages]
+ file mkdir [file join $base_dir incoming]
+ file mkdir [file join $base_dir in-stage]
+ file mkdir [file join $base_dir stage]
+ file mkdir [file join $base_dir pub]
+ file mkdir [file join $base_dir archive]
+
+ # default of no open files for other tests to override if needed
+ put_file [file join $base_dir mocks] ":^ lsof -Fn .*\n? 1\n"
+}
+
+load_lib mockgpg.exp
+
+# make_test_keyrings /some/dir/some/where {
+# some-package-name {
+# { id <subkey-long-ID>
+# name <user> [is <state>]
+# subkey-of <prikey-long-ID>
+# expires <expiration> }...
+# }
+# some-package-name/po {
+# <keylist for mockgpg.exp:write_test_keyring>
+# }
+# }
+proc make_test_keyrings { base_dir keylist } {
+ # file names could be properly split, instead of relying on passed in
+ # slashes being correct for writing the file, but this is unlikely to
+ # ever run on a non-POSIX system, and they are correct on POSIX
+ foreach { package keys } $keylist {
+ file mkdir [file join $base_dir packages $package]
+ write_test_keyring \
+ [file join $base_dir packages $package pubring.gpg] $keys
+ }
+}
+
+# register_test_packages /some/dir/some/where {
+# some-package-name {
+# email { <email address>... }
+# keys {
+# <keylist for mockgpg.exp:write_test_keyring>
+# }
+# maintainers { <PGP "Name <email>">... }
+# }
+# ...
+# }
+proc register_test_packages { base_dir packlist } {
+ foreach { package info } $packlist {
+ file mkdir [file join $base_dir packages $package]
+ foreach { element value } $info { switch $element {
+ email {
+ set c [open [file join $base_dir packages $package email] w]
+ foreach address $value { puts $c $address }
+ close $c
+ }
+ keys {
+ write_test_keyring \
+ [file join $base_dir packages $package pubring.gpg] $value
+ }
+ maintainers {
+ set c [open [file join $base_dir m.bypkg] a]
+ puts -nonewline $c [format "%s - " $package]
+ puts $c [join $value ", "]
+ close $c
+ }
+ } }
+ }
+}
+
+# make_test_case /some/dir/some/where {
+# some-package-name-1.2.3.tar.gz {
+# directive {
+# version 1.2
+# filename some-package-name-1.2.3.tar.gz
+# ...
+# }
+# dsig { good|bad <sigID> <keyID>
+# [<timestamp>] [expires <expire>] }
+# file { ... }
+# fsig { ... }
+# [directive-mtime <timespec>]
+# [file-mtime <timespec>]
+# [fsig-mtime <timespec>]
+# }
+# other-package-name-4.5.6.tar.bz2 {
+# directive { ... }
+# dsig { <args for mockgpg.exp:make_test_signature> }
+# file { ... }
+# fsig { ... }
+# }
+# }
+proc make_test_case { base_dir packlist } {
+ foreach { stem triplet } $packlist {
+ array unset parts
+ foreach part {directive file fsig} {
+ set "parts(${part}-mtime)" "3 minutes ago"
+ }
+ array set parts $triplet
+ if { [info exists parts(directive)] } {
+ set directive {}
+ foreach {key value} $parts(directive) {
+ append directive [format "%s: %s\n" $key $value]
+ }
+ if { [info exists parts(dsig)] } { # add signature
+ set directive \
+ [sign_test_message $directive \
+ [eval make_test_signature $parts(dsig)]]
+ }
+ put_file [file join $base_dir incoming "${stem}.directive.asc"] \
+ $directive
+ age_file [file join $base_dir incoming "${stem}.directive.asc"] \
+ $parts(directive-mtime)
+ }
+ if { [info exists parts(file)] } { # write file
+ put_file [file join $base_dir incoming "${stem}"] \
+ [string trimleft $parts(file)]
+ age_file [file join $base_dir incoming "${stem}"] \
+ $parts(file-mtime)
+ }
+ if { [info exists parts(fsig)] } { # write detached signature
+ put_file [file join $base_dir incoming "${stem}.sig"] \
+ [sign_test_file $stem \
+ [eval make_test_signature $parts(fsig)]]
+ age_file [file join $base_dir incoming "${stem}.sig"] \
+ $parts(fsig-mtime)
+ }
+ }
+}
+
+proc start_test_services { base_dir } {
+ global spawn_id
+ upvar 1 minlog_id minlog_id minsmtp_id minsmtp_id
+
+ set ::env(TEST_BASE_DIR) [file normalize $base_dir]
+ verbose -log "running test in ${base_dir}"
+
+ # start minlogd
+ set logsock [format "testlog%d" [pid]]
+ spawn [testsuite file -source -top lib exec minlogd.pl] \
+ -s $logsock \
+ -o [file join $base_dir syslog]
+ set minlog_id $spawn_id
+ expect {
+ -re {listening on [^\n]+\n} {}
+ timeout { error "minlogd did not start" }
+ }
+ set ::env(TEST_SYSLOG_SOCKET) $logsock
+
+ # start minsmtpd
+ spawn [testsuite file -source -top lib exec minsmtpd.tcl] \
+ -o [file join $base_dir mbox]
+ set minsmtp_id $spawn_id
+ expect {
+ -re {listening on local port ([0-9]+)[^\n]*\n} {
+ set ::env(TEST_SMTP_PORT) $expect_out(1,string)
+ }
+ timeout { error "minsmtpd did not start" }
+ }
+}
+proc stop_test_services {} {
+ global spawn_id
+ upvar 1 minlog_id minlog_id minsmtp_id minsmtp_id
+
+ # stop minsmtpd
+ set spawn_id $minsmtp_id
+ send "exit\n"
+ wait
+
+ # stop minlogd
+ set spawn_id $minlog_id
+ send "exit\n"
+ wait
+
+ # cleanup
+ unset ::env(TEST_BASE_DIR) ::env(TEST_SMTP_PORT) ::env(TEST_SYSLOG_SOCKET)
+}
+
+proc run_upload_batch_test {} {
+ global spawn_id
+ global UPLOAD_TOOL
+
+ # run test case
+ spawn $UPLOAD_TOOL --testing-this-script -s ftp
+ wait
+}
+
+proc analyze_file_tree { base_dir name zones mode {itemlist {}} } {
+ verbose -log "scanning { [string trim $zones] } for ${mode}:"
+
+ foreach zone $zones {
+ set zone_base [file normalize [file join $base_dir $zone]]
+
+ set result pass
+ switch -- $mode {
+
+ empty {
+ set desc "empty $zone tree"
+ spawn find $zone_base -print
+ expect {
+ -ex $zone_base { exp_continue }
+ -re {^[\r\n]+} { exp_continue }
+ -re {.+} { set result fail }
+ }
+ }
+
+ files {
+ set desc "expected files in $zone tree"
+ foreach file $itemlist {
+ set filemap_want($file) $file
+ set "filemap_sig(${file}.sig)" $file
+ }
+ spawn find $zone_base ( -type f -o -type l ) -print
+ expect {
+ -re {^[\r\n]+} { exp_continue }
+ -re "^$zone_base" { exp_continue }
+ -re {^/([^\r\n]+)[\r\n]+} {
+ if { [info exists \
+ filemap_want($expect_out(1,string))] } {
+ unset filemap_want($expect_out(1,string))
+ } elseif { [info exists \
+ filemap_sig($expect_out(1,string))] } {
+ unset filemap_sig($expect_out(1,string))
+ } else {
+ verbose -log "unexpected: $expect_out(1,string)"
+ set result fail
+ }
+ exp_continue
+ }
+ }
+ if { [llength [array get filemap_want]] } {
+ set result fail
+ foreach file [array names filemap_want] {
+ verbose -log "missing: $file"
+ }
+ }
+ }
+
+ archived-files {
+ # Archiving an upload inserts a timestamp and nonce; this
+ # handling for matching such files will work provided that
+ # the original file name begins with a letter.
+ set desc "expected archived files in $zone tree"
+ foreach file $itemlist {
+ set filemap_want($file) $file
+ set "filemap_sig(${file}.sig)" $file
+ }
+ spawn find $zone_base ( -type f -o -type l ) -print
+ expect {
+ -re {^[\r\n]+} { exp_continue }
+ -re "^$zone_base" { exp_continue }
+ -re {^/([^\r\n]+)[\r\n]+} {
+ regsub -- {/[-0-9_]+} $expect_out(1,string) / file
+ if { [info exists filemap_want($file)] } {
+ set filemap_have($file) 1
+ } elseif { [info exists filemap_sig($file)] } {
+ set filemap_havesig($file) 1
+ } else {
+ verbose -log "unexpected: $expect_out(1,string)"
+ verbose -log " match as: $file"
+ set result fail
+ }
+ exp_continue
+ }
+ }
+ # The handling here is more complex because the same file
+ # could be archived multiple times.
+ foreach file [array names filemap_have] {
+ unset filemap_want($file)
+ }
+ if { [llength [array get filemap_want]] } {
+ set result fail
+ foreach file [array names filemap_want] {
+ verbose -log "missing: $file"
+ }
+ }
+ }
+
+ symlink-targets {
+ set desc "expected link targets in $zone tree"
+ foreach { target link } $itemlist {
+ set linkmap_want($link) $target
+ }
+ spawn find $zone_base -type l -printf {%p\037%l\n}
+ expect {
+ -re {^[\r\n]+} { exp_continue }
+ -re "^$zone_base" { exp_continue }
+ -re {^/([^\037]+)\037([^\r\n]+)} {
+ if { [info exists \
+ linkmap_want($expect_out(1,string))] } {
+ if { $linkmap_want($expect_out(1,string)) \
+ ne $expect_out(2,string) } {
+ verbose -log "unexpected symlink target:\
+ $expect_out(1,string)\
+ -> $expect_out(2,string)"
+ set result fail
+ }
+ unset linkmap_want($expect_out(1,string))
+ } else {
+ verbose -log "unexpected symlink:\
+ $expect_out(1,string) -> $expect_out(2,string)"
+ set result fail
+ }
+ exp_continue
+ }
+ }
+ if { [llength [array get linkmap_want]] } {
+ set result fail
+ foreach link [array names linkmap_want] {
+ verbose -log "missing symlink:\
+ $link -> $linkmap_want($link)"
+ }
+ }
+ }
+ }
+ $result "$name: $desc"
+ wait
+ }
+}
+
+proc analyze_log { base_dir name assess } {
+ verbose -log "reading log for \"$name\" tests:"
+
+ foreach {key desc} $assess {
+ regexp {^!(.*)$} $key -> key
+ set A($key) 0
+ }
+
+ verbose -log "begin: [string repeat - 60]"
+ spawn -open [open [file join $base_dir syslog]]
+ expect {
+ -re {^[\r\n]+} { exp_continue }
+ -re {^<[0-9]+>1 [-0-9]+T[0-9:]+ localhost - - - - } { exp_continue }
+ -re {^minlogd\[[0-9]+\]: begin logging} { exp_continue }
+ -re {^minlogd\[[0-9]+\]: shutting down} { exp_continue }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ Beginning upload processing run.} {
+ # from main script, upon opening syslog channel
+ set A(start) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ found directive: ([^\r\n]+)} {
+ # from main script, top of file processing loop
+ set A(found,$expect_out(1,string)) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ No files found for processing.} {
+ # from main script, exiting when nothing was done
+ set A(nowork) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ Processing complete: ([[:digit:]]+) uploads processed.} {
+ # from main script, exiting after processing directives
+ set A(workdone) 1
+ set A(workdone,$expect_out(1,string)) 1
+ # set both to allow tests to check or ignore the number
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ Updated ftpindex} {
+ # from main script, exiting after processing directives
+ exp_continue
+ # in testing, redundant with "workdone" message above;
+ # in production, timestamp difference with same gives
+ # running time for the generate-ftpindex tool
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ archived [^ ]+ to [^\r\n]+} {
+ # from archive, upon success
+ set A(action,archive-item) 1
+ # will need to revise log messages to make this
+ # include a file name relative to the test base
+ exp_continue
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ added symlink [^ ]+ pointing to [^\r\n]+} {
+ # from execute_commands, creating a symlink
+ set A(action,make-symlink) 1
+ # will need to revise log messages to make this
+ # include a file name relative to the test base
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ creation of symlink [^ ]+ to [^ ]+ in [^ ]+ failed[^\r\n]+} {
+ # from execute_commands, when the symlink builtin fails
+ set A(action,make-symlink-failure) 1
+ # will need to revise log messages to make this
+ # include a file name relative to the test base
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ removed symlink [^\r\n]+} {
+ # from execute_commands, removing a symlink
+ set A(action,rm-symlink) 1
+ # will need to revise log messages to make this
+ # include a file name relative to the test base
+ exp_continue
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: uploaded file to check: ([^\r\n]+)} {
+ # from scan_incoming readdir loop
+ set A(scan,$expect_out(1,string)) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: lsof command line: [^\r\n]*} {
+ # from scan_incoming, tracing lsof call
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: lsof output: [^\r\n]*} {
+ # from scan_incoming, tracing lsof output
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: upload in progress for ([^,]+),\
+ ignoring during this run} {
+ # from scan_incoming, when lsof reports file still open
+ set A(open,$expect_out(1,string)) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: ([^ ]+) has[^,]+, skipping} {
+ # from scan_incoming, when recent mtime excludes a file
+ set A(recent,$expect_out(1,string)) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: considering ([^ ]+) for processing.} {
+ # from scan_incoming, top of triplet checking loop
+ set A(consider,$expect_out(1,string)) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ Found directive file with filename directive \(([^ ]+)\),\
+ but no accompanying files.\
+ Ignoring directive file in this run.} {
+ # from scan_incoming, on finding a loose triplet directive
+ set A(skip-loose,$expect_out(1,string)) 1
+ exp_continue
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: found keyring [^\r\n]+} {
+ # from keyring_file, while searching for keyrings
+ exp_continue
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ The directory line should start with the name of the package\
+ for which you are trying to upload a file[^\r\n]+} {
+ # from email_addresses, when the list cannot be opened
+ set A(unknown-package) 1
+ exp_continue
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ no directory directive specified in [^\r\n]+} {
+ # from read_directive_file, if no directory key found
+ set A(validate,no-directory-given) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ nothing to do - no commands in directive file} {
+ # from read_directive_file, if no action specified
+ set A(validate,no-op) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ not running in legacy v1 mode} {
+ # from read_directive_file, after determining mode
+ # TODO: will be removed with other v1 compatibility code
+ exp_continue
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: [^ ]+ size is [[:digit:]]+} {
+ # from verify_keyring, upon entry
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ DEBUG: gpgv command line: [^\r\n]+} {
+ # from verify_keyring, tracing gpgv call
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ gpgv exited ([[:digit:]]+)} {
+ # from verify_keyring, when closing pipe from gpgv
+ set A(gpgv,exitcode,$expect_out(1,string)) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ verified against ([^\r\n]+)} {
+ # from verify_keyring, upon success
+ exp_continue
+ # tests are not sensitive to this message because it
+ # is likely to be removed when gpgv is given multiple
+ # keyrings instead of being run repeatedly
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ gpg verify of directive file failed} {
+ # from verify_keyring, when no keys match
+ set A(gpgv,directive-verify-failed) 1
+ exp_continue
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ \(in [^()]+\) [^\r\n]+} {
+ # from fatal, just before calling ftp_die which exits
+ exp_continue
+ }
+
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ No uploader e-mail address\(es\) to report this error to!} {
+ # from mail, when no email address is provided
+ set A(mail,no-known-address) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ NOMAIL is set - net sending email to [^\r\n]+} {
+ # from mail, when mail is inhibited
+ set A(mail,inhibited) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ Sending email to [^\r\n]+} {
+ # from mail, recording address list
+ set A(mail,addresses) 1
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ Subject: [^\r\n]+} {
+ # from mail, outgoing Subject line
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ Error uploading package: [^\r\n]+} {
+ # from mail, when a generic failure is reported
+ exp_continue
+ }
+ -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+ Body: [^\r\n]+} {
+ # from mail, recording outgoing message body
+ exp_continue
+ }
+ }
+# -re {^ftp-upload\[[0-9]+\]: \(Test\)\
+# } {
+# exp_continue
+# }
+ verbose -log " done: [string repeat - 60]"
+
+ foreach {key desc} $assess {
+ if { [regexp {^!(.*)$} $key -> key] } {
+ if { ! $A($key) } {
+ pass "$name: $desc"
+ } else {
+ fail "$name: $desc"
+ }
+ } else {
+ if { $A($key) } {
+ pass "$name: $desc"
+ } else {
+ fail "$name: $desc"
+ }
+ }
+ }
+}
+
+proc analyze_no_mail { base_dir name } {
+ verbose -log "checking mail from \"$name\" tests:"
+
+ if { [file size [file join $base_dir mbox]] == 0 } {
+ pass "$name: no mail produced"
+ } else {
+ fail "$name: no mail produced"
+ }
+}
+
+# analyze_mail <base_dir> <name> [<key value>]...
+# keywords:
+# to <address list>
+proc analyze_mail { base_dir name args } {
+ verbose -log "checking mail from \"$name\" tests:"
+
+ array set opt { to {} }
+ array set opt $args
+
+ foreach address $opt(to) { set expected_address($address) $address }
+
+ verbose -log "begin: [string repeat - 60]"
+ set messages_remain 1
+ spawn -open [open [file join $base_dir mbox]]
+ while { $messages_remain } {
+ expect {
+ -re {^From } {
+ # at beginning of message
+ }
+ -re {^[^\r\n]*[\r\n]+} { exp_continue }
+ eof {
+ set $messages_remain 0
+ break
+ }
+ }
+ expect {
+ -re {^Received: From [^ ]+ \([.[:xdigit:]:]+\)\
+ via TCP with SMTP for } {
+ # at envelope addresses
+ }
+ -re {^[^\r\n]*[\r\n]+} { exp_continue }
+ }
+ expect {
+ -re {^<([^>]+)> *} {
+ set env_address($expect_out(1,string)) $expect_out(1,string)
+ exp_continue
+ }
+ -re {^[\r\n]+} {
+ # end of line
+ }
+ }
+ }
+ verbose -log " done: [string repeat - 60]"
+
+ set result pass
+ foreach address [array names expected_address] {
+ if { [info exists env_address($address)] } {
+ unset env_address($address)
+ } else {
+ verbose -log "expected mail not sent to <$address>" 0
+ set result fail
+ }
+ }
+ if { [llength [array names env_address]] > 0 } {
+ verbose -log "unexpected addresses received mail: \
+ [array names env_address]" 0
+ set result fail
+ }
+
+ $result "$name: expected mail produced to expected addresses"
+}
+
+proc upload_exit {} {
+ # clean up test environment tree
+ catch {file delete -- test.tmp}
+}
proc upload_version {} {
global UPLOAD_TOOL
- exec -- $UPLOAD_TOOL --version >@ stdout
+ exec -- $UPLOAD_TOOL --testing-this-script --version >@ stdout
}
#EOF
--- /dev/null
+# Tests for processing with nothing to do
+
+# Copyright (C) 2021 Jacob Bachmeyer
+#
+# This file is part of a testsuite for the GNU FTP upload system.
+#
+# This file is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+set tenv [new_test_environment [file join test.tmp tenv]]
+
+start_test_services $tenv
+run_upload_batch_test
+stop_test_services
+
+analyze_file_tree $tenv "idle processing: no files" {
+ incoming in-stage stage pub archive
+} empty
+
+analyze_log $tenv "idle processing: no files" {
+ start "ftp-upload start message"
+ nowork "ftp-upload 'nothing to do' message"
+}
+
+analyze_no_mail $tenv "idle processing: no files"
+
+close_test_environment $tenv
+
+# ----------------------------------------
+
+set tenv [new_test_environment [file join test.tmp tenv]]
+
+# files which are to be found in the scan but not processed
+put_file [file join $tenv incoming bogus1] "bogus file 1\n"
+put_file [file join $tenv incoming bogus2] "bogus file 2\n"
+put_file [file join $tenv incoming bogus3] "bogus file 3\n"
+
+age_file [file join $tenv incoming bogus1] "3 minutes ago"
+age_file [file join $tenv incoming bogus2] "2 minutes 15 seconds ago"
+age_file [file join $tenv incoming bogus3] "1 minute ago"
+
+foreach file {
+ _bogus +bogus __bogus _+bogus _-bogus _~bogus _.bogus
+} {
+ put_file [file join $tenv incoming ${file}] "bogus file $file\n"
+ age_file [file join $tenv incoming ${file}] "3 minutes ago"
+}
+
+# files which are to be rejected and ignored
+foreach file {
+ x=x .abcfoobar -abcfoobar x;x \\~xax x*x x:x x?x ;xax
+} {
+ put_file [file join $tenv incoming ${file}] "bogus input $file\n"
+ age_file [file join $tenv incoming ${file}] "3 minutes ago"
+}
+
+start_test_services $tenv
+run_upload_batch_test
+stop_test_services
+
+analyze_file_tree $tenv "idle processing: bogus files" {
+ incoming
+} files {
+ bogus1 bogus2 bogus3
+ _bogus +bogus __bogus _+bogus _-bogus _~bogus _.bogus
+ x=x .abcfoobar -abcfoobar x;x \\~xax x*x x:x x?x ;xax
+}
+analyze_file_tree $tenv "idle processing: bogus files" {
+ in-stage stage pub archive
+} empty
+
+analyze_log $tenv "idle processing: bogus files" {
+ start "ftp-upload start message"
+ nowork "ftp-upload 'nothing to do' message"
+
+ scan,bogus1 "scan found file: bogus1"
+ scan,bogus2 "scan found file: bogus2"
+ scan,bogus3 "scan found file: bogus3"
+
+ scan,_bogus "scan found file: _bogus"
+ scan,+bogus "scan found file: +bogus"
+ scan,__bogus "scan found file: __bogus"
+ scan,_+bogus "scan found file: _+bogus"
+ scan,_-bogus "scan found file: _-bogus"
+ scan,_~bogus "scan found file: _~bogus"
+ scan,_.bogus "scan found file: _.bogus"
+
+ !scan,x=x "ignored file: x=x"
+ !scan,.abcfoobar "ignored file: .abcfoobar"
+ !scan,-abcfoobar "ignored file: -abcfoobar"
+ !scan,x;x "ignored file: x;x"
+ !scan,~xax "ignored file: ~xax "
+ !scan,x*x "ignored file: x*x "
+ !scan,x:x "ignored file: x:x "
+ !scan,x?x "ignored file: x?x"
+ !scan,;xax "ignored file: ;xax"
+
+ recent,bogus3 "skipped recent file: bogus3"
+
+ consider,bogus1 "considered file: bogus1"
+ consider,bogus2 "considered file: bogus2"
+}
+
+analyze_no_mail $tenv "idle processing: bogus files"
+
+close_test_environment $tenv
+
+# ----------------------------------------
+
+proc check_incomplete_upload { has_directive has_main has_signature } {
+ set tenv [new_test_environment [file join test.tmp tenv]]
+
+ put_file [file join $tenv mocks] ":^ lsof -Fn .*\n? 1\n"
+
+ set msglist {
+ start "ftp-upload start message"
+ nowork "ftp-upload 'nothing to do' message"
+ }
+
+ set filelist [list]
+ set testcase [list]
+ if { $has_directive } {
+ lappend filelist partial.bin.directive.asc
+ lappend testcase directive {
+ version 1.2
+ filename partial.bin
+ } dsig { good 00 0000 }
+ lappend msglist \
+ scan,partial.bin.directive.asc "scan found directive file" \
+ consider,partial.bin.directive.asc "considered directive file"
+ }
+ if { $has_main } {
+ lappend filelist partial.bin
+ lappend testcase file {
+ incomplete upload main file
+ }
+ lappend msglist \
+ scan,partial.bin "scan found main file" \
+ consider,partial.bin "considered main file"
+ }
+ if { $has_signature } {
+ lappend filelist partial.bin.sig
+ lappend testcase fsig { good 01 0000 }
+ lappend msglist \
+ scan,partial.bin.sig "scan found signature file" \
+ consider,partial.bin.sig "considered signature file"
+ }
+ if { $has_directive && ! ( $has_main || $has_signature ) } {
+ lappend msglist skip-loose,partial.bin.directive.asc \
+ "skip directive file due to missing main file"
+ }
+ make_test_case $tenv [list partial.bin $testcase]
+
+ start_test_services $tenv
+ run_upload_batch_test
+ stop_test_services
+
+ set Name "idle processing: incomplete upload\
+ \[${has_directive}${has_main}${has_signature}\]"
+
+ analyze_file_tree $tenv $Name {
+ incoming
+ } files $filelist
+ analyze_file_tree $tenv $Name {
+ in-stage stage pub archive
+ } empty
+ analyze_log $tenv $Name $msglist
+ analyze_no_mail $tenv $Name
+
+ close_test_environment $tenv
+}
+
+check_incomplete_upload 0 1 0
+check_incomplete_upload 0 1 1
+check_incomplete_upload 0 0 1
+check_incomplete_upload 1 0 1
+check_incomplete_upload 1 0 0
+check_incomplete_upload 1 1 0
+
+# ----------------------------------------
+
+proc check_ongoing_upload { open_directive open_main open_signature } {
+ set tenv [new_test_environment [file join test.tmp tenv]]
+
+ set msglist {
+ start "ftp-upload start message"
+ nowork "ftp-upload 'nothing to do' message"
+
+ scan,partial.bin "scan found main file"
+ scan,partial.bin.sig "scan found signature file"
+ scan,partial.bin.directive.asc "scan found directive file"
+ }
+
+ set mockfile [open [file join $tenv mocks] w]
+ puts $mockfile {:^ lsof -Fn .*}
+ set lsofstem [file normalize [file join $tenv incoming]]
+ if { $open_directive } {
+ puts $mockfile "> n${lsofstem}/partial.bin.directive.asc"
+ lappend msglist \
+ open,partial.bin.directive.asc "directive file still open"
+ } else {
+ lappend msglist \
+ consider,partial.bin.directive.asc "considered directive file"
+ }
+ if { $open_main } {
+ puts $mockfile "> n${lsofstem}/partial.bin"
+ lappend msglist \
+ open,partial.bin "main file still open"
+ } else {
+ lappend msglist \
+ consider,partial.bin "considered main file"
+ }
+ if { $open_signature } {
+ puts $mockfile "> n${lsofstem}/partial.bin.sig"
+ lappend msglist \
+ open,partial.bin.sig "signature file still open"
+ } else {
+ lappend msglist \
+ consider,partial.bin.sig "considered signature file"
+ }
+ if { $open_directive || $open_main || $open_signature } {
+ puts $mockfile "? 0"
+ } else {
+ puts $mockfile "? 1"
+ }
+ close $mockfile
+
+ make_test_case $tenv {
+ partial.bin {
+ directive {
+ version 1.2
+ filename partial.bin
+ } dsig { good 02 0000 }
+ file { ongoing upload main file }
+ fsig { good 03 0000 }
+ }
+ }
+
+ start_test_services $tenv
+ run_upload_batch_test
+ stop_test_services
+
+ set Name "idle processing: ongoing upload\
+ \[${open_directive}${open_main}${open_signature}\]"
+
+ analyze_file_tree $tenv $Name {
+ incoming
+ } files {
+ partial.bin partial.bin.sig partial.bin.directive.asc
+ }
+ analyze_file_tree $tenv $Name {
+ in-stage stage pub archive
+ } empty
+ analyze_log $tenv $Name $msglist
+ analyze_no_mail $tenv $Name
+
+ close_test_environment $tenv
+}
+
+check_ongoing_upload 1 1 1
+check_ongoing_upload 1 0 1
+check_ongoing_upload 1 0 0
+check_ongoing_upload 1 1 0
+check_ongoing_upload 0 1 0
+check_ongoing_upload 0 1 1
+check_ongoing_upload 0 0 1
+
+#EOF
--- /dev/null
+# Tests for processing standalone directives
+
+# Copyright (C) 2021 Jacob Bachmeyer
+#
+# This file is part of a testsuite for the GNU FTP upload system.
+#
+# This file is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+proc check_loose_directive { desc case args } {
+ set tenv [new_test_environment [file join test.tmp tenv]]
+
+ array set opt {
+ initial-files {} initial-symlinks {}
+ email-to {} log {} file-tree {}
+ }
+ array set opt $args
+
+ set log_items {
+ start "ftp-upload start message"
+
+ scan,foo.directive.asc "scan found directive file"
+ consider,foo.directive.asc "considered directive file"
+ found,foo.directive.asc "found directive file for processing"
+ }
+
+ if { [llength $opt(log)] > 0 } { append log_items $opt(log) }
+
+ if { [llength $opt(email-to)] > 0 } {
+ lappend log_items mail,addresses "outgoing mail sent"
+ } else {
+ lappend log_items mail,no-known-address "no uploader address known"
+ lappend log_items mail,addresses "outgoing mail sent to admin"
+ }
+
+ register_test_packages $tenv {
+ foo {
+ email { "foo@example.org" }
+ keys { { id 1000 name "foo <foo@example.gnu.org>" } }
+ maintainers { "foo <foo@example.net>" }
+ }
+ baz {
+ email { }
+ keys { { id 1001 name "baz" } }
+ }
+ }
+
+ foreach {zone filelist} $opt(initial-files) {
+ foreach {file sig} $filelist {
+ file mkdir [file dirname [file join $tenv $zone $file]]
+ put_file [file join $tenv $zone $file] "${file}\n"
+ put_file [file join $tenv $zone "${file}.sig"] \
+ [sign_test_file [file tail $file] \
+ [eval [list make_test_signature] $sig]]
+ age_file [file join $tenv $zone $file] "10 minutes ago"
+ age_file [file join $tenv $zone "${file}.sig"] "10 minutes ago"
+ }
+ }
+ foreach {zone linklist} $opt(initial-symlinks) {
+ foreach {target link} $linklist {
+ # The Tcl [file link] command refuses to create dangling symlinks.
+ # file link -symbolic [file join $tenv $zone $link] $target
+ verbose -log [exec ln -sv $target [file join $tenv $zone $link]]
+ }
+ }
+
+ make_test_case $tenv [list foo $case]
+
+ start_test_services $tenv
+ run_upload_batch_test
+ stop_test_services
+
+ analyze_log $tenv "loose directive: $desc" $log_items
+ analyze_mail $tenv "loose directive: $desc" to $opt(email-to)
+ if { [llength $opt(file-tree)] > 0 } {
+ foreach {zones mode items} $opt(file-tree) {
+ analyze_file_tree $tenv "loose directive: $desc" \
+ $zones $mode $items
+ }
+ }
+
+ close_test_environment $tenv
+}
+
+# ----------------------------------------
+
+# TODO: All of the unsigned directive tests should probably produce a
+# message about the lack of a signature or a failed signature check
+# at the least; currently, they do not consistently do so.
+
+check_loose_directive "bogus: unsigned with no directory specified" {
+ directive {
+ version 1.2
+ no-op ""
+ comment "do nothing"
+ }
+} file-tree {
+ { incoming stage pub archive } empty {}
+ { in-stage } files { foo.directive.asc }
+} email-to {
+ ftp-upload-script@gnu.org
+}
+
+check_loose_directive "bogus: unsigned for bogus package" {
+ directive {
+ version 1.2
+ directory bar
+ no-op ""
+ comment "do nothing"
+ }
+} file-tree {
+ { incoming stage pub archive } empty {}
+ { in-stage } files { foo.directive.asc }
+} log {
+ unknown-package "unknown package from directive"
+} email-to {
+ ftp-upload-script@gnu.org
+}
+
+check_loose_directive "bogus: unsigned for package with no email address" {
+ directive {
+ version 1.2
+ directory baz
+ no-op ""
+ comment "do nothing"
+ }
+} file-tree {
+ { incoming stage pub archive } empty {}
+ { in-stage } files { foo.directive.asc }
+} email-to {
+ ftp-upload-script@gnu.org
+}
+
+check_loose_directive "bogus: unsigned for valid package" {
+ directive {
+ version 1.2
+ directory foo
+ no-op ""
+ comment "do nothing"
+ }
+} file-tree {
+ { incoming stage pub archive } empty {}
+ { in-stage } files { foo.directive.asc }
+} email-to {
+ ftp-upload-script@gnu.org foo@example.org foo@example.net
+}
+
+check_loose_directive "bogus: signed with no directory specified" {
+ directive {
+ version 1.2
+ no-op ""
+ comment "do nothing"
+ } dsig { good 00 1000 }
+} file-tree {
+ { incoming stage pub archive } empty {}
+ { in-stage } files { foo.directive.asc }
+} log {
+ validate,no-directory-given "directive rejected: no directory specified"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.gnu.org
+}
+
+check_loose_directive "bogus: signed with wrong key" {
+ directive {
+ version 1.2
+ directory baz
+ no-op ""
+ comment "do nothing"
+ } dsig { good 01 1000 }
+} file-tree {
+ { incoming stage pub archive } empty {}
+ { in-stage } files { foo.directive.asc }
+} log {
+ gpgv,directive-verify-failed "incorrect signature rejected"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.gnu.org
+}
+
+check_loose_directive "bogus: signed for bogus package" {
+ directive {
+ version 1.2
+ directory bar
+ no-op ""
+ comment "do nothing"
+ } dsig { good 02 1000 }
+} file-tree {
+ { incoming stage pub archive } empty {}
+ { in-stage } files { foo.directive.asc }
+} log {
+ unknown-package "unknown package from directive"
+} email-to {
+ ftp-upload-script@gnu.org foo@example.gnu.org
+}
+
+check_loose_directive "bogus: signed for package with no email address" {
+ directive {
+ version 1.2
+ directory baz
+ no-op ""
+ comment "do nothing"
+ } dsig { good 03 1001 }
+} file-tree {
+ { incoming in-stage stage pub archive } empty {}
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+}
+
+# ----------------------------------------
+
+check_loose_directive "create symlink" {
+ directive {
+ version 1.2
+ directory foo
+ symlink "foo-1.2.bin foo-latest.bin"
+ } dsig { good 10 1000 }
+} initial-files {
+ pub { foo/foo-1.2.bin { good 06 1000 } }
+} file-tree {
+ { incoming in-stage stage archive } empty {}
+ { pub } files { foo/foo-1.2.bin foo/foo-latest.bin }
+ { pub } symlink-targets { foo-1.2.bin foo/foo-latest.bin }
+} log {
+ action,make-symlink "recorded adding symlink"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.org foo@example.gnu.org foo@example.net
+}
+
+check_loose_directive "create dangling symlink" {
+ directive {
+ version 1.2
+ directory foo
+ symlink "foo-1.2.bin foo-latest.bin"
+ } dsig { good 11 1000 }
+} initial-files {
+ pub { foo/foo-1.0.bin { good 05 1000 } }
+} file-tree {
+ { incoming in-stage stage archive } empty {}
+ { pub } files { foo/foo-1.0.bin foo/foo-latest.bin }
+ { pub } symlink-targets { foo-1.2.bin foo/foo-latest.bin }
+} log {
+ action,make-symlink "recorded adding symlink"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.org foo@example.gnu.org foo@example.net
+}
+
+check_loose_directive "replace symlink" {
+ directive {
+ version 1.2
+ directory foo
+ symlink "foo-1.2.bin foo-latest.bin"
+ } dsig { good 12 1000 }
+} initial-files {
+ pub {
+ foo/foo-1.0.bin { good 05 1000 }
+ foo/foo-1.2.bin { good 06 1000 }
+ }
+} initial-symlinks {
+ pub { foo-1.0.bin foo/foo-latest.bin }
+} file-tree {
+ { incoming in-stage stage archive } empty {}
+ { pub } files { foo/foo-1.0.bin foo/foo-1.2.bin foo/foo-latest.bin }
+ { pub } symlink-targets { foo-1.2.bin foo/foo-latest.bin }
+} log {
+ action,make-symlink "recorded adding symlink"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.org foo@example.gnu.org foo@example.net
+}
+
+check_loose_directive "remove symlink" {
+ directive {
+ version 1.2
+ directory foo
+ rmsymlink foo-latest.bin
+ } dsig { good 13 1000 }
+} initial-files {
+ pub { foo/foo-1.2.bin { good 06 1000 } }
+} initial-symlinks {
+ pub { foo-1.2.bin foo/foo-latest.bin }
+} file-tree {
+ { incoming in-stage stage archive } empty {}
+ { pub } files { foo/foo-1.2.bin }
+} log {
+ action,rm-symlink "recorded removal of symlink"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.org foo@example.gnu.org foo@example.net
+}
+
+check_loose_directive "error: replace file with symlink" {
+ directive {
+ version 1.2
+ directory foo
+ symlink "foo-1.2.bin foo-1.0.bin"
+ } dsig { good 14 1000 }
+} initial-files {
+ pub {
+ foo/foo-1.0.bin { good 05 1000 }
+ foo/foo-1.2.bin { good 06 1000 }
+ }
+} file-tree {
+ { incoming stage archive } empty {}
+ { in-stage } files { foo.directive.asc }
+ { pub } files { foo/foo-1.0.bin foo/foo-1.2.bin }
+} log {
+ action,make-symlink-failure "overwrite with symlink fails"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.org foo@example.gnu.org foo@example.net
+}
+# TODO: The in-stage tree should be empty after this test.
+
+check_loose_directive "archive file" {
+ directive {
+ version 1.2
+ directory foo
+ archive foo-1.0.bin
+ } dsig { good 15 1000 }
+} initial-files {
+ pub {
+ foo/foo-1.0.bin { good 05 1000 }
+ foo/foo-1.2.bin { good 06 1000 }
+ }
+} file-tree {
+ { incoming in-stage stage } empty {}
+ { pub } files { foo/foo-1.2.bin }
+ { archive } archived-files { foo/foo-1.0.bin }
+} log {
+ action,archive-item "archived file"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.org foo@example.gnu.org foo@example.net
+}
+
+check_loose_directive "archive directory" {
+ directive {
+ version 1.2
+ directory foo
+ archive bar
+ } dsig { good 16 1000 }
+} initial-files {
+ pub {
+ foo/foo-1.0.bin { good 05 1000 }
+ foo/foo-1.2.bin { good 06 1000 }
+ foo/bar/bar-1.bin { good 07 1000 }
+ foo/bar/bar-2.bin { good 08 1000 }
+ }
+} file-tree {
+ { incoming in-stage stage } empty {}
+ { pub } files { foo/foo-1.0.bin foo/foo-1.2.bin }
+ { archive } archived-files { foo/bar/bar-1.bin foo/bar/bar-2.bin }
+} log {
+ action,archive-item "archived directory"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.org foo@example.gnu.org foo@example.net
+}
+
+check_loose_directive "archive symlink" {
+ directive {
+ version 1.2
+ directory foo
+ archive foo-latest.bin
+ } dsig { good 17 1000 }
+} initial-files {
+ pub {
+ foo/foo-1.0.bin { good 05 1000 }
+ foo/foo-1.2.bin { good 06 1000 }
+ }
+} initial-symlinks {
+ pub {
+ foo-1.2.bin foo/foo-latest.bin
+ foo-1.2.bin.sig foo/foo-latest.bin.sig
+ }
+} file-tree {
+ { incoming in-stage stage } empty {}
+ { pub } files { foo/foo-1.0.bin foo/foo-1.2.bin }
+ { archive } archived-files { foo/foo-latest.bin }
+} log {
+ action,archive-item "archived symlink"
+} email-to {
+ ftp-upload-script@gnu.org ftp-upload-report@gnu.org
+ foo@example.org foo@example.gnu.org foo@example.net
+}
+
+#EOF
projects / gatekeeper.git / commitdiff