REBOL [ Title: "Obscure File Server" Purpose: "Share files over HTTP protocol +NLS" Author: "pijoter" 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 ] 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] ] 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 ;; pusta mapa plikow ] 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 ] ] ;; sortuj oddzielnie pliki i katalogi 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: nie modyfikuj gloablnej listy za kazdym przeladowaniem katalogu 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: [ ;; zaufane hosty ] 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 ["" LF LF(second err) LFLF LF "SERVER-ERROR"
LF(third err) " " (to-string message)
LF ] 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 ;; wyswietlaj "parent-dir" tylko gdy nie jestesmy w glownym katalogu if not equal? dir net/server-dir [ set [prev-path prev-dir] (split-path dir) id: fs/make-id prev-path append output rejoin [{
(to-idate now)