154 lines
3.6 KiB
Factor
154 lines
3.6 KiB
Factor
! Copyright (C) 2009 Chris Double. All Rights Reserved.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING:
|
|
accessors
|
|
assocs
|
|
base64
|
|
calendar
|
|
calendar.format
|
|
checksums.hmac
|
|
checksums.sha
|
|
combinators
|
|
http
|
|
http.client
|
|
kernel
|
|
make
|
|
math.order
|
|
namespaces
|
|
sequences
|
|
sorting
|
|
strings
|
|
xml
|
|
xml.traversal
|
|
;
|
|
IN: s3
|
|
|
|
SYMBOL: key-id
|
|
SYMBOL: secret-key
|
|
|
|
<PRIVATE
|
|
|
|
TUPLE: s3-request path mime-type date method headers bucket data ;
|
|
|
|
: hashtable>headers ( hashtable -- seq )
|
|
[
|
|
[ swap % ":" % % "\n" % ] "" make
|
|
] { } assoc>map [ <=> ] sort ;
|
|
|
|
: signature ( s3-request -- string )
|
|
[
|
|
{
|
|
[ method>> % "\n" % "\n" % ]
|
|
[ mime-type>> % "\n" % ]
|
|
[ date>> timestamp>rfc822 % "\n" % ]
|
|
[ headers>> [ hashtable>headers [ % ] each ] when* ]
|
|
[ bucket>> [ "/" % % ] when* ]
|
|
[ path>> % ]
|
|
} cleave
|
|
] "" make ;
|
|
|
|
: sign ( s3-request -- string )
|
|
[
|
|
"AWS " %
|
|
key-id get %
|
|
":" %
|
|
signature secret-key get sha1 hmac-bytes >base64 %
|
|
] "" make ;
|
|
|
|
: s3-url ( s3-request -- string )
|
|
[
|
|
"http://" %
|
|
dup bucket>> [ % "." % ] when*
|
|
"s3.amazonaws.com" %
|
|
path>> %
|
|
] "" make ;
|
|
|
|
: <s3-request> ( bucket path headers method -- request )
|
|
s3-request new
|
|
swap >>method
|
|
swap >>headers
|
|
swap >>path
|
|
swap >>bucket
|
|
now >>date ;
|
|
|
|
: sign-http-request ( s3-request http-request -- request )
|
|
over date>> timestamp>rfc822 "Date" set-header
|
|
swap sign "Authorization" set-header ;
|
|
|
|
: s3-get ( bucket path headers -- request data )
|
|
"GET" <s3-request> dup s3-url <get-request>
|
|
sign-http-request http-request ;
|
|
|
|
: s3-put ( data bucket path headers -- request data )
|
|
"PUT" <s3-request> dup s3-url swapd <put-request>
|
|
sign-http-request http-request ;
|
|
|
|
PRIVATE>
|
|
|
|
TUPLE: bucket name date ;
|
|
|
|
<PRIVATE
|
|
|
|
: (buckets) ( xml -- seq )
|
|
"Buckets" tag-named
|
|
"Bucket" tags-named [
|
|
[ "Name" tag-named children>string ]
|
|
[ "CreationDate" tag-named children>string ] bi bucket boa
|
|
] map ;
|
|
PRIVATE>
|
|
|
|
: buckets ( -- seq )
|
|
f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
|
|
|
|
<PRIVATE
|
|
: bucket-url ( bucket -- string )
|
|
[ "http://" % % ".s3.amazonaws.com/" % ] "" make ;
|
|
PRIVATE>
|
|
|
|
TUPLE: key name last-modified size ;
|
|
|
|
<PRIVATE
|
|
: (keys) ( xml -- seq )
|
|
"Contents" tags-named [
|
|
[ "Key" tag-named children>string ]
|
|
[ "LastModified" tag-named children>string ]
|
|
[ "Size" tag-named children>string ]
|
|
tri key boa
|
|
] map ;
|
|
PRIVATE>
|
|
|
|
: keys ( bucket -- seq )
|
|
"/" H{ } clone s3-get
|
|
nip >string string>xml (keys) ;
|
|
|
|
: get-object ( bucket key -- response data )
|
|
s3-request new
|
|
swap "/" prepend >>path
|
|
swap >>bucket
|
|
s3-url http-get ;
|
|
|
|
: create-bucket ( bucket -- )
|
|
"" swap "/" H{ } clone "PUT" <s3-request>
|
|
"application/octet-stream" >>mime-type
|
|
dup s3-url swapd <put-request>
|
|
0 "content-length" set-header
|
|
sign-http-request
|
|
http-request 2drop ;
|
|
|
|
: delete-bucket ( bucket -- )
|
|
"/" H{ } clone "DELETE" <s3-request>
|
|
dup s3-url <delete-request> sign-http-request http-request 2drop ;
|
|
|
|
: put-object ( data mime-type bucket key headers -- )
|
|
[ "/" prepend ] dip "PUT" <s3-request>
|
|
over >>mime-type
|
|
[ <post-data> swap >>data ] dip
|
|
dup s3-url swapd <put-request>
|
|
dup header>> pick headers>> assoc-union >>header
|
|
sign-http-request
|
|
http-request 2drop ;
|
|
|
|
: delete-object ( bucket key -- )
|
|
"/" prepend H{ } clone "DELETE" <s3-request>
|
|
dup s3-url <delete-request> sign-http-request http-request 2drop ;
|