Put the script in the directory you want to share and start it.
Using a browser you'll obtain this:
REBOL [
Title: "Obscure File Server"
Purpose: "Share files over HTTP protocol +NLS"
Author: "pijoter" ;+ Massimiliano Vessi
Date: 2-Sep-2009/21:04:51+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
version: 2.0.0
]
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: [
;; directory systems SCM
%.git/ %.cvs/ %.svn/
]
DENY-FILE: reduce [
;; file server and logs
any [attempt [system/script/header/file] %fileserver.r]
any [attempt [system/script/header/log] log/FILE]
]
SORT-METHOD: 'name ;; 'date 'name 'size
paths: 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]
make-id: func [path [string! file!]] [enbase/base (checksum/method (form path) 'MD5) 16]
is-id?: func [id [string!]] [equal? 32 (length? id)]
update-paths: func [dir [string! file!]
/local hash dir-content bag item info dirs files path] [
dir: clean-path (self/to-dir dir)
hash: make hash! 64
any [
dir-content: attempt [sort read dir]
return hash ;;blank map files
]
if found? find [date size] self/SORT-METHOD [
attempt [
bag: make block! (2 * length? dir-content)
foreach item dir-content [
info: info? dir/:item
repend bag [(get in info self/SORT-METHOD) item]
]
sort/skip/reverse bag 2
clear dir-content
foreach [value item] bag [append dir-content item]
unset 'bag
]
]
;; sort files and directories separately
dirs: remove-each target (copy dir-content) [
any [
self/is-file? target
self/deny-dir? target
]]
files: remove-each target dir-content [
any [
self/is-dir? target
self/deny-file? target
]]
foreach item (union dirs files) [
path: dir/:item
repend hash [(self/make-id path) path]
;; net-utils/net-log ["fs/update-paths" "item" (item) "is-dir?" (is-dir? target)]
]
;; TODO: do not modify the list of global catalog for each overcharge
self/paths: union/skip self/paths hash 2
return hash
]
local-path: func [id [string! none!]] [select self/paths id]
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: [;; trusted hosts ]
SERVER-PORT: 8080
BUFFER-SIZE: 1024 * 1024 * 1 ; 1M
mime: none
status: none
response: [
200 "OK" "Everything is just fine"
400 "Bad Request" "Malformed request:"
401 "Unauthorized" "No permission to access:"
403 "Forbidden" "No permission to access:"
404 "Not Found" "Resource was not found:"
410 "Gone" "Resource is no longer available:"
]
server-ip: has [ip port interfaces ifc] [
ip: make block! 5
append ip [127.0.0.1]
attempt [
port: open tcp://
interfaces: get-modes port 'interfaces
foreach ifc interfaces [append ip get in ifc 'addr]
close port
]
if not empty? self/DENY-IP [self/ALLOW-IP: union self/ALLOW-IP ip]
sort unique ip
]
server-url: does [rejoin [http:// (first self/server-ip) ":" (self/SERVER-PORT)]]
server-dir: does [what-dir]
server-path: func [path [file!]] [find/tail (form path) (head remove back tail (form self/server-dir))]
url?: func [port [port!]] [rejoin ["http://" (port/local-ip) ":" (port/local-port)]]
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
"Expires: " (to-idate now) CRLF
"Date: " (to-idate now) CRLF
"Connection: close" 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!] message [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) " " (to-string message) <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 dir file mime size disposition fh buffer part bytes] [
set [dir file] split-path path
size: size? path
mime: fs/mime? file
disposition: rejoin [
"Content-Disposition: inline; filename=" {"} (form file) {"; size="} (size) {"} CRLF
"Content-Length: " (size) CRLF
]
net-utils/net-log ["net/send-file" (path) "size" (size) "mime" (mime)]
all [
self/send-header/with port mime disposition
attempt [
fh: open/binary/direct/read path
buffer: make binary! self/BUFFER-SIZE
part: 0
forever [
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
clear buffer
]
close fh
unset 'buffer
size
]
]
]
get-id: func [port [port!]
/local buffer space chars resource valid?] [
buffer: copy port
space: [some { }]
chars: complement charset { }
resource: make string! 40
valid?: to-logic all [
parse/all buffer ["GET" space "/" [opt [copy resource some chars]] space "HTTP" to end]
not empty? resource
]
net-utils/net-log ["net/get-id" "id" (resource) "valid?" (valid?) "buffer" (to-string buffer)]
if valid? [resource]
]
]
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 prev-path prev-dir id path target item f l s] [
output: make string! 1024
;; View "parent-dir" only when we are not in the main directory
if not equal? dir net/server-dir [
set [prev-path prev-dir] (split-path dir)
id: fs/make-id prev-path
append output rejoin [{<li><a href="} (id) {">..</a> :: (<a href="} (id) {">parent dir</a>)</li>} LF]
]
foreach [id path] (fs/update-paths dir) [
target: second (split-path path)
item: any [
attempt [
f: info? path
;;File size in human format
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="} (id) {">} (target) {</a> :: } (s) {</li>} LF]
directory [{<li><a href="} (id) {">} (target) {</a> :: (dir)</li>} LF]
] f/type
]
[{<li><a href="} (id) {">} (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 start id resource-id path resource-path dir target bytes err-num stop t] [
start: now/precise
;;retrieve the local path on the basis of ID from the URI
;; if ID exists but does not match the file (no entry in fs / paths or the file is missing) to generate a 404 error
any [
if id: net/get-id port [path: any [(fs/local-path id) (net/server-dir)]]
id: fs/make-id (path: net/server-dir)
]
either (id = fs/make-id path) [
;; keep copies of the access path to the file and the generated id
;; the original may be modified by append file name
resource-path: path
resource-id: id
if dir? path [
;; index file for the virtual directories containing
;; created a list of content (subdirectories and files)
path: rejoin [path "index.html"]
id: fs/make-id path
]
set [dir target] (split-path path)
bytes: any [
;; check access restrictions
if (net/deny-ip? port/host) [net/send-error port 401 (net/url? port)]
if (fs/deny-subdir? (second split-path dir)) [net/send-error port 410 resource-id]
if (fs/deny-file? target) [net/send-error port 410 resource-id]
;;generate index only when the original path does not include the file name (appended "index.html")
if all [(fs/is-dir? resource-path) (equal? (form target) "index.html")] [net/send-page port (self/make-index dir)]
;; if possible send a file
if not exists? path [net/send-error port 404 resource-id]
net/send-file port path
]
if zero? bytes [bytes: self/send-error port 404 resource-id]
][
;;if you can not assign the path to the CRC (because there is no entry in fs / file-map or no CRC) Use an empty string. In the absence of CRC checksum will be generated for resource-path variable
resource-path: {}
resource-id: any [id (fs/make-id resource-path)]
err-num: any [if (fs/is-id? resource-id) [404] 400]
bytes: net/send-error port err-num resource-id
]
stop: now/precise
;; log position relative to the shared folder
resource-path: any [
if all [resource-path (not empty? resource-path)] [net/server-path resource-path]
{}
]
log/emit [
port/host
resource-id
rejoin [{"} resource-path {"}]
net/mime
net/status
bytes
t: to-decimal (difference stop start)
]
net-utils/net-log ["content/handle" "bytes" (bytes) "time" t "speed" (round/to (bytes / t) / 1024 0.01) "KB/sec"]
bytes
]
]
;;
net-watch: false
system/options/quiet: true
my-name: read dns://
my-ip: read join dns:// my-name
either view? [
;; rebol/view
view/new gui: layout [
h1 "Server Running"
across
text "Your PC name is:"
text bold my-name
return
text"Your public IP to share is:"
text bold (rejoin ["http://" my-ip ":8080"])
;text to-string net/server-url
return
patr: text 200 "Pages transmitted: 0"
return
bytr: text 200 "Bytes transmitted: 0.0M"
return
btn "Browse server" [browse net/server-url]
btn "Show directory" [browse net/server-dir] return
do [
insert-event-func [
if equal? event/type 'close [attempt [(close client) (close server)] quit]
event
]
]
]
show gui
][
;; rebol/core
unprotect 'alert
alert: func [message] [print message ask "press-enter^/"]
any [
system/options/quiet
foreach ip net/server-ip [print rejoin [{Server URL: } "http://" ip ":" net/SERVER-PORT]]
]
]
any [
server: attempt [open/binary/direct/no-wait rejoin [tcp://: net/SERVER-PORT]]
do [
message: rejoin [
{Looks like a Web Server is already running on your computer (port } net/SERVER-PORT {).}
{Turn it off first, then try again.}
]
alert message
quit
]
]
pages: 0
bytes: 0.0
forever [
wait server
wait client: first server
if error? err: try [size: content/handle client] [
print disarm err
alert "an unexpected error occurred!"
quit
]
if view? [
pages: pages + 1
bytes: bytes + size
patr/text: join "Pages transmitted: " pages
bytr/text: rejoin ["Bytes transmitted: " round/to (bytes / 1048576) 0.01 "M"]
show [patr bytr]
]
close client
]
It generates also a file log called fileserver.log. You can use this script also with Rebol/Core (no graphic).
No comments:
Post a Comment