1 ! Copyright (C) 2009 Chris Double. All Rights Reserved.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs base64 calendar calendar.format
4 calendar.parser checksums.hmac checksums.sha combinators http
5 http.client kernel make math.order namespaces sequences
6 sequences.extras sorting sorting.slots strings xml xml.traversal ;
14 TUPLE: s3-request path mime-type date method headers bucket data ;
16 : hashtable>headers ( hashtable -- seq )
18 [ swap % ":" % % "\n" % ] "" make
19 ] { } assoc>map [ <=> ] sort ;
21 : signature ( s3-request -- string )
24 [ method>> % "\n" % "\n" % ]
25 [ mime-type>> % "\n" % ]
26 [ date>> timestamp>rfc822 % "\n" % ]
27 [ headers>> [ hashtable>headers [ % ] each ] when* ]
28 [ bucket>> [ "/" % % ] when* ]
33 : sign ( s3-request -- string )
38 signature secret-key get sha1 hmac-bytes >base64 %
41 : s3-url ( s3-request -- string )
44 dup bucket>> [ % "." % ] when*
49 : <s3-request> ( bucket path headers method -- request )
57 : sign-http-request ( s3-request http-request -- request )
58 over date>> timestamp>rfc822 "Date" set-header
59 swap sign "Authorization" set-header ;
61 : s3-get ( bucket path headers -- request data )
62 "GET" <s3-request> dup s3-url <get-request>
63 sign-http-request http-request ;
65 : s3-put ( data bucket path headers -- request data )
66 "PUT" <s3-request> dup s3-url swapd <put-request>
67 sign-http-request http-request ;
71 TUPLE: bucket name date ;
75 : (buckets) ( xml -- seq )
78 [ "Name" tag-named children>string ]
79 [ "CreationDate" tag-named children>string ] bi bucket boa
84 f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
86 : sorted-buckets ( -- seq )
87 buckets { { date>> rfc3339>timestamp <=> } } sort-by ;
90 : bucket-url ( bucket -- string )
91 [ "http://" % % ".s3.amazonaws.com/" % ] "" make ;
94 TUPLE: key name last-modified size ;
97 : (keys) ( xml -- seq )
98 "Contents" tags-named [
99 [ "Key" tag-named children>string ]
100 [ "LastModified" tag-named children>string ]
101 [ "Size" tag-named children>string ]
106 : keys ( bucket -- seq )
107 "/" H{ } clone s3-get
108 nip >string string>xml (keys) ;
110 : get-object ( bucket key -- response data )
111 "/" prepend H{ } clone s3-get ;
113 : create-bucket ( bucket -- )
114 "" swap "/" H{ } clone "PUT" <s3-request>
115 "application/octet-stream" >>mime-type
116 dup s3-url swapd <put-request>
117 0 "content-length" set-header
121 : delete-bucket ( bucket -- )
122 "/" H{ } clone "DELETE" <s3-request>
123 dup s3-url <delete-request> sign-http-request http-request 2drop ;
125 : put-object ( data mime-type bucket key headers -- )
126 [ "/" prepend ] dip "PUT" <s3-request>
128 [ <post-data> swap >>data ] dip
129 dup s3-url swapd <put-request>
130 dup header>> pick headers>> assoc-union >>header
134 : delete-object ( bucket key -- )
135 "/" prepend H{ } clone "DELETE" <s3-request>
136 dup s3-url <delete-request> sign-http-request http-request 2drop ;
138 : bucket>alist ( bucket -- alist )
140 [ name>> get-object nip ] with zip-with ;