| View script | License | Download script | History | Other scripts by: piotrgapinsk |
7-Sep 23:58 UTC
[0.047] 18.966k
[0.047] 18.966k
 | Archive version of: fileserver.r ... version: 5 ... piotrgapinsk 13-Nov-2005REBOL [
Title: "fileserver"
Purpose: "tool for serving files from the current directory"
Comment: "fileserver with national language support"
Date: Version: 2005-11-11
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-11-11 2005-07-14 2005-07-10 2005-07-08 2005-07-06]
]
fileserver-ctx: context [
web-dir: what-dir
recursive: true
index-file: %index.html
log-file: %fileserver.log
web: compose [
net allow shell throw file throw
(web-dir) [allow read]
(log-file) [allow write]
]
secure :web
set 'server-port 8080
set 'page-language "PL"
set 'page-encoding any [
select [3 "windows-1250"] fourth system/version
"iso-8859-2"
]
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 [p] [found? find [%.log %.r] (suffix? to-file p)]
deny-ip?: func [d ip] [false]
mime-type?: func [p /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 p]
"application/octet-stream"
]
]
set 'server-url does [
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]]
]
make-crc: func [p] [checksum/method p 'MD5]
to-bin-crc: func [ph] [debase/base ph 16]
to-str-crc: func [h] [enbase/base h 16]
file-map: make hash! 128
build-local: func [ph] [
attempt [
if not binary? ph [ph: to-bin-crc ph]
select file-map ph
]
]
build-hash: func [d /local b p h name] [
d: clean-path to-dir d
h: make hash! 64
b: any [
attempt [sort read to-dir d]
return h
]
foreach f b [
p: d/:f
any [
all [dir? p deny-dir? p]
deny-file? p
repend h [(make-crc p) p]
]
]
file-map: union/skip file-map h 2
return h
]
build-index: func [d] [
o: make string! 4096
if not equal? d web-dir [
set [pp pd] (split-path d)
ph: to-str-crc make-crc pp
append o build-markup pick [
{<li><a href="/">../</a> :: (dir)</li>^/}
{<li><a href="<% ph %>">../</a> :: (dir)</li>^/}
] (equal? pp web-dir)
]
foreach [h p] (build-hash d) [
f: second (split-path p)
ph: to-str-crc h
append o build-markup any [
attempt [
fi: info? p
select [
file {<li><a href="<% ph %>"><% f %></a> :: <% fi/size %> b</li>^/}
directory {<li><a href="<% ph %>"><% f %></a> :: (dir)</li>^/}
] fi/type
]
{<li><a href="<% ph %>"><% f %></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="<% page-language %>"/>
<meta name="generator" content="<% system/script/header/title %>"/>
<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 :: <% p %></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 <a href="http://www.rebol.org/cgi-bin/cgiwrap/rebol/view-script.r?script=fileserver.r">REBOL FileServer</a> :: <% 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] [
attempt [
insert dat join "HTTP/1.0 " [
"200 OK" CRLF
"Content-Type: " mime "; charset=" page-encoding CRLF
"Content-Language: " page-language CRLF
"Content-Disposition: inline; filename=" {"} file {"} CRLF
CRLF
]
write-io http-port dat length? dat
]
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
]
attempt [
insert http-port join "HTTP/1.0 " [
err-num " " err/2 CRLF
"Content-Type: text/html; charset=" page-encoding CRLF
"Content-Language: " page-language CRLF
CRLF
<html> LF
<head> <title> err/2 </title> <basefont face="tahoma,arial"/> </head> LF
<body> LF
<h2> "SERVER-ERROR" </h2> LF
<p> err/3 " " file <br/> now </p> LF
</body> LF
</html>
]
]
err-num
]
buffer: make string! 10240
space: [some " "]
chars: complement charset " "
set 'serve func [http-port /local t-start p 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 [
p: web-dir/:index-file
uri: to-str-crc (make-crc p)
][
p: build-local uri
if dir? (to-file p) [p: p/:index-file]
]
net-utils/net-log ["local-path" (form p) "empty?" empty? (form p)]
net-utils/net-log ["mime-type" mime-type? (form p)]
net-utils/net-log ["deny-ip?" http-port/host deny-ip? (form p) http-port/host]
net-utils/net-log ["deny-path?" deny-file? (form p)]
dat: copy #{}
mime:"text/plain"
uri: copy/part uri 32
response: any [
if (none? p) [send-error http-port 404 uri]
if (deny-ip? p http-port/host) [send-error http-port 400 http-port/host]
if (all [dir? p deny-dir? p]) [send-error http-port 400 uri]
if (deny-file? p) [send-error http-port 400 uri]
if not attempt [
set [d f] (split-path p)
any [
if all [
equal? f index-file
not exists? p
] [dat: build-index d]
dat: read/binary p
]
][send-error http-port 404 uri]
send-page http-port f dat (mime: mime-type? p)
]
net-utils/net-log ["response" response]
emit-log [
http-port/host
uri
rejoin [{"} find/tail form p (head remove back tail form web-dir) {"}]
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]
] |