Script Library: my-http.r

Script Library: 1247 scripts
my-http.r

REBOL [
   Title: "patched HTTP/HTTPS protocol with cookies support"
   Author: %cyphre--seznam--cz
   Company: "Prolific Publishing, Inc."
   Date: 18-Aug-2006
   File: %my-http.r
   Purpose: "Provide an HTTP/HTTPS handler that transparently supports cookies"
   Library: [
        level: 'advanced 
        platform: 'windows 'linux
        type: [module tool]
        domain: [http protocol web]
        tested-under: [Command 2.5.6 Command 2.5.125 WindowsXP Linux]
        license: 'MIT
        support: none
        see-also: none
      ]
   ]



cookies-db: copy []

cookie-object: make object! [
    domain:
    path:
    name:
    value:
    expires:
    none
]

get-cookies: func [port /local result domain path found?][
    result: copy "Cookie: "
;   print "GET COOKIES"
    domain: join "." port/host
    path: any [join "/" port/path ""]
    foreach c cookies-db [
        if all [
            find/part/reverse tail domain c/domain length? c/domain
            find/part path dirize c/path 1 + length? c/path
        ][
            found?: true
            insert tail result rejoin [c/name "=" c/value "; "]
        ]
    ]
    remove/part back back tail result 2
    insert tail result newline
    either found? [result][""]
]

set-cookies-http: func [
    port
    /direct cookie
    /local result digits chars found? c make-cookie
][
;   print "SET COOKIES"
    digits: charset [#"0" - #"9"]
    chars: charset [#"A" - #"Z" #"a" - #"z"]
    make-cookie: func [ c ][
        result: make cookie-object [
            domain: either port [join "." port/host][""]
            path: "/"
            expires: now + 365
        ]
        insert tail c ";"
        parse c [
            some [
                copy name to "=" skip copy value to ";" skip (
                    switch/default name [
                        "expires" [
                            parse/all value [
                                some [
                                    mark: 2 digits [" " | "-"] 3 chars [" " | "-"] 4 digits " " 2 digits ":" 2 digits ":" 2 digits (
                                        mark/3: #"-"
                                        mark/7: #"-"
                                        mark/12: #"/"
                                        result/expires: (to-date copy/part mark 20) + now/zone
                                    )
                                    | skip
                                ]
                            ]
                        ]
                        "path" [result/path: value]
                        "domain" [result/domain: value]
                        "version" []
                        "HTTPOnly" []
                        "secure" []
                    ][result/name: name result/value: value]
                )
                | skip
            ]
        ]
        if all [series? result/path not empty? result/path][
            found?: false
            foreach c cookies-db [
                if all [
                    c/domain = result/domain
                    c/path = result/path
                    c/name = result/name
                    found?: true
                    (difference result/expires c/expires) > 0:00
                ][
                    c/expires: result/expires
                    c/value: result/value
                    break
                ]
            ]
            if not found? [
                insert tail cookies-db result
            ]
        ]
    ]
    either port [
        foreach [n v] header-rules/head-list [
            if n = to-set-word 'set-cookie [
                if string? v [ make-cookie v ]
                if block? v [ foreach c v [ make-cookie c ] ]
            ]
        ]
    ][
        make-cookie cookie
    ]
    remove-each c cookies-db ["EXPIRED" = c/value]
]


system/schemes/http/user-agent: "Mozilla/5.0 (Windows; U; Windows NT 5.1; cs; rv:1.8.0.1) Gecko/20060111 Firefox/1.5.0.1"

system/schemes/http/handler: make system/schemes/http/handler [
    crlf-mode?: false
    open: func [
        port "the port to open"
        /local http-packet http-command response-actions success error response-line
        target headers http-version post-data result generic-proxy? sub-protocol
        build-port send-and-check create-request line continue-post
        tunnel-actions tunnel-success response-code forward proxyauth
    ][
        port/locals: make object! [list: copy [] headers: none]
        generic-proxy?: all [port/proxy/type = 'generic not none? port/proxy/host]

        build-port: func [] [
            sub-protocol: either port/scheme = 'https ['ssl] ['tcp]
            open-proto/sub-protocol/generic port sub-protocol
            port/url: rejoin [lowercase to-string port/scheme "://" port/host either port/port-id <> 80 [join #":" port/port-id] [copy ""] slash]
            if found? port/path [append port/url port/path]
            if found? port/target [append port/url port/target]
            if sub-protocol = 'ssl [
                if generic-proxy? [
                    HTTP-Get-Header: make object! [
                        Host: join port/host any [all [port/port-id (port/port-id <> 80) join #":" port/port-id] #]
                    ]
                    user: get in port/proxy 'user
                    pass: get in port/proxy 'pass
                    if string? :user [
                        HTTP-Get-Header: make HTTP-Get-Header [
                            Proxy-Authorization: join "Basic " enbase join user [#":" pass]
                        ]
                    ]
                    http-packet: reform ["CONNECT" HTTP-Get-Header/Host "HTTP/1.1^/"]
                    append http-packet net-utils/export HTTP-Get-Header
                    append http-packet "^/"
                    net-utils/net-log http-packet
                    insert port/sub-port http-packet
                    continue-post/tunnel
                ]
                system/words/set-modes port/sub-port [secure: true]
            ]
        ]

        ; smarter query
        http-command: either querying ["HEAD"] ["GET"]
        create-request: func [/local target user pass u] [
            HTTP-Get-Header: make object! [
                Accept: "*/*"
                Connection: "close"
                User-Agent: get in get in system/schemes port/scheme 'user-agent
                Host: join port/host any [all [port/port-id (port/port-id <> 80) join #":" port/port-id] #]
            ]

            if all [block? port/state/custom post-data: select port/state/custom 'header block? post-data] [
                HTTP-Get-Header: make HTTP-Get-Header post-data
            ]

            HTTP-Header: make object! [
                Date: Server: Last-Modified: Accept-Ranges: Content-Encoding: Content-Type:
                Content-Length: Location: Expires: Referer: Connection: Authorization: none
            ]

            http-version: "HTTP/1.0^/"
            all [port/user port/pass HTTP-Get-Header: make HTTP-Get-Header [Authorization: join "Basic " enbase join port/user [#":" port/pass]]]
            user: get in port/proxy 'user
            pass: get in port/proxy 'pass
            if all [generic-proxy? string? :user] [
                HTTP-Get-Header: make HTTP-Get-Header [
                    Proxy-Authorization: join "Basic " enbase join user [#":" pass]
                ]
            ]
            if port/state/index > 0 [
                http-version: "HTTP/1.1^/"
                HTTP-Get-Header: make HTTP-Get-Header [
                    Range: rejoin ["bytes=" port/state/index "-"]
                ]
            ]
            target: next mold to-file join (join "/" either found? port/path [port/path] [""]) either found? port/target [port/target] [""]

            post-data: none
            if all [block? port/state/custom post-data: find port/state/custom 'post post-data/2] [
                http-command: "POST"
                HTTP-Get-Header: make HTTP-Get-Header append [
                    Referer: either find port/url #"?" [head clear find copy port/url #"?"] [port/url]
                    Content-Type: "application/x-www-form-urlencoded"
                    Content-Length: length? post-data/2
                ] either block? post-data/3 [post-data/3] [[]]
                post-data: post-data/2
            ]

            http-packet: reform [http-command either generic-proxy? [port/url] [target] http-version]
            append http-packet net-utils/export HTTP-Get-Header

            append http-packet get-cookies port
            if all [crlf-mode? port/scheme = 'https][
                append http-packet "^/"
                replace/all http-packet lf crlf
            ]
            http-packet
            ]

        send-and-check: func [] [
            net-utils/net-log http-packet
            insert port/sub-port http-packet
            if post-data [write-io port/sub-port post-data length? post-data]
            continue-post
        ]

        continue-post: func [/tunnel /local digit space] [
            response-line: system/words/pick port/sub-port 1
            net-utils/net-log response-line
            either none? response-line [do error] [
                ; fixes #3494: should accept an HTTP/0.9 simple response.
                digit: charset "1234567890"
                space: charset " ^-"
                either parse/all response-line [
                    ; relaxing rule a bit
                    ;"HTTP/" digit "." digit some space copy response-code 3 digit some space to end
                    "HTTP/" digit "." digit some space copy response-code 3 digit to end
                ] [
                    ; valid status line
                    response-code: to integer! response-code
                    result: select either tunnel [tunnel-actions] [response-actions] response-code
                    either none? result [do error] [do get result]
                ] [
                    ; could not parse status line, assuming HTTP/0.9
                    port/status: 'file
                ]
            ]
        ]

        tunnel-actions: [
            200 tunnel-success
        ]

        response-actions: [
            100 continue-post
            200 success
            201 success
            204 success
            206 success
            300 forward
            301 forward
            302 forward
            304 success
            407 proxyauth
        ]

        tunnel-success: [
            while [ ( line: pick port/sub-port 1 ) <> ""] [net-log line]
        ]

        success: [
            headers: make string! 500
            while [(line: pick port/sub-port 1) <> ""] [append headers join line "^/"]
            port/locals/headers: headers: Parse-Header HTTP-Header headers
            port/size: 0
            if querying [if headers/Content-Length [port/size: load headers/Content-Length]]
            if error? try [port/date: parse-header-date headers/Last-Modified] [port/date: none]

            if not error? try [port/locals/headers/Set-Cookie] [
                set-cookies-http port
            ]

            port/status: 'file
        ]

        error: [
            system/words/close port/sub-port
            net-error reform ["Error.  Target url:" port/url "could not be retrieved.  Server response:" response-line]
        ]

        forward: [
            page: copy ""
            while [(str: pick port/sub-port 1) <> ""] [append page reduce [str newline]]
            headers: Parse-Header HTTP-Header page

            if not error? try [headers/Set-Cookie] [
                set-cookies-http port
            ]

            insert port/locals/list port/url
            either found? headers/Location [
                either any [find/match headers/Location "http://" find/match headers/Location "https://"] [
                    port/path: port/target: port/port-id: none
                    net-utils/URL-Parser/parse-url/set-scheme port to-url port/url: headers/Location
                    if not port/port-id: any [port/port-id all [in system/schemes port/scheme get in get in system/schemes port/scheme 'port-id]] [
                        net-error reform ["HTTP forwarding error: Scheme" port/scheme "for URL" port/url "not supported in this REBOL."]
                    ]
                ] [
                    either (first headers/Location) = slash [port/path: none remove headers/Location] [either port/path [insert port/path "/"] [port/path: copy "/"]]
                    port/target: headers/Location
                    port/url: rejoin [lowercase to-string port/scheme "://" port/host either port/path [port/path] [""] either port/target [port/target] [""]]
                ]
;                if find/case port/locals/list port/url [net-error reform ["Error.  Target url:" port/url "could not be retrieved.  Circular forwarding detected"]]
                system/words/close port/sub-port
                build-port
                create-request
                send-and-check
            ] [
                do error]
            ]

        proxyauth: [
            system/words/close port/sub-port
            either all [generic-proxy? (not string? get in port/proxy 'user)] [
                port/proxy/user: system/schemes/http/proxy/user: port/proxy/user
                port/proxy/pass: system/schemes/http/proxy/pass: port/proxy/pass
                if not error? try [result: get in system/schemes 'https] [
                    result/proxy/user: port/proxy/user
                    result/proxy/pass: port/proxy/pass
                ]
            ] [
                net-error reform ["Error. Target url:" port/url "could not be retrieved: Proxy authentication denied"]
            ]
            build-port
            create-request
            send-and-check
        ]
        build-port
        create-request
        send-and-check
    ]

    query: func [port] [
        if not port/locals [
            querying: true
            open port
            ; port was kept open after query
            ; attempt for extra safety
            ; also note, local close on purpose
            attempt [close port]
            ; RAMBO #3718
            querying: false
        ]
        none
    ]

    close: func [port] [system/words/close port/sub-port]
]

if find first system/schemes 'https [
    system/schemes/https/user-agent: "Mozilla/5.0 (Windows; U; Windows NT 5.1; cs; rv:1.8.0.1) Gecko/20060111 Firefox/1.5.0.1"
    system/schemes/https/handler: make system/schemes/https/handler [
        crlf-mode?: false
        open: func [
            port "the port to open"
            /local http-packet http-command response-actions success error response-line
            target headers http-version post-data result generic-proxy? sub-protocol
            build-port send-and-check create-request line continue-post
            tunnel-actions tunnel-success response-code forward proxyauth
        ][
            port/locals: make object! [list: copy [] headers: none]
            generic-proxy?: all [port/proxy/type = 'generic not none? port/proxy/host]
            build-port: func [] [
                sub-protocol: either port/scheme = 'https ['ssl] ['tcp]
                open-proto/sub-protocol/generic port sub-protocol
                port/url: rejoin [lowercase to-string port/scheme "://" port/host either port/port-id <> 80 [join #":" port/port-id] [copy ""] slash]
                if found? port/path [append port/url port/path]
                if found? port/target [append port/url port/target]
                if sub-protocol = 'ssl [
                    if generic-proxy? [
                        HTTP-Get-Header: make object! [
                            Host: join port/host any [all [port/port-id (port/port-id <> 80) join #":" port/port-id] #]
                        ]
                        user: get in port/proxy 'user
                        pass: get in port/proxy 'pass
                        if string? :user [
                            HTTP-Get-Header: make HTTP-Get-Header [
                                Proxy-Authorization: join "Basic " enbase join user [#":" pass]
                            ]
                        ]
                        http-packet: reform ["CONNECT" HTTP-Get-Header/Host "HTTP/1.1^/"]
                        append http-packet net-utils/export HTTP-Get-Header
                        append http-packet "^/"
                        net-utils/net-log http-packet
                        insert port/sub-port http-packet
                        continue-post/tunnel
                    ]
                    system/words/set-modes port/sub-port [secure: true]
                ]
            ]
            http-command: either querying ["HEAD"] ["GET"]
            create-request: func [/local target user pass u] [
                HTTP-Get-Header: make object! [
                    Accept: "*/*"
                    Connection: "close"
                    User-Agent: get in get in system/schemes port/scheme 'user-agent
                    Host: join port/host any [all [port/port-id (port/port-id <> 80) join #":" port/port-id] #]
                ]
                if all [block? port/state/custom post-data: select port/state/custom 'header block? post-data] [
                    HTTP-Get-Header: make HTTP-Get-Header post-data
                ]
                HTTP-Header: make object! [
                    Date: Server: Last-Modified: Accept-Ranges: Content-Encoding: Content-Type:
                    Content-Length: Location: Expires: Referer: Connection: Authorization: none
                ]
                http-version: "HTTP/1.0^/"
                all [port/user port/pass HTTP-Get-Header: make HTTP-Get-Header [Authorization: join "Basic " enbase join port/user [#":" port/pass]]]
                user: get in port/proxy 'user
                pass: get in port/proxy 'pass
                if all [generic-proxy? string? :user] [
                    HTTP-Get-Header: make HTTP-Get-Header [
                        Proxy-Authorization: join "Basic " enbase join user [#":" pass]
                    ]
                ]
                if port/state/index > 0 [
                    http-version: "HTTP/1.1^/"
                    HTTP-Get-Header: make HTTP-Get-Header [
                        Range: rejoin ["bytes=" port/state/index "-"]
                    ]
                ]
                target: next mold to-file join (join "/" either found? port/path [port/path] [""]) either found? port/target [port/target] [""]
                post-data: none
                if all [block? port/state/custom post-data: find port/state/custom 'post post-data/2] [
                    http-command: "POST"
                    HTTP-Get-Header: make HTTP-Get-Header append [
                        Referer: either find port/url #"?" [head clear find copy port/url #"?"] [port/url]
                        Content-Type: "application/x-www-form-urlencoded"
                        Content-Length: length? post-data/2
                    ] either block? post-data/3 [post-data/3] [[]]
                    post-data: post-data/2
                ]
                http-packet: reform [http-command either generic-proxy? [port/url] [target] http-version]
                append http-packet net-utils/export HTTP-Get-Header
                append http-packet get-cookies port
                if all [crlf-mode? port/scheme = 'https][
                    append http-packet "^/"
                    replace/all http-packet lf crlf
                ]
                http-packet
                ]
            send-and-check: func [] [
                net-utils/net-log http-packet
                insert port/sub-port http-packet
                if post-data [write-io port/sub-port post-data length? post-data]
                continue-post
            ]
            continue-post: func [/tunnel /local digit space] [
                response-line: system/words/pick port/sub-port 1
                net-utils/net-log response-line
                either none? response-line [do error] [
                    digit: charset "1234567890"
                    space: charset " ^-"
                    either parse/all response-line [
                        "HTTP/" digit "." digit some space copy response-code 3 digit to end
                    ] [
                        response-code: to integer! response-code
                        result: select either tunnel [tunnel-actions] [response-actions] response-code
                        either none? result [do error] [do get result]
                    ] [
                        port/status: 'file
                    ]
                ]
            ]
            tunnel-actions: [
                200 tunnel-success
            ]
            response-actions: [
                100 continue-post
                200 success
                201 success
                204 success
                206 success
                300 forward
                301 forward
                302 forward
                304 success
                407 proxyauth
            ]
            tunnel-success: [
                while [(line: pick port/sub-port 1) <> ""] [net-log line]]
            success: [
                headers: make string! 500
                while [(line: pick port/sub-port 1) <> ""] [append headers join line "^/"]
                port/locals/headers: headers: Parse-Header HTTP-Header headers
                port/size: 0
                if querying [if headers/Content-Length [port/size: load headers/Content-Length]]
                if error? try [port/date: parse-header-date headers/Last-Modified] [port/date: none]
                if not error? try [port/locals/headers/Set-Cookie] [
                    set-cookies-http port
                ]
                port/status: 'file
            ]
            error: [
                system/words/close port/sub-port
                net-error reform ["Error.  Target url:" port/url "could not be retrieved.  Server response:" response-line]
            ]
            forward: [
                page: copy ""
                while [(str: pick port/sub-port 1) <> ""] [append page reduce [str newline]]
                headers: Parse-Header HTTP-Header page
                if not error? try [headers/Set-Cookie] [
                    set-cookies-http port
                ]
                insert port/locals/list port/url
                either found? headers/Location [
                    either any [find/match headers/Location "http://" find/match headers/Location "https://"] [
                        port/path: port/target: port/port-id: none
                        net-utils/URL-Parser/parse-url/set-scheme port to-url port/url: headers/Location
                        if not port/port-id: any [port/port-id all [in system/schemes port/scheme get in get in system/schemes port/scheme 'port-id]] [
                            net-error reform ["HTTP forwarding error: Scheme" port/scheme "for URL" port/url "not supported in this REBOL."]
                        ]
                    ] [
                        either (first headers/Location) = slash [port/path: none remove headers/Location] [either port/path [insert port/path "/"] [port/path: copy "/"]]
                        port/target: headers/Location
                        port/url: rejoin [lowercase to-string port/scheme "://" port/host either port/path [port/path] [""] either port/target [port/target] [""]]
                    ]
;                   if find/case port/locals/list port/url [net-error reform ["Error.  Target url:" port/url {could not be retrieved.  Circular forwarding detected}]]
                    system/words/close port/sub-port
                    build-port
                    create-request
                    send-and-check
                ] [
                    do error
                ]
            ]
            proxyauth: [
                system/words/close port/sub-port
                either all [generic-proxy? (not string? get in port/proxy 'user)] [
                    port/proxy/user: system/schemes/http/proxy/user: port/proxy/user
                    port/proxy/pass: system/schemes/http/proxy/pass: port/proxy/pass
                    if not error? try [result: get in system/schemes 'https] [
                        result/proxy/user: port/proxy/user
                        result/proxy/pass: port/proxy/pass
                    ]
                ] [
                    net-error reform ["Error. Target url:" port/url {could not be retrieved: Proxy authentication denied}]
                ]
                build-port
                create-request
                send-and-check
            ]
            build-port
            create-request
            send-and-check
        ]
        query: func [port][
            if not port/locals [
                querying: true
                open port
                attempt [close port]
                querying: false
            ]
            none
        ]
    ]
]
Notes
my-http.r has a discussion thread. Posts: 17. Most recent: 5-Jun-2024
email address(es) have been munged to protect them from spam harvesters. If you are a Library member, you can log on and view this script without the munging.
(cyphre:seznam:cz)