--- /dev/null
+#!/usr/bin/tclsh
+
+# ---
+# --- [Config] ---
+# ---
+# Directory to place the files to.
+set outdir "out/"
+# The lenght of the random name every file is assigned.
+# Setting it to 0 disables random name mangling.
+set mangle_lenght 6
+# The characters which may appear within the basename of a generated random file name.
+set mangle_char_set {0123456789abcdefghijklmnopqrstuvwxyz}
+# Every random name has a chance to collide with a previously saved file.
+# Theoretically if you don't clean your uploads and both your
+# $::mangle_lenght and $::mangle_char_set are small, you could end up with a dead lock.
+# This value is the fail-safe.
+set max_save_attempts 20
+# The output of this function is (ideally) what the user will see.
+# I have provided a few default behaviours, but you do you champ.
+proc send_success {upload_name} {
+ proc simple {upload_name} {
+ puts "Status: 200 OK\r"
+ puts "Content-Type: text/plain\r"
+ puts "\r"
+ puts "$upload_name"
+ }
+
+ proc link {upload_name} {
+ set scheme $::env(REQUEST_SCHEME)
+ set host $::env(HTTP_HOST)
+ set url "$scheme://$host/$upload_name"
+
+ puts "Status: 200 OK\r"
+ puts "Content-Type: text/html\r"
+ puts "\r"
+ puts "<a href=$url>$url</a>"
+ }
+
+ proc redirect {upload_name} {
+ set scheme $::env(REQUEST_SCHEME)
+ set host $::env(HTTP_HOST)
+ set url "$scheme://$host/$upload_name"
+
+ puts "Status: 303 See Other\r"
+ puts "Location: $url\r"
+ puts "Content-Type: text/plain\r"
+ puts "\r"
+ puts "Redirecting to $url"
+ }
+
+ set agent $::env(HTTP_USER_AGENT)
+
+ if {[regexp -nocase {curl} $agent]} {
+ simple $upload_name
+ } else {
+ link $upload_name
+ #redirect $upload_name
+ }
+}
+
+
+
+# ---
+# --- [Core] ---
+# ---
+set method $::env(REQUEST_METHOD)
+set content_length $::env(CONTENT_LENGTH)
+
+fconfigure stdin -translation binary -encoding binary
+
+proc raise_fatal {} {
+ puts "Status: 400 Bad Request\r"
+ puts "Content-Type: text/plain\r\n"
+ puts "400 Bad Request"
+ exit 1
+}
+
+proc splitstr {text delim} {
+ # I hate the antichrist;
+ # why the fuck isnt this standard?
+ # what fucking moron thought the lack of splitting would be a good addition to Tcl?
+
+ set result {}
+ set dlen [string length $delim]
+ set start 0
+
+ while {[set idx [string first $delim $text $start]] >= 0} {
+ lappend result [string range $text $start [expr {$idx - 1}]]
+ set start [expr {$idx + $dlen}]
+ }
+
+ lappend result [string range $text $start end]
+ return $result
+}
+
+proc get_out_name {orig_name} {
+ proc get_random_name {} {
+ set chars $::mangle_char_set
+ set name ""
+ for {set i 0} {$i < $::mangle_lenght} {incr i} {
+ append name [string index $chars [expr {int(rand()*[string length $chars])}]]
+ }
+ return $name
+ }
+
+ if { $::mangle_lenght == 0 } { return $orig_name }
+
+ set extension [file extension $orig_name]
+
+ for { set tries 1 } { $tries <= $::max_save_attempts } { incr tries } {
+ set out_name "$::outdir/[get_random_name]$extension"
+ if { ![file exists $out_name] } { break }
+ }
+
+ return $out_name
+}
+
+if { $method eq "PUT" } {
+ set original_name [file tail $::env(REQUEST_URI)]
+
+ proc copy_stdin {out_name} {
+ set f [open $out_name "wb"]
+ fconfigure $f -translation binary -encoding binary
+ chan copy stdin $f
+ close $f
+ }
+ set write_file copy_stdin
+
+} elseif { $method eq "POST" } {
+ # NOTE:
+ # we must parse multipart/form-data;
+ # see: RFC 7578 (https://www.rfc-editor.org/rfc/rfc7578)
+ regexp {boundary=(.+)} $::env(CONTENT_TYPE) -> BOUNDARY
+ set BOUNDARY "\r\n--$BOUNDARY"
+
+ set raw [read stdin $::content_length]
+
+ # NOTE:
+ # It is not expected to have more then one part;
+ # why the hell would someone post multiple fields?
+ # However, it becomes a problem at somepoint,
+ # we simply need to find the one part that contains
+ # 'name="file"' on the first line, where 'file'
+ # is the field name specified on the form
+ # (the example uses 'file' as a literal).
+ set parts [splitstr $raw $BOUNDARY]
+ set part [lindex $parts 0]
+
+ if { $part eq "" } { raise_fatal }
+
+ set delim "\r\n\r\n"
+ set idx [string first $delim $part]
+ set header [string range $part 0 $idx]
+ set body [string range $part [expr {$idx + [string length $delim]}] end]
+
+ # NOTE:
+ # the filename parameter is not guaranteed to be provided
+ # and not guaranteed to be quoted
+ if {![regexp {filename="(.+)"} $header -> original_name]} { set original_name "" }
+
+ proc write_body {out_name} {
+ set f [open $out_name "wb"]
+ fconfigure $f -translation binary -encoding binary
+ puts -nonewline $f $::body
+ close $f
+ }
+ set write_file write_body
+
+} else {
+ raise_fatal
+}
+
+if { ![file isdirectory $outdir] } { file mkdir $outdir }
+set output_name [get_out_name $original_name]
+eval $write_file $output_name
+
+send_success $output_name
+
+## Notes
+# This is a very useful debug snippet:
+#
+# foreach name [lsort [array names ::env]] {
+# puts stderr "$name = $::env($name)"
+# }
projects / emil-up.chud.cyou.git / commitdiff
