rgchris/altjson-renc.reb

## altjson-renc.reb
Rebol [
    Title: "JSON Parser for Rebol 3"
    Author: "Christopher Ross-Gill"
    Date: 18-Sep-2015
    Home: http://www.ross-gill.com/page/JSON_and_Rebol
    File: %altjson.r
    Version: 0.3.6.1
    Purpose: "Convert a Rebol block to a JSON string"
    Rights: http://opensource.org/licenses/Apache-2.0
    ; Type: 'module
    ; Name: 'rgchris.altjson
    Exports: [load-json to-json]
    History: [
        25-Feb-2017 0.3.6.1 "Ren-C Compatibilities"
        18-Sep-2015 0.3.6 "Non-Word keys loaded as strings"
        17-Sep-2015 0.3.5 "Added GET-PATH! lookup"
        16-Sep-2015 0.3.4 "Reinstate /FLAT refinement"
        21-Apr-2015 0.3.3 {
            - Merge from Reb4.me version
            - Recognise set-word pairs as objects
            - Use map! as the default object type
            - Serialize dates in RFC 3339 form
        }
        14-Mar-2015 0.3.2 "Converts Json input to string before parsing"
        07-Jul-2014 0.3.0 "Initial support for JSONP"
        15-Jul-2011 0.2.6 "Flattens Flickr '_content' objects"
        02-Dec-2010 0.2.5 "Support for time! added"
        28-Aug-2010 0.2.4 "Encodes tag! any-type! paired blocks as an object"
        06-Aug-2010 0.2.2 "Issue! composed of digits encoded as integers"
        22-May-2005 0.1.0 "Original Version"
    ]
    Notes: {
        - Converts date! to RFC 3339 Date String
    }
]

attempt [_: blank: none blank!: none! blank?: :none?]

load-json: use [
    tree branch here val is-flat emit new-child to-parent neaten word to-word
    space comma number string block object _content value ident
][
    branch: make block! 10

    emit: func [val][here: insert/only here val]
    new-child: [(insert/only branch insert/only here here: make block! 10)]
    to-parent: [(here: take branch)]
    neaten: [
        (new-line/all head here true)
        (new-line/all/skip head here true 2)
    ]

    to-word: use [word1 word+][
        ; upper ranges borrowed from AltXML
        word1: charset [
            "!&*=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
            #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(02FF)"
            #"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)"
            #"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
            #"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
        ]

        word+: charset [
            "!&'*+-.0123456789=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
            #"^(B7)" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(037D)"
            #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)" #"^(203F)" - #"^(2040)"
            #"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
            #"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
        ]

        func [val [string!]][
            all [
                parse val [word1 any word+]
                to word! val
            ]
        ]
    ]

    space: use [space][
        space: charset " ^-^/^M"
        [any space]
    ]

    comma: [space #"," space]

    number: use [dg ex nm as-num][
        dg: charset "0123456789"
        ex: [[#"e" | #"E"] opt [#"+" | #"-"] some dg]
        nm: [opt #"-" some dg opt [#"." some dg] opt ex]

        as-num: func [val [string!]][
            case [
                not parse val [opt "-" some dg][to decimal! val]
                not integer? try [val: to integer! val][to issue! val]
                val [val]
            ]
        ]

        [copy val nm (val: as-num val)]
    ]

    string: use [ch es hx mp decode][
        ch: complement charset {\"}
        es: charset {"\/bfnrt}
        hx: charset "0123456789ABCDEFabcdef"
        mp: [#"^"" "^"" #"\" "\" #"/" "/" #"b" "^H" #"f" "^L" #"r" "^M" #"n" "^/" #"t" "^-"]

        decode: use [ch mk escape][
            escape: [
                ; should be possible to use CHANGE keyword to replace escaped characters.
                mk: #"\" [
                    es (mk: change/part mk select mp mk/2 2)
                    |
                    #"u" copy ch 4 hx (
                        mk: change/part mk to char! to-integer/unsigned debase/base ch 16 6
                    )
                ] :mk
            ]

            func [text [string! blank!]][
                either blank? text [make string! 0][
                    all [parse text [any [to "\" escape] to end] text]
                ]
            ]
        ]

        [#"^"" copy val [any [some ch | #"\" [#"u" 4 hx | es]]] #"^"" (val: decode val)]
    ]

    block: use [list][
        list: [space opt [value any [comma value]] space]

        [#"[" new-child list #"]" neaten/1 to-parent]
    ]

    _content: [#"{" space {"_content"} space #":" space value space "}"] ; Flickr

    object: use [name list as-map][
        name: [
            string space #":" space (
                emit either is-flat [
                    to tag! val
                ][
                    any [
                        to-word val
                        lock val
                    ]
                ]
            )
        ]
        list: [space opt [name value any [comma name value]] space]
        as-map: [(unless is-flat [here: change back here make map! pick back here 1])]

        [#"{" new-child list #"}" neaten/2 to-parent as-map]
    ]

    ident: use [initial ident][
        initial: charset ["$_" #"a" - #"z" #"A" - #"Z"]
        ident: union initial charset [#"0" - #"9"]

        [initial any ident]
    ]

    value: [
          "null" (emit _)
        | "true" (emit true)
        | "false" (emit false)
        | number (emit val)
        | string (emit val)
        | _content
        | object | block
    ]

    func [
        "Convert a JSON string to Rebol data"
        json [string! binary! file! url!] "JSON string"
        /flat "Objects are imported as tag-value pairs"
        /padded "Loads JSON data wrapped in a JSONP envelope"
    ][
        case/all [
            any [file? json url? json][
                if error? json: try [read/string (json)][
                    do :json
                ]
            ]
            binary? json [json: to string! json]
        ]

        is-flat: :flat
        tree: here: make block! 0

        either parse json either padded [
            [space ident space "(" space opt value space ")" opt ";" space]
        ][
            [space opt value space]
        ][
            pick tree 1
        ][
            do make error! "Not a valid JSON string"
        ]
    ]
]

to-json: use [
    json emit emits escape emit-issue emit-date
    here lookup comma block object block-of-pairs value
][
    emit: func [data][repend json data]
    emits: func [data][emit {"} emit data emit {"}]

    escape: use [mp ch encode][
        mp: [#"^/" "\n" #"^M" "\r" #"^-" "\t" #"^"" "\^"" #"\" "\\" #"/" "\/"]
        ch: intersect ch: charset [#" " - #"~"] difference ch charset extract mp 2

        encode: func [here][
            change/part here any [
                select mp here/1
                rejoin ["\u" skip tail form to-hex to integer! here/1 -4]
            ] 1
        ]

        func [txt][
            parse txt [any [txt: some ch | skip (txt: encode txt) :txt]]
            head txt
        ]
    ]

    emit-issue: use [dg nm mk][
        dg: charset "0123456789"
        nm: [opt "-" some dg]

        [(either parse next form here/1 [copy mk nm][emit mk][emits here/1])]
    ]

    emit-date: use [pad second][
        pad: func [part length][part: to string! part head insert/dup part "0" length - length? part]

        quote (
            emits rejoin collect [
                keep reduce [pad here/1/year 4 "-" pad here/1/month 2 "-" pad here/1/day 2]
                if here/1/time [
                    keep reduce ["T" pad here/1/hour 2 ":" pad here/1/minute 2 ":"]
                    keep either integer? here/1/second [
                        pad here/1/second 2
                    ][
                        second: split to string! here/1/second "."
                        reduce [pad second/1 2 "." second/2]
                    ]
                    keep either any [
                        blank? here/1/zone
                        zero? here/1/zone
                    ]["Z"][
                        reduce [
                            either here/1/zone/hour < 0 ["-"]["+"]
                            pad abs here/1/zone/hour 2 ":" pad here/1/zone/minute 2
                        ]
                    ]
                ]
            ]
        )
    ]

    lookup: [
        here: [get-word! | get-path!]
        (change here reduce reduce [here/1])
        fail
    ]

    comma: [(if not tail? here [emit ","])]

    block: [
        (emit "[") any [here: value here: comma] (emit "]")
    ]

    block-of-pairs: [
          some [set-word! skip]
        | some [tag! skip]
    ]

    object: [
        (emit "{")
        any [
            here: [set-word! (change here to word! here/1) | any-string! | any-word!]
            (emit [{"} escape to string! here/1 {":}])
            here: value here: comma
        ]
        (emit "}")
    ]

    value: [
          lookup ; resolve a GET-WORD! reference
        | number! (emit here/1)
        | [logic! | 'true | 'false] (emit to string! here/1)
        | [blank! | 'none | 'blank] (emit quote 'null)
        | date! emit-date
        | issue! emit-issue
        | [
            any-string! | word! | lit-word! | tuple! | pair! | money! | time!
        ] (emits escape form here/1)
        | any-word! (emits escape form to word! here/1)

        | [object! | map!] :here (change/only here body-of first here) into object
        | into block-of-pairs :here (change/only here copy first here) into object
        | any-block! :here (change/only here copy first here) into block

        | any-type! (emits to tag! type? first here)
    ]

    func [data][
        json: make string! 1024
        if parse compose/only [(data)][here: value][json]
    ]
]

## httpd-renc.reb
Rebol [
    Title: "Web Server Scheme for Ren-C"
    Author: "Christopher Ross-Gill"
    Date: 23-Feb-2017
    File: %httpd.reb
    Version: 0.3.0
    Purpose: "An elementary Web Server scheme for creating fast prototypes"
    Rights: http://opensource.org/licenses/Apache-2.0
    Type: module
    Name: httpd
    History: [
        23-Feb-2017 0.3.0 "Adapted from Rebol 2"
        06-Feb-2017 0.2.0 "Include HTTP Parser/Dispatcher"
        12-Jan-2017 0.1.0 "Original Version"
    ]
]

net-utils: reduce ['net-log _]

as-string: func [binary [binary!] /local mark][
    mark: binary
    while [mark: invalid-utf8? mark][
        mark: change/part mark #{EFBFBD} 1
    ]
    to string! binary
]

sys/make-scheme [
    title: "HTTP Server"
    name: 'httpd

    spec: make system/standard/port-spec-head [port-id: does: _]

    default-response: [probe request/action]

    init: func [server [port!] /local spec port-id does][
        spec: server/spec

        case [
            url? spec/ref []
            block? spec/does []
            parse spec/ref [
                set-word! lit-word!
                integer! block!
            ][
                spec/port-id: spec/ref/3
                spec/does: spec/ref/4
            ]
            /else [
                do make error! "Server lacking core features."
            ]
        ]

        server/locals: make object! [
            handler: subport: _
        ]

        server/locals/handler: procedure [
            request [object!]
            response [object!]
        ] case [
            function? get in server 'awake [body-of get in server 'awake]
            block? server/awake [server/awake]
            block? server/spec/does [server/spec/does]
            true [default-response]
        ]

        server/locals/subport: make port! [scheme: 'tcp]
        server/locals/subport/spec/port-id: spec/port-id
        server/locals/subport/locals: make object! [
            request: response: _
            wire: make binary! 4096
            parent: :server
        ]

        server/locals/subport/awake: func [event [event!] /local client server] compose [
            ; server: (:server)
            if event/type = 'accept [
                client: first event/port
                client/awake: :wake-client
                read client
            ]

            ; event
            false
        ]

        server
    ]

    start: func [port [port!]][
        append system/ports/wait-list port
    ]

    stop: func [port [port!]][
        remove find system/ports/wait-list port
        close port
    ]

    actor: [
        open: func [server [port!]][
            ; print ["Server running on port:" server/spec/port-id]
            start server/locals/subport
            open server/locals/subport
        ]

        close: func [server [port!]][
            stop server/locals/subport
        ]
    ]

    request-prototype: make object! [
        version: 1.1
        method: "GET"
        action: headers: http-headers: _
        oauth: target: binary: content: length: timeout: _
        type: 'application/x-www-form-urlencoded
        server-software: rejoin [
;          system/script/header/title " v" system/script/header/version " "
            "Rebol/" system/product " v" system/version
        ]
        server-name: gateway-interface: _
        server-protocol: "http"
        server-port: request-method: request-uri:
        path-info: path-translated: script-name: query-string:
        remote-host: remote-addr: auth-type:
        remote-user: remote-ident: content-type: content-length: _
        error: _
    ]

    response-prototype: make object! [
        status: 404
        content: "Not Found"
        location: _
        type: "text/html"
        length: 0
        kill?: false
        close?: true
    ]

    wake-client: use [instance][
        instance: 0

        func [event [event!] /local client request response this][
            client: event/port

            switch/default event/type [
                read [
                    ++ instance
                    ; print rejoin ["[" instance "]"]

                    either find client/data #{0D0A0D0A} [
                        transcribe client
                        dispatch client
                    ][
                        read client
                    ]
                ]
                wrote [
                    unless send-chunk client [
                        if client/locals/response/kill? [
                            close client
                            stop client/locals/parent
                        ]
                    ]
                    client
                ]
                close [close client]
            ][
                ; probe event/type
            ]
        ]
    ]

    transcribe: use [
        space request-action request-path request-query
        header-prototype header-feed header-name header-part
    ][
        request-action: ["HEAD" | "GET" | "POST" | "PUT" | "DELETE"]

        request-path: use [chars][
            chars: complement charset [#"^@" - #" " #"?"]
            [some chars]
        ]

        request-query: use [chars][
            chars: complement charset [#"^@" - #" "]
            [some chars]
        ]

        header-feed: [newline | crlf]

        header-part: use [chars][
            chars: complement charset [#"^(00)" - #"^(1F)"]
            [some chars any [header-feed some " " some chars]]
        ]

        header-name: use [chars][
            chars: charset ["_-0123456789" #"a" - #"z" #"A" - #"Z"]
            [some chars]
        ]

        space: use [space][
            space: charset " ^-"
            [some space]
        ]

        header-prototype: context [
            Accept: "*/*"
            Connection: "close"
            User-Agent: rejoin ["Rebol/" system/product " " system/version]
            Content-Length: Content-Type: Authorization: Range: _
        ]

        transcribe: func [
            client [port!]
            /local request name value pos
        ][
            client/locals/request: make request-prototype [
                either parse client/data [
                    copy method request-action space
                    copy request-uri [
                        copy target request-path opt [
                            "?" copy query-string request-query
                        ]
                    ] space
                    "HTTP/" copy version ["1.0" | "1.1"]
                    header-feed
                    (headers: make block! 10)
                    some [
                        copy name header-name ":" any " "
                        copy value header-part header-feed
                        (
                            name: as-string name
                            value: as-string value
                            append headers reduce [to set-word! name value]
                            switch name [
                                "Content-Type" [content-type: value]
                                "Content-Length" [length: content-length: value]
                            ]
                        )
                    ]
                    header-feed content: to end (
                        binary: copy :content
                        content: does [content: as-string binary]
                    )
                ][
                    version: to string! :version
                    request-method: method: to string! :method
                    path-info: target: as-string :target
                    action: reform [method target]
                    request-uri: as-string request-uri
                    server-port: query/mode client 'local-port
                    remote-addr: query/mode client 'remote-ip

                    headers: make header-prototype http-headers: new-line/all/skip headers true 2

                    type: if string? headers/Content-Type [
                        copy/part type: headers/Content-Type any [
                            find type ";"
                            tail type
                        ]
                    ]

                    length: content-length: any [
                        attempt [length: to integer! length]
                        0
                    ]

                    net-utils/net-log action
                ][
                    ; action: target: request-method: query-string: binary: content: request-uri: _
                    net-utils/net-log error: "Could Not Parse Request"
                ]
            ]
        ]
    ]

    dispatch: use [status-codes build-header][
        status-codes: [
            200 "OK" 201 "Created" 204 "No Content"
            301 "Moved Permanently" 302 "Moved temporarily" 303 "See Other" 307 "Temporary Redirect"
            400 "Bad Request" 401 "No Authorization" 403 "Forbidden" 404 "Not Found" 411 "Length Required"
            500 "Internal Server Error" 503 "Service Unavailable"
        ]

        build-header: func [response [object!]][
            append make binary! 0 collect [
                case/all [
                    not find status-codes response/status [
                        response/status: 500
                    ]
                    any [
                        not find [binary! string!] to word! type-of response/content
                        empty? response/content
                    ][
                        response/content: " "
                    ]
                ]

                keep reform ["HTTP/1.0" response/status select status-codes response/status]
                keep reform ["^/Content-Type:" response/type]
                keep reform ["^/Content-Length:" length? response/content]
                if response/location [
                    keep reform ["^/Location:" response/location]
                ]
                keep "^/^/"
            ]
        ]

        function [client [port!]][
            ; probe client/locals/wire
            client/locals/response: response: make response-prototype []
            client/locals/parent/locals/handler client/locals/request response

            case [
                error? outcome: trap [write client build-header response][
                    probe :outcome
                    unless all [
                        outcome/code = 5020
                        outcome/id = 'write-error
                        find [32 104] outcome/arg2
                    ][
                        fail :outcome
                    ]
                ]
            ]

            insert client/locals/wire response/content
        ]
    ]

    send-chunk: function [port [port!]][
        ;; Trying to send data > 32'000 bytes at once will trigger R3's internal
        ;; chunking (which is buggy, see above). So we cannot use chunks > 32'000
        ;; for our manual chunking.
        ;;
        ;; But let increase chunk size
        ;; to see if that bug exists again!
        case [
            empty? port/locals/wire [_]

            error? outcome: trap [
                write port take/part port/locals/wire 2'000'000'000
            ][
                probe :outcome
                ;; only mask some errors:
                unless all [
                    outcome/code = 5020
                    outcome/id = 'write-error
                    find [32 104] outcome/arg2
                ][
                    fail :outcome
                ]
            ]

            /else [:outcome]
        ]
    ]
]
	Rebol [
	Title: "JSON Parser for Rebol 3"
	Author: "Christopher Ross-Gill"
	Date: 18-Sep-2015
	Home: http://www.ross-gill.com/page/JSON_and_Rebol
	File: %altjson.r
	Version: 0.3.6.1
	Purpose: "Convert a Rebol block to a JSON string"
	Rights: http://opensource.org/licenses/Apache-2.0
	; Type: 'module
	; Name: 'rgchris.altjson
	Exports: [load-json to-json]
	History: [
	25-Feb-2017 0.3.6.1 "Ren-C Compatibilities"
	18-Sep-2015 0.3.6 "Non-Word keys loaded as strings"
	17-Sep-2015 0.3.5 "Added GET-PATH! lookup"
	16-Sep-2015 0.3.4 "Reinstate /FLAT refinement"
	21-Apr-2015 0.3.3 {
	- Merge from Reb4.me version
	- Recognise set-word pairs as objects
	- Use map! as the default object type
	- Serialize dates in RFC 3339 form
	}
	14-Mar-2015 0.3.2 "Converts Json input to string before parsing"
	07-Jul-2014 0.3.0 "Initial support for JSONP"
	15-Jul-2011 0.2.6 "Flattens Flickr '_content' objects"
	02-Dec-2010 0.2.5 "Support for time! added"
	28-Aug-2010 0.2.4 "Encodes tag! any-type! paired blocks as an object"
	06-Aug-2010 0.2.2 "Issue! composed of digits encoded as integers"
	22-May-2005 0.1.0 "Original Version"
	]
	Notes: {
	- Converts date! to RFC 3339 Date String
	}
	]

	attempt [_: blank: none blank!: none! blank?: :none?]

	load-json: use [
	tree branch here val is-flat emit new-child to-parent neaten word to-word
	space comma number string block object _content value ident
	][
	branch: make block! 10

	emit: func [val][here: insert/only here val]
	new-child: [(insert/only branch insert/only here here: make block! 10)]
	to-parent: [(here: take branch)]
	neaten: [
	(new-line/all head here true)
	(new-line/all/skip head here true 2)
	]

	to-word: use [word1 word+][
	; upper ranges borrowed from AltXML
	word1: charset [
	"!&*=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz\|~"
	#"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(02FF)"
	#"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)"
	#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
	#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
	]

	word+: charset [
	"!&'*+-.0123456789=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz\|~"
	#"^(B7)" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(037D)"
	#"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)" #"^(203F)" - #"^(2040)"
	#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
	#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
	]

	func [val [string!]][
	all [
	parse val [word1 any word+]
	to word! val
	]
	]
	]

	space: use [space][
	space: charset " ^-^/^M"
	[any space]
	]

	comma: [space #"," space]

	number: use [dg ex nm as-num][
	dg: charset "0123456789"
	ex: [[#"e" \| #"E"] opt [#"+" \| #"-"] some dg]
	nm: [opt #"-" some dg opt [#"." some dg] opt ex]

	as-num: func [val [string!]][
	case [
	not parse val [opt "-" some dg][to decimal! val]
	not integer? try [val: to integer! val][to issue! val]
	val [val]
	]
	]

	[copy val nm (val: as-num val)]
	]

	string: use [ch es hx mp decode][
	ch: complement charset {\"}
	es: charset {"\/bfnrt}
	hx: charset "0123456789ABCDEFabcdef"
	mp: [#"^"" "^"" #"\" "\" #"/" "/" #"b" "^H" #"f" "^L" #"r" "^M" #"n" "^/" #"t" "^-"]

	decode: use [ch mk escape][
	escape: [
	; should be possible to use CHANGE keyword to replace escaped characters.
	mk: #"\" [
	es (mk: change/part mk select mp mk/2 2)
	\|
	#"u" copy ch 4 hx (
	mk: change/part mk to char! to-integer/unsigned debase/base ch 16 6
	)
	] :mk
	]

	func [text [string! blank!]][
	either blank? text [make string! 0][
	all [parse text [any [to "\" escape] to end] text]
	]
	]
	]

	[#"^"" copy val [any [some ch \| #"\" [#"u" 4 hx \| es]]] #"^"" (val: decode val)]
	]

	block: use [list][
	list: [space opt [value any [comma value]] space]

	[#"[" new-child list #"]" neaten/1 to-parent]
	]

	_content: [#"{" space {"_content"} space #":" space value space "}"] ; Flickr

	object: use [name list as-map][
	name: [
	string space #":" space (
	emit either is-flat [
	to tag! val
	][
	any [
	to-word val
	lock val
	]
	]
	)
	]
	list: [space opt [name value any [comma name value]] space]
	as-map: [(unless is-flat [here: change back here make map! pick back here 1])]

	[#"{" new-child list #"}" neaten/2 to-parent as-map]
	]

	ident: use [initial ident][
	initial: charset ["$_" #"a" - #"z" #"A" - #"Z"]
	ident: union initial charset [#"0" - #"9"]

	[initial any ident]
	]

	value: [
	"null" (emit _)
	\| "true" (emit true)
	\| "false" (emit false)
	\| number (emit val)
	\| string (emit val)
	\| _content
	\| object \| block
	]

	func [
	"Convert a JSON string to Rebol data"
	json [string! binary! file! url!] "JSON string"
	/flat "Objects are imported as tag-value pairs"
	/padded "Loads JSON data wrapped in a JSONP envelope"
	][
	case/all [
	any [file? json url? json][
	if error? json: try [read/string (json)][
	do :json
	]
	]
	binary? json [json: to string! json]
	]

	is-flat: :flat
	tree: here: make block! 0

	either parse json either padded [
	[space ident space "(" space opt value space ")" opt ";" space]
	][
	[space opt value space]
	][
	pick tree 1
	][
	do make error! "Not a valid JSON string"
	]
	]
	]

	to-json: use [
	json emit emits escape emit-issue emit-date
	here lookup comma block object block-of-pairs value
	][
	emit: func [data][repend json data]
	emits: func [data][emit {"} emit data emit {"}]

	escape: use [mp ch encode][
	mp: [#"^/" "\n" #"^M" "\r" #"^-" "\t" #"^"" "\^"" #"\" "\\" #"/" "\/"]
	ch: intersect ch: charset [#" " - #"~"] difference ch charset extract mp 2

	encode: func [here][
	change/part here any [
	select mp here/1
	rejoin ["\u" skip tail form to-hex to integer! here/1 -4]
	] 1
	]

	func [txt][
	parse txt [any [txt: some ch \| skip (txt: encode txt) :txt]]
	head txt
	]
	]

	emit-issue: use [dg nm mk][
	dg: charset "0123456789"
	nm: [opt "-" some dg]

	[(either parse next form here/1 [copy mk nm][emit mk][emits here/1])]
	]

	emit-date: use [pad second][
	pad: func [part length][part: to string! part head insert/dup part "0" length - length? part]

	quote (
	emits rejoin collect [
	keep reduce [pad here/1/year 4 "-" pad here/1/month 2 "-" pad here/1/day 2]
	if here/1/time [
	keep reduce ["T" pad here/1/hour 2 ":" pad here/1/minute 2 ":"]
	keep either integer? here/1/second [
	pad here/1/second 2
	][
	second: split to string! here/1/second "."
	reduce [pad second/1 2 "." second/2]
	]
	keep either any [
	blank? here/1/zone
	zero? here/1/zone
	]["Z"][
	reduce [
	either here/1/zone/hour < 0 ["-"]["+"]
	pad abs here/1/zone/hour 2 ":" pad here/1/zone/minute 2
	]
	]
	]
	]
	)
	]

	lookup: [
	here: [get-word! \| get-path!]
	(change here reduce reduce [here/1])
	fail
	]

	comma: [(if not tail? here [emit ","])]

	block: [
	(emit "[") any [here: value here: comma] (emit "]")
	]

	block-of-pairs: [
	some [set-word! skip]
	\| some [tag! skip]
	]

	object: [
	(emit "{")
	any [
	here: [set-word! (change here to word! here/1) \| any-string! \| any-word!]
	(emit [{"} escape to string! here/1 {":}])
	here: value here: comma
	]
	(emit "}")
	]

	value: [
	lookup ; resolve a GET-WORD! reference
	\| number! (emit here/1)
	\| [logic! \| 'true \| 'false] (emit to string! here/1)
	\| [blank! \| 'none \| 'blank] (emit quote 'null)
	\| date! emit-date
	\| issue! emit-issue
	\| [
	any-string! \| word! \| lit-word! \| tuple! \| pair! \| money! \| time!
	] (emits escape form here/1)
	\| any-word! (emits escape form to word! here/1)

	\| [object! \| map!] :here (change/only here body-of first here) into object
	\| into block-of-pairs :here (change/only here copy first here) into object
	\| any-block! :here (change/only here copy first here) into block

	\| any-type! (emits to tag! type? first here)
	]

	func [data][
	json: make string! 1024
	if parse compose/only [(data)][here: value][json]
	]
	]
	Rebol [
	Title: "Web Server Scheme for Ren-C"
	Author: "Christopher Ross-Gill"
	Date: 23-Feb-2017
	File: %httpd.reb
	Version: 0.3.0
	Purpose: "An elementary Web Server scheme for creating fast prototypes"
	Rights: http://opensource.org/licenses/Apache-2.0
	Type: module
	Name: httpd
	History: [
	23-Feb-2017 0.3.0 "Adapted from Rebol 2"
	06-Feb-2017 0.2.0 "Include HTTP Parser/Dispatcher"
	12-Jan-2017 0.1.0 "Original Version"
	]
	]

	net-utils: reduce ['net-log _]

	as-string: func [binary [binary!] /local mark][
	mark: binary
	while [mark: invalid-utf8? mark][
	mark: change/part mark #{EFBFBD} 1
	]
	to string! binary
	]

	sys/make-scheme [
	title: "HTTP Server"
	name: 'httpd

	spec: make system/standard/port-spec-head [port-id: does: _]

	default-response: [probe request/action]

	init: func [server [port!] /local spec port-id does][
	spec: server/spec

	case [
	url? spec/ref []
	block? spec/does []
	parse spec/ref [
	set-word! lit-word!
	integer! block!
	][
	spec/port-id: spec/ref/3
	spec/does: spec/ref/4
	]
	/else [
	do make error! "Server lacking core features."
	]
	]

	server/locals: make object! [
	handler: subport: _
	]

	server/locals/handler: procedure [
	request [object!]
	response [object!]
	] case [
	function? get in server 'awake [body-of get in server 'awake]
	block? server/awake [server/awake]
	block? server/spec/does [server/spec/does]
	true [default-response]
	]

	server/locals/subport: make port! [scheme: 'tcp]
	server/locals/subport/spec/port-id: spec/port-id
	server/locals/subport/locals: make object! [
	request: response: _
	wire: make binary! 4096
	parent: :server
	]

	server/locals/subport/awake: func [event [event!] /local client server] compose [
	; server: (:server)
	if event/type = 'accept [
	client: first event/port
	client/awake: :wake-client
	read client
	]

	; event
	false
	]

	server
	]

	start: func [port [port!]][
	append system/ports/wait-list port
	]

	stop: func [port [port!]][
	remove find system/ports/wait-list port
	close port
	]

	actor: [
	open: func [server [port!]][
	; print ["Server running on port:" server/spec/port-id]
	start server/locals/subport
	open server/locals/subport
	]

	close: func [server [port!]][
	stop server/locals/subport
	]
	]

	request-prototype: make object! [
	version: 1.1
	method: "GET"
	action: headers: http-headers: _
	oauth: target: binary: content: length: timeout: _
	type: 'application/x-www-form-urlencoded
	server-software: rejoin [
	; system/script/header/title " v" system/script/header/version " "
	"Rebol/" system/product " v" system/version
	]
	server-name: gateway-interface: _
	server-protocol: "http"
	server-port: request-method: request-uri:
	path-info: path-translated: script-name: query-string:
	remote-host: remote-addr: auth-type:
	remote-user: remote-ident: content-type: content-length: _
	error: _
	]

	response-prototype: make object! [
	status: 404
	content: "Not Found"
	location: _
	type: "text/html"
	length: 0
	kill?: false
	close?: true
	]

	wake-client: use [instance][
	instance: 0

	func [event [event!] /local client request response this][
	client: event/port

	switch/default event/type [
	read [
	++ instance
	; print rejoin ["[" instance "]"]

	either find client/data #{0D0A0D0A} [
	transcribe client
	dispatch client
	][
	read client
	]
	]
	wrote [
	unless send-chunk client [
	if client/locals/response/kill? [
	close client
	stop client/locals/parent
	]
	]
	client
	]
	close [close client]
	][
	; probe event/type
	]
	]
	]

	transcribe: use [
	space request-action request-path request-query
	header-prototype header-feed header-name header-part
	][
	request-action: ["HEAD" \| "GET" \| "POST" \| "PUT" \| "DELETE"]

	request-path: use [chars][
	chars: complement charset [#"^@" - #" " #"?"]
	[some chars]
	]

	request-query: use [chars][
	chars: complement charset [#"^@" - #" "]
	[some chars]
	]

	header-feed: [newline \| crlf]

	header-part: use [chars][
	chars: complement charset [#"^(00)" - #"^(1F)"]
	[some chars any [header-feed some " " some chars]]
	]

	header-name: use [chars][
	chars: charset ["_-0123456789" #"a" - #"z" #"A" - #"Z"]
	[some chars]
	]

	space: use [space][
	space: charset " ^-"
	[some space]
	]

	header-prototype: context [
	Accept: "/"
	Connection: "close"
	User-Agent: rejoin ["Rebol/" system/product " " system/version]
	Content-Length: Content-Type: Authorization: Range: _
	]

	transcribe: func [
	client [port!]
	/local request name value pos
	][
	client/locals/request: make request-prototype [
	either parse client/data [
	copy method request-action space
	copy request-uri [
	copy target request-path opt [
	"?" copy query-string request-query
	]
	] space
	"HTTP/" copy version ["1.0" \| "1.1"]
	header-feed
	(headers: make block! 10)
	some [
	copy name header-name ":" any " "
	copy value header-part header-feed
	(
	name: as-string name
	value: as-string value
	append headers reduce [to set-word! name value]
	switch name [
	"Content-Type" [content-type: value]
	"Content-Length" [length: content-length: value]
	]
	)
	]
	header-feed content: to end (
	binary: copy :content
	content: does [content: as-string binary]
	)
	][
	version: to string! :version
	request-method: method: to string! :method
	path-info: target: as-string :target
	action: reform [method target]
	request-uri: as-string request-uri
	server-port: query/mode client 'local-port
	remote-addr: query/mode client 'remote-ip

	headers: make header-prototype http-headers: new-line/all/skip headers true 2

	type: if string? headers/Content-Type [
	copy/part type: headers/Content-Type any [
	find type ";"
	tail type
	]
	]

	length: content-length: any [
	attempt [length: to integer! length]
	0
	]

	net-utils/net-log action
	][
	; action: target: request-method: query-string: binary: content: request-uri: _
	net-utils/net-log error: "Could Not Parse Request"
	]
	]
	]
	]

	dispatch: use [status-codes build-header][
	status-codes: [
	200 "OK" 201 "Created" 204 "No Content"
	301 "Moved Permanently" 302 "Moved temporarily" 303 "See Other" 307 "Temporary Redirect"
	400 "Bad Request" 401 "No Authorization" 403 "Forbidden" 404 "Not Found" 411 "Length Required"
	500 "Internal Server Error" 503 "Service Unavailable"
	]

	build-header: func [response [object!]][
	append make binary! 0 collect [
	case/all [
	not find status-codes response/status [
	response/status: 500
	]
	any [
	not find [binary! string!] to word! type-of response/content
	empty? response/content
	][
	response/content: " "
	]
	]

	keep reform ["HTTP/1.0" response/status select status-codes response/status]
	keep reform ["^/Content-Type:" response/type]
	keep reform ["^/Content-Length:" length? response/content]
	if response/location [
	keep reform ["^/Location:" response/location]
	]
	keep "^/^/"
	]
	]

	function [client [port!]][
	; probe client/locals/wire
	client/locals/response: response: make response-prototype []
	client/locals/parent/locals/handler client/locals/request response

	case [
	error? outcome: trap [write client build-header response][
	probe :outcome
	unless all [
	outcome/code = 5020
	outcome/id = 'write-error
	find [32 104] outcome/arg2
	][
	fail :outcome
	]
	]
	]

	insert client/locals/wire response/content
	]
	]

	send-chunk: function [port [port!]][
	;; Trying to send data > 32'000 bytes at once will trigger R3's internal
	;; chunking (which is buggy, see above). So we cannot use chunks > 32'000
	;; for our manual chunking.
	;;
	;; But let increase chunk size
	;; to see if that bug exists again!
	case [
	empty? port/locals/wire [_]

	error? outcome: trap [
	write port take/part port/locals/wire 2'000'000'000
	][
	probe :outcome
	;; only mask some errors:
	unless all [
	outcome/code = 5020
	outcome/id = 'write-error
	find [32 104] outcome/arg2
	][
	fail :outcome
	]
	]

	/else [:outcome]
	]
	]
	]