1 ! Copyright (C) 2009 Chris Double. All Rights Reserved.
2 ! See http://factorcode.org/license.txt for BSD license.
29 TUPLE: s3-request path mime-type date method headers bucket data ;
31 : hashtable>headers ( hashtable -- seq )
33 [ swap % ":" % % "\n" % ] "" make
34 ] { } assoc>map [ <=> ] sort ;
36 : signature ( s3-request -- string )
39 [ method>> % "\n" % "\n" % ]
40 [ mime-type>> % "\n" % ]
41 [ date>> timestamp>rfc822 % "\n" % ]
42 [ headers>> [ hashtable>headers [ % ] each ] when* ]
43 [ bucket>> [ "/" % % ] when* ]
48 : sign ( s3-request -- string )
53 signature secret-key get sha1 hmac-bytes >base64 %
56 : s3-url ( s3-request -- string )
59 dup bucket>> [ % "." % ] when*
64 : <s3-request> ( bucket path headers method -- request )
72 : sign-http-request ( s3-request http-request -- request )
73 over date>> timestamp>rfc822 "Date" set-header
74 swap sign "Authorization" set-header ;
76 : s3-get ( bucket path headers -- request data )
77 "GET" <s3-request> dup s3-url <get-request>
78 sign-http-request http-request ;
80 : s3-put ( data bucket path headers -- request data )
81 "PUT" <s3-request> dup s3-url swapd <put-request>
82 sign-http-request http-request ;
84 TUPLE: bucket name date ;
86 : (buckets) ( xml -- seq )
89 [ "Name" tag-named children>string ]
90 [ "CreationDate" tag-named children>string ] bi bucket boa
94 f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
96 : bucket-url ( bucket -- string )
97 [ "http://" % % ".s3.amazonaws.com/" % ] "" make ;
99 TUPLE: key name last-modified size ;
101 : (keys) ( xml -- seq )
102 "Contents" tags-named [
103 [ "Key" tag-named children>string ]
104 [ "LastModified" tag-named children>string ]
105 [ "Size" tag-named children>string ]
109 : keys ( bucket -- seq )
110 "/" H{ } clone s3-get
111 nip >string string>xml (keys) ;
113 : object-get ( bucket key -- response data )
115 swap "/" prepend >>path
119 : create-bucket ( bucket -- )
120 "" swap "/" H{ } clone "PUT" <s3-request>
121 "application/octet-stream" >>mime-type
122 dup s3-url swapd <put-request>
123 0 "content-length" set-header
127 : delete-bucket ( bucket -- )
128 "/" H{ } clone "DELETE" <s3-request>
129 dup s3-url <delete-request> sign-http-request http-request 2drop ;
131 : put-object ( object type bucket key headers -- )
132 [ "/" prepend ] dip "PUT" <s3-request>
134 [ <post-data> swap >>data ] dip
135 dup s3-url swapd <put-request>
136 dup header>> pick headers>> assoc-union >>header
140 : delete-object ( bucket key -- )
141 "/" prepend H{ } clone "DELETE" <s3-request>
142 dup s3-url <delete-request> sign-http-request http-request 2drop ;
144 ! "testbucket" create-bucket
145 ! "testbucket" delete-bucket
148 ! "hello world" binary encode "text/plain" "testbucket" "hello.txt"
149 ! H{ { "x-amz-acl" "public-read" } } put-object
150 ! "hello.txt" <pathname> "text/plain" "testbucket" "hello.txt"
151 ! H{ { "x-amz-acl" "public-read" } } put-object
152 ! "testbucket" "hello.txt" object-get
153 ! Need to write docs...