Archive version of: fileserver.r ... version: 6 ... piotrgapinsk 24-Aug-2009

REBOL [
	Title: "Obscure File Server"
	Purpose: "Share files over HTTP protocol +NLS"
	Author: "pijoter"
	Date:  24-Aug-2009/21:49:10+2:00
	File: %fileserver.r
	Log: %fileserver.log
	Home: http://rowery.olsztyn.pl/rebol
	License: "GNU General Public License (Version II)"
	Library: [
		level: 'intermediate
		platform: 'all
		type: [tool]
		domain: [file-handling web tcp other-net]
		tested-under: [
			view 2.7.6  on [Linux WinXP]
		]
		support: none
		license: 'GPL
	]
	Tabs: 3
]

dt: context [
	to-human: func [dt [date!] /date /time /local pad d t s] [
		pad: func [val n] [head insert/dup val: form val #"0" (n - length? val)]

		dt: rejoin [
			(pad dt/year 4) #"-" (pad dt/month 2) #"-" (pad dt/day 2)
			#"/" to-itime any [dt/time 0:00]
		]

		any [
			if date [copy/part dt 10]
			if time [copy/part (skip dt 11) 8]
			dt
		]
	]

	to-stamp: func [dt [date!] /date] [
		dt: any [
			if date [self/to-human/date dt]
			self/to-human dt
		]
		remove-each ch dt [found? find "-/:" ch]
	]

	to-gmt: func [date [date!]] [
		any [
			zero? date/zone
			attempt [
				date: date - date/zone
				date/zone: 0:00
			]
		]
	]
]

log: context [
	FILE: any [attempt [system/script/header/log] %fileserver.log]

	emit: func [info] [
		if block? info [info: reduce info]
		attempt [write/append/lines self/FILE reform [(dt/to-stamp now) (form info)]]
	]
]

fs: context [
	DENY-DIR: [%.git/ %.cvs/ %.svn/]
	DENY-FILE: reduce [
		any [attempt [system/script/header/file] %fileserver.r]
		any [attempt [system/script/header/log] log/FILE]
	]

	file-map: make hash! 256

	deny-file?: func [file [file!]] [found? (find self/DENY-FILE file)]
	deny-dir?: func [dir [file!]] [found? (find self/DENY-DIR dir)]
	deny-subdir?: :deny-dir?
	to-dir: func [dir [string! file!]] [dirize to-file dir]
	is-dir?: func [dir [string! file!]] [#"/" = form back tail dir]

	crc?: func [path [string! file!]] [enbase/base (checksum/method (form path) 'MD5) 16]

	make-local: func [crc [binary! string!]] [select self/file-map crc]
	make-map: func [dir [string! file!]
		/local map items dirs files path target deny?] [

		dir: clean-path (self/to-dir dir)
		map: make hash! 64

		any [
			items: attempt [sort read dir]
			return map ;; pusta mapa plikow
		]

		;; sortuj oddzielnie pliki i katalogi
		dirs: remove-each target (copy items) [not dir? dir/:target]
		files: remove-each target items [dir? dir/:target]
		items: join dirs files

		foreach target items [
			path: dir/:target
			deny?: true

			any [
				all [(dir? path) (self/deny-dir? target)]
				self/deny-file? target
				deny?: false
				repend map [(self/crc? path) path]
			]

			net-utils/net-log ["net/make-map" "dir" dir "target" target "deny?" to-logic deny?]
		]

		;; TODO: nie modyfikuj gloablnej listy za kazdym przeladowaniem katalogu
		self/file-map: union/skip self/file-map map 2
		return map
	]

	mime-map: [
		%.html "text/html"
		%.htm  "text/html"
		%.png  "image/png"
		%.jpg  "image/jpeg"
		%.gif  "image/gif"
		%.txt  "text/plain"
		%.lha  "application/octet-stream"
		%.mp3  "audio/mp3"
		%.rar  "application/x-rar-compressed"
		%.rtf  "application/rtf"
		%.zip  "application/x-zip-compressed"
		%.r    "text/plain"
		%.reb  "text/plain"
		%.pl   "text/plain"
		%.php   "text/plain"
		%.py   "text/plain"
		%.jsp  "text/plain"
		%.js   "text/plain"
		%.css  "text/plain"
	]

	mime?: func [path [string! file!]] [
		any [
			attempt [select self/mime-map (suffix? to-file path)]
			"application/octet-stream"
		]
	]
]

net: context [
	DENY-IP: []
	;; DENY-IP: [255.255.255.255]
	ALLOW-IP: unique reduce [127.0.0.1 (read join dns:// (read dns://))]
	PORT: 8080
	BUFFER-SIZE: 1024 * 1024 * 1 ; 1M

	mime: none
	status: none

	response: [
		200 "OK" "Everything is just fine"
		400 "Forbidden" "No permission to access:"
		404 "Not Found" "File was not found:"
	]

	server-url: does [
		any [
			attempt [rejoin [http:// (read join dns:// read dns://) ":" self/PORT]]
			join http://127.0.0.1: self/PORT
		]
	]
	server-dir: does [what-dir]
	server-path: func [path [file!]] [find/tail (form path) (head remove back tail (form self/server-dir))]

	deny-ip?: func [ip] [
		if any [
				empty? self/DENY-IP
				found? find self/ALLOW-IP ip
			] [return false]

		to-logic any [
			found? find self/DENY-IP ip
			found? find self/DENY-IP 255.255.255.255
			found? find self/DENY-IP 'all
		]
	]

	send-header: func [port [port!] mime [string!]
		/with custom-header [string!]
		/error err-num [integer!]
		/local header status] [

		attempt [
			self/status: status: any [(if error [err-num]) 200]
			self/mime: mime
			header: rejoin [
					"HTTP/1.0 " status " " select self/response status CRLF
					"Content-Type: " mime "; charset=" content/encoding CRLF
					"Content-Language: " content/language CRLF
			]
			if with [append header custom-header]
			append header CRLF
			net-utils/net-log ["net/send-header" "size" length? header "header" header]
			write-io port header (length? header)
		]
	]

	send-page: func [port [port!] buffer [string! binary!]
		/error err-num [integer!]
		/local mime] [

		mime: "text/html"
		all [
			any [
				if error [self/send-header/error port mime err-num]
				self/send-header port mime
			]
			attempt [write-io port buffer (length? buffer)]
		]
	]

	send-error: func [port [port!] err-num [integer!] buffer [string! binary!]
		/local err body] [

		err: any [
			attempt [find self/response err-num]
			self/response
		]

		body: rejoin [""
			<html> LF
			<head> LF
				<title> (second err) </title> LF
				<basefont face="tahoma,arial"/> LF
			</head> LF
			<body>
				<h2> "SERVER-ERROR" </h2> LF
				<p> (third err) "&nbsp;" buffer <br/> to-idate now </p> LF
			</body>
			</html>]

		self/send-page/error port body err-num
	]

	send-file: func [port [port!] path [string! file!]
		/local disposition mime fh buffer bytes part] [

		set [dir file] split-path path

		disposition: rejoin ["Content-Disposition: inline; filename=" {"} (form file) {"} CRLF]
		mime: fs/mime? file

		all [
			self/send-header/with port mime disposition
			attempt [
				fh: open/binary/direct path
				part: 0
				forever [
					buffer: make binary! self/BUFFER-SIZE
					bytes: read-io fh buffer self/BUFFER-SIZE

					if zero? bytes [break]

					part: part + 1
					net-utils/net-log ["net/send-file" file "part" part "bytes" bytes]

					write-io port buffer bytes
				]
				close fh
				size? path
			]
		]
	]

	uri?: func [port [port!]
		/local buffer req space chars uri valid?] [

		buffer: copy port

		space: [some { }]
		chars: complement charset { }
		uri: make string! 200

		valid?: to-logic all [
			parse/all buffer ["GET" space "/" [opt [copy uri some chars]] space "HTTP" to end]
			not empty? (trim uri)
		]

		net-utils/net-log ["net/uri?" "valid?" valid? "buffer" (to-string buffer)]
		pick reduce [(copy/part uri 32) none] valid?
	]
]

content: context [
	language: "PL"
	encoding: any [
		select [3 "windows-1250" 4 "utf-8"] fourth system/version
		"iso-8859-1"
	]

	make-index: func [dir [string! file!]
		/local output item file f l s path crc prev-path prev-dir] [

		output: make string! 1024

		if not equal? dir net/server-dir [
			set [prev-path prev-dir] (split-path dir)
			crc: fs/crc? prev-path

			append output rejoin pick [
				[{<li><a href="/">..</a> :: (<a href="/">parent dir</a>)</li>} LF]
				[{<li><a href="} crc {">..</a> :: (<a href="} crc {">parent dir</a>)</li>} LF]
			] (equal? prev-path net/server-dir)
		]

		foreach [crc path] (fs/make-map dir) [
			file: second (split-path path)
			item: any [
				attempt [
					f: info? path

					;; wielkosc pliku w ludzkim formacie
					l: length? (to-string f/size)
					s: any [
						if l <  4 [join form f/size "B"]
						if l <  7 [join form (round/to (f/size / 1024) 0.01) "K"]
						if l < 10 [join form (round/to (f/size / 1048576) 0.01) "M"]
						join (form round/to (f/size / 1073741824) 0.01) "G"
					]

					select [
						file [{<li><a href="} crc {">} file {</a> :: } s {</li>} LF]
						directory [{<li><a href="} crc {">} file {</a> :: (dir)</li>} LF]
					] f/type
				]
				[{<li><a href="} crc {">} file {</a></li>} LF]
			]
			append output (rejoin item)
		]

		path: net/server-path dir
		rejoin [""
			<html> LF
			<head> LF
				<title> "FileServer" </title> LF
				{<meta http-equiv="Content-Type" content="text/html; charset=} self/encoding {"/>} LF
				{<meta http-equiv="Content-Language" content="} self/language {"/>} LF
				{<meta name="generator" content="} system/script/header/title {"/>} LF
				{<meta name="author" content="} system/script/header/author {"/>} LF
				<basefont face="tahoma,arial"/> LF
			</head> LF
			<body> LF
				<h2> {Index :: } path </h2> LF
				<ul> LF (trim output) </ul> LF
				<font size="-2"> LF
				<i> {Any inaccuracies in this index may be explained by the fact that it has been prepared with the help of a computer.} <br/> LF
				{Page generated by <a href="http://www.rebol.org/cgi-bin/cgiwrap/rebol/view-script.r?script=fileserver.r">REBOL FileServer</a> :: }
				form (to-idate now) </i> LF
				</font> LF
			</body> LF
			</html> LF
		]
	]

	handle: func [port [port!]
		/local orig-path path uri dir file size] [

		;; odtworz lokalna sciezke na podstawie crc z URI
		start-mark: now/precise
		orig-path: path: any [
			if uri: net/uri? port [
				any [
					;; komunikat o bledzie gdy crc z URI nie odpowiada lokalny plik
					fs/make-local uri
					do [
						size: net/send-error port 404 uri

						log/emit [
							port/host
							uri
							rejoin [{"} {"}]
							net/mime 
							net/status 
							size
							to-decimal (difference now/precise start-mark)
						]

						return size
					]
				]
			]
			net/server-dir
		]

		;; jezeli katalog to sprawdz obecnosc pliku index.html
		;; jezeli go nie ma to bedzie wygenerowany indeks zawartosci katalogu

		if dir? path [
			path: rejoin [path "index.html"]
			uri: fs/crc? path
		]	

		set [dir target] (split-path path)
		size: any [
			if (net/deny-ip? port/host) [net/send-error port 400 (form net/server-url)]
			if (fs/deny-subdir? (second split-path dir)) [net/send-error port 400 uri]
			if (fs/deny-file? target) [net/send-error port 400 uri]
			if (equal? (form target) "index.html") [net/send-page port (self/make-index dir)]
			if not exists? path [net/send-error port 404 uri]
			net/send-file port path
		]

		log/emit [
			port/host
			uri
			rejoin [{"} net/server-path orig-path {"}]
			net/mime 
			net/status 
			size
			to-decimal (difference now/precise start-mark)
		]

		return size
	]
]

any [
	port: attempt [open/binary/direct/no-wait (join tcp://: net/PORT)]
	do [
		alert "Looks like a Web Server is already running on your computer. Turn it off first, then launch FileServer again."
		quit
	]
]

if (not view?) [
	unprotect 'alert
	alert: func [t] [print t ask "press-enter"]
]

if view? [
	view/new gui: layout/size [] 175x160
	gui/pane: layout/tight [
		box white 180x45
		at 5x10 h1 "Server Running"
		at 5x60 patr: text 200 "Pages transmitted: 0"
		at 5x80 text to-string net/server-url
		across at 5x110 space 4x2
		btn "Browse me!" [browse net/server-url]
		btn "Show webdir" [browse net/server-dir] return
		at 5x140 text "www.rebol.net" blue [browse http://www.rebol.net]
		do [
			insert-event-func [
				if equal? event/type 'close [attempt [close client close port] quit]
				event
			]
		]
	]
	show gui
]

net-watch: false
system/options/quiet: true
pages: 0

forever [
	if view? [
		patr/text: join "Pages transmitted: " pages
		show patr
	]

	wait port
	wait client: first port

	if error? err: try [content/handle client] [
		print disarm err
		alert "an unexpected error occurred!"
		quit
	]

	close client
	pages: pages + 1
]