REBOL [
Title: "REBOL Protocols: HTTP"
Version: 2.7.6.2
Rights: "Copyright REBOL Technologies 2008. All rights reserved."
Home: http://www.rebol.com
Date: 14-Mar-2008
; You are free to use, modify, and distribute this file as long as the
; above header, copyright, and this entire comment remains intact.
; This software is provided "as is" without warranties of any kind.
; In no event shall REBOL Technologies or source contributors be liable
; for any damages of any kind, even if advised of the possibility of such
; damage. See license for more information.
; Please help us to improve this software by contributing changes and
; fixes. See http://www.rebol.com/support.html for details.
]
make Root-Protocol [
"The HTTP protocol."
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 fail-at
tunnel-actions tunnel-success response-code forward proxyauth
][
; RAMBO #4039: moved QUERYING to locals
; also now QUERY will initialize port/locals
unless port/locals [port/locals: make object! [list: copy [] headers: none querying: no]]
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 port/locals/querying ["HEAD"] ["GET"]
create-request: func [/local target user pass u data ] [
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.1^/"
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]
]
]
; range request
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
comment { ; original code
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
]
}
; start Graham's changes
either 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
][
either all [
block? port/state/custom
any [
post-data: find port/state/custom to-word http-command: "HEAD"
post-data: find port/state/custom to-word http-command: "GET"
]
post-data/2
] [
HTTP-Get-Header: make HTTP-Get-Header append [
Referer: either find port/url #"?" [head clear find copy port/url #"?"] [port/url]
] either block? post-data/3 [post-data/3] [[]]
post-data: none
][
either all [block? port/state/custom post-data: find port/state/custom 'put post-data/2] [
http-command: "PUT"
data: either file? post-data/2 [
system/words/read/binary post-data/2
][
post-data/2
]
HTTP-Get-Header: make HTTP-Get-Header append [
Content-Type: "application/octet-stream"
Content-Length: length? data
] either block? post-data/3 [post-data/3] [[]]
post-data: data
][
either all [block? port/state/custom post-data: find port/state/custom 'soap post-data/2] [
http-command: "POST"
data: either file? post-data/2 [
system/words/read/binary post-data/2
][
post-data/2
]
HTTP-Get-Header: make HTTP-Get-Header append [
Content-Type: {text/xml; charset="utf-8"}
Content-Length: length? data
] either block? post-data/3 [post-data/3] [[]]
post-data: data
][
if all [block? port/state/custom post-data: find port/state/custom 'delete post-data/2] [
http-command: "DELETE"
HTTP-Get-Header: make HTTP-Get-Header append [
Referer: either find port/url #"?" [head clear find copy port/url #"?"] [port/url]
] either block? post-data/3 [post-data/3] [[]]
post-data: none
]
]
]
]
]
; end changes from Graham
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 "^/"
; if post-data [append http-packet post-data]
]
send-and-check: func [] [
net-utils/net-log http-packet
; Sterling, why was this changed from insert to write-io ? It causes HTTP to be sent
; without cr and breaks things.
; write-io port/sub-port http-packet length? 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 ; Tunnel established
]
response-actions: [
100 continue-post ; HTTP/1.1 continue with posting data
200 success ; standard valid response
201 success ; post command successful - new url included
204 success ; no new content (maybe use :true here?)
206 success ; read partial content
300 forward ; multiple choices of locations in the body - maybe preferred in Location:
301 forward ; moved permanently - Location: hold new loc
302 forward ; moved temporarily - Location: hold new loc
304 success ; not modified since the If-Modified-Since header date
307 forward ; temporary redirect
400 fail-at ; bad request - chris
403 fail-at ; unauthorized request - chris
404 fail-at ; not found - chris
407 proxyauth ; requires proxy authorization
]
tunnel-success: [
while [ ( line: pick port/sub-port 1 ) <> "" ] [net-utils/net-log line]
]
success: [
headers: make string! 500
while [ ( line: pick port/sub-port 1 ) <> "" ] [append headers join line "^/"] ; remove the headers
port/locals/headers: headers: Parse-Header HTTP-Header headers
port/size: 0
if port/locals/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]
port/status: 'file
]
; start Chris's changes
fail-at: [
headers: make string! 500
while [ ( line: pick port/sub-port 1 ) <> "" ][
append headers join line "^/"
use [mk][
if parse/all line ["X-Error-Detail:" mk: to end][
append response-line back mk
]
]
] ; remove the headers
system/words/close port/sub-port
net-error response-line
port/status: 'file
]
; end Chris's changes
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
insert port/locals/list port/url
either found? headers/Location [
either any [find/match headers/Location "http://" find/match headers/Location "https://"] [ ; new whole url to go to
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 [
; RAMBO #4039: query mode is local to port now
port/locals: make object! [list: copy [] headers: none querying: yes]
open port
; port was kept open after query
; attempt for extra safety
; also note, local close on purpose
attempt [close port]
; RAMBO #3718 - superceded by fix for #4039
;querying: false
]
none
]
close: func [port] [system/words/close port/sub-port]
net-utils/net-install HTTP self 80
net-utils/net-install HTTPS self 443
system/schemes/http: make system/schemes/http [user-agent: reform ["REBOL" system/product system/version]]
system/schemes/https: make system/schemes/https [user-agent: reform ["REBOL" system/product system/version]]
]