extra/oauth/oauth.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs base64 calendar checksums.hmac
   4 checksums.sha combinators fry http http.client kernel locals
   5 make math namespaces present random sequences sorting strings
   6 urls urls.encoding ;
   7 IN: oauth
   8
   9 SYMBOL: consumer-token
  10
  11 TUPLE: token key secret user-data ;
  12
  13 : <token> ( key secret -- token )
  14     token new
  15         swap >>secret
  16         swap >>key ;
  17
  18 <PRIVATE
  19
  20 TUPLE: token-params
  21 consumer-token
  22 timestamp
  23 nonce ;
  24
  25 : new-token-params ( class -- params )
  26     new
  27         consumer-token get >>consumer-token
  28         now timestamp>unix-time >integer >>timestamp
  29         random-32 >>nonce ; inline
  30
  31 :: signature-base-string ( url request-method params -- string )
  32     [
  33         request-method % "&" %
  34         url present url-encode-full % "&" %
  35         params assoc>query url-encode-full %
  36     ] "" make ;
  37
  38 : hmac-key ( consumer-secret token-secret -- key )
  39     [ url-encode-full ] [ "" or url-encode-full ] bi* "&" glue ;
  40
  41 : make-token-params ( params quot -- assoc )
  42     '[
  43         "1.0" "oauth_version" ,,
  44         "HMAC-SHA1" "oauth_signature_method" ,,
  45
  46         _
  47         [
  48             [ consumer-token>> key>> "oauth_consumer_key" ,, ]
  49             [ timestamp>> "oauth_timestamp" ,, ]
  50             [ nonce>> "oauth_nonce" ,, ]
  51             tri
  52         ] bi
  53     ] H{ } make ; inline
  54
  55 :: sign-params ( url request-method consumer-token request-token params -- signed-params )
  56     params sort-keys :> params
  57     url request-method params signature-base-string :> sbs
  58     consumer-token secret>> request-token dup [ secret>> ] when hmac-key :> key
  59     sbs key sha1 hmac-bytes >base64 >string :> signature
  60     params { "oauth_signature" signature } prefix ;
  61
  62 : extract-user-data ( assoc -- assoc' )
  63     [
  64         drop
  65         { "oauth_token" "oauth_token_secret" } member? not
  66     ] assoc-filter ;
  67
  68 : parse-token ( response data -- token )
  69     nip
  70     query>assoc
  71     [ [ "oauth_token" ] dip at ]
  72     [ [ "oauth_token_secret" ] dip at ]
  73     [ extract-user-data ]
  74     tri
  75     [ <token> ] dip >>user-data ;
  76
  77 PRIVATE>
  78
  79 TUPLE: request-token-params < token-params
  80 { callback-url initial: "oob" } ;
  81
  82 : <request-token-params> ( -- params )
  83     request-token-params new-token-params ;
  84
  85 <PRIVATE
  86
  87 :: <token-request> ( url consumer-token request-token params -- request )
  88     url "POST" consumer-token request-token params sign-params
  89     url
  90     <post-request> ;
  91
  92 : make-request-token-params ( params -- assoc )
  93     [ callback-url>> "oauth_callback" ,, ] make-token-params ;
  94
  95 : <request-token-request> ( url params -- request )
  96     [ consumer-token>> f ] [ make-request-token-params ] bi
  97     <token-request> ;
  98
  99 PRIVATE>
 100
 101 : obtain-request-token ( url params -- token )
 102     <request-token-request> http-request parse-token ;
 103
 104 TUPLE: access-token-params < token-params request-token verifier ;
 105
 106 : <access-token-params> ( -- params )
 107     access-token-params new-token-params ;
 108
 109 <PRIVATE
 110
 111 : make-access-token-params ( params -- assoc )
 112     [
 113         [ request-token>> key>> "oauth_token" ,, ]
 114         [ verifier>> "oauth_verifier" ,, ]
 115         bi
 116     ] make-token-params ;
 117
 118 : <access-token-request> ( url params -- request )
 119     [ consumer-token>> ]
 120     [ request-token>> ]
 121     [ make-access-token-params ] tri
 122     <token-request> ;
 123
 124 PRIVATE>
 125
 126 : obtain-access-token ( url params -- token )
 127     <access-token-request> http-request parse-token ;
 128
 129 SYMBOL: access-token
 130
 131 TUPLE: oauth-request-params < token-params access-token ;
 132
 133 : <oauth-request-params> ( -- params )
 134     oauth-request-params new-token-params
 135         access-token get >>access-token ;
 136
 137 <PRIVATE
 138
 139 :: signed-oauth-request-params ( request params -- params )
 140     request url>>
 141     request method>>
 142     params consumer-token>>
 143     params access-token>>
 144     params
 145     [
 146         access-token>> key>> "oauth_token" ,,
 147         request post-data>> %%
 148     ] make-token-params
 149     sign-params ;
 150
 151 : build-auth-string ( params -- string )
 152     [ [ present url-encode-full ] bi@ "\"" "\"" surround "=" glue ] { } assoc>map
 153     ", " join "OAuth realm=\"\", " prepend ;
 154
 155 PRIVATE>
 156
 157 : set-oauth ( request params -- request )
 158     dupd signed-oauth-request-params build-auth-string
 159     "Authorization" set-header ;