init

11 files changed, 276 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..23f5353
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+out/
+*.log
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..4eff9af
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,9 @@
+serve:
+	lighttpd -D -f lighttpd.conf
+
+front:
+	lighttpd -D -f example.lighttpd.conf
+
+clean:
+	-${RM} -frfr out/
+	-${RM} errors.log
diff --git a/evil.tcl b/evil.tcl
new file mode 100755
index 0000000..9060f7c
--- /dev/null
+++ b/evil.tcl
@@ -0,0 +1,6 @@
+#!/usr/bin/tclsh
+
+set f [open "evil.txt" "w"]
+close $f
+
+puts stderr "evil.txt created"
diff --git a/example.html b/example.html
new file mode 100644
index 0000000..137594e
--- /dev/null
+++ b/example.html
@@ -0,0 +1,12 @@
+<div style="width: 400px;">
+    <form action="http://localhost:8080" method="post" enctype="multipart/form-data">
+        <fieldset>
+            <legend>Upload a file</legend>
+            <label>
+                Select file:
+                <input type="file" name="file" required>
+            </label>
+            <button type="submit">Upload</button>
+        </fieldset>
+    </form>
+</div>
diff --git a/example.lighttpd.conf b/example.lighttpd.conf
new file mode 100644
index 0000000..86a4f82
--- /dev/null
+++ b/example.lighttpd.conf
@@ -0,0 +1,6 @@
+# @BAKE lighttpd -D -f $@
+server.document-root = var.CWD
+server.port = "8081"
+
+server.modules += ( "mod_rewrite" )
+url.rewrite-once = ( ".*" => "/example.html" )
diff --git a/example.png b/example.png
new file mode 100644
index 0000000..df5d578
--- /dev/null
+++ b/example.png
diff --git a/example.txt b/example.txt
new file mode 100644
index 0000000..557db03
--- /dev/null
+++ b/example.txt
@@ -0,0 +1 @@
+Hello World
diff --git a/lighttpd.conf b/lighttpd.conf
new file mode 100644
index 0000000..921467d
--- /dev/null
+++ b/lighttpd.conf
@@ -0,0 +1,28 @@
+# @BAKE lighttpd -D -f $@
+server.document-root = var.CWD
+server.port = "8080"
+
+server.modules += ( "mod_rewrite" )
+url.rewrite-once = (
+    "^/out/.*" => "$0",
+    ".*"       => "/upchud.tcl"
+)
+
+# This limits the maximum upload size (in kbytes).
+server.max-request-size = 204800 # 200 MiB
+
+# This makes sure people cant inject Tcl scripts
+server.modules += ( "mod_cgi" )
+$HTTP["url"] == "/upchud.tcl" {
+    cgi.assign = ( ".tcl" => "" )
+}
+
+
+debug.log-request-header      = 1
+debug.log-file-not-found      = 1
+debug.log-condition-handling  = 1
+debug.log-request-handling    = 1
+debug.log-state-handling      = 1
+debug.log-response-header     = 1
+
+server.errorlog = "errors.log"
diff --git a/upchud-test.sh b/upchud-test.sh
new file mode 100755
index 0000000..6bf91d3
--- /dev/null
+++ b/upchud-test.sh
@@ -0,0 +1,26 @@
+#!/usr/bin/env bash
+
+TCL_SCRIPT="./upchud.tcl"
+TEST_FILE="example.png"
+#TEST_FILE="example.txt"
+TCLSH_CMD="$(command -v tclsh)"
+
+# verify files exist
+if [[ ! -x "$TCL_SCRIPT" ]]; then
+  echo "ERROR: cannot execute $TCL_SCRIPT" >&2
+  exit 1
+fi
+if [[ ! -f "$TEST_FILE" ]]; then
+  echo "ERROR: test file $TEST_FILE not found" >&2
+  exit 1
+fi
+
+CONTENT_LENGTH=$(wc -c < "$TEST_FILE")
+export CONTENT_LENGTH
+
+export HTTP_CONTENT_DISPOSITION="form-data; name=\"file\"; filename=\"$TEST_FILE\""
+
+echo "Uploading '$TEST_FILE' ($CONTENT_LENGTH bytes) to $TCL_SCRIPT"
+OUT_NAME=$("$TCLSH_CMD" "$TCL_SCRIPT" < "$TEST_FILE")
+
+echo "Script response:\n $OUT_NAME"
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)"
+#   }
diff --git a/upload-test.sh b/upload-test.sh
new file mode 100755
index 0000000..936e013
--- /dev/null
+++ b/upload-test.sh
@@ -0,0 +1,2 @@
+#!/bin/sh
+curl --upload-file example.png http://localhost:8080/