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
            ]
        ]
    ]
]