REBOL [
Title: "Sandbox Port (WRT)"
Author: "Christopher Ross-Gill"
Notes: {Part of the QuarterMaster web framework.}
File: %wrt.r
Date: 9-Jan-2007
Settings: [
; use a string-directory pair to set file domains
"sbox" %/path/to/sandbox/
]
Usage: [
do http://reb4.me/r/wrt ; uses settings above
read wrt://sbox/some/sandbox/file.txt
do/args http://reb4.me/r/wrt ["home" %~/]
read wrt://home/
]
]
;--## EXTENDED CORE FUNCTIONS
;-------------------------------------------------------------------##
context [
with: func [object [any-word! object! port!] block [any-block!] /only][
block: bind block object
either only [block] :block
]
envelop: func [data [any-type!]][either any-block? data [data][reduce [data]]]
press: func [values [any-block!] /local out][
values: reduce envelop values
remove-each value values [any [unset? get/any 'value none? value]]
append copy "" values
]
raise: func [[throw] reason][throw make error! rejoin envelop reason]
export: func [words [word! block!] /to dest [object!] /local word][
dest: any [dest system/words]
foreach word words [if word? word [set/any in dest word get/any word]]
]
export [with raise export]
]
;--## PORT HELPERS
;-------------------------------------------------------------------##
context [
add-protocol: func ['name id handler /with block][
unless in system/schemes name [
system/schemes: make system/schemes compose [
(to-set-word name) #[none]
]
]
set in system/schemes name make system/standard/port compose [
scheme: name
port-id: (id)
handler: (handler)
passive: #[none]
cache-size: 5
proxy: make object! [host: port-id: user: pass: type: bypass: #[none]]
(block)
]
]
codes: [read 1 write 2 append 4 new 8 binary 32 lines 64 direct 524288]
get-port-flags: func [port words][
remove-each word copy words [
word: select codes word
word <> (port/state/flags and word)
]
]
chars: charset [#"a" - #"z" #"A" - #"Z" #"0" - #"9" "-_!+%()"]
; #[bitset! 64#{AAAAACIo/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]
space!: context [
root: domain: path: target: folder: file: suffix: #[none]
]
spaces: any [
system/script/args
system/script/header/settings
]
get-space: func [base [url!] location [url!] /local space][
base: form base
space: make space! [uri: :location]
if all with/only space [
parse/all uri [
base
copy domain some chars #"/"
copy path any [some chars opt [#"." 1 10 chars] #"/"]
copy target opt [any chars 1 2 [#"." 1 10 chars]]
]
root: select spaces domain
] with/only space [
path: all [path to-file path]
target: all [target to-file target]
folder: join root any [path ""]
file: join folder any [target ""]
suffix: suffix? file
self
]
]
export [add-protocol get-port-flags get-space]
]
;--## FILESYSTEM
;-------------------------------------------------------------------##
context [
sw*: system/words
rights: [
folder [
owner-read: group-read: world-read:
owner-write: group-write: world-write:
owner-execute: group-execute: world-execute: #[true]
]
file [
owner-read: group-read: world-read:
owner-write: group-write: world-write: #[true]
owner-execute: group-execute: world-execute: #[false]
]
]
set-rights: func [file access][
unless find [1 3] system/version/4 [
attempt [set-modes file rights/:access]
; not perfect
]
]
break-path: func [[catch] target [file!] base [file!] /local path mk][
path: make block! []
either parse/all target: form target [
base some [
thru #"/" mk: (append path to-file copy/part target mk)
] end
][return path][
raise compose [access invalid-path (target)]
]
]
make-dir: func [[catch] path [file!] /root base [file!] /deep /local dirs][
all [empty? path return path]
if exists? path [
return either dir? path [path][false]
]
either deep [
close throw-on-error [open/new path]
any [
find [1 3] system/version/4
throw-on-error [set-rights path 'folder]
]
][
dirs: break-path path base
foreach path dirs [make-dir/deep path]
]
path
]
get-subfolders: func [folder /deep /local tree files][
tree: []
unless deep [clear tree]
insert tree folder
files: read folder
foreach file files [
if equal? last folder/:file #"/" [
get-subfolders/deep folder/:file
]
]
tree
]
delete: func [[catch] target [url!] /pare /local path folder err][
either error? set/any 'err try [
; Delete Children
if dir? target [
folder: get-subfolders dirize target
foreach path folder [close clear open path]
]
; Delete Target
set [path target] split-path target
folder: open path
remove find folder target
close folder
; Delete Empty Parents
if pare [
while [
pare: empty? folder: open path
close folder
pare
][
set [path target] split-path path
folder: open path
remove find folder target
close folder
]
]
][throw err][path]
]
dir?: func [[catch] target [file! url!]][
throw-on-error [
target: make port! target
query target
]
target/status = 'directory
]
touch: func [[catch] target [file! url!]][
throw-on-error [
target: make port! target
switch target/scheme [
wrt [target: make port! target/locals/file]
]
query target
switch target/status [
file [set-modes target [modification-date: now]]
#[none] [close open/new target]
]
]
exit
]
export [delete make-dir touch]
; INTERFACE
add-protocol wrt 0 context [
port-flags: system/standard/port-flags/pass-thru
init: func [port url /local spec][
unless all [
url? url
spec: get-space wrt:// url
][
raise ["Filesystem URL <" url "> is invalid."]
]
with port [
set [url host path target] reduce bind [uri domain path target] spec
locals: context [
flags: []
root: spec/root
folder: spec/folder
file: spec/file
suffix: spec/suffix
open: #[none]
]
sub-port: make port! spec/file
]
]
open: func [port][
with port [
locals/flags: get-port-flags port [read write append new binary lines]
all [
sw*/find locals/flags 'new
not dir? locals/folder
make-dir/root locals/folder locals/root
]
either all [
any [
exists? locals/file
sw*/find locals/flags 'new
]
sw*/open/mode sub-port locals/flags
][
locals/open: true
state/tail: sub-port/state/tail
][
state/tail: 0
]
state/index: 0
state/flags: state/flags or port-flags
]
]
copy: func [port][
if port/locals/open with/only port [
user-data: sw*/copy skip sub-port state/index
all [
block? user-data block? state/custom
remove-each file user-data [not parse file state/custom]
]
user-data
]
]
insert: func [port data][
if port/locals/open with/only port [
foreach [test onfail][
[sw*/insert sub-port data]
["Could not write <" url ">"]
[set-rights sub-port 'file]
["Could not set permissions <" url ">"]
][
if error? try :test [raise :onfail]
]
self
]
]
remove: func [port][
either port/locals/open with/only port [
sub-port: skip sub-port state/index
sw*/remove/part sub-port state/num
self
][]
]
find: func [port value][
if port/locals/open with/only port [
if value: sw*/find sub-port value [
sub-port: :value
self
]
]
]
close: func [port][
either port/locals/open with/only port [
any [locals/open exit]
sw*/close sub-port
self
][]
]
query: func [port][
with port [
sw*/query sub-port
size: sub-port/size
date: sub-port/date
status: sub-port/status
]
]
]
]