Archive version of: fileserver.r ... version: 7 ... piotrgapinsk 26-Aug-2009

REBOL [
	Title: "Obscure File Server"
	Purpose: "Share files over HTTP protocol +NLS"
	Author: "pijoter"
	Date: 26-Aug-2009/9:43:19+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-DOT: true
	DENY-DIR: [
		;; katalogi systemow SCM
		%.git/ %.cvs/ %.svn/
	]
	DENY-FILE: reduce [
		;; plik serwera i logow
		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!] /local rc] [
		rc: any [
			found? find self/DENY-FILE file
			if self/DENY-DOT [self/is-dot? file]
		]
		net-utils/net-log ["fs/deny-file?" file "deny?" (to-logic rc)]
		return rc
	]
	deny-dir?: func [dir [file!] /local rc] [
		rc: any [
			found? find self/DENY-DIR dir
			if self/DENY-DOT [self/is-dot? dir]
		]
		net-utils/net-log ["fs/deny-dir?" (dir) "deny?" (to-logic rc)]
		return rc
	]
	deny-subdir?: :deny-dir?

	to-dir: func [target [string! file!]] [dirize to-file target]
	is-dir?: func [target [string! file!]] [#"/" = last target]
	is-file?: func [target [string! file!]] [not self/is-dir? target]
	is-dot?: func [target [string! file!]] [#"." = first target]

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

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

		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) [
			any [
				self/is-file? target
				self/deny-dir? target
			]]

		files: remove-each target items [
			any [
				self/is-dir? target
				self/deny-file? target
			]]

		foreach target (union dirs files) [
			path: dir/:target
			repend map [(self/crc? path) path]
			;; net-utils/net-log ["fs/make-map" "target" target "is-dir?" is-dir? target]
		]

		;; 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.1 " (status) " " (select self/response status) CRLF
					"Content-Type: " (mime) "; charset=" (content/encoding) CRLF
					"Content-Language: " (content/language) CRLF
					"Date: " (to-idate now) CRLF
					"Expires: " (to-idate now) 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
			]
			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 size disposition mime fh buffer bytes part] [

		set [dir file] split-path path

		size: size? path
		mime: fs/mime? file

		disposition: rejoin [
			"Content-Disposition: inline; filename=" {"} (form file) {"} CRLF
			"Content-Length: " (size) CRLF
		]

		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
			]
		]
	]

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

		buffer: copy port

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

		valid?: to-logic all [
			parse/all buffer ["GET" space "/" [opt [copy uri some chars]] space "HTTP" to end]
			equal? fs/CRC-LENGTH (length? uri)
		]

		net-utils/net-log ["net/uri?" "uri" (uri) "valid?" (valid?) "buffer" (to-string buffer)]
		if valid? [copy/part uri fs/CRC-LENGTH]
	]
]

content: context [
	language: "pl,en"
	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 [

			;; wyswietlaj "parent-dir" tylko gdy nie jestesmy w glownym katalogu
			set [prev-path prev-dir] (split-path dir)
			crc: fs/crc? prev-path

			append output rejoin [{<li><a href="} (crc) {">..</a> :: (<a href="} (crc) {">parent dir</a>)</li>} LF]
		]

		foreach [crc path] (fs/make-map dir) [
			target: 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) {">} (target) {</a> :: } (s) {</li>} LF]
						directory [{<li><a href="} (crc) {">} (target) {</a> :: (dir)</li>} LF]
					] f/type
				]
				[{<li><a href="} (crc) {">} (target) {</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
				{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) LF
				</font> LF
			</body> LF
			</html> LF
		]
	]

	handle: func [port [port!]
		/local log-path path uri dir file size start stop] [

		start: now/precise

		;; odtworz lokalna sciezke na podstawie CRC z URI
		;; jezeli CRC istnieje ale nie pasuje do pliku (brak wpisu w fs/file-map
		;; lub z brak pliku) to generuj blad 404

		any [
			if uri: net/uri? port [path: any [fs/make-local uri net/server-dir]]
			uri: fs/crc? path: net/server-dir
		]

		either (uri = fs/crc? path) [
			;; zachowaj kopie sciezki dostepu to pliku
			;; oryginal moze byc modyfikowany przez doklejanie nazwy pliku

			log-path: path

			if dir? path [

				;; wirtualny plik indeksu dla katalogow zawierajacy
				;; wygenerowana liste zawartosci (podkatalogow oraz plikow)

				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
			]
		][
			;; jezeli nie mozna przypisac sciezki do CRC (z powodu braku wpisu
			;; w fs/file-map lub braku CRC) uzyj pusty ciag znakow. W przypadku
			;; braku CRC suma kontrolna bedzie generowana dla zmiennej log-path

			log-path: {}
			uri: any [uri (fs/crc? log-path)]
			size: net/send-error port 404 uri
		]

		stop: now/precise

		;; loguj polozenie wzgledem udostepnianego katalogu
		log-path: any [
			if all [log-path (not empty? log-path)] [net/server-path log-path]
			{}
		]

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

		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
]