Script Library: fileserver.r

Script Library: 1240 scripts
Archive version of: fileserver.r ... version: 4 ... piotrgapinsk 15-Jul-2005

REBOL [
	Title: "fileserver"
	Purpose: "fileserver serving files from the current directory"
	Comment: {
		server will listen on port 8080 and generate index.html files on-the-fly
		files with unrecognized types will be sent as "application/octet-stream"
		filenames with spaces and/or NLS chars are handled as well
	}
	Date: Version: 2005-07-14
	Author: "Piotr Gapinski"
	Email: {news [at] rowery! olsztyn.pl}
	File: %fileserver.r
	Copyright: "Olsztynska Strona Rowerowa http://www.rowery.olsztyn.pl"
	License: "GNU General Public License (Version II)"
	Library: [
		level: 'intermediate
		platform: 'all
		type: [tool]
		domain: [web tcp other-net]
		tested-under: [
			view 1.3.1 on [winxp]
			core 2.6.0 on [winxp linux]
		]
		support: none
		license: 'GPL
	]
	History: [2005-07-06 2005-07-08 2005-07-10 2005-07-14]
]

fileserver-ctx: context [

	web-dir:	what-dir
	recursive:	true
	set 'server-port 8080
	index-file: 	%index.html
	log-file: 	%fileserver.log

	page-encoding:	any [
		select [3 "windows-1250"] fourth system/version
		"iso-8859-2"
	]

	web: compose [
		net allow shell throw file throw 
		(web-dir) [allow read] 
		(log-file) [allow write]
	]
	secure :web

	to-dir: func [d] [to-file dirize d]
	deny-dir?: func [d] [either recursive [false] [all [dir? d web-dir <> (to-dir d)]]]
	deny-file?: func [f] [found? find [%.log %.r] (suffix? to-file f)]
	deny-ip?: func [d ip] [false]

	mime-type?: func [f /local mime-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"
			%.jsp	"text/plain"
		]

		any [
			select mime-map attempt [suffix? to-file f]
			"application/octet-stream"
		]
	]

	set 'server-url does [
		to-url any [
			attempt [rejoin [{http://} (read join dns:// read dns://) ":" server-port]]
			join "http://127.0.0.1:" server-port
		]
	]

	set 'server-home does [web-dir]

	emit-log: func [b] [
		if block? b [b: reduce b]
		attempt [write/append/lines log-file rejoin [now " " form b]]
	]

	file-map: make hash! 128

	build-local: func [ph] [
		attempt [
			if not binary? ph [ph: debase/base ph 16]
			select file-map ph
		]
	]

	build-hash: func [d /local b p h path name] [
		d: clean-path to-dir d
		h: make hash! 64

		b: any [
			attempt [sort read to-dir d]
			return h
		]

		foreach i b [
			set [path name] split-path p: d/:i
			any [
				deny-file? name
				name = index-file
				all [dir? p deny-dir? p]
				repend h [(checksum/method p 'MD5) p]
			]
		]

		file-map: union/skip file-map h 2
		return h
	]

	build-index: func [d /local i] [
		o: make string! 4096

		foreach [h p] (build-hash to-dir d) [
			set [path name] split-path p
			ph: enbase/base h 16
			append o build-markup any [
				attempt [
					size: get in (i: info? p) 'size
					select [file {<li><a href="<% ph %>"><% name %></a> :: <% size %> bytes</li>^/}] (get in i 'type)
				]
				{<li><a href="<% ph %>"><% name %></a></li>^/}
			]
		]
 
		p: find/tail form d (head remove back tail form web-dir)
		return build-markup
{
<html>
<head>
<title>FileServer Index :: <% p %></title>
<meta http-equiv="Content-Type" content="text/html; charset=<% page-encoding %>"/>
<meta http-equiv="Content-Language" content="pl"/>
<meta name="generator" content="REBOL FileServer"/>
<meta name="author" content="news [at] rowery! olsztyn.pl"/>
<basefont face="tahoma,arial"/>
<link rel="shortcut icon" href="http://www.rowery.olsztyn.pl/osrimg/favicon.ico"/>
</head>
<body>
<h2>Index</h2>
<ul>
<% trim/tail o %>
</ul>
<font size="-2">
Any inaccuracies in this index may be explained by the fact that it has been prepared with the help of a computer.<br/>
Page generated by REBOL FileServer :: <% form now %>
</font>
<script language="JavaScript" type="text/javascript" src="http://www.rowery.olsztyn.pl/lib/clock.js"></script>
</body>
</html>
}
	]

	send-page: func [http-port file dat mime /local response] [
		insert dat rejoin [
			"HTTP/1.0 200 OK^/"
			"Content-type: " mime "; charset=" page-encoding "^/"
			"Content-Disposition: inline; filename=" {"} file {"} "^/"
			"^/"
		]
		write-io http-port dat length? dat
		response: 200
	] 

	errors: [
		400 "Forbidden" "No permission to access:"
		404 "Not Found" "File was not found:"
	]

	send-error: func [http-port err-num file /local err response] [
		err: any [
			attempt [find errors err-num]
			errors
		]
		insert http-port join "HTTP/1.0 " [
			err-num " " err/2 "^/"
			"Content-type: text/html; charset=" page-encoding "^/"
			"^/" 
			<html> 
			<head> <title> err/2 </title> </head>
			<body> 
			<h2> "SERVER-ERROR" </h2> 
			<p> "REBOL FileServer Error: " err/3 " " file </p> 
			</body> 
			</html>
		]
		response: err-num
	]

	buffer: make string! 10240
	space: [some " "]
	chars: complement charset " "

	set 'serve func [http-port /local t-start path dat mime response uri] [
		response: 400
		t-start: now/precise

		clear buffer
		any [
			attempt [ while [not empty? http-request: first http-port] [repend buffer [http-request newline]] ]
			return response
		]

		repend buffer ["Address: " http-port/host newline] 
		uri: copy {}

		net-utils/net-log ["buffer" buffer]

		any [
			attempt [parse/all buffer ["GET" space "/" opt [copy uri some chars] space to end]]
			return response
		]

		net-utils/net-log ["uri" uri "empty?" empty? trim uri]

		either empty? trim uri [
			uri: enbase/base (checksum/method web-dir/:index-file 'MD5) 16
			path: web-dir/:index-file
		][

			build-hash web-dir
			path: build-local uri
			if all [not none? path dir? to-file path] [path: path/:index-file]
		]

		net-utils/net-log ["local-path" form path "empty?" empty? form path]
		net-utils/net-log ["mime-type" mime-type? form path]
		net-utils/net-log ["deny-ip?" http-port/host deny-ip? form path http-port/host]
		net-utils/net-log ["deny-path?" deny-file? form path]

		dat: copy #{}
		mime:"text/plain"
		
		response: any [
			if none? path [send-error http-port 404 uri]
			if deny-ip? path http-port/host [send-error http-port 400 http-port/host]
			if all [dir? path deny-dir? path] [send-error http-port 400 uri] 
			if deny-file? path [send-error http-port 400 uri]
			if none? attempt [
				dat: either equal? index-file (second split-path path) 
					[build-index (first split-path path)]
					[read/binary path]
			][send-error http-port 404 uri]
			send-page http-port (second split-path path) dat (mime: mime-type? path)
		]

		net-utils/net-log ["response" response]

		emit-log [
			http-port/host
			uri
			rejoin [{"} (to-local-file form path) {"}]
			mime 
			response 
			length? dat 
			to-decimal difference now/precise t-start
		]
		response
	]
]


net-watch: false
if (not view?) [alert: func [t] [print t ask "press-enter"]]
 
any [
	listen-port: attempt [open/lines join tcp://: server-port]
	do [
		alert "Looks like a Web Server is already running on your computer. Turn it off first, then launch FileServer again."
		quit
	]
]

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

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

	http-port: first wait listen-port

	any [
		attempt [serve http-port]
		do [
			alert {We apologize, an unexpected error occurred!}
			quit
		]
	]

	close http-port

	pages: pages + 1
	net-utils/net-log ["pages" pages]
]