REBOL [
    Title: "Sandbox Port"
    Author: "Christopher Ross-Gill"
    Date: 9-Jan-2007
]

config: construct [
    file-domains: [
        ; use a string-directory pair to set file domains
        "sbox"   %/path/to/sandbox/
    ]
]

;--## EXTENDED CORE FUNCTIONS
;-------------------------------------------------------------------##
context [
    set 'with func [object [object! port!] block [block!]][
        do bind block in object 'self
    ]
]

;--## PORT HELPERS
;-------------------------------------------------------------------##
context [
    set 'add-protocol func ['proto-name proto-port-id proto-handler][
        unless in system/schemes proto-name [
            system/schemes: make system/schemes compose [
                (to-set-word proto-name) #[none]
            ]
        ]
        set in system/schemes proto-name make system/standard/port [
            scheme: proto-name
            port-id: proto-port-id
            handler: proto-handler
            passive: none
            cache-size: 5
            proxy: make object! [host: port-id: user: pass: type: bypass: #[none]]
        ]
    ]

    codes: [read 1 write 2 append 4 new 8 binary 32 lines 64]
    set 'get-port-flags func [port words][
        remove-each word copy words [
            word: select codes word
            word <> (port/state/flags and word)
        ]
    ]
]

;--## SANDBOX FILESYSTEM
;-------------------------------------------------------------------##
context [
    chars: charset [#"a" - #"z" #"0" - #"9" "-_!+%"]

    parse-uri: func [uri /local domain root path target][
        if all [
            parse/all uri [
                "files://"
                copy domain some chars #"/"
                copy path any [some chars #"/"]
                copy target opt [any chars #"." 1 10 chars]
            ]
            root: select config/file-domains domain
        ][
            reduce [
                root
                domain
                all [path to-file path]
                all [target to-file target]
            ]
        ]
    ]

    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 [
            set-modes file rights/:access
        ]
    ]

    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][
            throw make error! reduce ['access 'invalid-path target]
        ]
    ]

    make-dir: func [[catch] path [file!] /root base [file!] /sub /local dirs][
        all [empty? path return path]
        if exists? path [
            return either dir? path [path][false]
        ]
        either sub [
            close throw-on-error [open/new path]
            any [
                system/words/find [1 3] system/version/4
                throw-on-error [set-rights path 'folder]
            ]
        ][
            dirs: break-path path base
            foreach path dirs [make-dir/sub path]
        ]
        path
    ]

    get-subfolders: func [folder /deep /local tree files][
        tree: []
        any [deep clear tree]
        insert tree folder: dirize folder
        files: read folder
        foreach file files [
            if dir? folder/:file [get-subfolders/deep folder/:file]
        ]
        tree
    ]

    system/words/delete: func [[catch] target [url!] /pare /local path folder err][
        either error? set/any 'err try [
            ; Delete Children
            if dir? target [
                folder: get-subfolders 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]
    ]

; INTERFACE
    actions: context [
        port-flags: system/standard/port-flags/pass-thru

        init: func [[catch] port url /local spec][
            unless all [
                url? url
                spec: parse-uri url
            ][
                make error! reform ["Spec Error:" url]
            ]

            with port [
                set [host path target] next spec


                locals: context [
                    flags: []
                    root: first spec
                    folder: join root any [path ""]
                    file: join folder any [target ""]
                    suffix: suffix? file
                    open: #[none]
                ]

                sub-port: make port! locals/file
            ]
        ]

        open: func [port][
            with port [
                locals/flags: get-port-flags port [read write append new binary lines]

                all [
                    system/words/find locals/flags 'new
                    not dir? locals/folder
                    make-dir/root locals/folder locals/root
                ]

                either all [
                    any [
                        exists? locals/file
                        system/words/find locals/flags 'new
                    ]
                    system/words/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][
            with port [
                any [locals/open return #[none]]
                user-data: system/words/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 [[catch] port data][
            with port [
                any [locals/open exit]
                throw-on-error [
                    system/words/insert sub-port data
                    set-rights sub-port 'file
                ]
            ]
            port
        ]

        remove: func [port][
            with port [
                any [locals/open exit]
                sub-port: skip sub-port state/index
                system/words/remove/part sub-port state/num
            ]
            port
        ]

        find: func [port value][
            any [port/locals/open return #[none]]
            if value: system/words/find port/sub-port value [
                port/sub-port: :value
                port
            ]
        ]

        close: func [port][
            with port [
                any [locals/open exit]
                system/words/close sub-port
            ]
            port
        ]

        query: func [port][
            with port [
                system/words/query sub-port
                size: sub-port/size
                date: sub-port/date
                status: sub-port/status
            ]
        ]
    ]

    add-protocol files 0 actions
]