post.red

Red [
	Title: "Simple HTTP server"
	Notes: {
		The compiler is not able to compile it.
	}
]

httpd: context [

	debug: :print
	;debug: :comment

	upload-form: {HTTP/1.0 200 OK^M^/Content-Type: text/html^M^/^M^/<form method="post" action="http://localhost:8082" enctype="multipart/form-data">
		    <input type="file" name="file" id="file">
		    <input type="submit">
		</form>
	}

	state: 'none
	received-data: make binary! 1000
	content-len: 0
	boundary: ""
	
	server: open tcp://:8082

	parse-header: func [data /local method uri b][
		parse data [
			copy method to space skip
			copy uri to space
		]
		try [content-len: transcode/one find/tail data "Content-Length:"]
		if b: find/tail data "boundary=" [
			boundary: copy/part b find b crlf
		]
		to-string method
	]

	process-request-get: function [port][
		insert port upload-form
	]

	process-request: func [port /local method end] [
		if state = 'post [
			append received-data port/data
			end: skip tail received-data -4 - length? boundary
			either all [
				content-len < length? received-data
				find end boundary
			][
				state: 'post-end
				insert port upload-form
				;write/binary %http-received.data received-data
				clear received-data
			][
				copy port
			]
			exit
		]
		method: parse-header port/data
		switch/default method [
			"GET"  [state: 'get process-request-get port]
			"POST" [
				state: 'post
				append received-data port/data
				copy port
			]
		][debug ["Httpd: cannot handle method: " method]]
	]

	client-handler: func [event /local client] [
	    debug ["=== client event:" event/type]
	    client: event/port
	    switch event/type [
	        read  [process-request client]
	        wrote [
		        if state = 'get [close client state: 'none]
		        if state = 'post-end [close client state: 'none]
	        ]
	    ]
	]

	server/awake: function [event] [
	    if event/type = 'accept [
			debug ["=== New client ==="]
			client: event/port
		    client/awake: :client-handler
		    copy client							;-- read from the client
	    ]
	]

	start: does [
		;browse http://127.0.0.1:8082
		wait server
	]
]

httpd/start