/usr/share/tcltk/tcllib1.18/amazon-s3/S3.tcl

# S3.tcl
# 
###Abstract
# This presents an interface to Amazon's S3 service.
# The Amazon S3 service allows for reliable storage
# and retrieval of data via HTTP.
#
# Copyright (c) 2006,2008 Darren New. All Rights Reserved.
#
###Copyright
# NO WARRANTIES OF ANY TYPE ARE PROVIDED.
# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS.
#
# This software is licensed under essentially the same 
# terms as Tcl. See LICENSE.txt for the terms.
#
###Revision String
# SCCS: %Z% %M% %I% %E% %U%
# 
###Change history:
# 0.7.2 - added -default-bucket.
# 0.8.0 - fixed bug in getLocal using wrong prefix.
#         Upgraded to Tcl 8.5 release version.
# 1.0.0 - added SetAcl, GetAcl, and -acl keep option.
#

package require Tcl 8.5

# This is by Darren New too. 
# It is a SAX package to format XML for easy retrieval.
# It should be in the same distribution as S3.
package require xsxp

# These three are required to do the auth, so always require them.
#    Note that package registry and package fileutil are required
#    by the individual routines that need them. Grep for "package".
package require sha1
package require md5
package require base64

package provide S3 1.0.3

namespace eval S3 { 
    variable config          ; # A dict holding the current configuration.
    variable config_orig     ; # Holds configuration to "reset" back to.
    variable debug 0         ; # Turns on or off S3::debug
    variable debuglog 0      ; # Turns on or off debugging into a file
    variable bgvar_counter 0 ; # Makes unique names for bgvars.

    set config_orig [dict create \
        -reset false \
        -retries 3 \
        -accesskeyid "" -secretaccesskey "" \
	-service-access-point "s3.amazonaws.com" \
        -slop-seconds 3 \
	-use-tls false \
        -bucket-prefix "TclS3" \
	-default-compare "always" \
	-default-separator "/" \
	-default-acl "" \
	-default-bucket "" \
	]

    set config $config_orig
}

# Internal, for development. Print a line, and maybe log it.
proc S3::debuglogline {line} {
    variable debuglog
    puts $line
    if {$debuglog} {
	set x [open debuglog.txt a]
	puts $x $line
	close $x
    }
}

# Internal, for development. Print debug info properly formatted.
proc S3::debug {args} {
    variable debug
    variable debuglog
    if {!$debug} return
    set res ""
    if {"-hex" == [lindex $args 0]} {
	set str [lindex $args 1]
	foreach ch [split $str {}] {
	    scan $ch %c val
	    append res [format %02x $val] 
	    append res " "
	}
	debuglogline $res
	return
    } 
    if {"-dict" == [lindex $args 0]} {
	set dict [lindex $args 1]
	debuglogline "DEBUG dict:"
	foreach {key val} $dict {
	    set val [string map [list \
		\r \\r \n \\n \0 \\0 ] $val]
	    debuglogline "$key=$val"
	}
	return
    }
    set x [string map [list \
        \r \\r \n \\n \0 \\0 ] $args]
    debuglogline "DEBUG: $x"
}

# Internal. Throws an error if keys have not been initialized.
proc S3::checkinit {} {
    variable config
    set error "S3 must be initialized with -accesskeyid and -secretaccesskey before use" 
    set e1 {S3 usage -accesskeyid "S3 identification not initialized"}
    set e2 {S3 usage -secretaccesskey "S3 identification not initialized"}
    if {[dict get $config -accesskeyid] eq ""} {
	error $error "" $e1
    }
    if {[dict get $config -secretaccesskey] eq ""} { 
	error $error "" $e2
    }
}

# Internal. Calculates the Content-Type for a given file name.
# Naturally returns application/octet-stream if anything goes wrong.
proc S3::contenttype {fname} {
    if {$::tcl_platform(platform) == "windows"} {
	set extension [file extension $fname]
	uplevel #0 package require registry
	set key "\\\\HKEY_CLASSES_ROOT\\"
	set key "HKEY_CLASSES_ROOT\\"
	if {"." != [string index $extension 0]} {append key .}
	append key $extension
	set ct "application/octet-stream"
	if {$extension != ""} {
	    catch {set ct [registry get $key {Content Type}]} caught
	}
    } else {
	# Assume something like Unix.
	if {[file readable /etc/mime.types]} {
	    set extension [string trim [file extension $fname] "."]
	    set f [open /etc/mime.types r]
	    while {-1 != [gets $f line] && ![info exists c]} {
		set line [string trim $line]
		if {[string match "#*" $line]} continue
		if {0 == [string length $line]} continue
		set items [split $line]
		for {set i 1} {$i < [llength $items]} {incr i} {
		    if {[lindex $items $i] eq $extension} {
			set c [lindex $items 0]
			break
		    }
		}
	    }
	    close $f
	    if {![info exists c]} {
		set ct "application/octet-stream"
	    } else {
		set ct [string trim $c]
	    }
	} else {
	    # No /etc/mime.types here.
	    if {[catch {exec file -i $fname} res]} {
		set ct "application/octet-stream"
	    } else {
		set ct [string range $res [expr {1+[string first : $res]}] end]
		if {-1 != [string first ";" $ct]} {
		    set ct [string range $ct 0 [string first ";" $ct]]
		}
		set ct [string trim $ct "; "]
	    }
	}
    }
    return $ct
}

# Change current configuration. Not object-oriented, so only one
# configuration is tracked per interpreter.
proc S3::Configure {args} {
    variable config
    variable config_orig
    if {[llength $args] == 0} {return $config}
    if {[llength $args] == 1 && ![dict exists $config [lindex $args 0]]} {
	error "Bad option \"[lindex $args 0]\": must be [join [dict keys $config] ,\  ]" "" [list S3 usage [lindex $args 0] "Bad option to config"]
    }
    if {[llength $args] == 1} {return [dict get $config [lindex $args 0]]}
    if {[llength $args] % 2 != 0} {
	error "Config args must be -name val -name val" "" [list S3 usage [lindex $args end] "Odd number of config args"]
    }
    set new $config
    foreach {tag val} $args {
	if {![dict exists $new $tag]} {
	    error "Bad option \"$tag\": must be [join [dict keys $config] ,\  ]" "" [list S3 usage $tag "Bad option to config"]
	}
	dict set new $tag $val
	if {$tag eq "-reset" && $val} {
	    set new $config_orig
	}
    }
    if {[dict get $config -use-tls]} {
	error "TLS for S3 not yet implemented!" "" \
	    [list S3 notyet -use-tls $config]
    }
    set config $new ; # Only update if all went well
    return $config
}

# Suggest a unique bucket name based on usename and config info.
proc S3::SuggestBucket {{usename ""}} {
    checkinit
    if {$usename eq ""} {set usename [::S3::Configure -bucket-prefix]}
    if {$usename eq ""} {
	error "S3::SuggestBucket requires name or -bucket-prefix set" \
	"" [list S3 usage -bucket-prefix]
    }
    return $usename\.[::S3::Configure -accesskeyid]
}

# Calculate authorization token for REST interaction.
# Doesn't work yet for "Expires" type headers. Hence, only for "REST".
# We specifically don't call checkinit because it's called in all
# callers and we don't want to throw an error inside here.
# Caveat Emptor if you expect otherwise.
# This is internal, but useful enough you might want to invoke it.
proc S3::authREST {verb resource content-type headers args} {
    if {[llength $args] != 0} {
	set body [lindex $args 0] ; # we use [info exists] later
    }
    if {${content-type} != "" && [dict exists $headers content-type]} {
	set content-type [dict get $headers content-type]
    }
    dict unset headers content-type
    set verb [string toupper $verb]
    if {[info exists body]} {
	set content-md5 [::base64::encode [::md5::md5 $body]]
	dict set headers content-md5 ${content-md5}
	dict set headers content-length [string length $body]
    } elseif {[dict exists $headers content-md5]} {
	set content-md5 [dict get $headers content-md5]
    } else {
	set content-md5 ""
    }
    if {[dict exists $headers x-amz-date]} {
	set date ""
	dict unset headers date
    } elseif {[dict exists $headers date]} {
	set date [dict get $headers date]
    } else {
	set date [clock format [clock seconds] -gmt true -format \
	    "%a, %d %b %Y %T %Z"]
	dict set headers date $date
    }
    if {${content-type} != ""} {
	dict set headers content-type ${content-type}
    }
    dict set headers host s3.amazonaws.com
    set xamz ""
    foreach key [lsort [dict keys $headers x-amz-*]] {
	# Assume each is seen only once, for now, and is canonical already.
        append xamz \n[string trim $key]:[string trim [dict get $headers $key]]
    }
    set xamz [string trim $xamz]
    # Hmmm... Amazon lies. No \n after xamz if xamz is empty.
    if {0 != [string length $xamz]} {append xamz \n}
    set signthis \
        "$verb\n${content-md5}\n${content-type}\n$date\n$xamz$resource"
    S3::debug "Sign this:" $signthis ; S3::debug -hex $signthis 
    set sig [::sha1::hmac [S3::Configure -secretaccesskey] $signthis]
    set sig [binary format H* $sig]
    set sig [string trim [::base64::encode $sig]]
    dict set headers authorization "AWS [S3::Configure -accesskeyid]:$sig"
    return $headers
}

# Internal. Takes resource and parameters, tacks them together.
# Useful enough you might want to invoke it yourself.
proc S3::to_url {resource parameters} {
    if {0 == [llength $parameters]} {return $resource}
    if {-1 == [string first "?" $resource]} {
	set front ?
    } else {
	set front &
    }
    foreach {key value} $parameters {
	append resource $front $key "=" $value
	set front &
    }
    return $resource
}

# Internal. Encode a URL, including utf-8 versions.
# Useful enough you might want to invoke it yourself.
proc S3::encode_url {orig} {
    set res ""
    set re {[-a-zA-Z0-9/.,_]}
    foreach ch [split $orig ""] {
	if {[regexp $re $ch]} {
	    append res $ch
	} else {
	    foreach uch [split [encoding convertto utf-8 $ch] ""] {
		append res "%"
		binary scan $uch H2 hex
		append res $hex
	    }
	}
    }
    if {$res ne $orig} {
	S3::debug "URL Encoded:" $orig $res
    }
    return $res
}

# This is used internally to either queue an event-driven
# item or to simply call the next routine, depending on
# whether the current transaction is supposed to be running
# in the background or not.
proc S3::nextdo {routine thunk direction args} {
    global errorCode
    S3::debug "nextdo" $routine $thunk $direction $args
    if {[dict get $thunk blocking]} {
	return [S3::$routine $thunk]
    } else {
	if {[llength $args] == 2} {
	    # fcopy failed!
	    S3::fail $thunk "S3 fcopy failed: [lindex $args 1]" "" \
		[list S3 socket $errorCode]
	} else {
	    fileevent [dict get $thunk S3chan] $direction \
		[list S3::$routine $thunk]
	    if {$direction == "writable"} {
		fileevent [dict get $thunk S3chan] readable {}
	    } else {
		fileevent [dict get $thunk S3chan] writable {}
	    }
	}
    }
}

# The proverbial It.  Do a REST call to Amazon S3 service.
proc S3::REST {orig} {
    variable config
    checkinit
    set EndPoint [dict get $config -service-access-point]
    
    # Save the original stuff first.
    set thunk [dict create orig $orig]

    # Now add to thunk's top-level the important things
    if {[dict exists $thunk orig resultvar]} {
	dict set thunk blocking 0
    } else {
	dict set thunk blocking 1
    }
    if {[dict exists $thunk orig S3chan]} {
	dict set thunk S3chan [dict get $thunk orig S3chan]
    } elseif {[dict get $thunk blocking]} {
	dict set thunk S3chan [socket $EndPoint 80]
    } else {
	dict set thunk S3chan [socket -async $EndPoint 80]
    }
    fconfigure [dict get $thunk S3chan] -translation binary -encoding binary

    dict set thunk verb [dict get $thunk orig verb]
    dict set thunk resource [S3::encode_url [dict get $thunk orig resource]]
    if {[dict exists $orig rtype]} {
	dict set thunk resource \
	    [dict get $thunk resource]?[dict get $orig rtype]
    }
    if {[dict exists $orig headers]} {
	dict set thunk headers [dict get $orig headers]
    } else {
	dict set thunk headers [dict create]
    }
    if {[dict exists $orig infile]} {
	dict set thunk infile [dict get $orig infile]
    }
    if {[dict exists $orig content-type]} {
	dict set thunk content-type [dict get $orig content-type]
    } else {
	if {[dict exists $thunk infile]} {
	    set zz [dict get $thunk infile]
	} else {
	    set zz [dict get $thunk resource]
	}
	if {-1 != [string first "?" $zz]} {
	    set zz [string range $zz 0 [expr {[string first "?" $zz]-1}]]
	    set zz [string trim $zz]
	}
	if {$zz != ""} {
	    catch {dict set thunk content-type [S3::contenttype $zz]}
	} else {
	    dict set thunk content-type application/octet-stream
	    dict set thunk content-type ""
	}
    }
    set p {}
    if {[dict exist $thunk orig parameters]} {
	set p [dict get $thunk orig parameters]
    }
    dict set thunk url [S3::to_url [dict get $thunk resource] $p]

    if {[dict exists $thunk orig inbody]} {
        dict set thunk headers [S3::authREST \
            [dict get $thunk verb] [dict get $thunk resource] \
            [dict get $thunk content-type] [dict get $thunk headers] \
	    [dict get $thunk orig inbody] ]
    } else {
        dict set thunk headers [S3::authREST \
            [dict get $thunk verb] [dict get $thunk resource] \
            [dict get $thunk content-type] [dict get $thunk headers] ]
    }
    # Not the best place to put this code.
    if {![info exists body] && [dict exists $thunk infile]} {
	set size [file size [dict get $thunk infile]]
	set x [dict get $thunk headers]
	dict set x content-length $size
	dict set thunk headers $x
    }


    # Ready to go!
    return [S3::nextdo send_headers $thunk writable]
}

# Internal. Send the headers to Amazon. Might block if you have
# really small socket buffers, but Amazon doesn't want
# data that big anyway.
proc S3::send_headers {thunk} {
    S3::debug "Send-headers" $thunk 
    set s3 [dict get $thunk S3chan]
    puts $s3 "[dict get $thunk verb] [dict get $thunk url] HTTP/1.0"
    S3::debug ">> [dict get $thunk verb] [dict get $thunk url] HTTP/1.0"
    foreach {key val} [dict get $thunk headers] {
	puts $s3 "$key: $val"
	S3::debug ">> $key: $val"
    }
    puts $s3 ""
    flush $s3
    return [S3::nextdo send_body $thunk writable]
}

# Internal. Send the body to Amazon.
proc S3::send_body {thunk} {
    global errorCode
    set s3 [dict get $thunk S3chan]
    if {[dict exists $thunk orig inbody]} {
	# Send a string. Let's guess that even in non-blocking
	# mode, this is small enough or Tcl's smart enough that
	# we don't blow up the buffer.
	puts -nonewline $s3 [dict get $thunk orig inbody]
	flush $s3
	return [S3::nextdo read_headers $thunk readable]
    } elseif {![dict exists $thunk orig infile]} {
	# No body, no file, so nothing more to do.
	return [S3::nextdo read_headers $thunk readable]
    } elseif {[dict get $thunk blocking]} {
	# A blocking file copy. Still not too hard.
	if {[catch {set inchan [open [dict get $thunk infile] r]} caught]} {
	    S3::fail $thunk "S3 could not open infile - $caught" "" \
		[list S3 local [dict get $thunk infile] $errorCode]
	}
	fconfigure $inchan -translation binary -encoding binary
	fileevent $s3 readable {}
	fileevent $s3 writable {}
	if {[catch {fcopy $inchan $s3 ; flush $s3 ; close $inchan} caught]} {
	    S3::fail $thunk "S3 could not copy infile - $caught" "" \
		[list S3 local [dict get $thunk infile] $errorCode]
	}
	S3::nextdo read_headers $thunk readable
    } else {
	# The hard one. Background file copy.
	fileevent $s3 readable {}
	fileevent $s3 writable {}
	if {[catch {set inchan [open [dict get $thunk infile] r]} caught]} {
	    S3::fail $thunk "S3 could not open infile - $caught" "" \
		[list S3 local [dict get $thunk infile] $errorCode]
	}
	fconfigure $inchan -buffering none -translation binary -encoding binary
	fconfigure $s3 -buffering none -translation binary \
	    -encoding binary -blocking 0 ; # Doesn't work without this?
	dict set thunk inchan $inchan ; # So we can close it.
        fcopy $inchan $s3 -command \
	    [list S3::nextdo read_headers $thunk readable]
    }
}

# Internal. The first line has come back. Grab out the 
# stuff we care about.
proc S3::parse_status {thunk line} {
    # Got the status line
    S3::debug "<< $line"
    dict set thunk httpstatusline [string trim $line]
    dict set thunk outheaders [dict create]
    regexp {^HTTP/1.. (...) (.*)$} $line junk code message
    dict set thunk httpstatus $code
    dict set thunk httpmessage [string trim $message]
    return $thunk
}

# A line of header information has come back. Grab it.
# This probably is unhappy with multiple lines for one 
# header.
proc S3::parse_header {thunk line} {
    # Got a header line. For now, assume no continuations.
    S3::debug "<< $line"
    set line [string trim $line]
    set left [string range $line 0 [expr {[string first ":" $line]-1}]]
    set right [string range $line [expr {[string first ":" $line]+1}] end]
    set left [string trim [string tolower $left]]
    set right [string trim $right]
    dict set thunk outheaders $left $right
    return $thunk
}

# I don't know if HTTP requires a blank line after the headers if
# there's no body.

# Internal. Read all the headers, and throw if we get EOF before
# we get any headers at all.
proc S3::read_headers {thunk} {
    set s3 [dict get $thunk S3chan]
    flush $s3
    fconfigure $s3 -blocking [dict get $thunk blocking] 
    if {[dict get $thunk blocking]} {
	# Blocking. Just read to a blank line. Otherwise,
	# if we use nextdo here, we wind up nesting horribly.
	# If we're not blocking, of course, we're returning
	# to the event loop each time, so that's OK.
	set count [gets $s3 line]
	if {[eof $s3]} {
	    S3::fail $thunk "S3 EOF during status line read" "" "S3 socket EOF"
	}
	set thunk [S3::parse_status $thunk $line]
	while {[string trim $line] != ""} {
	    set count [gets $s3 line]
	    if {$count == -1 && 0 == [dict size [dict get $thunk outheaders]]} {
		S3::fail $thunk "S3 EOF during headers read" "" "S3 socket EOF"
	    }
	    if {[string trim $line] != ""} {
		set thunk [S3::parse_header $thunk $line]
	    }
	}
	return [S3::nextdo read_body $thunk readable]
    } else {
	# Non-blocking, so we have to reenter for each line.
	#  First, fix up the file handle, tho.
	if {[dict exists $thunk inchan]} {
	    close [dict get $thunk inchan]
	    dict unset thunk inchan
	}
	# Now get one header.
	set count [gets $s3 line]
	if {[eof $s3]} {
	    fileevent $s3 readable {}
	    fileevent $s3 writable {}
	    if {![dict exists $thunk httpstatusline]} {
		S3::fail $thunk "S3 EOF during status line read" "" "S3 socket EOF"
	    } elseif {0 == [dict size [dict get $thunk outheaders]]} {
		S3::fail $thunk "S3 EOF during header read" "" "S3 socket EOF"
	    }
	}
	if {$count < 0} return ; # Wait for a whole line
	set line [string trim $line]
	if {![dict exists $thunk httpstatus]} {
	    set thunk [S3::parse_status $thunk $line]
	    S3::nextdo read_headers $thunk readable ; # New thunk here.
	} elseif {$line != ""} {
	    set thunk [S3::parse_header $thunk $line]
	    S3::nextdo read_headers $thunk readable ; # New thunk here.
	} else {
	    # Got an empty line. Switch to copying the body.
	    S3::nextdo read_body $thunk readable
	}
    }
}

# Internal. Read the body of the response.
proc S3::read_body {thunk} {
    set s3 [dict get $thunk S3chan]
    if {[dict get $thunk blocking]} {
	# Easy. Just read it.
	if {[dict exists $thunk orig outchan]} {
	    fcopy $s3 [dict get $thunk orig outchan]
	} else {
	    set x [read $s3]
	    dict set thunk outbody $x
	    #S3::debug "Body: $x" -- Disable unconditional wasteful conversion to string
	    #Need better debug system which does this only when active.
	}
	return [S3::nextdo all_done $thunk readable]
    } else {
	# Nonblocking mode. 
	if {[dict exists $thunk orig outchan]} {
	    fileevent $s3 readable {}
	    fileevent $s3 writable {}
	    fcopy $s3 [dict get $thunk orig outchan] -command \
	        [list S3::nextdo all_done $thunk readable]
        } else {
            dict append thunk outbody [read $s3]
	    if {[eof $s3]} {
		# We're done.
		S3::nextdo all_done $thunk readable
	    } else {
		S3::nextdo read_body $thunk readable
	    }
	}
    }
}

# Internal. Convenience function.
proc S3::fail {thunk error errorInfo errorCode} {
    S3::all_done $thunk $error $errorInfo $errorCode
}

# Internal. We're all done the transaction. Clean up everything,
# potentially record errors, close channels, etc etc etc.
proc S3::all_done {thunk {error ""} {errorInfo ""} {errorCode ""}} {
    set s3 [dict get $thunk S3chan]
    catch {
	fileevent $s3 readable {}
	fileevent $s3 writable {}
    }
    if {![dict exists $thunk orig S3chan]} {
	catch {close $s3}
    }
    set res [dict get $thunk orig]
    catch {
	dict set res httpstatus [dict get $thunk httpstatus]
	dict set res httpmessage [dict get $thunk httpmessage]
	dict set res outheaders [dict get $thunk outheaders]
    }
    if {![dict exists $thunk orig outchan]} {
	if {[dict exists $thunk outbody]} {
	    dict set res outbody [dict get $thunk outbody]
	} else {
	    # Probably HTTP failure
	    dict set rest outbody {}
	}
    }
    if {$error ne ""} {
	dict set res error $error
	dict set res errorInfo $errorInfo
	dict set res errorCode $errorCode
    }
    if {![dict get $thunk blocking]} {
	after 0 [list uplevel #0 \
	    [list set [dict get $thunk orig resultvar] $res]]
    }
    if {$error eq "" || ![dict get $thunk blocking] || \
	([dict exists $thunk orig throwsocket] && \
	    "return" == [dict get $thunk orig throwsocket])} {
	return $res
    } else {
	error $error $errorInfo $errorCode
    }
}

# Internal. Parse the lst and make sure it has only keys from the 'valid' list.
# Used to parse arguments going into the higher-level functions.
proc S3::parseargs1 {lst valid} {
    if {[llength $lst] % 2 != 0} {
	error "Option list must be even -name val pairs" \
	    "" [list S3 usage [lindex $lst end] $lst]
    }
    foreach {key val} $lst {
	# Sadly, lsearch applies -glob to the wrong thing for our needs
	set found 0
	foreach v $valid {
	    if {[string match $v $key]} {set found 1 ; break}
	}
	if {!$found} {
	    error "Option list has invalid -key" \
		"" [list S3 usage $key $lst]
	}
    }
    return $lst ; # It seems OK
}

# Internal. Create a variable for higher-level functions to vwait.
proc S3::bgvar {} {
    variable bgvar_counter
    incr bgvar_counter
    set name ::S3::bgvar$bgvar_counter
    return $name
}

# Internal. Given a request and the arguments, run the S3::REST in
# the foreground or the background as appropriate. Also, do retries
# for internal errors.
proc S3::maybebackground {req myargs} {
    variable config
    global errorCode errorInfo
    set mytries [expr {1+[dict get $config -retries]}]
    set delay 2000
    dict set req throwsocket return
    while {1} {
	if {![dict exists $myargs -blocking] || [dict get $myargs -blocking]} {
	    set dict [S3::REST $req]
	} else {
	    set res [bgvar]
	    dict set req resultvar $res
	    S3::REST $req
	    vwait $res
	    set dict [set $res]
	    unset $res ; # clean up temps
	}
	if {[dict exists $dict error]} {
	    set code [dict get $dict errorCode]
	    if {"S3" != [lindex $code 0] || "socket" != [lindex $code 1]} {
		error [dict get $dict error] \
		    [dict get $dict errorInfo] \
		    [dict get $dict errorCode]
	    }
	}
	incr mytries -1
	incr delay $delay ; if {20000 < $delay} {set delay 20000}
	if {"500" ne [dict get $dict httpstatus] || $mytries <= 0} {
	    return $dict
	}
	if {![dict exists $myargs -blocking] || [dict get $myargs -blocking]} {
	    after $delay
	} else {
	    set timer [bgvar]
	    after $delay [list set $timer 1]
	    vwait $timer
	    unset $timer
	}
    }
}

# Internal. Maybe throw an HTTP error if httpstatus not in 200 range.
proc S3::throwhttp {dict} {
    set hs [dict get $dict httpstatus]
    if {![string match "2??" $hs]} {
	error "S3 received non-OK HTTP result of $hs"  "" \
	    [list S3 remote $hs $dict]
    }
}

# Public. Returns the list of buckets for this user.
proc S3::ListAllMyBuckets {args} {
    checkinit ; # I know this gets done later.
    set myargs [S3::parseargs1 $args {-blocking -parse-xml -result-type}]
    if {![dict exists $myargs -result-type]} {
	dict set myargs -result-type names
    }
    if {![dict exists $myargs -blocking]} {
	dict set myargs -blocking true
    }
    set restype [dict get $myargs -result-type]
    if {$restype eq "REST" && [dict exists $myargs -parse-xml]} {
	error "Do not use REST with -parse-xml" "" \
	    [list S3 usage -parse-xml $args]
    }
    if {![dict exists $myargs -parse-xml]} {
	# We need to fetch the results.
	set req [dict create verb GET resource /]
	set dict [S3::maybebackground $req $myargs]
	if {$restype eq "REST"} {
	    return $dict ; #we're done!
	}
	S3::throwhttp $dict ; #make sure it worked.
	set xml [dict get $dict outbody] 
    } else {
	set xml [dict get $myargs -parse-xml]
    }
    # Here, we either already returned the dict, or the XML is in "xml".
    if {$restype eq "xml"} {return $xml}
    if {[catch {set pxml [::xsxp::parse $xml]}]} {
	error "S3 invalid XML structure" "" [list S3 usage xml $xml]
    }
    if {$restype eq "pxml"} {return $pxml}
    if {$restype eq "dict" || $restype eq "names"} {
	set buckets [::xsxp::fetch $pxml "Buckets" %CHILDREN]
	set names {} ; set dates {}
	foreach bucket $buckets {
	    lappend names [::xsxp::fetch $bucket "Name" %PCDATA]
	    lappend dates [::xsxp::fetch $bucket "CreationDate" %PCDATA]
	}
	if {$restype eq "names"} {
	    return $names
	} else {
	    return [dict create \
		Owner/ID [::xsxp::fetch $pxml "Owner/ID" %PCDATA] \
		Owner/DisplayName \
		    [::xsxp::fetch $pxml "Owner/DisplayName" %PCDATA] \
		Bucket/Name $names Bucket/Date $dates \
	    ]
	}
    }
    if {$restype eq "owner"} {
	return [list [::xsxp::fetch $pxml Owner/ID %PCDATA] \
	    [::xsxp::fetch $pxml Owner/DisplayName %PCDATA] ]
    }
    error "ListAllMyBuckets requires -result-type to be REST, xml, pxml, dict, owner, or names" "" [list S3 usage -result-type $args]
}

# Public. Create a bucket.
proc S3::PutBucket {args} {
    checkinit
    set myargs [S3::parseargs1 $args {-blocking -bucket -acl}]
    if {![dict exists $myargs -acl]} {
	dict set myargs -acl [S3::Configure -default-acl]
    }
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict exists $myargs -bucket]} {
	error "PutBucket requires -bucket" "" [list S3 usage -bucket $args]
    }

    set req [dict create verb PUT resource /[dict get $myargs -bucket]]
    if {[dict exists $myargs -acl]} {
	dict set req headers [list x-amz-acl [dict get $myargs -acl]]
    }
    set dict [S3::maybebackground $req $myargs]
    S3::throwhttp $dict
    return "" ; # until we decide what to return.
}

# Public. Delete a bucket.
proc S3::DeleteBucket {args} {
    checkinit
    set myargs [S3::parseargs1 $args {-blocking -bucket}]
    if {![dict exists $myargs -bucket]} {
	error "DeleteBucket requires -bucket" "" [list S3 usage -bucket $args]
    }
    dict set myargs -bucket [string trim [dict get $args -bucket] "/ "]

    set req [dict create verb DELETE resource /[dict get $myargs -bucket]]
    set dict [S3::maybebackground $req $myargs]
    S3::throwhttp $dict
    return "" ; # until we decide what to return.
}

# Internal. Suck out the one and only answer from the list, if needed.
proc S3::firstif {list myargs} {
    if {[dict exists $myargs -max-keys]} {
	return [lindex $list 0]
    } else {
	return $list
    }
}

# Public. Get the list of resources within a bucket.
proc S3::GetBucket {args} {
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -parse-xml -max-keys 
	-result-type -prefix -delimiter
	-TEST
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "GetBucket requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {[dict get $myargs -bucket] eq ""} {
	error "GetBucket requires -bucket nonempty" "" \
	    [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -result-type]} {
	dict set myargs -result-type names
    }
    if {[dict get $myargs -result-type] eq "REST" && \
	    [dict exists $myargs "-parse-xml"]} {
	error "GetBucket can't have -parse-xml with REST result" "" \
	    [list S3 usage -parse-xml $args]
    }
    set req [dict create verb GET resource /[dict get $myargs -bucket]]
    set parameters {}
    # Now, just to make test cases easier...
    if {[dict exists $myargs -TEST]} {
	dict set parameters max-keys [dict get $myargs -TEST]
    }
    # Back to your regularly scheduled argument parsing
    if {[dict exists $myargs -max-keys]} {
	dict set parameters max-keys [dict get $myargs -max-keys]
    }
    if {[dict exists $myargs -prefix]} {
	set p [dict get $myargs -prefix]
	if {[string match "/*" $p]} {
	    set p [string range $p 1 end]
	}
	dict set parameters prefix $p
    }
    if {[dict exists $myargs -delimiter]} {
	dict set parameters delimiter [dict get $myargs -delimiter]
    }
    set nextmarker0 {} ; # We use this for -result-type dict.
    if {![dict exists $myargs -parse-xml]} {
	# Go fetch answers.
	#   Current xaction in "0" vars, with accumulation in "L" vars.
	#   Ultimate result of this loop is $RESTL, a list of REST results.
	set RESTL [list]
	while {1} {
	    set req0 $req ; dict set req0 parameters $parameters
	    set REST0 [S3::maybebackground $req0 $myargs]
	    S3::throwhttp $REST0
	    lappend RESTL $REST0
	    if {[dict exists $myargs -max-keys]} {
		# We were given a limit, so just return the answer.
		break
	    }
	    set pxml0 [::xsxp::parse [dict get $REST0 outbody]]
	    set trunc0 [expr "true" eq \
		[::xsxp::fetch $pxml0 IsTruncated %PCDATA]]
	    if {!$trunc0} {
		# We've retrieved the final block, so go parse it.
		set nextmarker0 "" ; # For later.
		break
	    }
	    # Find the highest contents entry. (Would have been
	    # easier if Amazon always supplied NextMarker.)
	    set nextmarker0 {}
	    foreach {only tag} {Contents Key CommonPrefixes Prefix} {
		set only0 [::xsxp::only $pxml0 $only]
		if {0 < [llength $only0]} {
		    set k0 [::xsxp::fetch [lindex $only0 end] $tag %PCDATA]
		    if {[string compare $nextmarker0 $k0] < 0} {
			set nextmarker0 $k0
		    }
		}
	    }
	    if {$nextmarker0 eq ""} {error "Internal Error in S3 library"}
	    # Here we have the next marker, so fetch the next REST
	    dict set parameters marker $nextmarker0
	    # Note - $nextmarker0 is used way down below again!
	}
	# OK, at this point, the caller did not provide the xml via -parse-xml
	# And now we have a list of REST results. So let's process.
	if {[dict get $myargs -result-type] eq "REST"} {
	    return [S3::firstif $RESTL $myargs]
	}
	set xmlL [list]
	foreach entry $RESTL {
	    lappend xmlL [dict get $entry outbody]
	}
	unset RESTL ; # just to save memory
    } else {
	# Well, we've parsed out the XML from the REST, 
	# so we're ready for -parse-xml
	set xmlL [list [dict get $myargs -parse-xml]]
    }
    if {[dict get $myargs -result-type] eq "xml"} {
	return [S3::firstif $xmlL $myargs]
    }
    set pxmlL [list]
    foreach xml $xmlL {
	lappend pxmlL [::xsxp::parse $xml]
    }
    unset xmlL
    if {[dict get $myargs -result-type] eq "pxml"} {
	return [S3::firstif $pxmlL $myargs]
    }
    # Here, for result types of "names" and "dict",
    # we need to actually parse out all the results.
    if {[dict get $myargs -result-type] eq "names"} {
	# The easy one.
	set names [list]
	foreach pxml $pxmlL {
	    set con0 [::xsxp::only $pxml Contents]
	    set con1 [::xsxp::only $pxml CommonPrefixes]
	    lappend names {*}[concat [::xsxp::fetchall $con0 Key %PCDATA] \
		[::xsxp::fetchall $con1 Prefix %PCDATA]]
	}
	return [lsort $names]
    } elseif {[dict get $myargs -result-type] eq "dict"} {
	# The harder one.
	set last0 [lindex $pxmlL end]
	set res [dict create]
	foreach thing {Name Prefix Marker MaxKeys IsTruncated} {
	    dict set res $thing [::xsxp::fetch $last0 $thing %PCDATA?]
	}
	dict set res NextMarker $nextmarker0 ; # From way up above.
	set Prefix [list]
	set names {Key LastModified ETag Size Owner/ID Owner/DisplayName StorageClass}
	foreach name $names {set $name [list]}
	foreach pxml $pxmlL {
	    foreach tag [::xsxp::only $pxml CommonPrefixes] {
		lappend Prefix [::xsxp::fetch $tag Prefix %PCDATA]
	    }
	    foreach tag [::xsxp::only $pxml Contents] {
		foreach name $names {
		    lappend $name [::xsxp::fetch $tag $name %PCDATA]
		}
	    }
	}
	dict set res CommonPrefixes/Prefix $Prefix
	foreach name $names {dict set res $name [set $name]}
	return $res
    } else {
	# The hardest one ;-)
	error "GetBucket Invalid result type, must be REST, xml, pxml, names, or dict" "" [list S3 usage -result-type $args]
    }
}

# Internal. Compare a resource to a file.
# Returns 1 if they're different, 0 if they're the same.
#   Note that using If-Modified-Since and/or If-Match,If-None-Match
#   might wind up being more efficient than pulling the head
#   and checking. However, this allows for slop, checking both
#   the etag and the date, only generating local etag if the
#   date and length indicate they're the same, and so on.
# Direction is G or P for Get or Put.
# Assumes the source always exists. Obviously, Get and Put will throw if not,
# but not because of this.
proc S3::compare {myargs direction} {
    variable config
    global errorInfo
    set compare [dict get $myargs -compare]
    if {$compare ni {always never exists missing newer date checksum different}} {
	error "-compare must be always, never, exists, missing, newer, date, checksum, or different" "" \
	    [list S3 usage -compare $myargs]
    }
    if {"never" eq $compare} {return 0}
    if {"always" eq $compare} {return 1}
    if {[dict exists $myargs -file] && [file exists [dict get $myargs -file]]} {
	set local_exists 1
    } else {
	set local_exists 0
    }
    # Avoid hitting S3 if we don't need to.
    if {$direction eq "G" && "exists" eq $compare} {return $local_exists}
    if {$direction eq "G" && "missing" eq $compare} {
	return [expr !$local_exists]
    }
    # We need to get the headers from the resource.
    set req [dict create \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
	verb HEAD ]
    set res [S3::maybebackground $req $myargs]
    set httpstatus [dict get $res httpstatus]
    if {"404" eq $httpstatus} {
	set remote_exists 0
    } elseif {[string match "2??" $httpstatus]} {
	set remote_exists 1
    } else {
	error "S3: Neither 404 or 2xx on conditional compare" "" \
	    [list S3 remote $httpstatus $res]
    } 
    if {$direction eq "P"} {
	if {"exists" eq $compare} {return $remote_exists}
	if {"missing" eq $compare} {return [expr {!$remote_exists}]}
	if {!$remote_exists} {return 1}
    } elseif {$direction eq "G"} {
	# Actually already handled above, but it never hurts...
	if {"exists" eq $compare} {return $local_exists}
	if {"missing" eq $compare} {return [expr {!$local_exists}]}
    }
    set outheaders [dict get $res outheaders]
    if {[dict exists $outheaders content-length]} {
	set remote_length [dict get $outheaders content-length]
    } else {
	set remote_length -1
    }
    if {[dict exists $outheaders etag]} {
	set remote_etag [string tolower \
	    [string trim [dict get $outheaders etag] \"]]
    } else {
	set remote_etag "YYY"
    }
    if {[dict exists $outheaders last-modified]} {
	set remote_date [clock scan [dict get $outheaders last-modified]]
    } else {
	set remote_date -1
    }
    if {[dict exists $myargs -content]} {
	# Probably should work this out better...
	#set local_length [string length [encoding convert-to utf-8 \
	    #[dict get $myargs -content]]]
	set local_length [string length [dict get $myargs -content]]
    } elseif {$local_exists} {
	if {[catch {file size [dict get $myargs -file]} local_length]} {
	    error "S3: Couldn't stat [dict get $myargs -file]" "" \
		[list S3 local $errorInfo]
	}
    } else {
	set local_length -2
    }
    if {[dict exists $myargs -content]} {
	set local_date [clock seconds]
    } elseif {$local_exists} {
	set local_date [file mtime [dict get $myargs -file]]
	# Shouldn't throw, since [file size] worked.
    } else {
	set local_date -2
    }
    if {$direction eq "P"} {
	if {"newer" eq $compare} {
	    if {$remote_date < $local_date - [dict get $config -slop-seconds]} {
		return 1 ; # Yes, local is newer
	    } else {
		return 0 ; # Older, or the same
	    }
	}
    } elseif {$direction eq "G"} {
	if {"newer" eq $compare} {
	    if {$local_date < $remote_date - [dict get $config -slop-seconds]} {
		return 1 ; # Yes, remote is later.
	    } else {
		return 0 ; # Local is older or same.
	    }
	}
    }
    if {[dict get $config -slop-seconds] <= abs($local_date - $remote_date)} {
	set date_diff 1 ; # Difference is greater
    } else {
	set date_diff 0 ; # Difference negligible
    }
    if {"date" eq $compare} {return $date_diff}
    if {"different" eq $compare && [dict exists $myargs -file] && $date_diff} {
	return 1
    }
    # Date's the same, but we're also interested in content, so check the rest
    # Only others to handle are checksum and different-with-matching-dates
    if {$local_length != $remote_length} {return 1} ; #easy quick case
    if {[dict exists $myargs -file] && $local_exists} {
	if {[catch {
	    # Maybe deal with making this backgroundable too?
	    set local_etag [string tolower \
		[::md5::md5 -hex -filename [dict get $myargs -file]]]
	} caught]} {
	    # Maybe you can stat but not read it?
	    error "S3 could not hash file" "" \
		[list S3 local [dict get $myargs -file] $errorInfo]
	}
    } elseif {[dict exists $myargs -content]} {
	set local_etag [string tolower \
	    [string tolower [::md5::md5 -hex [dict get $myargs -content]]]]
    } else {
	set local_etag "XXX"
    }
    # puts "local:  $local_etag\nremote: $remote_etag"
    if {$local_etag eq $remote_etag} {return 0} {return 1}
}

# Internal. Calculates the ACL based on file permissions.
proc S3::calcacl {myargs} {
    # How would one work this under Windows, then?
    # Silly way: invoke [exec cacls $filename],
    # parse the result looking for Everyone:F or Everyone:R
    # Messy security if someone replaces the cacls.exe or something.
    error "S3 Not Yet Implemented" "" [list S3 notyet calcacl $myargs]
    set result [S3::Configure -default-acl]
    catch {
	set chmod [file attributes [dict get $myargs -file] -permissions]
	set chmod [expr {$chmod & 6}]
	if {$chmod == 0} {set result private}
	if {$chmod == 2} {set result public-write}
	if {$chmod == 6} {set result public-read-write}
    }
}

# Public. Put a resource into a bucket.
proc S3::Put {args} {
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -file -content -resource -acl
	-content-type -x-amz-meta-* -compare
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Put requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -blocking]} {
	dict set myargs -blocking true
    }
    if {![dict exists $myargs -file] && ![dict exists $myargs -content]} {
	error "Put requires -file or -content" "" [list S3 usage -file $args]
    }
    if {[dict exists $myargs -file] && [dict exists $myargs -content]} {
	error "Put says -file, -content mutually exclusive" "" [list S3 usage -file $args]
    }
    if {![dict exists $myargs -resource]} {
	error "Put requires -resource" "" [list S3 usage -resource $args]
    }
    if {![dict exists $myargs -compare]} {
	dict set myargs -compare [S3::Configure -default-compare]
    }
    if {![dict exists $myargs -acl] && "" ne [S3::Configure -default-acl]} {
	dict set myargs -acl [S3::Configure -default-acl]
    }
    if {[dict exists $myargs -file] && \
	    "never" ne [dict get $myargs -compare] && \
	    ![file exists [dict get $myargs -file]]} {
	error "Put -file doesn't exist: [dict get $myargs -file]" \
	    "" [list S3 usage -file $args]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    # See if we need to copy it.
    set comp [S3::compare $myargs P]
    if {!$comp} {return 0} ;  # skip it, then.

    # Oookeydookey. At this point, we're actually going to send 
    # the file, so all we need to do is build the request array.
    set req [dict create verb PUT \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
    if {[dict exists $myargs -file]} {
	dict set req infile [dict get $myargs -file]
    } else {
	dict set req inbody [dict get $myargs -content]
    }
    if {[dict exists $myargs -content-type]} {
	dict set req content-type [dict get $myargs -content-type]
    }
    set headers {}
    foreach xhead [dict keys $myargs -x-amz-meta-*] {
	dict set headers [string range $xhead 1 end] [dict get $myargs $xhead]
    }
    set xmlacl "" ; # For calc and keep
    if {[dict exists $myargs -acl]} {
	if {[dict get $myargs -acl] eq "calc"} {
	    # We could make this more complicated by 
	    # assigning it to xmlacl after building it.
	    dict set myargs -acl [S3::calcacl $myargs]
	} elseif {[dict get $myargs -acl] eq "keep"} {
	    dict set myargs -acl [S3::Configure -default-acl]
	    catch {
		set xmlacl [S3::GetAcl \
		    -bucket [dict get $myargs -bucket] \
		    -resource [dict get $myargs -resource] \
		    -blocking [dict get $myargs -blocking] \
		    -result-type xml]
	    }
	}
	dict set headers x-amz-acl [dict get $myargs -acl]
    }
    dict set req headers $headers
    # That should do it.
    set res [S3::maybebackground $req $myargs]
    S3::throwhttp $res
    if {"<" == [string index $xmlacl 0]} {
	# Set the saved ACL back on the new object
	S3::PutAcl \
	    -bucket [dict get $myargs -bucket] \
	    -resource [dict get $myargs -resource] \
	    -blocking [dict get $myargs -blocking] \
	    -acl $xmlacl
    }
    return 1 ; # Yep, we copied it!
}

# Public. Get a resource from a bucket.
proc S3::Get {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -file -content -resource -timestamp
	-headers -compare
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Get requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -file] && ![dict exists $myargs -content]} {
	error "Get requires -file or -content" "" [list S3 usage -file $args]
    }
    if {[dict exists $myargs -file] && [dict exists $myargs -content]} {
	error "Get says -file, -content mutually exclusive" "" [list S3 usage -file $args]
    }
    if {![dict exists $myargs -resource]} {
	error "Get requires -resource" "" [list S3 usage -resource $args]
    }
    if {![dict exists $myargs -compare]} {
	dict set myargs -compare [S3::Configure -default-compare]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    # See if we need to copy it.
    if {"never" eq [dict get $myargs -compare]} {return 0}
    if {[dict exists $myargs -content]} {
	set comp 1
    } else {
	set comp [S3::compare $myargs G]
    }
    if {!$comp} {return 0} ;  # skip it, then.

    # Oookeydookey. At this point, we're actually going to fetch 
    # the file, so all we need to do is build the request array.
    set req [dict create verb GET \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
    if {[dict exists $myargs -file]} {
	set pre_exists [file exists [dict get $myargs -file]]
	if {[catch { 
	    set x [open [dict get $myargs -file] w]
	    fconfigure $x -translation binary -encoding binary
	} caught]} {
	    error "Get could not create file [dict get $myargs -file]" "" \
		[list S3 local -file $errorCode]
	}
	dict set req outchan $x
    }
    # That should do it.
    set res [S3::maybebackground $req $myargs]
    if {[dict exists $req outchan]} {
	catch {close [dict get $req outchan]}
	if {![string match "2??" [dict get $res httpstatus]] && !$pre_exists} {
	    catch {file delete -force -- [dict get $myargs -file]}
	}
    }
    S3::throwhttp $res
    if {[dict exists $myargs -headers]} {
	uplevel 1 \
	    [list set [dict get $myargs -headers] [dict get $res outheaders]]
    }
    if {[dict exists $myargs -content]} {
	uplevel 1 \
	    [list set [dict get $myargs -content] [dict get $res outbody]]
    }
    if {[dict exists $myargs -timestamp] && [dict exists $myargs -file]} {
	if {"aws" eq [dict get $myargs -timestamp]} {
	    catch {
		set t [dict get $res outheaders last-modified]
		set t [clock scan $t -gmt true]
		file mtime [dict get $myargs -file] $t
	    }
	}
    }
    return 1 ; # Yep, we copied it!
}

# Public. Get information about a resource in a bucket.
proc S3::Head {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -resource -headers -dict -status
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Head requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -resource]} {
	error "Head requires -resource" "" [list S3 usage -resource $args]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    set req [dict create verb HEAD \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
    set res [S3::maybebackground $req $myargs]
    if {[dict exists $myargs -dict]} {
	uplevel 1 \
	    [list set [dict get $myargs -dict] $res]
    }
    if {[dict exists $myargs -headers]} {
	uplevel 1 \
	    [list set [dict get $myargs -headers] [dict get $res outheaders]]
    }
    if {[dict exists $myargs -status]} {
	set x [list [dict get $res httpstatus] [dict get $res httpmessage]]
	uplevel 1 \
	    [list set [dict get $myargs -status] $x]
    }
    return [string match "2??" [dict get $res httpstatus]]
}

# Public. Get the full ACL from an object and parse it into something useful.
proc S3::GetAcl {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -resource -result-type -parse-xml
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {![dict exists $myargs -result-type]} {
	dict set myargs -result-type "dict"
    }
    set restype [dict get $myargs -result-type]
    if {$restype eq "REST" && [dict exists $myargs -parse-xml]} {
	error "Do not use REST with -parse-xml" "" \
	    [list S3 usage -parse-xml $args]
    }
    if {![dict exists $myargs -parse-xml]} {
	# We need to fetch the results.
	if {"" eq [dict get $myargs -bucket]} {
	    error "GetAcl requires -bucket" "" [list S3 usage -bucket $args]
	}
	if {![dict exists $myargs -resource]} {
	    error "GetAcl requires -resource" "" [list S3 usage -resource $args]
	}
	# Clean up bucket, and take one leading slash (if any) off resource.
	if {[string match "/*" [dict get $myargs -resource]]} {
	    dict set myargs -resource \
		[string range [dict get $myargs -resource] 1 end]
	}
	set req [dict create verb GET \
	    resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
	    rtype acl]
	set dict [S3::maybebackground $req $myargs]
	if {$restype eq "REST"} {
	    return $dict ; #we're done!
	}
	S3::throwhttp $dict ; #make sure it worked.
	set xml [dict get $dict outbody] 
    } else {
	set xml [dict get $myargs -parse-xml]
    }
    if {[dict get $myargs -result-type] == "xml"} {
	return $xml
    }
    set pxml [xsxp::parse $xml]
    if {[dict get $myargs -result-type] == "pxml"} {
	return $pxml
    }
    if {[dict get $myargs -result-type] == "dict"} {
	array set resdict {}
	set owner [xsxp::fetch $pxml Owner/ID %PCDATA]
	set grants [xsxp::fetch $pxml AccessControlList %CHILDREN]
	foreach grant $grants {
	    set perm [xsxp::fetch $grant Permission %PCDATA]
	    set id ""
	    catch {set id [xsxp::fetch $grant Grantee/ID %PCDATA]}
	    if {$id == ""} {
		set id [xsxp::fetch $grant Grantee/URI %PCDATA]
	    }
	    lappend resdict($perm) $id
	}
	return [dict create owner $owner acl [array get resdict]]
    }
    error "GetAcl requires -result-type to be REST, xml, pxml or dict" "" [list S3 usage -result-type $args]
}

# Make one Grant thingie
proc S3::engrant {who what} {
    if {$who == "AuthenticatedUsers" || $who == "AllUsers"} {
	set who http://acs.amazonaws.com/groups/global/$who
    }
    if {-1 != [string first "//" $who]} {
	set type Group ; set tag URI
    } elseif {-1 != [string first "@" $who]} {
	set type AmazonCustomerByEmail ; set tag EmailAddress
    } else {
	set type CanonicalUser ; set tag ID
    }
    set who [string map {< &lt; > &gt; & &amp;} $who]
    set what [string toupper $what]
    set xml "<Grant><Grantee xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xsi:type=\"$type\"><$tag>$who</$tag></Grantee>"
    append xml "<Permission>$what</Permission></Grant>"
    return $xml
}

# Make the owner header
proc S3::enowner {owner} {
    return "<AccessControlPolicy xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><Owner><ID>$owner</ID></Owner><AccessControlList>"
    return "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<AccessControlPolicy xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><Owner><ID>$owner</ID></Owner><AccessControlList>"
}

proc S3::endacl {} {
    return "</AccessControlList></AccessControlPolicy>\n"
}

# Public. Set the ACL on an existing object.
proc S3::PutAcl {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -resource -acl -owner
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "PutAcl requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -resource]} {
	error "PutAcl requires -resource" "" [list S3 usage -resource $args]
    }
    if {![dict exists $myargs -acl]} {
	dict set myargs -acl [S3::Configure -default-acl]
    }
    dict set myargs -acl [string trim [dict get $myargs -acl]]
    if {[dict get $myargs -acl] == ""} {
	dict set myargs -acl [S3::Configure -default-acl]
    }
    if {[dict get $myargs -acl] == ""} {
	error "PutAcl requires -acl" "" [list D3 usage -resource $args]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    # Now, figure out the XML to send.
    set acl [dict get $myargs -acl]
    set owner ""
    if {"<" != [string index $acl 0] && ![dict exists $myargs -owner]} {
	# Grab the owner off the resource
	set req [dict create verb GET \
	    resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
	    rtype acl]
	set dict [S3::maybebackground $req $myargs]
	S3::throwhttp $dict ; #make sure it worked.
	set xml [dict get $dict outbody] 
	set pxml [xsxp::parse $xml]
	set owner [xsxp::fetch $pxml Owner/ID %PCDATA]
    }
    if {[dict exists $myargs -owner]} {
	set owner [dict get $myargs -owner]
    }
    set xml [enowner $owner] 
    if {"" == $acl || "private" == $acl} {
	append xml [engrant $owner FULL_CONTROL]
	append xml [endacl]
    } elseif {"public-read" == $acl} {
	append xml [engrant $owner FULL_CONTROL]
	append xml [engrant AllUsers READ]
	append xml [endacl]
    } elseif {"public-read-write" == $acl} {
	append xml [engrant $owner FULL_CONTROL]
	append xml [engrant AllUsers READ]
	append xml [engrant AllUsers WRITE]
	append xml [endacl]
    } elseif {"authenticated-read" == $acl} {
	append xml [engrant $owner FULL_CONTROL]
	append xml [engrant AuthenticatedUsers READ]
	append xml [endacl]
    } elseif {"<" == [string index $acl 0]} {
	set xml $acl
    } elseif {[llength $acl] % 2 != 0} {
	error "S3::PutAcl -acl must be xml, private, public-read, public-read-write, authenticated-read, or a dictionary" \
	"" [list S3 usage -acl $acl]
    } else {
	# ACL in permission/ID-list format.
	if {[dict exists $acl owner] && [dict exists $acl acl]} {
	    set xml [S3::enowner [dict get $acl owner]]
	    set acl [dict get $acl acl]
	}
	foreach perm {FULL_CONTROL READ READ_ACP WRITE WRITE_ACP} {
	    if {[dict exists $acl $perm]} {
		foreach id [dict get $acl $perm] {
		    append xml [engrant $id $perm]
		}
	    }
	}
	append xml [endacl]
    }
    set req [dict create verb PUT \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
	inbody $xml \
	rtype acl]
    set res [S3::maybebackground $req $myargs]
    S3::throwhttp $res ; #make sure it worked.
    return $xml
}

# Public. Delete a resource from a bucket.
proc S3::Delete {args} {
    global errorCode
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -resource -status
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Delete requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -resource]} {
	error "Delete requires -resource" "" [list S3 usage -resource $args]
    }
    # Clean up bucket, and take one leading slash (if any) off resource.
    if {[string match "/*" [dict get $myargs -resource]]} {
	dict set myargs -resource \
	    [string range [dict get $myargs -resource] 1 end]
    }
    set req [dict create verb DELETE \
	resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
    set res [S3::maybebackground $req $myargs]
    if {[dict exists $myargs -status]} {
	set x [list [dict get $res httpstatus] [dict get $res httpmessage]]
	uplevel 1 \
	    [list set [dict get $myargs -status] $x]
    }
    return [string match "2??" [dict get $res httpstatus]]
}

# Some helper routines for Push, Pull, and Sync

# Internal. Filter for fileutil::find.
proc S3::findfilter {dirs name} {
    # In particular, skip links, devices, etc.
    if {$dirs} {
	return [expr {[file isdirectory $name] || [file isfile $name]}]
    } else {
	return [file isfile $name]
    }
}

# Internal.  Get list of local files, appropriately trimmed.
proc S3::getLocal {root dirs} {
    # Thanks to Michael Cleverly for this first line...
    set base [file normalize [file join [pwd] $root]]
    if {![string match "*/" $base]} {
	set base $base/
    }
    set files {} ; set bl [string length $base]
    foreach file [fileutil::find $base [list S3::findfilter $dirs]] {
	if {[file isdirectory $file]} {
	    lappend files [string range $file $bl end]/
	} else {
	    lappend files [string range $file $bl end]
	}
    }
    set files [lsort $files]
    # At this point, $files is a sorted list of all the local files,
    # with a trailing / on any directories included in the list.
    return $files
}

# Internal. Get list of remote resources, appropriately trimmed.
proc S3::getRemote {bucket prefix blocking} {
    set prefix [string trim $prefix " /"]
    if {0 != [string length $prefix]} {append prefix /}
    set res [S3::GetBucket -bucket $bucket -prefix $prefix \
	-result-type names -blocking $blocking]
    set names {} ; set pl [string length $prefix]
    foreach name $res {
	lappend names [string range $name $pl end]
    }
    return [lsort $names]
}

# Internal. Create any directories we need to put the file in place.
proc S3::makeDirs {directory suffix} {
    set sofar {}
    set nodes [split $suffix /]
    set nodes [lrange $nodes 0 end-1]
    foreach node $nodes {
	lappend sofar $node
	set tocheck [file join $directory {*}$sofar]
	if {![file exists $tocheck]} {
	    catch {file mkdir $tocheck}
	}
    }
}

# Internal. Default progress monitor for push, pull, toss.
proc S3::ignore {args} {} ; # default progress monitor

# Internal. For development and testing. Progress monitor.
proc S3::printargs {args} {puts $args} ; # For testing.

# Public. Send a local directory tree to S3.
proc S3::Push {args} {
    uplevel #0 package require fileutil
    global errorCode errorInfo
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -prefix -directory 
	-compare -x-amz-meta-* -acl -delete -error -progress
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Push requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -directory]} {
	error "Push requires -directory" "" [list S3 usage -directory $args]
    }
    # Set default values.
    set defaults "
    -acl \"[S3::Configure -default-acl]\"
    -compare [S3::Configure -default-compare]
    -prefix {} -delete 0 -error continue -progress ::S3::ignore -blocking 1"
    foreach {key val} $defaults {
	if {![dict exists $myargs $key]} {dict set myargs $key $val}
    }
    # Pull out arguments for convenience
    foreach i {progress prefix directory bucket blocking} {
	set $i [dict get $myargs -$i]
    }
    set prefix [string trimright $prefix /]
    set meta [dict filter $myargs key x-amz-meta-*]
    # We're readdy to roll here.
    uplevel 1 [list {*}$progress args $myargs]
    if {[catch {
	set local [S3::getLocal $directory 0]
    } caught]}  {
	error "Push could not walk local directory - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress local $local]
    if {[catch {
	set remote [S3::getRemote $bucket $prefix $blocking]
    } caught]} {
	error "Push could not walk remote directory - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress remote $remote]
    set result [dict create]
    set result0 [dict create \
	filescopied 0 bytescopied 0 compareskipped 0 \
	errorskipped 0 filesdeleted 0 filesnotdeleted 0]
    foreach suffix $local {
	uplevel 1 [list {*}$progress copy $suffix start]
	set err [catch {
	    S3::Put -bucket $bucket -blocking $blocking \
	    -file [file join $directory $suffix] \
	    -resource $prefix/$suffix \
	    -acl [dict get $myargs -acl] \
	    {*}$meta \
	    -compare [dict get $myargs -compare]} caught]
	if {$err} {
	    uplevel 1 [list {*}$progress copy $suffix $errorCode]
	    dict incr result0 errorskipped
	    dict set result $suffix $errorCode
	    if {[dict get $myargs -error] eq "throw"} {
		error "Push failed to Put - $caught" $errorInfo $errorCode
	    } elseif {[dict get $myargs -error] eq "break"} {
		break
	    }
	} else {
	    if {$caught} {
		uplevel 1 [list {*}$progress copy $suffix copied]
		dict incr result0 filescopied
		dict incr result0 bytescopied \
		    [file size [file join $directory $suffix]]
		dict set result $suffix copied
	    } else {
		uplevel 1 [list {*}$progress copy $suffix skipped]
		dict incr result0 compareskipped
		dict set result $suffix skipped
	    }
	}
    }
    # Now do deletes, if so desired
    if {[dict get $myargs -delete]} {
	foreach suffix $remote {
	    if {$suffix ni $local} {
		set err [catch {
		    S3::Delete -bucket $bucket -blocking $blocking \
			-resource $prefix/$suffix } caught]
		if {$err} {
		    uplevel 1 [list {*}$progress delete $suffix $errorCode]
		    dict incr result0 filesnotdeleted
		    dict set result $suffix notdeleted
		} else {
		    uplevel 1 [list {*}$progress delete $suffix {}]
		    dict incr result0 filesdeleted
		    dict set result $suffix deleted
		}
	    }
	}
    }
    dict set result {} $result0
    uplevel 1 [list {*}$progress finished $result]
    return $result
}

# Public. Fetch a portion of a remote bucket into a local directory tree.
proc S3::Pull {args} {
    # This is waaaay to similar to Push for comfort.
    # Fold it up later.
    uplevel #0 package require fileutil
    global errorCode errorInfo
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -prefix -directory 
	-compare -timestamp -delete -error -progress
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Pull requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -directory]} {
	error "Pull requires -directory" "" [list S3 usage -directory $args]
    }
    # Set default values.
    set defaults "
    -timestamp now
    -compare [S3::Configure -default-compare]
    -prefix {} -delete 0 -error continue -progress ::S3::ignore -blocking 1"
    foreach {key val} $defaults {
	if {![dict exists $myargs $key]} {dict set myargs $key $val}
    }
    # Pull out arguments for convenience
    foreach i {progress prefix directory bucket blocking} {
	set $i [dict get $myargs -$i]
    }
    set prefix [string trimright $prefix /]
    # We're readdy to roll here.
    uplevel 1 [list {*}$progress args $myargs]
    if {[catch {
	set local [S3::getLocal $directory 1]
    } caught]}  {
	error "Pull could not walk local directory - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress local $local]
    if {[catch {
	set remote [S3::getRemote $bucket $prefix $blocking]
    } caught]} {
	error "Pull could not walk remote directory - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress remote $remote]
    set result [dict create]
    set result0 [dict create \
	filescopied 0 bytescopied 0 compareskipped 0 \
	errorskipped 0 filesdeleted 0 filesnotdeleted 0]
    foreach suffix $remote {
	uplevel 1 [list {*}$progress copy $suffix start]
	set err [catch {
	    S3::makeDirs $directory $suffix
	    S3::Get -bucket $bucket -blocking $blocking \
	    -file [file join $directory $suffix] \
	    -resource $prefix/$suffix \
	    -timestamp [dict get $myargs -timestamp] \
	    -compare [dict get $myargs -compare]} caught]
	if {$err} {
	    uplevel 1 [list {*}$progress copy $suffix $errorCode]
	    dict incr result0 errorskipped
	    dict set result $suffix $errorCode
	    if {[dict get $myargs -error] eq "throw"} {
		error "Pull failed to Get - $caught" $errorInfo $errorCode
	    } elseif {[dict get $myargs -error] eq "break"} {
		break
	    }
	} else {
	    if {$caught} {
		uplevel 1 [list {*}$progress copy $suffix copied]
		dict incr result0 filescopied
		dict incr result0 bytescopied \
		    [file size [file join $directory $suffix]]
		dict set result $suffix copied
	    } else {
		uplevel 1 [list {*}$progress copy $suffix skipped]
		dict incr result0 compareskipped
		dict set result $suffix skipped
	    }
	}
    }
    # Now do deletes, if so desired
    if {[dict get $myargs -delete]} {
	foreach suffix [lsort -decreasing $local] {
	    # Note, decreasing because we delete empty dirs
	    if {[string match "*/" $suffix]} {
		set f [file join $directory $suffix]
		catch {file delete -- $f} 
		if {![file exists $f]} {
		    uplevel 1 [list {*}$progress delete $suffix {}]
		    dict set result $suffix deleted
		    dict incr result0 filesdeleted
		}
	    } elseif {$suffix ni $remote} {
		set err [catch {
		    file delete [file join $directory $suffix]
		} caught]
		if {$err} {
		    uplevel 1 [list {*}$progress delete $suffix $errorCode]
		    dict incr result0 filesnotdeleted
		    dict set result $suffix notdeleted
		} else {
		    uplevel 1 [list {*}$progress delete $suffix {}]
		    dict incr result0 filesdeleted
		    dict set result $suffix deleted
		}
	    }
	}
    }
    dict set result {} $result0
    uplevel 1 [list {*}$progress finished $result]
    return $result
}

# Public. Delete a collection of resources with the same prefix.
proc S3::Toss {args} {
    # This is waaaay to similar to Push for comfort.
    # Fold it up later.
    global errorCode errorInfo
    checkinit
    set myargs [S3::parseargs1 $args {
	-bucket -blocking -prefix 
	-error -progress
    }]
    if {![dict exists $myargs -bucket]} {
	dict set myargs -bucket [S3::Configure -default-bucket]
    }
    dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
    if {"" eq [dict get $myargs -bucket]} {
	error "Toss requires -bucket" "" [list S3 usage -bucket $args]
    }
    if {![dict exists $myargs -prefix]} {
	error "Toss requires -prefix" "" [list S3 usage -directory $args]
    }
    # Set default values.
    set defaults "-error continue -progress ::S3::ignore -blocking 1"
    foreach {key val} $defaults {
	if {![dict exists $myargs $key]} {dict set myargs $key $val}
    }
    # Pull out arguments for convenience
    foreach i {progress prefix bucket blocking} {
	set $i [dict get $myargs -$i]
    }
    set prefix [string trimright $prefix /]
    # We're readdy to roll here.
    uplevel 1 [list {*}$progress args $myargs]
    if {[catch {
	set remote [S3::getRemote $bucket $prefix $blocking]
    } caught]} {
	error "Toss could not walk remote bucket - $caught" \
	    $errorInfo $errorCode
    }
    uplevel 1 [list {*}$progress remote $remote]
    set result [dict create]
    set result0 [dict create \
	filescopied 0 bytescopied 0 compareskipped 0 \
	errorskipped 0 filesdeleted 0 filesnotdeleted 0]
    # Now do deletes
    foreach suffix $remote {
	set err [catch {
	    S3::Delete -bucket $bucket -blocking $blocking \
		-resource $prefix/$suffix } caught]
	if {$err} {
	    uplevel 1 [list {*}$progress delete $suffix $errorCode]
	    dict incr result0 filesnotdeleted
	    dict set result $suffix notdeleted
	} else {
	    uplevel 1 [list {*}$progress delete $suffix {}]
	    dict incr result0 filesdeleted
	    dict set result $suffix deleted
	}
    }
    dict set result {} $result0
    uplevel 1 [list {*}$progress finished $result]
    return $result
}
tcllib 1.18-dfsg-3 / usr / share / tcltk / tcllib1.18 / amazon-s3 / S3.tcl
