extra/s3/s3.factor

   1 ! Copyright (C) 2009 Chris Double. All Rights Reserved.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING:
   4     accessors
   5     assocs
   6     base64
   7     calendar
   8     calendar.format
   9     checksums.hmac
  10     checksums.sha
  11     combinators
  12     http
  13     http.client
  14     kernel
  15     make
  16     math.order
  17     namespaces
  18     sequences
  19     sorting
  20     strings
  21     xml
  22     xml.traversal
  23 ;
  24 IN: s3
  25
  26 SYMBOL: key-id
  27 SYMBOL: secret-key
  28
  29 TUPLE: s3-request path mime-type date method headers  bucket data ;
  30
  31 : hashtable>headers ( hashtable -- seq )
  32     [
  33         [ swap % ":" % % "\n" % ] "" make
  34     ] { } assoc>map [ <=> ] sort ;
  35
  36 : signature ( s3-request -- string )
  37     [
  38         {
  39             [ method>> % "\n" % "\n" % ]
  40             [ mime-type>> % "\n" % ]
  41             [ date>> timestamp>rfc822 % "\n" % ]
  42             [ headers>> [ hashtable>headers [ % ] each ] when* ]
  43             [ bucket>> [ "/" % % ] when* ]
  44             [ path>> % ]
  45         } cleave
  46     ] "" make ;
  47
  48 : sign ( s3-request -- string )
  49     [
  50         "AWS " %
  51         key-id get %
  52         ":" %
  53         signature secret-key get sha1 hmac-bytes >base64 %
  54     ] "" make ;
  55
  56 : s3-url ( s3-request -- string )
  57     [
  58         "http://" %
  59         dup bucket>> [ % "." % ] when*
  60         "s3.amazonaws.com" %
  61         path>> %
  62     ] "" make ;
  63
  64 : <s3-request> ( bucket path headers method -- request )
  65     s3-request new
  66         swap >>method
  67         swap >>headers
  68         swap >>path
  69         swap >>bucket
  70         now >>date ;
  71
  72 : sign-http-request ( s3-request http-request -- request )
  73     over date>> timestamp>rfc822 "Date" set-header
  74     swap sign "Authorization" set-header ;
  75
  76 : s3-get ( bucket path headers -- request data )
  77     "GET" <s3-request> dup s3-url <get-request>
  78     sign-http-request http-request ;
  79
  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 ;
  83
  84 TUPLE: bucket name date ;
  85
  86 : (buckets) ( xml -- seq )
  87     "Buckets" tag-named
  88     "Bucket" tags-named [
  89         [ "Name" tag-named children>string ]
  90         [ "CreationDate" tag-named children>string ] bi bucket boa
  91     ] map ;
  92
  93 : buckets ( -- seq )
  94     f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
  95
  96 : bucket-url ( bucket -- string )
  97     [ "http://" % % ".s3.amazonaws.com/" % ] "" make ;
  98
  99 TUPLE: key name last-modified size ;
 100
 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 ]
 106       tri key boa
 107   ] map ;
 108
 109 : keys ( bucket -- seq )
 110     "/" H{ } clone s3-get
 111     nip >string string>xml (keys) ;
 112
 113 : object-get ( bucket key -- response data )
 114     s3-request new
 115         swap "/" prepend >>path
 116         swap >>bucket
 117     s3-url http-get ;
 118
 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
 124     sign-http-request
 125     http-request 2drop ;
 126
 127 : delete-bucket ( bucket -- )
 128     "/" H{ } clone "DELETE" <s3-request>
 129     dup s3-url <delete-request> sign-http-request http-request 2drop ;
 130
 131 : put-object ( object type bucket key headers -- )
 132     [ "/" prepend ] dip "PUT" <s3-request>
 133     over >>mime-type
 134     [ <post-data> swap >>data ] dip
 135     dup s3-url swapd <put-request>
 136     dup header>> pick headers>> assoc-union >>header
 137     sign-http-request
 138     http-request 2drop ;
 139
 140 ! "testbucket" create-bucket
 141 ! "testbucket" delete-bucket
 142 ! buckets
 143 ! "testbucket" keys
 144 ! "hello world" binary encode "text/plain" "testbucket" "hello.txt"
 145 ! H{ { "x-amz-acl" "public-read" } } put-object
 146 ! "hello.txt" <pathname> "text/plain" "testbucket" "hello.txt"
 147 ! H{ { "x-amz-acl" "public-read" } } put-object
 148 ! "testbucket" "hello.txt" object-get
 149 ! Need to write docs...