real-example.html

<!DOCTYPE HTML>
<html>
    <head>
        <link rel="stylesheet" type="text/css" href="https://cdn.rawgit.com/google/code-prettify/master/src/prettify.css" />
        <link rel="stylesheet" type="text/css" href="https://cdn.rawgit.com/google/code-prettify/master/styles/desert.css" />
        <script type="text/javascript" src="https://cdn.rawgit.com/google/code-prettify/master/loader/run_prettify.js"></script>
        <script type="text/javascript" src="lang-rebol.js"></script>
    </head>
    <body>
        <h1>Rebol</h1>
        <h2>Real code (borrowed from gchui/rebolbot/prot-http.r) - Desert CSS</h2>

        <pre class="prettyprint lang-rebol">
REBOL [
    System: "REBOL [R3] Language Interpreter and Run-time Environment"
    Title: "REBOL 3 HTTP protocol scheme"
    Rights: {
        Copyright 2012 REBOL Technologies
        REBOL is a trademark of REBOL Technologies
    }
    License: {
        Licensed under the Apache License, Version 2.0
        See: http://www.apache.org/licenses/LICENSE-2.0
    }
    Name: 'http
    Type: 'module
    Version: 0.1.0
    File: %prot-http.r
    Purpose: {
        This program defines the HTTP protocol scheme for REBOL 3.
    }
    Author: "Gabriele Santilli"
    Date: 22-Jun-2007
]

sync-op: func [port body /local state] [
    unless port/state [open port port/state/close?: yes]
    state: port/state
    state/awake: :read-sync-awake
    do body
    if state/state = 'ready [do-request port]
    unless port? wait [state/connection port/spec/timeout] [http-error "Timeout"]
    body: copy port
    if all [
        select state/info/headers 'Content-Type
        state/info/headers/Content-Type
        parse state/info/headers/Content-Type [
            "text/" thru "; charset=UTF-8"
        ]
    ] [
        body: to string! body
    ]
    if state/close? [close port]
    body
]
read-sync-awake: func [event [event!] /local error] [
    switch/default event/type [
        connect ready [
            do-request event/port
            false
        ]
        done [
            true
        ]
        close [
            true
        ]
        error [
            error: event/port/state/error
            event/port/state/error: none
            do error
        ]
    ] [
        false
    ]
]
http-awake: func [event /local port http-port state awake res] [
    port: event/port
    http-port: port/locals
    state: http-port/state
    if any-function? :http-port/awake [state/awake: :http-port/awake]
    awake: :state/awake
    switch/default event/type [
        read [
            awake make event! [type: 'read port: http-port]
            check-response http-port
        ]
        wrote [
            awake make event! [type: 'wrote port: http-port]
            state/state: 'reading-headers
            read port
            false
        ]
        lookup [open port false]
        connect [
            state/state: 'ready
            awake make event! [type: 'connect port: http-port]
        ]
        close [
            res: switch state/state [
                ready [
                    awake make event! [type: 'close port: http-port]
                ]
                doing-request reading-headers [
                    state/error: make-http-error "Server closed connection"
                    awake make event! [type: 'error port: http-port]
                ]
                reading-data [
                    either any [integer? state/info/headers/content-length state/info/headers/transfer-encoding = "chunked"] [
                        state/error: make-http-error "Server closed connection"
                        awake make event! [type: 'error port: http-port]
                    ] [
                        any [
                            awake make event! [type: 'done port: http-port]
                            awake make event! [type: 'close port: http-port]
                        ]
                    ]
                ]
            ]
            close http-port
            res
        ]
    ] [true]
]
make-http-error: func [
    "Make an error for the HTTP protocol"
    message [string! block!]
] [
    if block? message [message: ajoin message]
    make error! [
        type: 'Access
        id: 'Protocol
        arg1: message
    ]
]
http-error: func [
    "Throw an error for the HTTP protocol"
    message [string! block!]
] [
    do make-http-error message
]
make-http-request: func [
    "Create an HTTP request (returns string!)"
    method [word! string!] "E.g. GET, HEAD, POST etc."
    target [file! string!] {In case of string!, no escaping is performed (eg. useful to override escaping etc.). Careful!}
    headers [block!] "Request headers (set-word! string! pairs)"
    content [any-string! binary! none!] {Request contents (Content-Length is created automatically). Empty string not exactly like none.}
    /local result
] [
    result: rejoin [
        uppercase form method #" "
        either file? target [next mold target] [target]
        " HTTP/1.0" CRLF
    ]
    foreach [word string] headers [
        repend result [mold word #" " string CRLF]
    ]
    if content [
        content: to binary! content
        repend result ["Content-Length: " length? content CRLF]
    ]
    append result CRLF
    result: to binary! result
    if content [append result content]
    result
]
do-request: func [
    "Perform an HTTP request"
    port [port!]
    /local spec info
] [
    spec: port/spec
    info: port/state/info
    spec/headers: body-of make make object! [
        Accept: "*/*"
        Accept-Charset: "utf-8"
        Host: either spec/port-id <> 80 [
            rejoin [form spec/host #":" spec/port-id]
        ] [
            form spec/host
        ]
        User-Agent: "REBOL"
    ] spec/headers
    port/state/state: 'doing-request
    info/headers: info/response-line: info/response-parsed: port/data:
    info/size: info/date: info/name: none
    write port/state/connection
    make-http-request spec/method to file! any [spec/path %/]
    spec/headers spec/content
]
parse-write-dialect: func [port block /local spec] [
    spec: port/spec
    parse block [[set block word! (spec/method: block) | (spec/method: 'post)]
        opt [set block [file! | url!] (spec/path: block)] [set block block! (spec/headers: block) | (spec/headers: [])] [set block [any-string! | binary!] (spec/content: block) | (spec/content: none)]
    ]
]
check-response: func [port /local conn res headers d1 d2 line info state awake spec] [
    state: port/state
    conn: state/connection
    info: state/info
    headers: info/headers
    line: info/response-line
    awake: :state/awake
    spec: port/spec
    if all [
        not headers
        d1: find conn/data crlfbin
        d2: find/tail d1 crlf2bin
    ] [
        info/response-line: line: to string! copy/part conn/data d1
        info/headers: headers: construct/with d1 http-response-headers
        info/name: to file! any [spec/path %/]
        if headers/content-length [info/size: headers/content-length: to integer! headers/content-length]
        if headers/last-modified [info/date: attempt [to date! headers/last-modified]]
        remove/part conn/data d2
        state/state: 'reading-data
    ]
    unless headers [
        read conn
        return false
    ]
    res: false
    unless info/response-parsed [
        ;?? line
        parse/all line [
            "HTTP/1." [#"0" | #"1"] some #" " [
                #"1" (info/response-parsed: 'info)
                |
                #"2" [["04" | "05"] (info/response-parsed: 'no-content)
                    | (info/response-parsed: 'ok)
                ]
                |
                #"3" [
                    "03" (info/response-parsed: 'see-other)
                    |
                    "04" (info/response-parsed: 'not-modified)
                    |
                    "05" (info/response-parsed: 'use-proxy)
                    | (info/response-parsed: 'redirect)
                ]
                |
                #"4" [
                    "01" (info/response-parsed: 'unauthorized)
                    |
                    "07" (info/response-parsed: 'proxy-auth)
                    | (info/response-parsed: 'client-error)
                ]
                |
                #"5" (info/response-parsed: 'server-error)
            ]
            | (info/response-parsed: 'version-not-supported)
        ]
    ]
    switch/all info/response-parsed [
        ok [
            either spec/method = 'head [
                state/state: 'ready
                res: awake make event! [type: 'done port: port]
                unless res [res: awake make event! [type: 'ready port: port]]
            ] [
                res: check-data port
                if all [not res state/state = 'ready] [
                    res: awake make event! [type: 'done port: port]
                    unless res [res: awake make event! [type: 'ready port: port]]
                ]
            ]
        ]
        redirect see-other [
            either spec/method = 'head [
                state/state: 'ready
                res: awake make event! [type: 'custom port: port code: 0]
            ] [
                res: check-data port
            ]
            if all [not res state/state = 'ready] [
                either all [
                    any [
                        find [get head] spec/method
                        all [
                            info/response-parsed = 'see-other
                            spec/method: 'get
                        ]
                    ]
                    in headers 'Location
                ] [
                    res: do-redirect port headers/location
                ] [
                    state/error: make-http-error "Redirect requires manual intervention"
                    res: awake make event! [type: 'error port: port]
                ]
            ]
        ]
        unauthorized client-error server-error proxy-auth [
            either spec/method = 'head [
                state/state: 'ready
            ] [
                check-data port
            ]
        ]
        unauthorized [
            state/error: make-http-error "Authentication not supported yet"
            res: awake make event! [type: 'error port: port]
        ]
        client-error server-error [
            state/error: make-http-error ["Server error: " line]
            res: awake make event! [type: 'error port: port]
        ]
        not-modified [state/state: 'ready
            res: awake make event! [type: 'done port: port]
            unless res [res: awake make event! [type: 'ready port: port]]
        ]
        use-proxy [
            state/state: 'ready
            state/error: make-http-error "Proxies not supported yet"
            res: awake make event! [type: 'error port: port]
        ]
        proxy-auth [
            state/error: make-http-error "Authentication and proxies not supported yet"
            res: awake make event! [type: 'error port: port]
        ]
        no-content [
            state/state: 'ready
            res: awake make event! [type: 'done port: port]
            unless res [res: awake make event! [type: 'ready port: port]]
        ]
        info [
            info/headers: info/response-line: info/response-parsed: port/data: none
            state/state: 'reading-headers
            read conn
        ]
        version-not-supported [
            state/error: make-http-error "HTTP response version not supported"
            res: awake make event! [type: 'error port: port]
            close port
        ]
    ]
    res
]
crlfbin: #{0D0A}
crlf2bin: #{0D0A0D0A}
crlf2: to string! crlf2bin
http-response-headers: context [
    Content-Length:
    Transfer-Encoding:
    Last-Modified: none
]
do-redirect: func [port [port!] new-uri [url! string! file!] /local spec state] [
    spec: port/spec
    state: port/state
    if #"/" = first new-uri [
        new-uri: to url! ajoin [spec/scheme "://" spec/host new-uri]
    ]
    new-uri: construct/with decode-url new-uri port/scheme/spec
    if new-uri/scheme <> 'http [
        state/error: make-http-error {Redirect to a protocol different from HTTP not supported}
        return state/awake make event! [type: 'error port: port]
    ]
    either all [
        new-uri/host = spec/host
        new-uri/port-id = spec/port-id
    ] [
        spec/path: new-uri/path
        do-request port
        false
    ] [
        state/error: make-http-error "Redirect to other host - requires custom handling"
        state/awake make event! [type: 'error port: port]
    ]
]
check-data: func [port /local headers res data out chunk-size mk1 mk2 trailer state conn] [
    state: port/state
    headers: state/info/headers
    conn: state/connection
    res: false
    case [
        headers/transfer-encoding = "chunked" [
            data: conn/data
            out: port/data: make binary! length? data
            until [
                either parse/all data [
                    copy chunk-size some hex-digits thru crlfbin mk1: to end
                ] [
                    chunk-size: to integer! to issue! chunk-size
                    either chunk-size = 0 [
                        if parse/all mk1 [
                            crlfbin (trailer: "") to end | copy trailer to crlf2bin to end
                        ] [
                            trailer: construct trailer
                            append headers body-of trailer
                            state/state: 'ready
                            res: state/awake make event! [type: 'custom port: port code: 0]
                            clear data
                        ]
                        true
                    ] [
                        either parse/all mk1 [
                            chunk-size skip mk2: crlfbin to end
                        ] [
                            insert/part tail out mk1 mk2
                            remove/part data skip mk2 2
                            empty? data
                        ] [
                            true
                        ]
                    ]
                ] [
                    true
                ]
            ]
            unless state/state = 'ready [read conn]
        ]
        integer? headers/content-length [
            port/data: conn/data
            either headers/content-length <= length? port/data [
                state/state: 'ready
                conn/data: make binary! 32000
                res: state/awake make event! [type: 'custom port: port code: 0]
            ] [
                read conn
            ]
        ]
        true [
            port/data: conn/data
            read conn
        ]
    ]
    res
]
hex-digits: charset "1234567890abcdefABCDEF"
sys/make-scheme [
    name: 'http
    title: "HyperText Transport Protocol v1.1"
    spec: make system/standard/port-spec-net [
        path: %/
        method: 'get
        headers: []
        content: none
        timeout: 15
    ]
    info: make system/standard/file-info [
        response-line:
        response-parsed:
        headers: none
    ]
    actor: [
        read: func [
            port [port!]
        ] [
            either any-function? :port/awake [
                unless open? port [cause-error 'Access 'not-open port/spec/ref]
                if port/state/state <> 'ready [http-error "Port not ready"]
                port/state/awake: :port/awake
                do-request port
                port
            ] [
                sync-op port []
            ]
        ]
        write: func [
            port [port!]
            value
        ] [
            unless any [block? :value binary? :value any-string? :value] [value: form :value]
            unless block? value [value: reduce [[Content-Type: "application/x-www-form-urlencoded; charset=utf-8"] value]]
            either any-function? :port/awake [
                unless open? port [cause-error 'Access 'not-open port/spec/ref]
                if port/state/state <> 'ready [http-error "Port not ready"]
                port/state/awake: :port/awake
                parse-write-dialect port value
                do-request port
                port
            ] [
                sync-op port [parse-write-dialect port value]
            ]
        ]
        open: func [
            port [port!]
            /local conn
        ] [
            if port/state [return port]
            if none? port/spec/host [http-error "Missing host address"]
            port/state: context [
                state: 'inited
                connection:
                error: none
                close?: no
                info: make port/scheme/info [type: 'file]
                awake: :port/awake
            ]
            port/state/connection: conn: make port! [
                scheme: 'tcp
                host: port/spec/host
                port-id: port/spec/port-id
                ref: rejoin [tcp:// host ":" port-id]
            ]
            conn/awake: :http-awake
            conn/locals: port
            open conn
            port
        ]
        open?: func [
            port [port!]
        ] [
            found? all [port/state open? port/state/connection]
        ]
        close: func [
            port [port!]
        ] [
            if port/state [
                close port/state/connection
                port/state/connection/awake: none
                port/state: none
            ]
            port
        ]
        copy: func [
            port [port!]
        ] [
            either all [port/spec/method = 'head port/state] [
                reduce bind [name size date] port/state/info
            ] [
                if port/data [copy port/data]
            ]
        ]
        query: func [
            port [port!]
            /local error state
        ] [
            if state: port/state [
                either error? error: state/error [
                    state/error: none
                    error
                ] [
                    state/info
                ]
            ]
        ]
        length?: func [
            port [port!]
        ] [
            either port/data [length? port/data] [0]
        ]
    ]
]
        </pre>
    </body>
</html>