zip-download-procs.tcl

Regression tests for ZIP download links and destination-page CSP.

Location:

packages/file-storage/tcl/test/zip-download-procs.tcl

Procedures in this file

Detailed information

[ hide source ] | [ make this the default ]

Content File Source

ad_library {
    Regression tests for ZIP download links and destination-page CSP.
}

aa_register_case -cats {api smoke production_safe} -procs {
    security::csp::require security::csp::render
} file_storage_zip_download_ui {
    Execute the ZIP page scripts with isolated request/database dependencies,
    using temporary files and the production CSP collector and renderer.
} {
    set child [interp create]
    set tmp [ad_mktmpdir]
    try {
        set root [acs_package_root_dir file-storage]
        interp eval $child [list set testDir $tmp]
        interp alias $child ns_urlencode {} ns_urlencode
        interp alias $child ns_quotehtml {} ns_quotehtml
        interp eval $child {
            namespace eval auth {}; namespace eval permission {}
            namespace eval fs {}; namespace eval util {}; namespace eval site_node {}
            namespace eval security::csp {}
            proc ad_page_contract args {
                dict for {key value} $::contract {uplevel 1 [list set $key $value]}
            }
            proc ad_include_contract args {
                uplevel 1 {set n_past_days 99999; set folder_id 2781645}
            }
            proc auth::require_login {} {incr ::loginChecks}
            proc permission::require_permission args {lappend ::permissionChecks $args}
            proc permission::permission_p args {return -code error -errorcode FS_TEST_STOP stop}
            proc ad_conn key {
                switch $key {
                    user_id {return $::userId}
                    outputheaders {return headers}
                    default {error "Unexpected ad_conn $key"}
                }
            }
            proc ad_return_url {} {return /storage/index?folder_id=2781645}
            proc db_string args {return 0}
            proc ad_try args {uplevel 1 [list try {*}$args]}
            proc _ key {return $key}
            proc ad_progress_bar_begin args {set ::progressStarted 1}
            proc ad_progress_bar_end args {set ::returnTarget [lindex $args 1]}
            proc ad_mktmpdir {} {
                set path $::testDir/staging
                file mkdir $path
                return $path
            }
            proc ad_tmpnam {} {return $::testDir/archive.zip}
            proc fs::publish_object_to_file_system args {
                set f [open $::testDir/staging/payload w]
                puts $f payload
                close $f
            }
            proc util::zip args {
                set f [open $::testDir/archive.zip wb]
                puts -nonewline $f ZIP-FIXTURE
                close $f
            }
            proc fs::get_file_system_safe_object_name args {return {archive'"&<test>}}
            proc fs::get_file_package_id args {return 123}
            proc fs::get_parent args {return 2781645}
            proc site_node::get_url_from_object_id args {return $::packageUrl}
            proc export_vars {flag base specs} {
                set ::exportBase $base
                set ::exportSpecs $specs
                set pairs {}; set ::exportValues {}
                foreach spec $specs {
                    set name [lindex [split $spec :] 0]
                    set value [uplevel 1 [list set $name]]
                    dict set ::exportValues $name $value
                    lappend pairs "[ns_urlencode -- $name]=[ns_urlencode -- $value]"
                    lappend pairs "[ns_urlencode -- ${name}:sig]=[ns_urlencode -- {7 123 HASH}]"
                }
                set ::generatedUrl "$base?[join $pairs &]"
                return $::generatedUrl
            }
            proc util_user_message args {
                set ::messageArgs $args
                set ::readyMessage [lindex $args [expr {[lsearch -exact $args -message]+1}]]
            }
            proc ns_set {op set name value} {dict set ::responseHeaders $name $value}
            proc ns_returnfile {status type path} {
                set f [open $path rb]
                try {set ::delivered [list $status $type [read $f]]} finally {close $f}
            }
            proc ad_file {op path} {file $op $path}
            proc ns_returnnotfound {} {set ::notFound 1}
            proc ad_script_abort {} {return -code error -errorcode FS_TEST_ABORT abort}
            proc security::csp::nonce {} {return testnonce}
            set userId 143022; set loginChecks 0; set permissionChecks {}
        }
        # Use the actual CSP collector/renderer rather than testing a mock
        # implementation of the destination page's policy requirement.
        set f [open [file join [acs_package_root_dir acs-tcl] tcl security-procs.tcl]]
        try {set text [read $f]} finally {close $f}
        foreach {name arguments defaults} {
            require {directive value} {set force_p 0}
            render {} {}
        } {
            set prefix "ad_proc -public ::security::csp::$name"
            set start [string first "$prefix \{" $text]
            if {$start < 0} {error "Missing declaration: $prefix"}
            set declaration {}
            foreach line [split [string range $text $start end] \n] {
                append declaration $line \n
                if {[info complete $declaration]} break
            }
            interp eval $child [list proc security::csp::$name $arguments "$defaults\n[lindex $declaration end]"]
        }
        foreach packageUrl {/storage/ /storage /demo/storage/ /} {
            interp eval $child [list set packageUrl $packageUrl]
            interp eval $child {
                set contract {object_id 2781645 confirm_p 0 return_url /storage/index?folder_id=2781645}
            }
            interp eval $child [list source [file join $root www download-zip.tcl]]
            aa_equals "ZIP staging files cleaned up ($packageUrl)" [file exists $tmp/staging] 0
            aa_true "Archive retained for the second request ($packageUrl)" [file exists $tmp/archive.zip]
            aa_equals "Download path has exactly one boundary slash ($packageUrl)" \
                [interp eval $child {set exportBase}] "[string trimright $packageUrl /]/download-zip-2"
            set specs [interp eval $child {set exportSpecs}]
            aa_equals "All three signature specs present ($packageUrl)" \
                [join $specs ,] {f:sign(max_age=300),n:sign(max_age=300),u:sign(max_age=300)}
            set message [interp eval $child {set readyMessage}]
            set quoted [ns_quotehtml [interp eval $child {set generatedUrl}]]
            aa_true "Visible localized download link ($packageUrl)" \
                [expr {[string first "<a href='$quoted'>#file-storage.Download_ZIP#</a>" $message]>=0}]
            aa_true "Automatic iframe uses the same escaped URL ($packageUrl)" \
                [expr {[string first "<iframe style='display:none' src='$quoted'></iframe>" $message]>=0}]
            aa_true "Ready message is passed as HTML ($packageUrl)" \
                [expr {[lsearch -exact [interp eval $child {set messageArgs}] -html]>=0}]
            aa_equals "Folder return target is preserved ($packageUrl)" \
                [interp eval $child {set returnTarget}] /storage/index?folder_id=2781645
            # Exercise the actual delivery page, including its ownership check
            # and removal of the completed archive after delivery.
            interp eval $child {set contract $exportValues; set responseHeaders {}}
            interp eval $child [list source [file join $root www download-zip-2.tcl]]
            aa_equals "Archive content is delivered ($packageUrl)" \
                [interp eval $child {set delivered}] {200 application/octet-stream ZIP-FIXTURE}
            aa_equals "ZIP attachment disposition retained ($packageUrl)" \
                [interp eval $child {dict get $responseHeaders Content-Disposition}] \
                {attachment;filename="archive'"&<test>.zip"}
            aa_equals "Archive removed after delivery ($packageUrl)" [file exists $tmp/archive.zip] 0
        }
        # Empty return_url falls back to the file-storage package URL.
        interp eval $child {
            set packageUrl /storage/
            set contract {object_id {2781645 4169041} confirm_p 0 return_url {}}
        }
        interp eval $child [list source [file join $root www download-zip.tcl]]
        aa_equals "Empty return URL falls back to the folder root" \
            [interp eval $child {set returnTarget}] /storage/
        interp eval $child {set contract $exportValues; set userId 0; set notFound 0}
        set code [catch {interp eval $child [list source [file join $root www download-zip-2.tcl]]} result opts]
        aa_equals "Different user cannot collect the archive" [dict get $opts -errorcode] FS_TEST_ABORT
        aa_equals "Ownership failure returns not found" [interp eval $child {set notFound}] 1
        aa_true "Ownership failure does not delete another user's archive" [file exists $tmp/archive.zip]
        interp eval $child {
            unset -nocomplain ::__csp__directive ::__csp__directive_forced
            security::csp::require default-src 'none'
            set userId 143022
        }
        set code [catch {interp eval $child [list source [file join $root www folder-chunk.tcl]]} result opts]
        aa_equals "Folder script reaches the policy setup before data queries" \
            [dict get $opts -errorcode] FS_TEST_STOP
        aa_equals "Destination folder permits only same-origin frames" \
            [interp eval $child {set ::__csp__directive(frame-src)}] {'self'}
        aa_equals "Folder setup preserves restrictive default-src" \
            [interp eval $child {set ::__csp__directive(default-src)}] {'none'}
        set policy [interp eval $child {security::csp::render}]
        aa_true "Rendered policy explicitly permits same-origin frames" \
            [expr {[string first {frame-src 'self';} $policy]>=0}]
        aa_equals "Folder does not add a broad child-src policy" \
            [interp eval $child {info exists ::__csp__directive(child-src)}] 0
    } finally {
        interp delete $child
        file delete -force -- $tmp
    }
}