extra/s3/s3.factor

   1 ! Copyright (C) 2009 Chris Double. All Rights Reserved.
   2 ! See https://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 sorting strings xml xml.traversal ;
   7 IN: s3
   8
   9 SYMBOL: key-id
  10 SYMBOL: secret-key
  11
  12 <PRIVATE
  13
  14 TUPLE: s3-request path mime-type date method headers bucket data ;
  15
  16 : hashtable>headers ( hashtable -- seq )
  17     [
  18         [ swap % ":" % % "\n" % ] "" make
  19     ] { } assoc>map sort ;
  20
  21 : signature ( s3-request -- string )
  22     [
  23         {
  24             [ method>> % "\n" % "\n" % ]
  25             [ mime-type>> % "\n" % ]
  26             [ date>> timestamp>rfc822 % "\n" % ]
  27             [ headers>> [ hashtable>headers [ % ] each ] when* ]
  28             [ bucket>> [ "/" % % ] when* ]
  29             [ path>> % ]
  30         } cleave
  31     ] "" make ;
  32
  33 : sign ( s3-request -- string )
  34     [
  35         "AWS " %
  36         key-id get %
  37         ":" %
  38         signature secret-key get sha1 hmac-bytes >base64 %
  39     ] "" make ;
  40
  41 : s3-url ( s3-request -- string )
  42     [
  43         "https://" %
  44         dup bucket>> [ % "." % ] when*
  45         "s3.amazonaws.com" %
  46         path>> %
  47     ] "" make ;
  48
  49 : <s3-request> ( bucket path headers method -- request )
  50     s3-request new
  51         swap >>method
  52         swap >>headers
  53         swap >>path
  54         swap >>bucket
  55         now >>date ;
  56
  57 : sign-http-request ( s3-request http-request -- request )
  58     over date>> timestamp>rfc822 "Date" set-header
  59     swap sign "Authorization" set-header ;
  60
  61 : s3-get ( bucket path headers -- request data )
  62     "GET" <s3-request> dup s3-url <get-request>
  63     sign-http-request http-request ;
  64
  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 ;
  68
  69 PRIVATE>
  70
  71 TUPLE: bucket name date ;
  72
  73 <PRIVATE
  74
  75 : (buckets) ( xml -- seq )
  76     "Buckets" tag-named
  77     "Bucket" tags-named [
  78         [ "Name" tag-named children>string ]
  79         [ "CreationDate" tag-named children>string ] bi bucket boa
  80     ] map ;
  81 PRIVATE>
  82
  83 : buckets ( -- seq )
  84     f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
  85
  86 : sorted-buckets ( -- seq )
  87     buckets [ date>> rfc3339>timestamp ] sort-by ;
  88
  89 <PRIVATE
  90 : bucket-url ( bucket -- string )
  91     [ "https://" % % ".s3.amazonaws.com/" % ] "" make ;
  92 PRIVATE>
  93
  94 TUPLE: key name last-modified size ;
  95
  96 <PRIVATE
  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 ]
 102         tri key boa
 103     ] map ;
 104 PRIVATE>
 105
 106 : keys ( bucket -- seq )
 107     "/" H{ } clone s3-get
 108     nip >string string>xml (keys) ;
 109
 110 : get-object ( bucket key -- response data )
 111     "/" prepend H{ } clone s3-get ;
 112
 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
 118     sign-http-request
 119     http-request 2drop ;
 120
 121 : delete-bucket ( bucket -- )
 122     "/" H{ } clone "DELETE" <s3-request>
 123     dup s3-url <delete-request> sign-http-request http-request 2drop ;
 124
 125 : put-object ( data mime-type bucket key headers -- )
 126     [ "/" prepend ] dip "PUT" <s3-request>
 127     over >>mime-type
 128     [ <post-data> swap >>data ] dip
 129     dup s3-url swapd <put-request>
 130     dup header>> pick headers>> assoc-union >>header
 131     sign-http-request
 132     http-request 2drop ;
 133
 134 : delete-object ( bucket key -- )
 135     "/" prepend H{ } clone "DELETE" <s3-request>
 136     dup s3-url <delete-request> sign-http-request http-request 2drop ;
 137
 138 : bucket>alist ( bucket -- alist )
 139     dup keys
 140     [ name>> get-object nip ] with zip-with ;
 141