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 <PRIVATE
  30
  31 TUPLE: s3-request path mime-type date method headers  bucket data ;
  32
  33 : hashtable>headers ( hashtable -- seq )
  34     [
  35         [ swap % ":" % % "\n" % ] "" make
  36     ] { } assoc>map [ <=> ] sort ;
  37
  38 : signature ( s3-request -- string )
  39     [
  40         {
  41             [ method>> % "\n" % "\n" % ]
  42             [ mime-type>> % "\n" % ]
  43             [ date>> timestamp>rfc822 % "\n" % ]
  44             [ headers>> [ hashtable>headers [ % ] each ] when* ]
  45             [ bucket>> [ "/" % % ] when* ]
  46             [ path>> % ]
  47         } cleave
  48     ] "" make ;
  49
  50 : sign ( s3-request -- string )
  51     [
  52         "AWS " %
  53         key-id get %
  54         ":" %
  55         signature secret-key get sha1 hmac-bytes >base64 %
  56     ] "" make ;
  57
  58 : s3-url ( s3-request -- string )
  59     [
  60         "http://" %
  61         dup bucket>> [ % "." % ] when*
  62         "s3.amazonaws.com" %
  63         path>> %
  64     ] "" make ;
  65
  66 : <s3-request> ( bucket path headers method -- request )
  67     s3-request new
  68         swap >>method
  69         swap >>headers
  70         swap >>path
  71         swap >>bucket
  72         now >>date ;
  73
  74 : sign-http-request ( s3-request http-request -- request )
  75     over date>> timestamp>rfc822 "Date" set-header
  76     swap sign "Authorization" set-header ;
  77
  78 : s3-get ( bucket path headers -- request data )
  79     "GET" <s3-request> dup s3-url <get-request>
  80     sign-http-request http-request ;
  81
  82 : s3-put ( data bucket path headers -- request data )
  83     "PUT" <s3-request> dup s3-url swapd <put-request>
  84     sign-http-request http-request ;
  85
  86 PRIVATE>
  87
  88 TUPLE: bucket name date ;
  89
  90 <PRIVATE
  91
  92 : (buckets) ( xml -- seq )
  93     "Buckets" tag-named
  94     "Bucket" tags-named [
  95         [ "Name" tag-named children>string ]
  96         [ "CreationDate" tag-named children>string ] bi bucket boa
  97     ] map ;
  98 PRIVATE>
  99
 100 : buckets ( -- seq )
 101     f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
 102
 103 <PRIVATE
 104 : bucket-url ( bucket -- string )
 105     [ "http://" % % ".s3.amazonaws.com/" % ] "" make ;
 106 PRIVATE>
 107
 108 TUPLE: key name last-modified size ;
 109
 110 <PRIVATE
 111 : (keys) ( xml -- seq )
 112     "Contents" tags-named [
 113         [ "Key" tag-named children>string ]
 114         [ "LastModified" tag-named children>string ]
 115         [ "Size" tag-named children>string ]
 116         tri key boa
 117     ] map ;
 118 PRIVATE>
 119
 120 : keys ( bucket -- seq )
 121     "/" H{ } clone s3-get
 122     nip >string string>xml (keys) ;
 123
 124 : get-object ( bucket key -- response data )
 125     s3-request new
 126         swap "/" prepend >>path
 127         swap >>bucket
 128     s3-url http-get ;
 129
 130 : create-bucket ( bucket -- )
 131     "" swap "/" H{ } clone "PUT" <s3-request>
 132     "application/octet-stream" >>mime-type
 133     dup s3-url swapd <put-request>
 134     0 "content-length" set-header
 135     sign-http-request
 136     http-request 2drop ;
 137
 138 : delete-bucket ( bucket -- )
 139     "/" H{ } clone "DELETE" <s3-request>
 140     dup s3-url <delete-request> sign-http-request http-request 2drop ;
 141
 142 : put-object ( data mime-type bucket key headers -- )
 143     [ "/" prepend ] dip "PUT" <s3-request>
 144     over >>mime-type
 145     [ <post-data> swap >>data ] dip
 146     dup s3-url swapd <put-request>
 147     dup header>> pick headers>> assoc-union >>header
 148     sign-http-request
 149     http-request 2drop ;
 150
 151 : delete-object ( bucket key -- )
 152     "/" prepend H{ } clone "DELETE" <s3-request>
 153     dup s3-url <delete-request> sign-http-request http-request 2drop ;