1 files changed, 184 insertions, 0 deletions
diff --git a/upchud.tcl b/upchud.tcl
new file mode 100755
index 0000000..9da256c
--- /dev/null
+++ b/upchud.tcl
@@ -0,0 +1,184 @@
+#!/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)"
+#   }