From 02814d2803a39a0fb14893e5cf30d35609ee67de Mon Sep 17 00:00:00 2001
From: anon
Date: Sat, 5 Jul 2025 13:11:35 +0200
Subject: init
---
.gitignore | 2 +
Makefile | 9 +++
evil.tcl | 6 ++
example.html | 12 ++++
example.lighttpd.conf | 6 ++
example.png | Bin 0 -> 310382 bytes
example.txt | 1 +
lighttpd.conf | 28 ++++++++
upchud-test.sh | 26 +++++++
upchud.tcl | 184 ++++++++++++++++++++++++++++++++++++++++++++++++++
upload-test.sh | 2 +
11 files changed, 276 insertions(+)
create mode 100644 .gitignore
create mode 100644 Makefile
create mode 100755 evil.tcl
create mode 100644 example.html
create mode 100644 example.lighttpd.conf
create mode 100644 example.png
create mode 100644 example.txt
create mode 100644 lighttpd.conf
create mode 100755 upchud-test.sh
create mode 100755 upchud.tcl
create mode 100755 upload-test.sh
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 @@
+
+
+
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
Binary files /dev/null and b/example.png differ
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 "$url"
+ }
+
+ 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/
--
cgit v1.2.3