REBOL [
	Title: "Amazon S3 Protocol"
	Author: "Christopher Ross-Gill"
	Date: 30-Aug-2011
	File: %s3.r
	Version: 0.2.0
	License: 'BSD
	Purpose: {Basic retrieve and upload protocol for Amazon S3.}
	Example: [
		write s3://<bucket>/file/foo.txt "Foo"
		read s3://<bucket>/file/foo.txt
	]
	History: [
		23-Nov-2008 ["Graham Chiu" "Maarten Koopmans" "Gregg Irwin"]
	]
	Settings: [
		AWSAccessKeyId: <AWSAccessKeyId>
		AWSSecretAccessKey: <AWSSecretAccessKey>
	]
]

do http://reb4.me/r/http-custom.r

context bind [
	port-flags: system/standard/port-flags/pass-thru

	init: use [chars url][
		chars: ; charset [#"a" - #"z" #"A" - #"Z" #"0" - #"9" "-_!+%.,"]
		#[bitset! 64#{AAAAACJ4/wP+//+H/v//BwAAAAAAAAAAAAAAAAAAAAA=}]

		url: [
			"s3://" [
				copy user some chars #":"
				copy pass some chars #"@"
				| (user: none pass: none)
			]
			copy host some chars #"/"
			copy path any [some chars #"/"]
			copy target any chars
			end

			(
				path: all [path to-file path]
				target: all [target to-file target]
				user: any [user settings/awsaccesskeyid]
				pass: any [pass settings/awssecretaccesskey]
				url: rejoin [s3:// host "/" any [path ""] any [target ""]]
			)
		]

		func [port spec][
			unless all [
				url? spec
				parse/all spec bind url port
			][make error! "Invalid S3 Spec"]

			spec: rejoin [
				https:// port/host ".s3.amazonaws.com/"
				any [all [port/target port/path] ""] any [port/target ""]
			]

			port/sub-port: make port! spec
		]
	]

	open: use [options][
		options: context [
			options: modes: type: md5: access: prefix: none
		]

		func [port][
			port/state/flags: port/state/flags or port-flags

			port/locals: make options [
				modes: make block! 3

				if port/state/flags and 1 > 0 [append modes 'read]
				if port/state/flags and 2 > 0 [append modes 'write]
				if port/state/flags and 32 > 0 [append modes 'binary]

				options: any [port/state/custom make block! []]

				if all [port/path not port/target][
					repend options ['prefix port/path]
				]

				parse options [
					any [
						  'md5 set md5 string!
						| 'type set type path! (type: form type)
						| 'read (access: "public-read")
						| 'write (access: "public-read-write")
						| 'prefix set prefix [string! | file!] (
							unless port/target [
								port/sub-port/path: join "?prefix=" prefix
							]
						)
						| skip
					]
				]
			]
		]
	]

	copy: func [port][send "GET" port none]

	insert: func [port data][
		unless port/target [make error! "Not a valid S3 key"]

		case [
			none? data [send "DELETE" port data]
			any [string? data binary? data][send "PUT" port data]
			data [send "PUT" port form data]
		]
	]

	close: does []

	query: func [port][
		port/locals: [modes [read]]

		send "HEAD" port none

		port/size: attempt [to-integer port/sub-port/locals/headers/content-length]
		port/date: port/sub-port/date
		port/status: either port/target ['file]['directory]
	]

	unless in system/schemes 's3 [system/schemes: make system/schemes [s3: none]]

	system/schemes/s3: make system/standard/port compose [
		scheme: 's3
		port-id: 0
		handler: (self)
		passive: none
		cache-size: 5
		proxy: context [host: port-id: user: pass: type: bypass: none]
	]

] context [
	settings: make context [
		awsaccesskeyid: awssecretaccesskey: ""
	] any [
		system/script/args
		system/script/header/settings
	]

	get-http-response: func [port][
		reform next parse do bind [response-line] last second get in port/handler 'open none
	]

	send: use [timestamp detect-mime sign compose-request][
		timestamp: func [/for date [date!]][
			date: any [date now]
			date/time: date/time - date/zone

			rejoin [
				copy/part pick system/locale/days date/weekday 3 
				", " next form 100 + date/day " " 
				copy/part pick system/locale/months date/month 3 
				" " date/year " "
				next form 100 + date/time/hour ":"
				next form 100 + date/time/minute ":"
				next form 100 + to-integer date/time/second " GMT" 
			]
		]

		detect-mime: use [types][
			types: [
				application/octet-stream
				text/html %.html %.htm
				image/jpeg %.jpg %.jpeg
				image/png %.png
				image/tiff %.tif %.tiff
				application/pdf %.pdf
				text/plain %.txt %.r
				application/xml %.xml
				video/mpeg %.mpg %.mpeg
				video/x-m4v %.m4v
			]

			func [file [file! url! none!]][
				if file [
					file: any [find types suffix? file next types]
					form first find/reverse file path!
				]
			]
		]

		sign: func [verb [string!] port [port!] request [object!]][
			rejoin [
				"AWS " port/user ":" enbase/base checksum/secure/key rejoin [
					form verb newline
					newline ; any [port/locals/md5 ""] newline
					any [request/type ""] newline
					timestamp newline
					either request/auth [join "x-amz-acl:" [request/auth "^/"]][""]
					"/" port/host "/" any [all [port/target port/path] ""] any [port/target ""]
				] port/pass 64
			]
		]

		compose-request: func [verb [string!] port [port!] data [series! none!]][
			data: context [
				body: any [data ""]
				size: all [data length? data]
				type: all [data any [port/locals/type detect-mime port/target]]
				auth: all [data port/locals/access]
			]

			reduce [
				to-word verb data/body
				foreach [header value][
					"Date" [timestamp]
					"Content-Type" [data/type]
					"Content-Length" [data/size]
					"Authorization" [sign verb port data]
					"x-amz-acl" [data/auth]
					"Pragma" ["no-cache"]
					"Cache-Control" ["no-cache"]
				][
					if value: all :value [
						repend [] [to-set-word header form value]
					]
				]
			]
		]

		send: func [[catch] method [string!] port [port!] data [any-type!]][
			either error? data: try [
				open/mode/custom port/sub-port port/locals/modes compose-request method port data
			][
				net-error rejoin ["Target url " port/url " could not be retrieved (" get-http-response port/sub-port ")."]
			][
				data: copy port/sub-port
				either port/target [
					data
				][
					unless method = "HEAD" [
						data: load/markup data
						parse data [
							copy data any [
								data: <key> (remove data change data to-file data/1) | skip (remove data) :data
							]
						]
						data
					]
				]
			]
		]
	]
]