View script | License | Download script | History | Other scripts by: piotrgapinsk |
7-Sep 23:54 UTC
[0.042] 22.487k
[0.042] 22.487k
Archive version of: fileserver.r ... version: 6 ... piotrgapinsk 24-Aug-2009REBOL [ 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) " " 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 ] |